git.iko.soy/skrepka
on 0cabbfd help sign in
skrepka/server.knot
676 lines 27 kB history raw
1-- Skrepka Relay Server
2-- Single-server implementation of the Skrepka protocol (v0.1)
3-- Binary data (keys, signatures, blobs) uses hex encoding (bytesToHex/bytesFromHex)
5-- ============================================
6-- Configuration
7-- ============================================
9serverHost = "localhost:8080"
10federationSecret = "" -- must be set to enable federation
11federationScheme = "https://" -- scheme for federation HTTP calls
12messageMaxAge = 86400000 -- 24 hours in milliseconds
13maxPresenceTtl = 3600 -- max presence TTL from gossip in seconds
14maxPubkeyLen = 256
15maxBlobLen = 65536
16maxSignatureLen = 256
17maxMessageIds = 100
18maxGossipEvents = 100
19clockSkewTolerance = 5000 -- 5 seconds tolerance for clock skew between federated servers
21-- ============================================
22-- Types
23-- ============================================
25type PollEvent = {id: Text, eventType: Text, payload: Text}
27type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int, ttl: Int}
29-- ============================================
30-- Persisted State
31-- ============================================
33*challenges : [{pubkey: Text, challenge: Text, expiresAt: Int}]
35*sessions : [{token: Text, pubkey: Text, expiresAt: Int}]
37*messages : [{messageId: Text, toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, receivedAt: Int}]
39*presence : [{pubkey: Text, server: Text, expiresAt: Int, timestamp: Int}]
41*seqCounter : Int
43-- ============================================
44-- Routes
45-- ============================================
47route AuthApi where
48 /auth
49 POST {pubkey: Text} /challenge
50 -> {challenge: Text}
51 = ReqChallenge
52 POST {pubkey: Text, challenge: Text, signature: Text} /verify
53 -> {token: Text, expiresAt: Int}
54 = VerifyAuth
56route ClientApi where
57 GET {cursor: Int} /poll headers {authorization: Text}
58 -> {events: [PollEvent], cursor: Int}
59 = Poll
60 /messages
61 POST {to: Text, encryptedBlob: Text, timestamp: Int} / headers {authorization: Text}
62 -> {status: Text, messageId: Text}
63 = SendMessage
64 POST {messageIds: [Text]} /ack headers {authorization: Text}
65 -> {ok: Bool}
66 = AckMessages
67 GET /lookup/{pubkey: Text} headers {authorization: Text}
68 -> {online: Bool, server: Text, authorized: Bool}
69 = LookupPresence
71route FederationApi where
72 /federation
73 POST {events: [GossipEvent], hopsRemaining: Int, fromServer: Text} /gossip headers {authorization: Text}
74 -> {ok: Bool}
75 = RecvGossip
76 POST {toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, messageId: Text} /forward headers {authorization: Text}
77 -> {ok: Bool}
78 = ForwardMessage
79 POST {messageIds: [Text], originServer: Text, fromServer: Text} /ack headers {authorization: Text}
80 -> {ok: Bool}
81 = FederationAck
83route Api = AuthApi | ClientApi | FederationApi
85-- ============================================
86-- Helpers
87-- ============================================
89genToken = do
90 a <- randomInt 2147483647
91 b <- randomInt 2147483647
92 c <- randomInt 2147483647
93 d <- randomInt 2147483647
94 yield (bytesToHex (textToBytes (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d)))
96tooLong = \s maxLen -> not (drop maxLen s == "")
98isValidHex = \s -> not (s == "") && bytesToHex (bytesFromHex s) == s
100lookupSession = \sessions token t ->
101 single (do
102 s <- sessions
103 where s.token == token
104 where s.expiresAt > t
105 yield s)
107extractToken = \authHeader ->
108 if take 7 authHeader == "Bearer "
109 then drop 7 authHeader
110 else ""
112verifyFederationAuth = \authorization ->
113 extractToken authorization == federationSecret && not (federationSecret == "")
115clampTtl = \ttl -> if ttl < 1 then 1 else if ttl > maxPresenceTtl then maxPresenceTtl else ttl
117forwardToAll = \servers path headers body ->
118 if count servers == 0
119 then yield False {}
120 else do
121 let server = fold (\acc s -> if acc == "" then s else acc) "" servers
122 let rest = do s <- servers; where not (s == server); yield s
123 if server == ""
124 then yield False {}
125 else do
126 result <- httpPost (federationScheme ++ server ++ path) headers body
127 restOk <- forwardToAll rest path headers body
128 yield (if result.ok then True {} else restOk)
130sendToEach = \servers action ->
131 if count servers == 0
132 then yield {}
133 else do
134 let server = fold (\acc s -> if acc == "" then s else acc) "" servers
135 let rest = do s <- servers; where not (s == server); yield s
136 if server == ""
137 then yield {}
138 else do
139 action server
140 sendToEach rest action
142pruneExpired = \t -> do
143 challenges <- *challenges
144 set *challenges = do
145 c <- challenges
146 where c.expiresAt > t
147 yield c
148 sessions <- *sessions
149 set *sessions = do
150 s <- sessions
151 where s.expiresAt > t
152 yield s
153 presenceBefore <- *presence
154 let peerServersBefore = fold (\acc p ->
155 if p.server == serverHost then acc
156 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
157 else union acc [p.server]) [] presenceBefore
158 let presenceAfter = do
159 p <- presenceBefore
160 where p.expiresAt > t
161 yield p
162 set *presence = presenceAfter
163 messages <- *messages
164 set *messages = do
165 m <- messages
166 where m.timestamp >= t - messageMaxAge
167 yield m
168 yield {expiredLocal: (do
169 p <- presenceBefore
170 where p.expiresAt <= t
171 where p.server == serverHost
172 where count (do
173 q <- presenceAfter
174 where q.pubkey == p.pubkey
175 where q.server == serverHost
176 yield q) == 0
177 yield p), peerServers: peerServersBefore}
179broadcastOfflineGossip = \t peerServers expiredLocal -> do
180 let expiredPubkeys = fold (\acc p ->
181 if count (do a <- acc; where a == p.pubkey; yield a) > 0 then acc
182 else union acc [p.pubkey]) [] expiredLocal
183 if not (federationSecret == "") && count expiredPubkeys > 0 && count peerServers > 0
184 then do
185 let gossipEvents = do
186 pk <- expiredPubkeys
187 yield {eventType: "offline", pubkey: pk, server: serverHost, timestamp: t, ttl: 3600}
188 sendToEach peerServers (\server ->
189 httpPost (federationScheme ++ server ++ "/federation/gossip")
190 {authorization: "Bearer " ++ federationSecret}
191 {events: gossipEvents, hopsRemaining: 2, fromServer: serverHost})
192 else yield {}
194-- ============================================
195-- Request Handler
196-- ============================================
198serve = \req -> case req of
200 ReqChallenge {pubkey, respond} ->
201 if pubkey == "" || tooLong pubkey maxPubkeyLen
202 then respond {challenge: ""}
203 else do
204 challenge <- genToken
205 t <- now
206 pruneResult <- atomic do
207 pr <- pruneExpired t
208 challenges <- *challenges
209 set *challenges = union challenges
210 [{pubkey: pubkey, challenge: challenge, expiresAt: t + 60000}]
211 yield pr
212 respond {challenge: challenge}
213 broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal
215 VerifyAuth {pubkey, challenge, signature, respond} -> do
216 t <- now
217 token <- genToken
218 let expiry = t + 3600000
219 result <- atomic do
220 pr <- pruneExpired t
221 challenges <- *challenges
222 sessions <- *sessions
223 presence <- *presence
224 let matched = single (do
225 c <- challenges
226 where c.pubkey == pubkey
227 where c.challenge == challenge
228 where c.expiresAt > t
229 yield c)
230 let sigValid = case matched of
231 Nothing {} -> False {}
232 _ -> if tooLong signature maxSignatureLen
233 then False {}
234 else if not (isValidHex pubkey) || not (isValidHex signature)
235 then False {}
236 else verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
237 set *challenges = if sigValid
238 then do
239 c <- challenges
240 where not (c.pubkey == pubkey && c.challenge == challenge)
241 yield c
242 else challenges
243 let existingForKey = do
244 s <- sessions
245 where s.pubkey == pubkey
246 where s.expiresAt > t
247 yield s
248 let oldestExpiry = fold (\acc s -> if s.expiresAt < acc then s.expiresAt else acc) expiry existingForKey
249 let cappedFold = fold (\acc s ->
250 if not acc.removed && s.pubkey == pubkey && s.expiresAt == oldestExpiry
251 then {removed: True {}, sessions: acc.sessions}
252 else {removed: acc.removed, sessions: union acc.sessions [s]}) {removed: False {}, sessions: []} sessions
253 let sessionsCapped = if count existingForKey >= 10
254 then cappedFold.sessions
255 else sessions
256 set *sessions = if sigValid
257 then union sessionsCapped [{token: token, pubkey: pubkey, expiresAt: expiry}]
258 else sessions
259 let updatedPresence = if sigValid
260 then union
261 (do
262 p <- presence
263 where not (p.pubkey == pubkey && p.server == serverHost)
264 yield p)
265 [{pubkey: pubkey, server: serverHost, expiresAt: expiry, timestamp: t}]
266 else presence
267 set *presence = updatedPresence
268 let peerServers = if sigValid && not (federationSecret == "")
269 then fold (\acc p ->
270 if p.server == serverHost then acc
271 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
272 else union acc [p.server]) [] updatedPresence
273 else []
274 yield {sigValid: sigValid, peerServers: peerServers, expiredLocal: pr.expiredLocal, offlinePeers: pr.peerServers}
275 if result.sigValid
276 then respond {token: token, expiresAt: expiry}
277 else respond {token: "", expiresAt: 0}
278 if result.sigValid && not (federationSecret == "")
279 then sendToEach result.peerServers (\server ->
280 httpPost (federationScheme ++ server ++ "/federation/gossip")
281 {authorization: "Bearer " ++ federationSecret}
282 {events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: 3600}], hopsRemaining: 2, fromServer: serverHost})
283 else yield {}
284 broadcastOfflineGossip t result.offlinePeers result.expiredLocal
286 Poll {cursor, authorization, respond} -> do
287 t <- now
288 let token = extractToken authorization
289 result <- atomic do
290 pr <- pruneExpired t
291 sessions <- *sessions
292 messages <- *messages
293 seqCounter <- *seqCounter
294 let session = lookupSession sessions token t
295 let evts = case session of
296 Nothing {} -> []
297 Just {value: s} -> do
298 m <- messages
299 where m.toKey == s.pubkey
300 where m.timestamp >= t - messageMaxAge
301 where m.receivedAt > cursor
302 yield {id: m.messageId, eventType: "message",
303 payload: toJson {toKey: m.toKey, fromKey: m.fromKey,
304 encryptedBlob: m.encryptedBlob,
305 timestamp: m.timestamp}}
306 let newCursor = case session of
307 Nothing {} -> -1
308 _ -> if seqCounter > cursor then seqCounter else cursor
309 yield {events: evts, cursor: newCursor, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
310 respond {events: result.events, cursor: result.cursor}
311 broadcastOfflineGossip t result.peerServers result.expiredLocal
313 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
314 t <- now
315 msgId <- genToken
316 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
317 let validInput = not (to == "") && not (encryptedBlob == "") && not (tooLong to maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen)
318 result <- atomic do
319 pr <- pruneExpired t
320 sessions <- *sessions
321 messages <- *messages
322 presence <- *presence
323 let session = lookupSession sessions (extractToken authorization) t
324 seqCounter <- *seqCounter
325 let seqTs = if t > seqCounter then t else seqCounter + 1
326 let shouldInsert = case session of
327 Nothing {} -> False {}
328 Just {value: _} -> validInput
329 set *seqCounter = if shouldInsert then seqTs else seqCounter
330 set *messages = case session of
331 Nothing {} -> messages
332 Just {value: s} -> if validInput
333 then union messages
334 [{messageId: msgId, toKey: to, fromKey: s.pubkey,
335 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]
336 else messages
337 let localOnline = case session of
338 Nothing {} -> False {}
339 Just {value: _} -> count (do
340 p <- presence
341 where p.pubkey == to
342 where p.server == serverHost
343 where p.expiresAt > t
344 yield p) > 0
345 let remoteServers = case session of
346 Nothing {} -> []
347 Just {value: _} -> do
348 p <- presence
349 where p.pubkey == to
350 where not (p.server == serverHost)
351 where p.expiresAt > t
352 yield p.server
353 let fromKey = case session of
354 Nothing {} -> ""
355 Just {value: s} -> s.pubkey
356 let status = case session of
357 Nothing {} -> "unauthorized"
358 _ -> if not validInput then "invalid"
359 else if localOnline then "delivered"
360 else if count remoteServers > 0 then "federated"
361 else "queued"
362 yield {status: status, remoteServers: remoteServers, fromKey: fromKey, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
363 finalStatus <- if result.status == "federated" && not (federationSecret == "")
364 then do
365 anyOk <- forwardToAll result.remoteServers "/federation/forward"
366 {authorization: "Bearer " ++ federationSecret}
367 {toKey: to, fromKey: result.fromKey, encryptedBlob: encryptedBlob,
368 timestamp: clampedTs, originServer: serverHost, messageId: msgId}
369 yield (if anyOk then "federated" else "queued")
370 else yield result.status
371 respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
372 broadcastOfflineGossip t result.peerServers result.expiredLocal
374 AckMessages {messageIds, authorization, respond} -> do
375 t <- now
376 let dedupedIds = fold (\acc mid ->
377 if mid == "" then acc
378 else if count acc >= maxMessageIds then acc
379 else if count (do a <- acc; where a == mid; yield a) > 0 then acc
380 else union acc [mid]) [] messageIds
381 result <- atomic do
382 pr <- pruneExpired t
383 sessions <- *sessions
384 messages <- *messages
385 let session = lookupSession sessions (extractToken authorization) t
386 let ackedMessages = case session of
387 Nothing {} -> []
388 Just {value: s} -> do
389 m <- messages
390 mid <- dedupedIds
391 where m.messageId == mid
392 where m.toKey == s.pubkey
393 yield m
394 set *messages = case session of
395 Nothing {} -> messages
396 Just {value: _} -> diff messages ackedMessages
397 let ok = case session of
398 Nothing {} -> False {}
399 _ -> True {}
400 yield {ok: ok, ackedMessages: ackedMessages, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
401 let fedMessages = do
402 m <- result.ackedMessages
403 where not (m.originServer == "")
404 where not (m.originServer == serverHost)
405 yield m
406 let originServers = fold (\acc m ->
407 if count (do a <- acc; where a == m.originServer; yield a) > 0 then acc
408 else union acc [m.originServer]) [] fedMessages
409 if result.ok && count originServers > 0 && not (federationSecret == "")
410 then sendToEach originServers (\server ->
411 httpPost (federationScheme ++ server ++ "/federation/ack")
412 {authorization: "Bearer " ++ federationSecret}
413 {messageIds: (do m <- fedMessages; where m.originServer == server; yield m.messageId),
414 originServer: server, fromServer: serverHost})
415 else yield {}
416 respond {ok: result.ok}
417 broadcastOfflineGossip t result.peerServers result.expiredLocal
419 LookupPresence {pubkey, authorization, respond} -> do
420 t <- now
421 result <- atomic do
422 pr <- pruneExpired t
423 sessions <- *sessions
424 presence <- *presence
425 let session = lookupSession sessions (extractToken authorization) t
426 let authorized = case session of
427 Nothing {} -> False {}
428 _ -> True {}
429 let valid = do
430 p <- presence
431 where p.pubkey == pubkey
432 where p.expiresAt > t
433 yield p
434 let foundServer = case session of
435 Nothing {} -> ""
436 Just {value: _} ->
437 if pubkey == "" || tooLong pubkey maxPubkeyLen || count valid == 0
438 then ""
439 else case single (do
440 p <- valid
441 where p.server == serverHost
442 yield p) of
443 Just {value: p} -> p.server
444 Nothing {} -> fold (\_ p -> p.server) "" valid
445 yield {foundServer: foundServer, authorized: authorized, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
446 respond {online: not (result.foundServer == ""), server: result.foundServer, authorized: result.authorized}
447 broadcastOfflineGossip t result.peerServers result.expiredLocal
449 RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
450 t <- now
451 let authorized = verifyFederationAuth authorization
452 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
453 let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (tooLong fromServer maxPubkeyLen) && count events <= maxGossipEvents
454 let onlineEntries = do
455 e <- events
456 where validRequest
457 where e.eventType == "online"
458 where not (e.server == "")
459 where not (e.pubkey == "")
460 where not (tooLong e.pubkey maxPubkeyLen)
461 where not (tooLong e.server maxPubkeyLen)
462 where not (e.server == serverHost)
463 where e.timestamp <= t + clockSkewTolerance
464 where e.timestamp + (clampTtl e.ttl) * 1000 > t
465 yield {pubkey: e.pubkey, server: e.server, expiresAt: e.timestamp + (clampTtl e.ttl) * 1000, timestamp: e.timestamp}
466 let offlineEntries = do
467 e <- events
468 where validRequest
469 where e.eventType == "offline"
470 where not (e.server == "")
471 where not (e.pubkey == "")
472 where not (tooLong e.pubkey maxPubkeyLen)
473 where not (tooLong e.server maxPubkeyLen)
474 where not (e.server == serverHost)
475 where e.timestamp <= t + clockSkewTolerance
476 where t - e.timestamp < (clampTtl e.ttl) * 1000
477 yield {pubkey: e.pubkey, server: e.server, timestamp: e.timestamp}
478 let filteredOnline = do
479 e <- onlineEntries
480 where count (do
481 o <- offlineEntries
482 where o.pubkey == e.pubkey
483 where o.server == e.server
484 where o.timestamp >= e.timestamp
485 yield o) == 0
486 yield {pubkey: e.pubkey, server: e.server, expiresAt: e.expiresAt, timestamp: e.timestamp}
487 let affectedKeys = union
488 (do
489 e <- onlineEntries
490 yield {pubkey: e.pubkey, server: e.server})
491 (do
492 e <- offlineEntries
493 yield {pubkey: e.pubkey, server: e.server})
494 let deduped = fold (\acc e ->
495 if count (do
496 a <- acc
497 where a.pubkey == e.pubkey
498 where a.server == e.server
499 where a.expiresAt >= e.expiresAt
500 yield a) > 0
501 then acc
502 else union
503 (do
504 a <- acc
505 where not (a.pubkey == e.pubkey && a.server == e.server)
506 yield a)
507 [e]) [] filteredOnline
508 gossipResult <- atomic do
509 pr <- pruneExpired t
510 presence <- *presence
511 let appliedOnline = do
512 e <- deduped
513 where count (do
514 p <- presence
515 where p.pubkey == e.pubkey
516 where p.server == e.server
517 where p.expiresAt >= e.expiresAt
518 yield p) == 0
519 yield {pubkey: e.pubkey, server: e.server}
520 let merged = fold (\acc e ->
521 if count (do
522 p <- acc
523 where p.pubkey == e.pubkey
524 where p.server == e.server
525 where p.expiresAt >= e.expiresAt
526 yield p) > 0
527 then acc
528 else union
529 (do
530 p <- acc
531 where not (p.pubkey == e.pubkey && p.server == e.server)
532 yield p)
533 [e]) presence deduped
534 let offlineOnlyKeys = do
535 k <- affectedKeys
536 where count (do d <- deduped; where d.pubkey == k.pubkey; where d.server == k.server; yield d) == 0
537 yield k
538 let appliedOffline = do
539 k <- offlineOnlyKeys
540 where count (do
541 p <- presence
542 where p.pubkey == k.pubkey
543 where p.server == k.server
544 where count (do
545 o <- offlineEntries
546 where o.pubkey == k.pubkey
547 where o.server == k.server
548 where o.timestamp >= p.timestamp
549 yield o) > 0
550 yield p) > 0
551 yield {pubkey: k.pubkey, server: k.server}
552 let afterOffline = diff merged (do
553 p <- merged
554 k <- offlineOnlyKeys
555 where p.pubkey == k.pubkey
556 where p.server == k.server
557 where count (do
558 o <- offlineEntries
559 where o.pubkey == k.pubkey
560 where o.server == k.server
561 where o.timestamp >= p.timestamp
562 yield o) > 0
563 yield p)
564 set *presence = if validRequest
565 then afterOffline
566 else presence
567 yield {appliedKeys: (union appliedOnline appliedOffline), expiredLocal: pr.expiredLocal, peerServers: pr.peerServers}
568 let validEvents = do
569 e <- events
570 where validRequest
571 where not (e.server == "")
572 where not (e.pubkey == "")
573 where not (tooLong e.pubkey maxPubkeyLen)
574 where not (tooLong e.server maxPubkeyLen)
575 where not (e.server == serverHost)
576 where e.timestamp <= t + clockSkewTolerance
577 where e.timestamp + (clampTtl e.ttl) * 1000 > t
578 where not (e.eventType == "online" && count (do
579 o <- offlineEntries
580 where o.pubkey == e.pubkey
581 where o.server == e.server
582 where o.timestamp >= e.timestamp
583 yield o) > 0)
584 yield e
585 let effectiveEvents = do
586 e <- validEvents
587 where count (do a <- gossipResult.appliedKeys; where a.pubkey == e.pubkey; where a.server == e.server; yield a) > 0
588 yield e
589 if validRequest && cappedHops > 1 && not (federationSecret == "") && count effectiveEvents > 0
590 then do
591 peerServers <- atomic do
592 presence <- *presence
593 yield (fold (\acc p ->
594 if p.server == serverHost then acc
595 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
596 else union acc [p.server]) [] presence)
597 let senderServers = fold (\acc e ->
598 if count (do a <- acc; where a == e.server; yield a) > 0 then acc
599 else union acc [e.server]) (if fromServer == "" then [] else [fromServer]) effectiveEvents
600 let targets = do
601 s <- peerServers
602 where count (do ss <- senderServers; where ss == s; yield ss) == 0
603 yield s
604 sendToEach targets (\server ->
605 httpPost (federationScheme ++ server ++ "/federation/gossip")
606 {authorization: "Bearer " ++ federationSecret}
607 {events: effectiveEvents, hopsRemaining: cappedHops - 1, fromServer: serverHost})
608 else yield {}
609 respond {ok: validRequest}
610 broadcastOfflineGossip t gossipResult.peerServers gossipResult.expiredLocal
612 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
613 t <- now
614 let authorized = verifyFederationAuth authorization
615 let validOrigin = not (originServer == "") && not (originServer == serverHost)
616 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 maxPubkeyLen)
617 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
618 pruneResult <- atomic do
619 pr <- pruneExpired t
620 messages <- *messages
621 seqCounter <- *seqCounter
622 let seqTs = if t > seqCounter then t else seqCounter + 1
623 let exists = count (do
624 m <- messages
625 where m.messageId == messageId
626 where m.timestamp >= t - messageMaxAge
627 yield m) > 0
628 let shouldInsert = authorized && validOrigin && validFields && not exists
629 set *seqCounter = if shouldInsert then seqTs else seqCounter
630 set *messages = if shouldInsert
631 then union messages
632 [{messageId: messageId, toKey: toKey, fromKey: fromKey,
633 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs}]
634 else messages
635 yield pr
636 respond {ok: authorized && validOrigin && validFields}
637 broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal
639 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
640 t <- now
641 let authorized = verifyFederationAuth authorization
642 let dedupedIds = fold (\acc mid ->
643 if mid == "" then acc
644 else if count acc >= maxMessageIds then acc
645 else if count (do a <- acc; where a == mid; yield a) > 0 then acc
646 else union acc [mid]) [] messageIds
647 let validAck = authorized && originServer == serverHost && not (fromServer == "") && not (fromServer == serverHost) && not (tooLong fromServer maxPubkeyLen) && count messageIds <= maxMessageIds
648 pruneResult <- atomic do
649 pr <- pruneExpired t
650 messages <- *messages
651 presence <- *presence
652 set *messages = if validAck
653 then diff messages (do
654 m <- messages
655 mid <- dedupedIds
656 where m.messageId == mid
657 where m.originServer == ""
658 where count (do
659 p <- presence
660 where p.pubkey == m.toKey
661 where p.server == serverHost
662 where p.expiresAt > t
663 yield p) == 0
664 yield m)
665 else messages
666 yield pr
667 respond {ok: validAck}
668 broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal
670-- ============================================
671-- Entry Point
672-- ============================================
674main = do
675 println "Skrepka relay server starting on port 8080..."
676 listen 8080 serve