-- Skrepka Relay Server
-- Single-server implementation of the Skrepka protocol (v0.1)
-- Binary data (keys, signatures, blobs) uses hex encoding (bytesToHex/bytesFromHex)

-- ============================================
-- Configuration
-- ============================================

serverHost = "localhost:8080"
federationSecret = "" -- must be set to enable federation
maintenanceSecret = "" -- set to enable /maintenance/prune independently of federation
federationScheme = "https://" -- scheme for federation HTTP calls
messageMaxAge = 2592000000 -- 30 days in milliseconds
maxPresenceTtl = 3600 -- max presence TTL from gossip in seconds
maxPubkeyLen = 256
maxBlobLen = 65536
maxSignatureLen = 256
maxMessageIds = 100
maxGossipEvents = 100
maxPollEvents = 50
maxPresenceEntries = 10000
maxMessagesPerRecipient = 500
clockSkewTolerance = 5000 -- 5 seconds tolerance for clock skew between federated servers
maxForwardsEntries = 10000
maxServerNameLen = 128
maxMessageIdLen = 128
maxTokenLen = 256
maxChallenges = 10000
maxSessions = 10000
maxAckedIds = 10000
maxChallengesPerKey = 5
maxSessionsPerKey = 10
challengeExpiry = 60000 -- 1 minute in milliseconds
sessionExpiry = 3600000 -- 1 hour in milliseconds
onlineGossipTtl = 3600 -- 1 hour in seconds
offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events in seconds
maxForwardRetriesPerServer = 100
federationEnabled = not (federationSecret == "")

-- ============================================
-- Types
-- ============================================

type PollEventType = Text where \s -> s == "message"

type PollEvent = {id: MessageIdHex, eventType: PollEventType, payload: {encryptedBlob: BlobHex, fromKey: PubkeyHex, timestamp: Timestamp, toKey: PubkeyHex}}

type GossipEventType = Text where \s -> s == "online" || s == "offline"

type GossipEvent = {eventType: GossipEventType, pubkey: Text, server: Text, timestamp: Timestamp, ttl: Int<S>}

type ValidGossipEntry = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, expiresAt: Timestamp, timestamp: Timestamp, ttl: Int<S>}

type MessageStatus = Text where \s -> s == "unauthorized" || s == "rejected" || s == "delivered" || s == "federated" || s == "queued"

type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen)
type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen)
type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen)
type MessageIdHex = Text where \s -> isValidHex s && not (tooLong s maxMessageIdLen)
type ServerName = Text where \s -> not (tooLong s maxServerNameLen) && not (isBadServerName s)
type OptionalServerName = Text where \s -> s == "" || (not (tooLong s maxServerNameLen) && not (isBadServerName s))

type Timestamp = Int<Ms>

type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp}
type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp}
type Message = {messageId: MessageIdHex, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: OptionalServerName, receivedAt: Timestamp}
type PresenceEntry = {pubkey: PubkeyHex, server: Text, expiresAt: Timestamp, timestamp: Timestamp}
type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp}
type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName}
type AuthResult = Authorized {pubkey: PubkeyHex} | Unauthorized {}
type PruneResult = {expiredLocal: [PresenceEntry], peerServers: [ServerName]}
type PollResult = PollUnauthorized {} | PollAuthorized {events: [PollEvent], cursor: Timestamp}
type DeliveryStatus = Text where \s -> s == "delivered" || s == "federated" || s == "queued"
type SendResult = SendUnauthorized {} | SendRejected {} | SendDone {status: DeliveryStatus, remoteServers: [ServerName], fromKey: PubkeyHex}
type AckResult = AckUnauthorized {} | AckDone {pendingAcks: [AckedEntry], evictedEntries: [AckedEntry]}


-- ============================================
-- Persisted State
-- ============================================

*challenges : [Challenge]

*sessions : [Session]

*messages : [Message]

*presence : [PresenceEntry]

*seqCounter : Timestamp

*forwards : [ForwardEntry]

*ackedIds : [AckedEntry]

*lastPrunedAt : Timestamp

-- ============================================
-- Routes
-- ============================================

route AuthApi where
  /auth
    POST {pubkey: PubkeyHex} /challenge
      -> {challenge: Text}
      = ReqChallenge
    POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex} /verify
      -> {token: Text, expiresAt: Timestamp}
      = VerifyAuth

route ClientApi where
  POST {cursor: Timestamp, timeout: Int} /poll headers {authorization: Text}
    -> {events: [PollEvent], cursor: Timestamp, authorized: Bool}
    = Poll
  /messages
    POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp} / headers {authorization: Text}
      -> {status: MessageStatus, messageId: Text}
      = SendMessage
    POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text}
      -> {ok: Bool}
      = AckMessages
  GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text}
    -> {online: Bool, server: Text, authorized: Bool}
    = LookupPresence

route FederationApi where
  /federation
    POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName} /gossip headers {authorization: Text}
      -> {ok: Bool}
      = RecvGossip
    POST {toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex} /forward headers {authorization: Text}
      -> {ok: Bool}
      = ForwardMessage
    POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName} /ack headers {authorization: Text}
      -> {ok: Bool}
      = FederationAck

route MaintenanceApi where
  POST {} /maintenance/prune headers {authorization: Text}
    -> {ok: Bool}
    = Prune

route Api = AuthApi | ClientApi | FederationApi | MaintenanceApi

-- ============================================
-- Helpers
-- ============================================

any = \xs pred -> fold (\acc x -> if acc then acc else pred x) (False {}) xs
none = \xs pred -> not (any xs pred)
when = \cond action -> if cond then action else yield {}
whenOk = \result action -> case result of
  Ok _ -> action
  Err _ -> yield {}
clamp = \lo hi x -> if x < lo then lo else if x > hi then hi else x
headOf = \items -> fold (\acc x -> case acc of
  Nothing {} -> Just {value: x}
  _ -> acc) Nothing {} items

hexDigit = \n ->
  let n = if n < 0 then 0 else if n > 15 then 15 else n in
  if n == 0 then "0" else if n == 1 then "1" else if n == 2 then "2" else if n == 3 then "3"
  else if n == 4 then "4" else if n == 5 then "5" else if n == 6 then "6" else if n == 7 then "7"
  else if n == 8 then "8" else if n == 9 then "9" else if n == 10 then "a" else if n == 11 then "b"
  else if n == 12 then "c" else if n == 13 then "d" else if n == 14 then "e" else "f"

byteToHex = \n -> hexDigit (n / 16) ++ hexDigit (n - (n / 16) * 16)

intTo3Hex = \n ->
  let b0 = n / 65536 in
  let r0 = n - b0 * 65536 in
  let b1 = r0 / 256 in
  let b2 = r0 - b1 * 256 in
  byteToHex b0 ++ byteToHex b1 ++ byteToHex b2

genTokenN = \n -> if n <= 0 then yield "" else do
  chunk <- randomInt 16777216
  rest <- genTokenN (n - 1)
  yield (intTo3Hex chunk ++ rest)

genToken = genTokenN 8

tooLong = \s maxLen -> not (drop maxLen s == "")

isHexChar = \c ->
  c == "0" || c == "1" || c == "2" || c == "3" || c == "4" || c == "5" || c == "6" || c == "7" || c == "8" || c == "9" ||
  c == "a" || c == "b" || c == "c" || c == "d" || c == "e" || c == "f" ||
  c == "A" || c == "B" || c == "C" || c == "D" || c == "E" || c == "F"

isValidHexPairs = \s ->
  if s == "" then True {}
  else if drop 1 s == "" then False {}
  else if isHexChar (take 1 s) && isHexChar (take 1 (drop 1 s)) then isValidHexPairs (drop 2 s)
  else False {}

isValidHex = \s -> not (s == "") && isValidHexPairs s

normalizeHex = \s -> bytesToHex (bytesFromHex s)

isDigitChar = \c -> c == "0" || c == "1" || c == "2" || c == "3" || c == "4" || c == "5" || c == "6" || c == "7" || c == "8" || c == "9"

isAllowedServerChar = \c ->
  isDigitChar c || c == "-" || c == "." || c == ":"
  || c == "a" || c == "b" || c == "c" || c == "d" || c == "e" || c == "f"
  || c == "g" || c == "h" || c == "i" || c == "j" || c == "k" || c == "l"
  || c == "m" || c == "n" || c == "o" || c == "p" || c == "q" || c == "r"
  || c == "s" || c == "t" || c == "u" || c == "v" || c == "w" || c == "x"
  || c == "y" || c == "z"

containsBadUrlChar = \s ->
  if s == "" then False {}
  else if not (isAllowedServerChar (take 1 s)) then True {}
  else containsBadUrlChar (drop 1 s)

isCgnatRange = \s ->
  if not (take 4 s == "100.") then False {}
  else if (take 1 (drop 4 s) == "7" || take 1 (drop 4 s) == "8" || take 1 (drop 4 s) == "9")
    && isDigitChar (take 1 (drop 5 s)) && take 1 (drop 6 s) == "."
    && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
    then True {}
  else if take 1 (drop 4 s) == "6"
    && (take 1 (drop 5 s) == "4" || take 1 (drop 5 s) == "5" || take 1 (drop 5 s) == "6" || take 1 (drop 5 s) == "7" || take 1 (drop 5 s) == "8" || take 1 (drop 5 s) == "9")
    && take 1 (drop 6 s) == "."
    && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
    then True {}
  else if take 1 (drop 4 s) == "1" && (take 1 (drop 5 s) == "0" || take 1 (drop 5 s) == "1")
    && isDigitChar (take 1 (drop 6 s)) && take 1 (drop 7 s) == "."
    && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
    then True {}
  else if take 1 (drop 4 s) == "1" && take 1 (drop 5 s) == "2"
    && (take 1 (drop 6 s) == "0" || take 1 (drop 6 s) == "1" || take 1 (drop 6 s) == "2" || take 1 (drop 6 s) == "3"
      || take 1 (drop 6 s) == "4" || take 1 (drop 6 s) == "5" || take 1 (drop 6 s) == "6" || take 1 (drop 6 s) == "7")
    && take 1 (drop 7 s) == "."
    && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
    then True {}
  else False {}

containsColon = \s ->
  if s == "" then False {}
  else if take 1 s == ":" then True {}
  else containsColon (drop 1 s)

containsMultipleColons = \s ->
  if s == "" then False {}
  else if take 1 s == ":" then containsColon (drop 1 s)
  else containsMultipleColons (drop 1 s)

hasOctalOctet = \s ->
  if take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s) then True {}
  else hasOctalOctetAfterDot s

hasOctalOctetAfterDot = \s ->
  if s == "" then False {}
  else if take 1 s == "." && take 1 (drop 1 s) == "0" && isDigitChar (take 1 (drop 2 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 3 s) then True {}
  else hasOctalOctetAfterDot (drop 1 s)

hasHexPrefix = \s ->
  if take 2 s == "0x" || take 2 s == "0X" then True {}
  else hasHexPrefixAfterDot s

hasHexPrefixAfterDot = \s ->
  if s == "" then False {}
  else if take 1 s == "." && (take 2 (drop 1 s) == "0x" || take 2 (drop 1 s) == "0X") then True {}
  else hasHexPrefixAfterDot (drop 1 s)

isAllDigitsOrDotsUntilColonOrEnd = \s ->
  if s == "" then True {}
  else if take 1 s == ":" then True {}
  else if isDigitChar (take 1 s) || take 1 s == "." then isAllDigitsOrDotsUntilColonOrEnd (drop 1 s)
  else False {}

toLowerChar = \c ->
  if c == "A" then "a" else if c == "B" then "b" else if c == "C" then "c"
  else if c == "D" then "d" else if c == "E" then "e" else if c == "F" then "f"
  else if c == "G" then "g" else if c == "H" then "h" else if c == "I" then "i"
  else if c == "J" then "j" else if c == "K" then "k" else if c == "L" then "l"
  else if c == "M" then "m" else if c == "N" then "n" else if c == "O" then "o"
  else if c == "P" then "p" else if c == "Q" then "q" else if c == "R" then "r"
  else if c == "S" then "s" else if c == "T" then "t" else if c == "U" then "u"
  else if c == "V" then "v" else if c == "W" then "w" else if c == "X" then "x"
  else if c == "Y" then "y" else if c == "Z" then "z"
  else c

toLower = \s ->
  if s == "" then ""
  else toLowerChar (take 1 s) ++ toLower (drop 1 s)

isTrailingDots = \s ->
  if s == "" then True {}
  else if take 1 s == ":" then True {}
  else if take 1 s == "." then isTrailingDots (drop 1 s)
  else False {}

stripTrailingDot = \s ->
  if s == "" then ""
  else if take 1 s == "." && isTrailingDots (drop 1 s) then stripTrailingDot (drop 1 s)
  else take 1 s ++ stripTrailingDot (drop 1 s)

normalizeServerName = \s -> toLower (stripTrailingDot s)

serverHostN = normalizeServerName serverHost

containsSuffix = \suffix suffixLen s ->
  if s == "" then False {}
  else if take suffixLen s == suffix && (drop suffixLen s == "" || take 1 (drop suffixLen s) == ":") then True {}
  else containsSuffix suffix suffixLen (drop 1 s)

containsLocalhostSuffix = \s -> containsSuffix ".localhost" 10 s
containsLocalSuffix = \s -> containsSuffix ".local" 6 s
containsInternalSuffix = \s -> containsSuffix ".internal" 9 s

is172Private = \sn ->
  take 4 sn == "172."
  && let d1 = take 1 (drop 4 sn) in
  let d2 = take 1 (drop 5 sn) in
  take 1 (drop 6 sn) == "."
  && ((d1 == "1" && (d2 == "6" || d2 == "7" || d2 == "8" || d2 == "9"))
    || (d1 == "2" && isDigitChar d2)
    || (d1 == "3" && (d2 == "0" || d2 == "1")))

isHighOctetPrefix = \sn ->
  take 1 sn == "2"
  && let d2 = take 1 (drop 1 sn) in
  let d3 = take 1 (drop 2 sn) in
  take 1 (drop 3 sn) == "."
  && ((d2 == "2" && (d3 == "4" || d3 == "5" || d3 == "6" || d3 == "7" || d3 == "8" || d3 == "9"))
    || (d2 == "3" && isDigitChar d3)
    || (d2 == "4" && isDigitChar d3)
    || (d2 == "5" && (d3 == "0" || d3 == "1" || d3 == "2" || d3 == "3" || d3 == "4" || d3 == "5")))

matchesHostname = \sn name nameLen ->
  take nameLen sn == name && (drop nameLen sn == "" || take 1 (drop nameLen sn) == ":")

isBadServerName = \s ->
  let sn = toLower (stripTrailingDot s) in
  sn == ""
  || take 1 sn == "."
  || take 1 sn == ":"
  || containsBadUrlChar sn
  || matchesHostname sn "localhost" 9
  || matchesHostname sn "localhost.localdomain" 21
  || containsLocalhostSuffix sn
  || matchesHostname sn "local" 5
  || containsLocalSuffix sn
  || matchesHostname sn "internal" 8
  || containsInternalSuffix sn
  || matchesHostname sn "metadata" 8
  || take 4 sn == "127." || take 3 sn == "10."
  || take 8 sn == "192.168." || take 8 sn == "169.254."
  || take 2 sn == "0." || take 1 sn == "["
  || is172Private sn
  || take 7 sn == "198.18." || take 7 sn == "198.19."
  || take 8 sn == "192.0.0."
  || take 8 sn == "192.0.2."
  || take 10 sn == "192.88.99."
  || take 11 sn == "198.51.100."
  || take 10 sn == "203.0.113."
  || take 2 sn == "::"
  || isCgnatRange sn
  || containsMultipleColons sn
  || hasOctalOctet sn
  || hasHexPrefix sn
  || (isDigitChar (take 1 sn) && isAllDigitsOrDotsUntilColonOrEnd sn)
  || isHighOctetPrefix sn

authenticateSession : [Session] -> Text -> Timestamp -> AuthResult
authenticateSession = \sessions token t ->
  case headOf (do s <- sessions; where safeCompare s.token token && s.expiresAt > t; yield s) of
    Nothing {} -> Unauthorized {}
    Just {value: s} -> Authorized {pubkey: s.pubkey}

authenticateRequest = \sessions authorization t ->
  authenticateSession sessions (extractToken authorization) t

extractToken = \authHeader ->
  let token = drop 7 authHeader in
  if toLower (take 7 authHeader) == "bearer " && not (tooLong token maxTokenLen)
    then token
    else ""

verifySecret = \token secret ->
  not (secret == "") && safeCompare token secret

verifyFederationAuth = \authorization ->
  verifySecret (extractToken authorization) federationSecret

verifyMaintenanceAuth = \authorization ->
  let token = extractToken authorization in
  verifySecret token federationSecret || verifySecret token maintenanceSecret

clampTtl = clamp 1 maxPresenceTtl

clampTimestamp = \timestamp t -> clamp (t - messageMaxAge) t timestamp

nextSeqTs = \t seqCounter -> if t > seqCounter then t else seqCounter + 1

isFederatedOrigin = \originServer -> not (originServer == "") && not (originServer == serverHostN)

takeN = \items n -> fold (\acc e -> if count acc >= n then acc else union acc [e]) [] items

dedupMessageIds = \messageIds ->
  fold (\acc mid ->
    let nmid = normalizeHex mid in
    if count acc >= maxMessageIds then acc
    else if any acc (\a -> a == nmid) then acc
    else union acc [nmid]) [] messageIds

boundedSmallest = \items n getKey ->
  (fold (\acc a ->
    let k = getKey a in
    if acc.size < n
      then
        let newHeap = union acc.heap [a] in
        let newSize = count newHeap in
        if newSize > acc.size
          then {size: newSize, heap: newHeap, heapMax: case acc.heapMax of
            Nothing {} -> Just {value: k}
            Just {value: v} -> if k > v then Just {value: k} else acc.heapMax}
          else acc
      else case acc.heapMax of
        Nothing {} -> acc
        Just {value: maxVal} ->
          if k < maxVal
            then
              let removed = fold (\r x ->
                if not r.done && getKey x == maxVal
                  then {done: True {}, items: r.items}
                  else {done: r.done, items: union r.items [x]}) {done: False {}, items: []} acc.heap in
              let newHeap = union removed.items [a] in
              let newMax = fold (\best x -> case best of
                Nothing {} -> Just {value: getKey x}
                Just {value: v} -> if getKey x > v then Just {value: getKey x} else best) Nothing {} newHeap in
              {size: acc.size, heap: newHeap, heapMax: newMax}
            else acc) {size: 0, heap: [], heapMax: Nothing {}} items).heap

evictOldestAckedIds = \items n ->
  if n <= 0 then items
  else diff items (boundedSmallest items n (\a -> a.ackedAt))

safeCompareLoop = \s1 s2 n result ->
  if n <= 0 && s1 == "" && s2 == ""
    then result
    else safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1) (result + (if take 1 s1 == take 1 s2 then 0 else 1))

safeCompare = \a b ->
  safeCompareLoop a b maxTokenLen 0 + (if a == "" then 1 else 0) + (if b == "" then 1 else 0) == 0

evictOneOldest = \items getKey ->
  let oldest = fold (\acc x -> let k = getKey x in case acc of
    Nothing {} -> Just {value: k}
    Just {value: v} -> if k < v then Just {value: k} else acc) Nothing {} items in
  case oldest of
    Nothing {} -> items
    Just {value: oldestKey} ->
      (fold (\acc x ->
        if not acc.removed && getKey x == oldestKey
          then {removed: True {}, items: acc.items}
          else {removed: acc.removed, items: union acc.items [x]}) {removed: False {}, items: []} items).items

capPerKey = \items matchKey maxPerKey getExpiry t ->
  let active = do x <- items; where getExpiry x > t; yield x in
  let forKey = do x <- active; where matchKey x; yield x in
  if count forKey >= maxPerKey
    then let others = do x <- active; where not (matchKey x); yield x in
         union others (evictOneOldest forKey getExpiry)
    else active

capGlobal = \items maxCount getKey ->
  if count items >= maxCount
    then evictOneOldest items getKey
    else items

collectPeerServers = \items getServer ->
  fold (\acc item ->
    let s = getServer item in
    if s == serverHostN then acc
    else if any acc (\a -> a == s) then acc
    else union acc [s]) [] items

samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server

mergeByKey = \sameKey initial items ->
  fold (\acc e ->
    if any acc (\a -> sameKey a e && a.expiresAt >= e.expiresAt)
      then acc
      else union
        (do a <- acc; where not (sameKey a e); yield a)
        [e]) initial items

mergeByPubkeyServer = mergeByKey samePubkeyServer

removeOffline = \presenceSet offlineOnlyKeys trustedOffline t ->
  diff presenceSet (do
    p <- presenceSet
    k <- offlineOnlyKeys
    where samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp)
    yield p)

countMessagesFor = \messages toKey t ->
  count (do
    m <- messages
    where m.toKey == toKey && m.receivedAt >= t - messageMaxAge
    yield m)


validGossipEvents : [GossipEvent] -> Timestamp -> [ValidGossipEntry]
validGossipEvents = \events t -> do
  e <- events
  where isValidHex e.pubkey && not (tooLong e.pubkey maxPubkeyLen) && not (tooLong e.server maxServerNameLen) && not (isBadServerName e.server)
  let server = normalizeServerName e.server
  where not (server == serverHostN) && e.timestamp <= t + clockSkewTolerance
  let ttl = clampTtl e.ttl
  let expiresAt = e.timestamp + ttl * 1000
  where expiresAt > t
  yield {eventType: e.eventType, pubkey: normalizeHex e.pubkey, server: server, expiresAt: expiresAt, timestamp: e.timestamp, ttl: ttl}

sendToEach : [ServerName] -> (ServerName -> (a {})) -> a {}
sendToEach = \servers action ->
  case headOf servers of
    Nothing {} -> yield {}
    Just {value: server} -> do
      let rest = do s <- servers; where not (s == server); yield s
      fork (action server)
      sendToEach rest action

pruneExpired = \t -> do
  set *challenges = do
    c <- *challenges
    where c.expiresAt > t
    yield c
  set *sessions = do
    s <- *sessions
    where s.expiresAt > t
    yield s
  presenceBefore <- *presence
  let peerServersBefore = collectPeerServers presenceBefore (\p -> p.server)
  let presenceAfter = do
    p <- presenceBefore
    where p.expiresAt > t
    yield p
  set *presence = presenceAfter
  set *messages = do
    m <- *messages
    where m.receivedAt >= t - messageMaxAge
    yield m
  set *forwards = do
    f <- *forwards
    where f.createdAt >= t - messageMaxAge
    yield f
  set *ackedIds = do
    a <- *ackedIds
    where a.ackedAt >= t - messageMaxAge
    yield a
  yield {expiredLocal: (do
    p <- presenceBefore
    where p.expiresAt <= t && p.server == serverHostN && none presenceAfter (\q -> q.pubkey == p.pubkey && q.server == serverHostN)
    yield p), peerServers: peerServersBefore}

maybePrune = \t -> do
  lastPruned <- *lastPrunedAt
  if t - lastPruned < 1000
    then yield {expiredLocal: [], peerServers: []}
    else do
      set *lastPrunedAt = t
      pruneExpired t

forEachBatch = \items batchSize process ->
  if count items == 0 then yield {}
  else do
    let batch = takeN items batchSize
    let rest = diff items batch
    process batch
    forEachBatch rest batchSize process

sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {}
sendBatchedGossipToServer = \server allEvents hops ->
  forEachBatch allEvents maxGossipEvents (\batch -> do
    _ <- fetch (federationScheme ++ server) (RecvGossip {
      authorization: "Bearer " ++ federationSecret,
      events: batch, hopsRemaining: hops, fromServer: serverHostN})
    yield {})

sendBatchedGossip : [ServerName] -> [GossipEvent] -> Int -> IO {network} {}
sendBatchedGossip = \peerServers allEvents hops ->
  sendToEach peerServers (\server -> sendBatchedGossipToServer server allEvents hops)

broadcastOfflineGossip = \t peerServers expiredLocal ->
  when (federationEnabled && count peerServers > 0 && count expiredLocal > 0) (do
    let expiredEntries = mergeByKey (\a b -> a.pubkey == b.pubkey) [] (do
      p <- expiredLocal
      let ttl = clamp offlineGossipMinTtl maxPresenceTtl ((p.expiresAt - p.timestamp) / 1000)
      yield {pubkey: p.pubkey, ttl: ttl, expiresAt: p.expiresAt})
    let gossipEvents = do
      e <- expiredEntries
      yield {eventType: "offline", pubkey: e.pubkey, server: serverHostN, timestamp: e.expiresAt, ttl: e.ttl}
    sendBatchedGossip peerServers gossipEvents 2)

forkBroadcastOffline = \t result ->
  fork (broadcastOfflineGossip t result.peerServers result.expiredLocal)

maybePruneAndBroadcast = \t -> do
  pruneResult <- atomic do maybePrune t
  forkBroadcastOffline t pruneResult

removeForward = \mid srv -> atomic do
  forwards <- *forwards
  set *forwards = do
    x <- forwards
    where not (x.messageId == mid && x.toServer == srv)
    yield x

retryForwardsForServer : [ForwardEntry] -> Int -> IO {network} {}
retryForwardsForServer = \entries remaining ->
  if remaining <= 0
    then yield {}
    else case headOf entries of
      Nothing {} -> yield {}
      Just {value: f} -> do
        let rest = do x <- entries; where not (x.messageId == f.messageId); yield x
        result <- fetch (federationScheme ++ f.toServer) (ForwardMessage {
          toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob,
          timestamp: f.timestamp, originServer: serverHostN, messageId: f.messageId,
          authorization: "Bearer " ++ federationSecret})
        whenOk result (removeForward f.messageId f.toServer)
        retryForwardsForServer rest (remaining - 1)

retryPendingForwards : [ForwardEntry] -> IO {network} {}
retryPendingForwards = \pending -> do
  let servers = collectPeerServers pending (\x -> x.toServer)
  sendToEach servers (\server ->
    retryForwardsForServer (do x <- pending; where x.toServer == server; yield x) maxForwardRetriesPerServer)
  yield {}

sendBatchedAcksToServer : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> ServerName -> IO {network} {}
sendBatchedAcksToServer = \serverAcks server ->
  forEachBatch serverAcks maxMessageIds (\batch -> do
    result <- fetch (federationScheme ++ server) (FederationAck {
      authorization: "Bearer " ++ federationSecret,
      messageIds: (do a <- batch; yield a.messageId),
      originServer: server, fromServer: serverHostN})
    whenOk result (atomic do
      ackedIds <- *ackedIds
      set *ackedIds = do
        a <- ackedIds
        where not (a.originServer == server && any batch (\sa -> sa.messageId == a.messageId && sa.toKey == a.toKey))
        yield a))

sendAcksAndClean : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> [ServerName] -> IO {network} {}
sendAcksAndClean = \pendingAcks servers ->
  sendToEach servers (\server ->
    sendBatchedAcksToServer (do a <- pendingAcks; where a.originServer == server; yield a) server)

retryEvictedAcks = \evictedEntries pendingAcks ->
  let evictedToRetry = do
    a <- evictedEntries
    where none pendingAcks (\a2 -> a2.messageId == a.messageId && a2.toKey == a.toKey)
    yield a
  in when (count evictedToRetry > 0) (do
    let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
    sendToEach evictedOriginServers (\server -> do
      fetchResult <- fetch (federationScheme ++ server) (FederationAck {
        authorization: "Bearer " ++ federationSecret,
        messageIds: (do a <- evictedToRetry; where a.originServer == server; yield a.messageId),
        originServer: server, fromServer: serverHostN})
      case fetchResult of
        Err _ -> do
          dropped <- atomic do
            ackedIds <- *ackedIds
            let reinsert = do a <- evictedToRetry; where a.originServer == server; yield a
            let combined = union ackedIds reinsert
            let excess = count combined - maxAckedIds
            let afterEviction = if excess <= 0 then combined
              else evictOldestAckedIds combined excess
            set *ackedIds = afterEviction
            yield excess
          when (dropped > 0)
            (println ("ackMessages: ackedIds at capacity (" ++ show maxAckedIds ++ "), " ++ show dropped ++ " ack entries permanently lost for " ++ server))
        _ -> yield {}))

pruneAndRetry = \t -> do
  result <- atomic do
    set *lastPrunedAt = t
    pr <- pruneExpired t
    forwards <- *forwards
    ackedIds <- *ackedIds
    let pendingAcks = do a <- ackedIds; where isFederatedOrigin a.originServer; yield a
    yield {expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, pendingForwards: forwards, pendingAcks: pendingAcks}
  broadcastOfflineGossip t result.peerServers result.expiredLocal
  when (federationEnabled && count result.pendingForwards > 0)
    (retryPendingForwards result.pendingForwards)
  when (federationEnabled && count result.pendingAcks > 0) (do
    let ackOriginServers = collectPeerServers result.pendingAcks (\a -> a.originServer)
    sendAcksAndClean result.pendingAcks ackOriginServers)

pollOnce = \token cursor -> do
  t <- now
  atomic do
    sessions <- *sessions
    let auth = authenticateSession sessions token t
    case auth of
      Unauthorized {} ->
        yield PollUnauthorized {}
      Authorized {pubkey} -> do
        seqCounter <- *seqCounter
        messages <- *messages
        let cursorCeil = if seqCounter > t then seqCounter else t
        let clampedCursor = clamp 0 cursorCeil cursor
        let matchingMsgs = do
          m <- messages
          where m.toKey == pubkey && m.receivedAt >= t - messageMaxAge && m.receivedAt > clampedCursor
          yield m
        let limitedMsgs = boundedSmallest matchingMsgs maxPollEvents (\m -> m.receivedAt)
        let evts = do
          m <- limitedMsgs
          yield {id: m.messageId, eventType: "message",
                 payload: {toKey: m.toKey, fromKey: m.fromKey,
                            encryptedBlob: m.encryptedBlob,
                            timestamp: m.timestamp}}
        let lastReceivedAt = fold (\acc m -> if m.receivedAt > acc then m.receivedAt else acc) clampedCursor limitedMsgs
        yield PollAuthorized {events: evts, cursor: lastReceivedAt}

pollLoop = \token cursor deadline -> do
  result <- pollOnce token cursor
  t <- now
  case result of
    PollUnauthorized {} -> yield result
    PollAuthorized {events} ->
      if count events == 0 && t < deadline
        then do
          let remaining = deadline - t
          let sleepMs  = if remaining > 500 then 500<Ms> else remaining
          sleep sleepMs
          pollLoop token cursor deadline
        else yield result

-- ============================================
-- Request Handler
-- ============================================

serve = \req -> case req of

  ReqChallenge {pubkey, respond} -> do
    let pubkey = normalizeHex pubkey
    challenge <- genToken
    t <- now
    pruneResult <- atomic do
      pr <- maybePrune t
      challenges <- *challenges
      let activeChallenges = capPerKey challenges (\c -> c.pubkey == pubkey) maxChallengesPerKey (\c -> c.expiresAt) t
      let globalCapped = capGlobal activeChallenges maxChallenges (\c -> c.expiresAt)
      set *challenges = union
        globalCapped
        [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry}]
      yield pr
    forkBroadcastOffline t pruneResult
    yield (respond {challenge: challenge})

  VerifyAuth {pubkey, challenge, signature, respond} -> do
    let pubkey = normalizeHex pubkey
    t <- now
    token <- genToken
    let expiry = t + sessionExpiry
    result <- atomic do
      pr <- maybePrune t
      challenges <- *challenges
      sessions <- *sessions
      presence <- *presence
      let hasMatch = any challenges (\c -> c.pubkey == pubkey && c.challenge == challenge && c.expiresAt > t)
      let sigValid = if hasMatch then verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature) else False {}
      if not sigValid
        then yield {pr: pr, verified: False {}, peerServers: []}
        else do
          set *challenges = do
            c <- challenges
            where not (c.pubkey == pubkey && c.challenge == challenge)
            yield c
          let activeSessions = capPerKey sessions (\s -> s.pubkey == pubkey) maxSessionsPerKey (\s -> s.expiresAt) t
          let globalSessionsCapped = capGlobal activeSessions maxSessions (\s -> s.expiresAt)
          set *sessions = union globalSessionsCapped [{token: token, pubkey: pubkey, expiresAt: expiry}]
          let presenceWithout = do
                p <- presence
                where not (p.pubkey == pubkey && p.server == serverHostN)
                yield p
          let presenceEvicted = capGlobal presenceWithout maxPresenceEntries (\p -> p.expiresAt)
          let updatedPresence = union presenceEvicted [{pubkey: pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}]
          set *presence = updatedPresence
          let peerServers = if federationEnabled
            then collectPeerServers updatedPresence (\p -> p.server)
            else []
          yield {pr: pr, verified: True {}, peerServers: peerServers}
    let expiredLocal = if result.verified
      then do p <- result.pr.expiredLocal; where not (p.pubkey == pubkey); yield p
      else result.pr.expiredLocal
    fork (do
      when (result.verified && federationEnabled)
        (sendBatchedGossip result.peerServers [{eventType: "online", pubkey: pubkey, server: serverHostN, timestamp: t, ttl: onlineGossipTtl}] 2)
      broadcastOfflineGossip t result.pr.peerServers expiredLocal)
    yield (if result.verified
      then respond {token: token, expiresAt: expiry}
      else respond {token: "", expiresAt: 0})

  Poll {cursor, timeout, authorization, respond} -> do
    t <- now
    let clampedTimeout = clamp 0 60000 timeout
    let deadline = t + clampedTimeout
    let token = extractToken authorization
    result <- pollLoop token cursor deadline
    tAfterPoll <- now
    maybePruneAndBroadcast tAfterPoll
    yield (case result of
      PollUnauthorized {} -> respond {events: [], cursor: -1, authorized: False {}}
      PollAuthorized {events, cursor: c} -> respond {events: events, cursor: c, authorized: True {}})

  SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
    let to = normalizeHex to
    let encryptedBlob = normalizeHex encryptedBlob
    t <- now
    msgId <- genToken
    let clampedTs = clampTimestamp timestamp t
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      let auth = authenticateRequest sessions authorization t
      case auth of
        Unauthorized {} ->
          yield {pr: pr, send: SendUnauthorized {}}
        Authorized {pubkey: fromKey} -> do
          messages <- *messages
          if countMessagesFor messages to t >= maxMessagesPerRecipient
            then yield {pr: pr, send: SendRejected {}}
            else do
              presence <- *presence
              seqCounter <- *seqCounter
              let seqTs = nextSeqTs t seqCounter
              set *seqCounter = seqTs
              set *messages = union messages
                [{messageId: msgId, toKey: to, fromKey: fromKey,
                  encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]
              let toPresence = do p <- presence; where p.pubkey == to && p.expiresAt > t; yield p
              let localOnline = any toPresence (\p -> p.server == serverHostN)
              let remoteServers = do p <- toPresence; where not (p.server == serverHostN); yield p.server
              forwards <- *forwards
              let forwardServers = takeN remoteServers (maxForwardsEntries - count forwards)
              let shouldForward = federationEnabled && count forwardServers > 0
              let status = if localOnline then "delivered"
                else if shouldForward then "federated"
                else "queued"
              set *forwards = if shouldForward
                then union forwards (do s <- forwardServers; yield {messageId: msgId, toServer: s, createdAt: t, toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob, timestamp: clampedTs})
                else forwards
              yield {pr: pr, send: SendDone {status: status, remoteServers: remoteServers, fromKey: fromKey}}
    fork (do
      case result.send of
        SendDone {status, remoteServers, fromKey} ->
          when (count remoteServers > 0 && federationEnabled) (do
            sendToEach remoteServers (\server -> do
              fwdResult <- fetch (federationScheme ++ server) (ForwardMessage {
                toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob,
                timestamp: clampedTs, originServer: serverHostN, messageId: msgId,
                authorization: "Bearer " ++ federationSecret})
              whenOk fwdResult (removeForward msgId server))
            when (status == "queued")
              (println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")))
        _ -> yield {}
      broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
    yield (case result.send of
      SendUnauthorized _ -> respond {status: "unauthorized", messageId: ""}
      SendRejected _ -> respond {status: "rejected", messageId: ""}
      SendDone {status} -> respond {status: status, messageId: msgId})

  AckMessages {messageIds, authorization, respond} -> do
    t <- now
    let dedupedIds = dedupMessageIds messageIds
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      let auth = authenticateRequest sessions authorization t
      case auth of
        Unauthorized {} ->
          yield {pr: pr, ack: AckUnauthorized {}}
        Authorized {pubkey} -> do
          messages <- *messages
          let ackedMessages = do
            m <- messages
            mid <- dedupedIds
            where m.messageId == mid && m.toKey == pubkey
            yield m
          set *messages = diff messages ackedMessages
          let ackedFederated = do
            m <- ackedMessages
            where isFederatedOrigin m.originServer
            yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer}
          ackedIds <- *ackedIds
          let combinedAckedIds = union ackedIds ackedFederated
          let evictedEntries = let excessCount = count combinedAckedIds - maxAckedIds in
            if excessCount <= 0 then [] else boundedSmallest combinedAckedIds excessCount (\a -> a.ackedAt)
          set *ackedIds = diff combinedAckedIds evictedEntries
          yield {pr: pr, ack: AckDone {pendingAcks: ackedFederated, evictedEntries: evictedEntries}}
    fork (do
      case result.ack of
        AckDone {pendingAcks, evictedEntries} ->
          when federationEnabled (do
            let originServers = collectPeerServers pendingAcks (\a -> a.originServer)
            when (count originServers > 0)
              (sendAcksAndClean pendingAcks originServers)
            retryEvictedAcks evictedEntries pendingAcks)
        _ -> yield {}
      broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
    yield (case result.ack of
      AckUnauthorized _ -> respond {ok: False {}}
      AckDone _ -> respond {ok: True {}})

  LookupPresence {pubkey, authorization, respond} -> do
    let pubkey = normalizeHex pubkey
    t <- now
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      let auth = authenticateRequest sessions authorization t
      case auth of
        Unauthorized {} ->
          yield {pr: pr, authorized: False {}, foundServer: ""}
        Authorized _ -> do
          presence <- *presence
          let valid = do
            p <- presence
            where p.pubkey == pubkey && p.expiresAt > t
            yield p
          let foundServer = (fold (\acc p ->
            if acc.server == serverHostN then acc
            else if p.server == serverHostN then {server: serverHostN, best: p.expiresAt}
            else if p.expiresAt > acc.best then {server: p.server, best: p.expiresAt}
            else acc) {server: "", best: 0} valid).server
          yield {pr: pr, authorized: True {}, foundServer: foundServer}
    forkBroadcastOffline t result.pr
    yield (if result.authorized
      then respond {online: not (result.foundServer == ""), server: result.foundServer, authorized: True {}}
      else respond {online: False {}, server: "", authorized: False {}})

  RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
    t <- now
    let authorized = verifyFederationAuth authorization
    let cappedHops = clamp 0 5 hopsRemaining
    let fromServer = normalizeServerName fromServer
    if not authorized || cappedHops < 1 || fromServer == serverHostN || count events > maxGossipEvents
      then do
        maybePruneAndBroadcast t
        yield (respond {ok: False {}})
      else do
        let allValidEntries = validGossipEvents events t
        let onlineEntries = do e <- allValidEntries; where e.eventType == "online"; yield e
        let offlineEntries = do e <- allValidEntries; where e.eventType == "offline"; yield e
        let filteredOnline = do
          e <- onlineEntries
          where none offlineEntries (\o -> o.server == fromServer && samePubkeyServer o e && o.timestamp > e.timestamp)
          yield e
        let filteredOffline = do
          e <- offlineEntries
          where none onlineEntries (\o -> samePubkeyServer o e && o.timestamp > e.timestamp)
          yield e
        let trustedOffline = do
          e <- offlineEntries
          where e.server == fromServer
          yield e
        let deduped = mergeByPubkeyServer [] filteredOnline
        gossipResult <- atomic do
          pr <- maybePrune t
          presence <- *presence
          let trustedDeduped = do
            e <- deduped
            where e.server == fromServer || any presence (\p -> p.server == e.server && p.expiresAt > t)
            yield e
          let appliedOnline = do
            e <- trustedDeduped
            where none presence (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt)
            yield {pubkey: e.pubkey, server: e.server}
          let merged = mergeByPubkeyServer presence trustedDeduped
          let offlineOnlyKeys = do
            e <- allValidEntries
            where none trustedDeduped (\d -> samePubkeyServer d e)
            yield e
          let appliedOffline = do
            k <- offlineOnlyKeys
            where any presence (\p -> samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp))
            yield {pubkey: k.pubkey, server: k.server}
          let afterOffline = removeOffline merged offlineOnlyKeys trustedOffline t
          let withinCapacity = count afterOffline <= maxPresenceEntries
          let capResult = if withinCapacity
            then {finalPresence: afterOffline, appliedOnline: appliedOnline}
            else
              let updatesOnly = do e <- trustedDeduped; where any presence (\p -> samePubkeyServer p e); yield e in
              let updatesOnlyMerged = mergeByPubkeyServer presence updatesOnly in
              let updatesOnlyAfterOffline = removeOffline updatesOnlyMerged offlineOnlyKeys trustedOffline t in
              let reclaimSlots = maxPresenceEntries - count updatesOnlyAfterOffline in
              let newEntries = do e <- trustedDeduped; where none presence (\p -> samePubkeyServer p e) && none updatesOnlyAfterOffline (\p -> samePubkeyServer p e); yield e in
              let reclaimedEntries = takeN newEntries reclaimSlots in
              {finalPresence: union updatesOnlyAfterOffline reclaimedEntries,
               appliedOnline: union
                (do e <- updatesOnly; where none presence (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt); yield {pubkey: e.pubkey, server: e.server})
                (do e <- reclaimedEntries; yield {pubkey: e.pubkey, server: e.server})}
          set *presence = capResult.finalPresence
          let gossipPeerServers = collectPeerServers capResult.finalPresence (\p -> p.server)
          yield {appliedKeys: union capResult.appliedOnline appliedOffline, pr: pr, gossipPeerServers: gossipPeerServers, withinCapacity: withinCapacity}
        let effectiveEvents = do
          e <- union filteredOnline filteredOffline
          where any gossipResult.appliedKeys (\a -> samePubkeyServer a e)
          yield {eventType: e.eventType, pubkey: e.pubkey, server: e.server, timestamp: e.timestamp, ttl: e.ttl}
        when (not gossipResult.withinCapacity)
          (println ("gossip: presence at capacity (" ++ show maxPresenceEntries ++ "), limiting new entries from " ++ fromServer))
        fork (do
          when (cappedHops > 1 && federationEnabled && count effectiveEvents > 0) (
            let targets = do
              s <- gossipResult.gossipPeerServers
              where not (s == fromServer)
              yield s
            in sendBatchedGossip targets effectiveEvents (cappedHops - 1))
          let pr = gossipResult.pr
          broadcastOfflineGossip t pr.peerServers pr.expiredLocal)
        yield (respond {ok: True {}})

  ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
    let toKey = normalizeHex toKey
    let fromKey = normalizeHex fromKey
    let encryptedBlob = normalizeHex encryptedBlob
    let messageId = normalizeHex messageId
    let originServer = normalizeServerName originServer
    t <- now
    let authorized = verifyFederationAuth authorization
    let validOrigin = isFederatedOrigin originServer
    if not (authorized && validOrigin)
      then do
        maybePruneAndBroadcast t
        yield (respond {ok: False {}})
      else do
        let clampedTs = clampTimestamp timestamp t
        result <- atomic do
          pr <- maybePrune t
          messages <- *messages
          ackedIds <- *ackedIds
          if any messages (\m -> m.messageId == messageId && m.toKey == toKey)
            || any ackedIds (\a -> a.messageId == messageId && a.toKey == toKey)
            then yield {pr: pr, ok: True {}}
            else if countMessagesFor messages toKey t >= maxMessagesPerRecipient
              then yield {pr: pr, ok: False {}}
              else do
                seqCounter <- *seqCounter
                let seqTs = nextSeqTs t seqCounter
                set *seqCounter = seqTs
                set *messages = union messages
                  [{messageId: messageId, toKey: toKey, fromKey: fromKey,
                    encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs}]
                yield {pr: pr, ok: True {}}
        forkBroadcastOffline t result.pr
        yield (respond {ok: result.ok})

  FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
    let fromServer = normalizeServerName fromServer
    let originServer = normalizeServerName originServer
    t <- now
    let authorized = verifyFederationAuth authorization
    if not authorized || not (originServer == serverHostN) || fromServer == serverHostN
      then do
        maybePruneAndBroadcast t
        yield (respond {ok: False {}})
      else do
        let dedupedIds = dedupMessageIds messageIds
        pruneResult <- atomic do
          pr <- maybePrune t
          forwards <- *forwards
          set *forwards = do
            f <- forwards
            where not (f.toServer == fromServer && any dedupedIds (\mid -> f.messageId == mid))
            yield f
          yield pr
        forkBroadcastOffline t pruneResult
        yield (respond {ok: True {}})

  Prune {authorization, respond} -> do
    t <- now
    let authorized = verifyMaintenanceAuth authorization
    when authorized (fork (pruneAndRetry t))
    yield (respond {ok: authorized})

-- ============================================
-- Entry Point
-- ============================================

backgroundPrune = do
  sleep 30000
  t <- now
  pruneAndRetry t
  fork backgroundPrune

main = do
  println "Skrepka relay server starting on port 8080..."
  fork backgroundPrune
  listen 8080 serve