-- 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

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

type PollEvent = {id: Text, eventType: Text, payload: Text}

type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int, ttl: Int}

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

*challenges : [{pubkey: Text, challenge: Text, expiresAt: Int}]

*sessions : [{token: Text, pubkey: Text, expiresAt: Int}]

*messages : [{messageId: Text, toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, receivedAt: Int}]

*presence : [{pubkey: Text, server: Text, expiresAt: Int, timestamp: Int}]

*seqCounter : Int

*forwards : [{messageId: Text, toServer: Text, createdAt: Int, toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int}]

*ackedIds : [{messageId: Text, toKey: Text, ackedAt: Int, originServer: Text}]

*lastPrunedAt : Int

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

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

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

route FederationApi where
  /federation
    POST {events: [GossipEvent], hopsRemaining: Int, fromServer: Text} /gossip headers {authorization: Text}
      -> {ok: Bool}
      = RecvGossip
    POST {toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, messageId: Text} /forward headers {authorization: Text}
      -> {ok: Bool}
      = ForwardMessage
    POST {messageIds: [Text], originServer: Text, fromServer: Text} /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
-- ============================================

hexDigit = \n ->
  let n = if n < 0 then 0 else if n > 15 then 15 else n
  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
  let r0 = n - b0 * 65536
  let b1 = r0 / 256
  let b2 = r0 - b1 * 256
  byteToHex b0 ++ byteToHex b1 ++ byteToHex b2

genToken = do
  a <- randomInt 16777216
  b <- randomInt 16777216
  c <- randomInt 16777216
  d <- randomInt 16777216
  e <- randomInt 16777216
  f <- randomInt 16777216
  g <- randomInt 16777216
  h <- randomInt 16777216
  yield (intTo3Hex a ++ intTo3Hex b ++ intTo3Hex c ++ intTo3Hex d ++ intTo3Hex e ++ intTo3Hex f ++ intTo3Hex g ++ intTo3Hex h)

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)

containsBadUrlChar = \s ->
  if s == "" then False {}
  else if take 1 s == "/" || take 1 s == "?" || take 1 s == "#" || take 1 s == " " || take 1 s == "@" || take 1 s == "%" || take 1 s == "\\"
    || take 1 (bytesToHex (textToBytes (take 1 s))) == "0" || take 1 (bytesToHex (textToBytes (take 1 s))) == "1" || bytesToHex (textToBytes (take 1 s)) == "7f"
    || not (drop 2 (bytesToHex (textToBytes (take 1 s))) == "")
    then True {}
    else containsBadUrlChar (drop 1 s)

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

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 {}

isAllDigitsUntilColonOrEnd = \s ->
  if s == "" then True {}
  else if take 1 s == ":" then True {}
  else if isDigitChar (take 1 s) then isAllDigitsUntilColonOrEnd (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

containsLocalhostSuffix = \s ->
  if s == "" then False {}
  else if take 10 s == ".localhost" && (drop 10 s == "" || take 1 (drop 10 s) == ":") then True {}
  else containsLocalhostSuffix (drop 1 s)

isBadServerName = \s ->
  let sn = toLower (stripTrailingDot s)
  sn == ""
  || take 1 sn == "."
  || take 1 sn == ":"
  || containsBadUrlChar sn
  || sn == "localhost" || take 10 sn == "localhost:"
  || sn == "localhost.localdomain" || take 22 sn == "localhost.localdomain:"
  || containsLocalhostSuffix sn
  || take 4 sn == "127." || take 3 sn == "10."
  || take 8 sn == "192.168." || take 7 sn == "169.254."
  || take 2 sn == "0." || take 1 sn == "["
  || take 7 sn == "172.16." || take 7 sn == "172.17." || take 7 sn == "172.18." || take 7 sn == "172.19."
  || take 7 sn == "172.20." || take 7 sn == "172.21." || take 7 sn == "172.22." || take 7 sn == "172.23."
  || take 7 sn == "172.24." || take 7 sn == "172.25." || take 7 sn == "172.26." || take 7 sn == "172.27."
  || take 7 sn == "172.28." || take 7 sn == "172.29." || take 7 sn == "172.30." || take 7 sn == "172.31."
  || 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 12 sn == "198.51.100."
  || take 11 sn == "203.0.113."
  || take 2 sn == "::"
  || isCgnatRange sn
  || containsMultipleColons sn
  || hasOctalOctet sn
  || hasHexPrefix sn
  || (isDigitChar (take 1 sn) && isAllDigitsUntilColonOrEnd sn)
  || take 4 sn == "224." || take 4 sn == "225." || take 4 sn == "226." || take 4 sn == "227."
  || take 4 sn == "228." || take 4 sn == "229." || take 4 sn == "230." || take 4 sn == "231."
  || take 4 sn == "232." || take 4 sn == "233." || take 4 sn == "234." || take 4 sn == "235."
  || take 4 sn == "236." || take 4 sn == "237." || take 4 sn == "238." || take 4 sn == "239."
  || take 4 sn == "240." || take 4 sn == "241." || take 4 sn == "242." || take 4 sn == "243."
  || take 4 sn == "244." || take 4 sn == "245." || take 4 sn == "246." || take 4 sn == "247."
  || take 4 sn == "248." || take 4 sn == "249." || take 4 sn == "250." || take 4 sn == "251."
  || take 4 sn == "252." || take 4 sn == "253." || take 4 sn == "254." || take 4 sn == "255."

lookupSession = \sessions token t ->
  single (do
    s <- sessions
    where s.token == token
    where s.expiresAt > t
    yield s)

extractToken = \authHeader ->
  if (take 1 authHeader == "B" || take 1 authHeader == "b")
    && (take 1 (drop 1 authHeader) == "e" || take 1 (drop 1 authHeader) == "E")
    && (take 1 (drop 2 authHeader) == "a" || take 1 (drop 2 authHeader) == "A")
    && (take 1 (drop 3 authHeader) == "r" || take 1 (drop 3 authHeader) == "R")
    && (take 1 (drop 4 authHeader) == "e" || take 1 (drop 4 authHeader) == "E")
    && (take 1 (drop 5 authHeader) == "r" || take 1 (drop 5 authHeader) == "R")
    && take 1 (drop 6 authHeader) == " "
    && not (tooLong (drop 7 authHeader) maxTokenLen)
    then drop 7 authHeader
    else ""

verifyFederationAuth = \authorization ->
  not (federationSecret == "") && safeCompare (extractToken authorization) federationSecret

verifyMaintenanceAuth = \authorization ->
  let token = extractToken authorization
  let fedOk = not (federationSecret == "") && safeCompare token federationSecret
  let maintOk = not (maintenanceSecret == "") && safeCompare token maintenanceSecret
  fedOk || maintOk

clampTtl = \ttl -> if ttl < 1 then 1 else if ttl > maxPresenceTtl then maxPresenceTtl else ttl

evictOldestAckedIds = \items n ->
  if n <= 0 then items
  else
    let oldest = fold (\acc a -> if acc.ackedAt == -1 || a.ackedAt < acc.ackedAt then a else acc) {messageId: "", toKey: "", ackedAt: -1, originServer: ""} items
    in if oldest.ackedAt == -1 then items
       else evictOldestAckedIds (fold (\acc a ->
         if not acc.removed && a == oldest
           then {removed: True {}, items: acc.items}
           else {removed: acc.removed, items: union acc.items [a]}) {removed: False {}, items: []} items).items (n - 1)

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

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

sendToEach = \servers action ->
  if count servers == 0
    then yield {}
    else do
      let server = fold (\acc s -> if acc == "" then s else acc) "" servers
      let rest = do s <- servers; where not (s == server); yield s
      if server == ""
        then yield {}
        else do
          catch (action server) (\err ->
            println ("federation: error reaching " ++ server ++ ": " ++ show err))
          sendToEach rest action

pruneExpired = \t -> do
  challenges <- *challenges
  set *challenges = do
    c <- challenges
    where c.expiresAt > t
    yield c
  sessions <- *sessions
  set *sessions = do
    s <- sessions
    where s.expiresAt > t
    yield s
  presenceBefore <- *presence
  let peerServersBefore = fold (\acc p ->
    if p.server == serverHostN then acc
    else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
    else union acc [p.server]) [] presenceBefore
  let presenceAfter = do
    p <- presenceBefore
    where p.expiresAt > t
    yield p
  set *presence = presenceAfter
  messages <- *messages
  set *messages = do
    m <- messages
    where m.receivedAt >= t - messageMaxAge
    yield m
  forwards <- *forwards
  set *forwards = do
    f <- forwards
    where f.createdAt >= t - messageMaxAge
    yield f
  ackedIds <- *ackedIds
  set *ackedIds = do
    a <- ackedIds
    where a.ackedAt >= t - messageMaxAge
    yield a
  yield {expiredLocal: (do
    p <- presenceBefore
    where p.expiresAt <= t
    where p.server == serverHostN
    where count (do
      q <- presenceAfter
      where q.pubkey == p.pubkey
      where q.server == serverHostN
      yield q) == 0
    yield p), peerServers: peerServersBefore}

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

sendBatchedGossip = \peerServers allEvents ->
  if count allEvents == 0
    then yield {}
    else do
      let batch = fold (\acc e ->
        if count acc >= maxGossipEvents then acc
        else union acc [e]) [] allEvents
      let rest = (fold (\acc e ->
        if acc.taken < maxGossipEvents
          then {taken: acc.taken + 1, items: acc.items}
          else {taken: acc.taken, items: union acc.items [e]}) {taken: 0, items: []} allEvents).items
      sendToEach peerServers (\server ->
        fetch (federationScheme ++ server) (RecvGossip {
          authorization: "Bearer " ++ federationSecret,
          events: batch, hopsRemaining: 2, fromServer: serverHostN}))
      sendBatchedGossip peerServers rest

broadcastOfflineGossip = \t peerServers expiredLocal -> do
  let expiredEntries = fold (\acc p ->
    if count (do a <- acc; where a.pubkey == p.pubkey; yield a) > 0 then acc
    else union acc [{pubkey: p.pubkey, ttl: clampTtl ((p.expiresAt - p.timestamp) / 1000)}]) [] expiredLocal
  if not (federationSecret == "") && count expiredEntries > 0 && count peerServers > 0
    then do
      let gossipEvents = do
        e <- expiredEntries
        yield {eventType: "offline", pubkey: e.pubkey, server: serverHostN, timestamp: t, ttl: e.ttl}
      sendBatchedGossip peerServers gossipEvents
    else yield {}

retryPendingForwards = \pending ->
  if count pending == 0
    then yield {}
    else do
      let f = fold (\acc x -> if acc.messageId == "" then x else acc) {messageId: "", toServer: "", toKey: "", fromKey: "", encryptedBlob: "", timestamp: 0} pending
      let rest = do x <- pending; where not (x.messageId == f.messageId && x.toServer == f.toServer); yield x
      if f.messageId == ""
        then yield {}
        else do
          catch (do
            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})
            yield {}) (\err ->
            println ("prune: retry forward to " ++ f.toServer ++ " failed: " ++ show err))
          retryPendingForwards rest

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

serve = \req -> case req of

  ReqChallenge {pubkey, respond} -> do
    let valid = not (pubkey == "") && not (tooLong pubkey maxPubkeyLen) && isValidHex pubkey
    let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
    challenge <- genToken
    t <- now
    if valid
      then do
        pruneResult <- atomic do
          pr <- maybePrune t
          challenges <- *challenges
          let existingCount = count (do c <- challenges; where c.pubkey == pubkey; yield c)
          let oldestChallengeExpiry = fold (\acc c2 -> if c2.pubkey == pubkey && (acc == -1 || c2.expiresAt < acc) then c2.expiresAt else acc) -1 challenges
          let cappedChallenges = if existingCount >= maxChallengesPerKey && oldestChallengeExpiry >= 0
            then fold (\acc c ->
              if not acc.removed && c.pubkey == pubkey && c.expiresAt == oldestChallengeExpiry
                then {removed: True {}, items: acc.items}
                else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} challenges
            else {removed: False {}, items: challenges}
          let globalOldestExpiry = if count cappedChallenges.items >= maxChallenges
            then fold (\acc c -> if acc == -1 || c.expiresAt < acc then c.expiresAt else acc) -1 cappedChallenges.items
            else -1
          let globalCapped = if globalOldestExpiry >= 0
            then (fold (\acc c ->
              if not acc.removed && c.expiresAt == globalOldestExpiry
                then {removed: True {}, items: acc.items}
                else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} cappedChallenges.items).items
            else cappedChallenges.items
          set *challenges = union
            globalCapped
            [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry}]
          yield pr
        respond {challenge: challenge}
        broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal
      else respond {challenge: ""}

  VerifyAuth {pubkey, challenge, signature, respond} -> do
    let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
    t <- now
    token <- genToken
    let expiry = t + sessionExpiry
    result <- atomic do
      pr <- maybePrune t
      challenges <- *challenges
      sessions <- *sessions
      presence <- *presence
      let matched = single (do
        c <- challenges
        where c.pubkey == pubkey
        where c.challenge == challenge
        where c.expiresAt > t
        yield c)
      let sigValid = case matched of
        Nothing {} -> False {}
        _ -> if tooLong signature maxSignatureLen
          then False {}
          else if not (isValidHex pubkey) || not (isValidHex signature)
          then False {}
          else verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
      set *challenges = case matched of
        Just {value: _} -> do
          c <- challenges
          where not (c.pubkey == pubkey && c.challenge == challenge)
          yield c
        Nothing {} -> challenges
      let existingForKey = do
        s <- sessions
        where s.pubkey == pubkey
        where s.expiresAt > t
        yield s
      let oldestExpiry = fold (\acc s -> if acc == -1 || s.expiresAt < acc then s.expiresAt else acc) -1 existingForKey
      let cappedFold = fold (\acc s ->
          if not acc.removed && s.pubkey == pubkey && s.expiresAt == oldestExpiry
            then {removed: True {}, sessions: acc.sessions}
            else {removed: acc.removed, sessions: union acc.sessions [s]}) {removed: False {}, sessions: []} sessions
      let sessionsCapped = if count existingForKey >= maxSessionsPerKey && oldestExpiry >= 0
        then cappedFold.sessions
        else sessions
      let globalOldestSessionExpiry = if count sessionsCapped >= maxSessions
        then fold (\acc s -> if acc == -1 || s.expiresAt < acc then s.expiresAt else acc) -1 sessionsCapped
        else -1
      let globalSessionsCapped = if globalOldestSessionExpiry >= 0
        then (fold (\acc s ->
          if not acc.removed && s.expiresAt == globalOldestSessionExpiry
            then {removed: True {}, items: acc.items}
            else {removed: acc.removed, items: union acc.items [s]}) {removed: False {}, items: []} sessionsCapped).items
        else sessionsCapped
      set *sessions = if sigValid
        then union globalSessionsCapped [{token: token, pubkey: pubkey, expiresAt: expiry}]
        else sessions
      let presenceWithout = do
            p <- presence
            where not (p.pubkey == pubkey && p.server == serverHostN)
            yield p
      let oldestPresenceExp = fold (\acc p -> if acc == -1 || p.expiresAt < acc then p.expiresAt else acc) -1 presenceWithout
      let presenceEvicted = if count presenceWithout >= maxPresenceEntries && oldestPresenceExp >= 0
        then (fold (\acc p ->
          if not acc.removed && p.expiresAt == oldestPresenceExp
            then {removed: True {}, items: acc.items}
            else {removed: acc.removed, items: union acc.items [p]}) {removed: False {}, items: []} presenceWithout).items
        else presenceWithout
      let updatedPresence = if sigValid
        then union presenceEvicted [{pubkey: pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}]
        else presence
      set *presence = updatedPresence
      let peerServers = if sigValid && not (federationSecret == "")
        then fold (\acc p ->
          if p.server == serverHostN then acc
          else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
          else union acc [p.server]) [] updatedPresence
        else []
      yield {sigValid: sigValid, peerServers: peerServers, expiredLocal: pr.expiredLocal, offlinePeers: pr.peerServers}
    if result.sigValid
      then respond {token: token, expiresAt: expiry}
      else respond {token: "", expiresAt: 0}
    if result.sigValid && not (federationSecret == "")
      then sendToEach result.peerServers (\server ->
        fetch (federationScheme ++ server) (RecvGossip {
          authorization: "Bearer " ++ federationSecret,
          events: [{eventType: "online", pubkey: pubkey, server: serverHostN, timestamp: t, ttl: onlineGossipTtl}], hopsRemaining: 2, fromServer: serverHostN}))
      else yield {}
    broadcastOfflineGossip t result.offlinePeers (do
      p <- result.expiredLocal
      where not (p.pubkey == pubkey)
      yield p)

  Poll {cursor, timeout, authorization, respond} -> do
    t <- now
    let clampedTimeout = if timeout < 0 then 0 else if timeout > 60000 then 60000 else timeout
    let deadline = t + clampedTimeout
    let token = extractToken authorization
    result <- atomic do
      tNow <- now
      pr <- maybePrune tNow
      sessions <- *sessions
      messages <- *messages
      seqCounter <- *seqCounter
      let session = lookupSession sessions token tNow
      let clampedCursor = if cursor < 0 then 0 else if cursor > seqCounter then seqCounter else cursor
      let matchingMsgs = case session of
        Nothing {} -> []
        Just {value: s} -> do
          m <- messages
          where m.toKey == s.pubkey
          where m.receivedAt >= tNow - messageMaxAge
          where m.receivedAt > clampedCursor
          yield m
      let limitedMsgs = fold (\acc m ->
        if count acc >= maxPollEvents then acc
        else union acc [m]) [] matchingMsgs
      let authorized = case session of
        Nothing {} -> False {}
        _ -> True {}
      if authorized && count limitedMsgs == 0 && tNow < deadline
        then retry
        else do
          let evts = do
            m <- limitedMsgs
            yield {id: m.messageId, eventType: "message",
                   payload: toJson {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
          let newCursor = case session of
            Nothing {} -> -1
            _ -> if count limitedMsgs >= maxPollEvents
              then lastReceivedAt
              else if seqCounter > clampedCursor then seqCounter else clampedCursor
          yield {events: evts, cursor: newCursor, authorized: authorized, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
    respond {events: result.events, cursor: result.cursor, authorized: result.authorized}
    tAfterPoll <- now
    broadcastOfflineGossip tAfterPoll result.peerServers result.expiredLocal

  SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
    let validInput = not (to == "") && not (encryptedBlob == "") && not (tooLong to maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen) && isValidHex to && isValidHex encryptedBlob
    let to = if isValidHex to then normalizeHex to else to
    let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
    t <- now
    msgId <- genToken
    let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t - messageMaxAge else timestamp
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      messages <- *messages
      presence <- *presence
      let session = lookupSession sessions (extractToken authorization) t
      seqCounter <- *seqCounter
      let seqTs = if t > seqCounter then t else seqCounter + 1
      let recipientMsgCount = count (do
        m <- messages
        where m.toKey == to
        where m.receivedAt >= t - messageMaxAge
        yield m)
      let shouldInsert = case session of
        Nothing {} -> False {}
        Just {value: _} -> validInput && recipientMsgCount < maxMessagesPerRecipient
      set *seqCounter = if shouldInsert then seqTs else seqCounter
      set *messages = case session of
        Nothing {} -> messages
        Just {value: s} -> if validInput && recipientMsgCount < maxMessagesPerRecipient
          then union messages
            [{messageId: msgId, toKey: to, fromKey: s.pubkey,
              encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]
          else messages
      let localOnline = case session of
        Nothing {} -> False {}
        Just {value: _} -> count (do
          p <- presence
          where p.pubkey == to
          where p.server == serverHostN
          where p.expiresAt > t
          yield p) > 0
      let remoteServers = case session of
        Nothing {} -> []
        Just {value: _} -> do
          p <- presence
          where p.pubkey == to
          where not (p.server == serverHostN)
          where p.expiresAt > t
          yield p.server
      let fromKey = case session of
        Nothing {} -> ""
        Just {value: s} -> s.pubkey
      let status = case session of
        Nothing {} -> "unauthorized"
        _ -> if not validInput then "invalid"
             else if localOnline then "delivered"
             else if count remoteServers > 0 then "federated"
             else "queued"
      forwards <- *forwards
      let forwardsAtCapacity = count forwards >= maxForwardsEntries
      set *forwards = if shouldInsert && not forwardsAtCapacity && count remoteServers > 0
        then union forwards (do s <- remoteServers; yield {messageId: msgId, toServer: s, createdAt: t, toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob, timestamp: clampedTs})
        else forwards
      yield {status: status, remoteServers: remoteServers, fromKey: fromKey, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, forwardsAtCapacity: forwardsAtCapacity}
    let finalStatus = if result.status == "federated" && (federationSecret == "" || result.forwardsAtCapacity) then "queued" else result.status
    respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
    if count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid") && not (federationSecret == "")
      then sendToEach result.remoteServers (\server ->
        fetch (federationScheme ++ server) (ForwardMessage {
          toKey: to, fromKey: result.fromKey, encryptedBlob: encryptedBlob,
          timestamp: clampedTs, originServer: serverHostN, messageId: msgId,
          authorization: "Bearer " ++ federationSecret}))
      else yield {}
    if result.forwardsAtCapacity && count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid")
      then println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
      else yield {}
    broadcastOfflineGossip t result.peerServers result.expiredLocal

  AckMessages {messageIds, authorization, respond} -> do
    t <- now
    let dedupedIds = fold (\acc mid ->
        if mid == "" then acc
        else if count acc >= maxMessageIds then acc
        else if tooLong mid maxMessageIdLen then acc
        else if not (isValidHex mid) then acc
        else if count (do a <- acc; where a == normalizeHex mid; yield a) > 0 then acc
        else union acc [normalizeHex mid]) [] messageIds
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      messages <- *messages
      let session = lookupSession sessions (extractToken authorization) t
      let ackedMessages = case session of
        Nothing {} -> []
        Just {value: s} -> do
          m <- messages
          mid <- dedupedIds
          where m.messageId == mid
          where m.toKey == s.pubkey
          yield m
      set *messages = case session of
        Nothing {} -> messages
        Just {value: _} -> diff messages ackedMessages
      let ackedFederated = do
        m <- ackedMessages
        where not (m.originServer == "")
        where not (m.originServer == serverHostN)
        yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer}
      ackedIds <- *ackedIds
      let combinedAckedIds = union ackedIds ackedFederated
      let excessCount = count combinedAckedIds - maxAckedIds
      set *ackedIds = if excessCount <= 0
        then combinedAckedIds
        else evictOldestAckedIds combinedAckedIds excessCount
      let ok = case session of
        Nothing {} -> False {}
        _ -> True {}
      yield {ok: ok, ackedMessages: ackedMessages, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
    let fedMessages = do
      m <- result.ackedMessages
      where not (m.originServer == "")
      where not (m.originServer == serverHostN)
      yield m
    let originServers = fold (\acc m ->
      if count (do a <- acc; where a == m.originServer; yield a) > 0 then acc
      else union acc [m.originServer]) [] fedMessages
    respond {ok: result.ok}
    if result.ok && count originServers > 0 && not (federationSecret == "")
      then sendToEach originServers (\server ->
        fetch (federationScheme ++ server) (FederationAck {
          authorization: "Bearer " ++ federationSecret,
          messageIds: (do m <- fedMessages; where m.originServer == server; yield m.messageId),
          originServer: server, fromServer: serverHostN}))
      else yield {}
    broadcastOfflineGossip t result.peerServers result.expiredLocal

  LookupPresence {pubkey, authorization, respond} -> do
    let validPubkey = not (pubkey == "") && not (tooLong pubkey maxPubkeyLen) && isValidHex pubkey
    let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
    t <- now
    result <- atomic do
      pr <- maybePrune t
      sessions <- *sessions
      presence <- *presence
      let session = lookupSession sessions (extractToken authorization) t
      let authorized = case session of
        Nothing {} -> False {}
        _ -> True {}
      let valid = do
        p <- presence
        where p.pubkey == pubkey
        where p.expiresAt > t
        yield p
      let foundServer = case session of
        Nothing {} -> ""
        Just {value: _} ->
          if not validPubkey || count valid == 0
            then ""
            else case single (do
              p <- valid
              where p.server == serverHostN
              yield p) of
              Just {value: p} -> p.server
              Nothing {} -> (fold (\acc p -> if p.expiresAt > acc.best then {server: p.server, best: p.expiresAt} else acc) {server: "", best: 0} valid).server
      yield {foundServer: foundServer, authorized: authorized, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
    respond {online: not (result.foundServer == ""), server: result.foundServer, authorized: result.authorized}
    broadcastOfflineGossip t result.peerServers result.expiredLocal

  RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
    t <- now
    let authorized = verifyFederationAuth authorization
    let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
    let fromServer = normalizeServerName fromServer
    let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer) && count events <= maxGossipEvents
    let onlineEntries = do
      e <- events
      where validRequest
      where e.eventType == "online"
      where not (e.server == "")
      where not (e.pubkey == "")
      where not (tooLong e.pubkey maxPubkeyLen)
      where not (tooLong e.server maxServerNameLen)
      where not (isBadServerName e.server)
      where isValidHex e.pubkey
      where not (normalizeServerName e.server == serverHostN)
      where e.timestamp <= t + clockSkewTolerance
      where e.timestamp + (clampTtl e.ttl) * 1000 > t
      yield {pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, expiresAt: e.timestamp + (clampTtl e.ttl) * 1000, timestamp: e.timestamp}
    let offlineEntries = do
      e <- events
      where validRequest
      where e.eventType == "offline"
      where not (e.server == "")
      where not (e.pubkey == "")
      where not (tooLong e.pubkey maxPubkeyLen)
      where not (tooLong e.server maxServerNameLen)
      where not (isBadServerName e.server)
      where isValidHex e.pubkey
      where not (normalizeServerName e.server == serverHostN)
      where e.timestamp <= t + clockSkewTolerance
      where t - e.timestamp < (clampTtl e.ttl) * 1000
      yield {pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, timestamp: e.timestamp}
    let filteredOnline = do
      e <- onlineEntries
      where count (do
        o <- offlineEntries
        where o.pubkey == e.pubkey
        where o.server == e.server
        where o.timestamp > e.timestamp
        yield o) == 0
      yield {pubkey: e.pubkey, server: e.server, expiresAt: e.expiresAt, timestamp: e.timestamp}
    let affectedKeys = union
      (do
        e <- onlineEntries
        yield {pubkey: e.pubkey, server: e.server})
      (do
        e <- offlineEntries
        yield {pubkey: e.pubkey, server: e.server})
    let deduped = fold (\acc e ->
        if count (do
            a <- acc
            where a.pubkey == e.pubkey
            where a.server == e.server
            where a.expiresAt >= e.expiresAt
            yield a) > 0
          then acc
          else union
            (do
              a <- acc
              where not (a.pubkey == e.pubkey && a.server == e.server)
              yield a)
            [e]) [] filteredOnline
    gossipResult <- atomic do
      pr <- maybePrune t
      presence <- *presence
      let fromServerTrusted = count (do p <- presence; where p.server == fromServer; yield p) > 0
      let trustedDeduped = do
        e <- deduped
        where e.server == fromServer || fromServerTrusted || count (do p <- presence; where p.server == e.server; yield p) > 0
        yield e
      let trustedOffline = do
        e <- offlineEntries
        where e.server == fromServer || fromServerTrusted || count (do p <- presence; where p.server == e.server; yield p) > 0
        yield e
      let appliedOnline = do
        e <- trustedDeduped
        where count (do
          p <- presence
          where p.pubkey == e.pubkey
          where p.server == e.server
          where p.expiresAt >= e.expiresAt
          yield p) == 0
        yield {pubkey: e.pubkey, server: e.server}
      let merged = fold (\acc e ->
          if count (do
              p <- acc
              where p.pubkey == e.pubkey
              where p.server == e.server
              where p.expiresAt >= e.expiresAt
              yield p) > 0
            then acc
            else union
              (do
                p <- acc
                where not (p.pubkey == e.pubkey && p.server == e.server)
                yield p)
              [e]) presence trustedDeduped
      let offlineOnlyKeys = do
        k <- affectedKeys
        where count (do d <- trustedDeduped; where d.pubkey == k.pubkey; where d.server == k.server; yield d) == 0
        yield k
      let appliedOffline = do
        k <- offlineOnlyKeys
        where count (do
          p <- presence
          where p.pubkey == k.pubkey
          where p.server == k.server
          where count (do
            o <- trustedOffline
            where o.pubkey == k.pubkey
            where o.server == k.server
            where o.timestamp >= p.timestamp
            yield o) > 0
          yield p) > 0
        yield {pubkey: k.pubkey, server: k.server}
      let afterOffline = diff merged (do
        p <- merged
        k <- offlineOnlyKeys
        where p.pubkey == k.pubkey
        where p.server == k.server
        where count (do
          o <- trustedOffline
          where o.pubkey == k.pubkey
          where o.server == k.server
          where o.timestamp >= p.timestamp
          yield o) > 0
        yield p)
      let withinCapacity = count afterOffline <= maxPresenceEntries
      let updatesOnlyMerged = if withinCapacity then afterOffline
        else fold (\acc e ->
          if count (do
              p <- acc
              where p.pubkey == e.pubkey
              where p.server == e.server
              where p.expiresAt >= e.expiresAt
              yield p) > 0
            then acc
            else if count (do p <- presence; where p.pubkey == e.pubkey; where p.server == e.server; yield p) > 0
              then union
                (do
                  p <- acc
                  where not (p.pubkey == e.pubkey && p.server == e.server)
                  yield p)
                [e]
              else acc) presence trustedDeduped
      let updatesOnlyAfterOffline = if withinCapacity then afterOffline
        else diff updatesOnlyMerged (do
          p <- updatesOnlyMerged
          k <- offlineOnlyKeys
          where p.pubkey == k.pubkey
          where p.server == k.server
          where count (do
            o <- trustedOffline
            where o.pubkey == k.pubkey
            where o.server == k.server
            where o.timestamp >= p.timestamp
            yield o) > 0
          yield p)
      let reclaimCapacity = if withinCapacity then 0 else maxPresenceEntries - count updatesOnlyAfterOffline
      let newEntries = if withinCapacity then []
        else do
          e <- trustedDeduped
          where count (do p <- presence; where p.pubkey == e.pubkey; where p.server == e.server; yield p) == 0
          where count (do p <- updatesOnlyAfterOffline; where p.pubkey == e.pubkey; where p.server == e.server; yield p) == 0
          yield e
      let reclaimedEntries = if withinCapacity then []
        else fold (\acc e ->
          if count acc >= reclaimCapacity then acc
          else union acc [e]) [] newEntries
      let afterReclaim = if withinCapacity then afterOffline
        else union updatesOnlyAfterOffline reclaimedEntries
      let appliedOnlineUpdates = if withinCapacity then appliedOnline
        else union
          (do
            e <- trustedDeduped
            where count (do p <- presence; where p.pubkey == e.pubkey; where p.server == e.server; yield p) > 0
            where count (do
              p <- presence
              where p.pubkey == e.pubkey
              where p.server == e.server
              where p.expiresAt >= e.expiresAt
              yield p) == 0
            yield {pubkey: e.pubkey, server: e.server})
          (do
            e <- reclaimedEntries
            yield {pubkey: e.pubkey, server: e.server})
      let finalPresence = if validRequest
        then if withinCapacity then afterOffline else afterReclaim
        else presence
      set *presence = finalPresence
      let gossipPeerServers = fold (\acc p ->
        if p.server == serverHostN then acc
        else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
        else union acc [p.server]) [] finalPresence
      yield {appliedKeys: (if withinCapacity then union appliedOnline appliedOffline else union appliedOnlineUpdates appliedOffline), expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, gossipPeerServers: gossipPeerServers, withinCapacity: withinCapacity}
    let validEvents = do
      e <- events
      where validRequest
      where e.eventType == "online" || e.eventType == "offline"
      where not (e.server == "")
      where not (e.pubkey == "")
      where not (tooLong e.pubkey maxPubkeyLen)
      where not (tooLong e.server maxServerNameLen)
      where not (isBadServerName e.server)
      where isValidHex e.pubkey
      where not (normalizeServerName e.server == serverHostN)
      where e.timestamp <= t + clockSkewTolerance
      where e.timestamp + (clampTtl e.ttl) * 1000 > t
      where not (e.eventType == "online" && count (do
        o <- offlineEntries
        where o.pubkey == normalizeHex e.pubkey
        where o.server == normalizeServerName e.server
        where o.timestamp > e.timestamp
        yield o) > 0)
      where not (e.eventType == "offline" && count (do
        o <- onlineEntries
        where o.pubkey == normalizeHex e.pubkey
        where o.server == normalizeServerName e.server
        where o.timestamp > e.timestamp
        yield o) > 0)
      yield e
    let effectiveEvents = do
      e <- validEvents
      where count (do a <- gossipResult.appliedKeys; where a.pubkey == normalizeHex e.pubkey; where a.server == normalizeServerName e.server; yield a) > 0
      yield {eventType: e.eventType, pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, timestamp: e.timestamp, ttl: clampTtl e.ttl}
    respond {ok: validRequest}
    if not gossipResult.withinCapacity
      then println ("gossip: presence at capacity (" ++ show maxPresenceEntries ++ "), limiting new entries from " ++ fromServer)
      else yield {}
    if validRequest && cappedHops > 1 && not (federationSecret == "") && count effectiveEvents > 0
      then do
        let targets = do
          s <- gossipResult.gossipPeerServers
          where not (s == fromServer)
          yield s
        sendToEach targets (\server ->
          fetch (federationScheme ++ server) (RecvGossip {
            authorization: "Bearer " ++ federationSecret,
            events: effectiveEvents, hopsRemaining: cappedHops - 1, fromServer: serverHostN}))
      else yield {}
    broadcastOfflineGossip t gossipResult.peerServers gossipResult.expiredLocal

  ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
    let validFields = not (toKey == "") && not (fromKey == "") && not (encryptedBlob == "") && not (messageId == "") && not (tooLong toKey maxPubkeyLen) && not (tooLong fromKey maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen) && not (tooLong messageId maxMessageIdLen) && isValidHex toKey && isValidHex fromKey && isValidHex encryptedBlob && isValidHex messageId
    let toKey = if isValidHex toKey then normalizeHex toKey else toKey
    let fromKey = if isValidHex fromKey then normalizeHex fromKey else fromKey
    let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
    let messageId = if isValidHex messageId then normalizeHex messageId else messageId
    let originServer = normalizeServerName originServer
    t <- now
    let authorized = verifyFederationAuth authorization
    let validOrigin = not (originServer == "") && not (originServer == serverHostN) && not (tooLong originServer maxServerNameLen) && not (isBadServerName originServer)
    let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t - messageMaxAge else timestamp
    result <- atomic do
      pr <- maybePrune t
      messages <- *messages
      seqCounter <- *seqCounter
      let seqTs = if t > seqCounter then t else seqCounter + 1
      let recipientMsgCount = count (do
        m <- messages
        where m.toKey == toKey
        where m.receivedAt >= t - messageMaxAge
        yield m)
      let existsInMessages = count (do
        m <- messages
        where m.messageId == messageId
        where m.toKey == toKey
        where m.receivedAt >= t - messageMaxAge
        yield m) > 0
      ackedIds <- *ackedIds
      let existsInAcked = count (do
        a <- ackedIds
        where a.messageId == messageId
        where a.toKey == toKey
        yield a) > 0
      let exists = existsInMessages || existsInAcked
      let shouldInsert = authorized && validOrigin && validFields && not exists && recipientMsgCount < maxMessagesPerRecipient
      set *seqCounter = if shouldInsert then seqTs else seqCounter
      set *messages = if shouldInsert
        then union messages
          [{messageId: messageId, toKey: toKey, fromKey: fromKey,
            encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs}]
        else messages
      yield {peerServers: pr.peerServers, expiredLocal: pr.expiredLocal, inserted: shouldInsert, alreadyExists: exists}
    respond {ok: result.inserted || (authorized && validOrigin && validFields && result.alreadyExists)}
    broadcastOfflineGossip t result.peerServers result.expiredLocal

  FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
    let fromServer = normalizeServerName fromServer
    let originServer = normalizeServerName originServer
    t <- now
    let authorized = verifyFederationAuth authorization
    let dedupedIds = fold (\acc mid ->
        if mid == "" then acc
        else if count acc >= maxMessageIds then acc
        else if tooLong mid maxMessageIdLen then acc
        else if not (isValidHex mid) then acc
        else if count (do a <- acc; where a == normalizeHex mid; yield a) > 0 then acc
        else union acc [normalizeHex mid]) [] messageIds
    let validAckFields = authorized && originServer == serverHostN && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer)
    pruneResult <- atomic do
      pr <- maybePrune t
      forwards <- *forwards
      let validAck = validAckFields
      let forwardsToRemove = do
        f <- forwards
        mid <- dedupedIds
        where f.messageId == mid
        where f.toServer == fromServer
        yield f
      set *forwards = if validAck
        then diff forwards forwardsToRemove
        else forwards
      yield {peerServers: pr.peerServers, expiredLocal: pr.expiredLocal, validAck: validAck}
    respond {ok: pruneResult.validAck}
    broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal

  Prune {authorization, respond} -> do
    t <- now
    let authorized = verifyMaintenanceAuth authorization
    if authorized
      then do
        result <- atomic do
          set *lastPrunedAt = t
          pr <- pruneExpired t
          forwards <- *forwards
          let pendingForwards = do
            f <- forwards
            yield {toServer: f.toServer, toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob, timestamp: f.timestamp, messageId: f.messageId}
          ackedIds <- *ackedIds
          let pendingAcks = do
            a <- ackedIds
            where not (a.originServer == "")
            where not (a.originServer == serverHostN)
            yield a
          yield {expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, pendingForwards: pendingForwards, pendingAcks: pendingAcks}
        respond {ok: True {}}
        broadcastOfflineGossip t result.peerServers result.expiredLocal
        if not (federationSecret == "") && count result.pendingForwards > 0
          then retryPendingForwards result.pendingForwards
          else yield {}
        if not (federationSecret == "") && count result.pendingAcks > 0
          then do
            let ackOriginServers = fold (\acc a ->
              if count (do s <- acc; where s == a.originServer; yield s) > 0 then acc
              else union acc [a.originServer]) [] result.pendingAcks
            sendToEach ackOriginServers (\server ->
              fetch (federationScheme ++ server) (FederationAck {
                authorization: "Bearer " ++ federationSecret,
                messageIds: (do a <- result.pendingAcks; where a.originServer == server; yield a.messageId),
                originServer: server, fromServer: serverHostN}))
          else yield {}
      else respond {ok: False {}}

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

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