git.iko.soy/skrepka
on d1663a6 help sign in
skrepka/server.knot
534 lines 20 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
15-- ============================================
16-- Types
17-- ============================================
19type PollEvent = {id: Text, eventType: Text, payload: Text}
21type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int, ttl: Int}
23-- ============================================
24-- Persisted State
25-- ============================================
27*challenges : [{pubkey: Text, challenge: Text, expiresAt: Int}]
29*sessions : [{token: Text, pubkey: Text, expiresAt: Int}]
31*messages : [{messageId: Text, toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, receivedAt: Int}]
33*presence : [{pubkey: Text, server: Text, expiresAt: Int}]
35-- ============================================
36-- Routes
37-- ============================================
39route AuthApi where
40 /auth
41 POST {pubkey: Text} /challenge
42 -> {challenge: Text}
43 = ReqChallenge
44 POST {pubkey: Text, challenge: Text, signature: Text} /verify
45 -> {token: Text, expiresAt: Int}
46 = VerifyAuth
48route ClientApi where
49 GET {cursor: Int} /poll headers {authorization: Text}
50 -> {events: [PollEvent], cursor: Int}
51 = Poll
52 /messages
53 POST {to: Text, encryptedBlob: Text, timestamp: Int} / headers {authorization: Text}
54 -> {status: Text, messageId: Text}
55 = SendMessage
56 POST {messageIds: [Text]} /ack headers {authorization: Text}
57 -> {ok: Bool}
58 = AckMessages
59 GET /lookup/{pubkey: Text} headers {authorization: Text}
60 -> {online: Bool, server: Text}
61 = LookupPresence
63route FederationApi where
64 /federation
65 POST {events: [GossipEvent], hopsRemaining: Int, fromServer: Text} /gossip headers {authorization: Text}
66 -> {ok: Bool}
67 = RecvGossip
68 POST {toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, messageId: Text} /forward headers {authorization: Text}
69 -> {ok: Bool}
70 = ForwardMessage
71 POST {messageIds: [Text], originServer: Text, fromServer: Text} /ack headers {authorization: Text}
72 -> {ok: Bool}
73 = FederationAck
75route Api = AuthApi | ClientApi | FederationApi
77-- ============================================
78-- Helpers
79-- ============================================
81genToken = do
82 a <- randomInt 2147483647
83 b <- randomInt 2147483647
84 c <- randomInt 2147483647
85 d <- randomInt 2147483647
86 yield (bytesToHex (textToBytes (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d)))
88lookupSession = \sessions token t ->
89 single (do
90 s <- sessions
91 where s.token == token
92 where s.expiresAt > t
93 yield s)
95extractToken = \authHeader ->
96 if take 7 authHeader == "Bearer "
97 then drop 7 authHeader
98 else ""
100verifyFederationAuth = \authorization ->
101 extractToken authorization == federationSecret && not (federationSecret == "")
103clampTtl = \ttl -> if ttl < 1 then 1 else if ttl > maxPresenceTtl then maxPresenceTtl else ttl
105forwardToAll = \servers path headers body ->
106 if count servers == 0
107 then yield False {}
108 else do
109 let server = fold (\acc s -> if acc == "" then s else acc) "" servers
110 let rest = do s <- servers; where not (s == server); yield s
111 if server == ""
112 then yield False {}
113 else do
114 result <- httpPost (federationScheme ++ server ++ path) headers body
115 restOk <- forwardToAll rest path headers body
116 yield (if result.ok then True {} else restOk)
118sendToEach = \servers action ->
119 if count servers == 0
120 then yield {}
121 else do
122 let server = fold (\acc s -> if acc == "" then s else acc) "" servers
123 let rest = do s <- servers; where not (s == server); yield s
124 if server == ""
125 then yield {}
126 else do
127 action server
128 sendToEach rest action
130pruneExpired = \t -> do
131 challenges <- *challenges
132 set *challenges = do
133 c <- challenges
134 where c.expiresAt > t
135 yield c
136 sessions <- *sessions
137 set *sessions = do
138 s <- sessions
139 where s.expiresAt > t
140 yield s
141 presence <- *presence
142 set *presence = do
143 p <- presence
144 where p.expiresAt > t
145 yield p
146 messages <- *messages
147 set *messages = do
148 m <- messages
149 where m.timestamp >= t - messageMaxAge
150 yield m
152-- ============================================
153-- Request Handler
154-- ============================================
156serve = \req -> case req of
158 ReqChallenge {pubkey, respond} ->
159 if pubkey == ""
160 then respond {challenge: ""}
161 else do
162 challenge <- genToken
163 t <- now
164 atomic do
165 pruneExpired t
166 challenges <- *challenges
167 set *challenges = union challenges
168 [{pubkey: pubkey, challenge: challenge, expiresAt: t + 60000}]
169 respond {challenge: challenge}
171 VerifyAuth {pubkey, challenge, signature, respond} -> do
172 t <- now
173 token <- genToken
174 let expiry = t + 3600000
175 result <- atomic do
176 pruneExpired t
177 challenges <- *challenges
178 sessions <- *sessions
179 presence <- *presence
180 let matched = single (do
181 c <- challenges
182 where c.pubkey == pubkey
183 where c.challenge == challenge
184 where c.expiresAt > t
185 yield c)
186 let sigValid = case matched of
187 Nothing {} -> False {}
188 _ -> verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
189 set *challenges = if sigValid
190 then do
191 c <- challenges
192 where not (c.pubkey == pubkey && c.challenge == challenge)
193 yield c
194 else challenges
195 let existingForKey = do
196 s <- sessions
197 where s.pubkey == pubkey
198 where s.expiresAt > t
199 yield s
200 let oldestExpiry = fold (\acc s -> if s.expiresAt < acc then s.expiresAt else acc) expiry existingForKey
201 let cappedFold = fold (\acc s ->
202 if not acc.removed && s.pubkey == pubkey && s.expiresAt == oldestExpiry
203 then {removed: True {}, sessions: acc.sessions}
204 else {removed: acc.removed, sessions: union acc.sessions [s]}) {removed: False {}, sessions: []} sessions
205 let sessionsCapped = if count existingForKey >= 10
206 then cappedFold.sessions
207 else sessions
208 set *sessions = if sigValid
209 then union sessionsCapped [{token: token, pubkey: pubkey, expiresAt: expiry}]
210 else sessions
211 let updatedPresence = if sigValid
212 then union
213 (do
214 p <- presence
215 where not (p.pubkey == pubkey && p.server == serverHost)
216 yield p)
217 [{pubkey: pubkey, server: serverHost, expiresAt: expiry}]
218 else presence
219 set *presence = updatedPresence
220 let peerServers = if sigValid && not (federationSecret == "")
221 then fold (\acc p ->
222 if p.server == serverHost then acc
223 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
224 else union acc [p.server]) [] updatedPresence
225 else []
226 yield {sigValid: sigValid, peerServers: peerServers}
227 if result.sigValid
228 then respond {token: token, expiresAt: expiry}
229 else respond {token: "", expiresAt: 0}
230 if result.sigValid && not (federationSecret == "")
231 then sendToEach result.peerServers (\server ->
232 httpPost (federationScheme ++ server ++ "/federation/gossip")
233 {authorization: "Bearer " ++ federationSecret}
234 {events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: 3600}], hopsRemaining: 2, fromServer: serverHost})
235 else yield {}
237 Poll {cursor, authorization, respond} -> do
238 t <- now
239 let token = extractToken authorization
240 result <- atomic do
241 pruneExpired t
242 sessions <- *sessions
243 messages <- *messages
244 let session = lookupSession sessions token t
245 let evts = case session of
246 Nothing {} -> []
247 Just {value: s} -> do
248 m <- messages
249 where m.toKey == s.pubkey
250 where m.timestamp >= t - messageMaxAge
251 where m.receivedAt > cursor
252 yield {id: m.messageId, eventType: "message",
253 payload: toJson {toKey: m.toKey, fromKey: m.fromKey,
254 encryptedBlob: m.encryptedBlob,
255 timestamp: m.timestamp}}
256 let newCursor = case session of
257 Nothing {} -> 0
258 _ -> t
259 yield {events: evts, cursor: newCursor}
260 respond result
262 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
263 t <- now
264 msgId <- genToken
265 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
266 let validInput = not (to == "") && not (encryptedBlob == "")
267 result <- atomic do
268 pruneExpired t
269 sessions <- *sessions
270 messages <- *messages
271 presence <- *presence
272 let session = lookupSession sessions (extractToken authorization) t
273 set *messages = case session of
274 Nothing {} -> messages
275 Just {value: s} -> if validInput
276 then union messages
277 [{messageId: msgId, toKey: to, fromKey: s.pubkey,
278 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: t}]
279 else messages
280 let localOnline = case session of
281 Nothing {} -> False {}
282 Just {value: _} -> count (do
283 p <- presence
284 where p.pubkey == to
285 where p.server == serverHost
286 where p.expiresAt > t
287 yield p) > 0
288 let remoteServers = case session of
289 Nothing {} -> []
290 Just {value: _} -> do
291 p <- presence
292 where p.pubkey == to
293 where not (p.server == serverHost)
294 where p.expiresAt > t
295 yield p.server
296 let fromKey = case session of
297 Nothing {} -> ""
298 Just {value: s} -> s.pubkey
299 let status = case session of
300 Nothing {} -> "unauthorized"
301 _ -> if not validInput then "invalid"
302 else if localOnline then "delivered"
303 else if count remoteServers > 0 then "federated"
304 else "queued"
305 yield {status: status, remoteServers: remoteServers, fromKey: fromKey}
306 finalStatus <- if result.status == "federated" && not (federationSecret == "")
307 then do
308 anyOk <- forwardToAll result.remoteServers "/federation/forward"
309 {authorization: "Bearer " ++ federationSecret}
310 {toKey: to, fromKey: result.fromKey, encryptedBlob: encryptedBlob,
311 timestamp: clampedTs, originServer: serverHost, messageId: msgId}
312 yield (if anyOk then "federated" else "queued")
313 else yield result.status
314 respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
316 AckMessages {messageIds, authorization, respond} -> do
317 t <- now
318 let dedupedIds = fold (\acc mid ->
319 if count (do a <- acc; where a == mid; yield a) > 0 then acc
320 else union acc [mid]) [] messageIds
321 result <- atomic do
322 pruneExpired t
323 sessions <- *sessions
324 messages <- *messages
325 let session = lookupSession sessions (extractToken authorization) t
326 let ackedMessages = case session of
327 Nothing {} -> []
328 Just {value: s} -> do
329 m <- messages
330 mid <- dedupedIds
331 where m.messageId == mid
332 where m.toKey == s.pubkey
333 yield m
334 set *messages = case session of
335 Nothing {} -> messages
336 Just {value: _} -> diff messages ackedMessages
337 let ok = case session of
338 Nothing {} -> False {}
339 _ -> True {}
340 yield {ok: ok, ackedMessages: ackedMessages}
341 let fedMessages = do
342 m <- result.ackedMessages
343 where not (m.originServer == "")
344 where not (m.originServer == serverHost)
345 yield m
346 let originServers = fold (\acc m ->
347 if count (do a <- acc; where a == m.originServer; yield a) > 0 then acc
348 else union acc [m.originServer]) [] fedMessages
349 if result.ok && count originServers > 0 && not (federationSecret == "")
350 then sendToEach originServers (\server ->
351 httpPost (federationScheme ++ server ++ "/federation/ack")
352 {authorization: "Bearer " ++ federationSecret}
353 {messageIds: (do m <- fedMessages; where m.originServer == server; yield m.messageId),
354 originServer: server, fromServer: serverHost})
355 else yield {}
356 respond {ok: result.ok}
358 LookupPresence {pubkey, authorization, respond} -> do
359 t <- now
360 result <- atomic do
361 pruneExpired t
362 sessions <- *sessions
363 presence <- *presence
364 let session = lookupSession sessions (extractToken authorization) t
365 let valid = do
366 p <- presence
367 where p.pubkey == pubkey
368 where p.expiresAt > t
369 yield p
370 let foundServer = case session of
371 Nothing {} -> ""
372 Just {value: _} ->
373 if count valid == 0
374 then ""
375 else case single (do
376 p <- valid
377 where p.server == serverHost
378 yield p) of
379 Just {value: p} -> p.server
380 Nothing {} -> fold (\_ p -> p.server) "" valid
381 let authorized = case session of
382 Nothing {} -> False {}
383 _ -> True {}
384 yield {foundServer: foundServer, authorized: authorized}
385 if result.authorized
386 then respond {online: not (result.foundServer == ""), server: result.foundServer}
387 else respond {online: False {}, server: "unauthorized"}
389 RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
390 t <- now
391 let authorized = verifyFederationAuth authorization
392 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
393 let validRequest = authorized && cappedHops >= 1
394 let onlineEntries = do
395 e <- events
396 where e.eventType == "online"
397 where not (e.server == "")
398 where not (e.pubkey == "")
399 where not (e.server == serverHost)
400 where e.timestamp <= t
401 where e.timestamp + (clampTtl e.ttl) * 1000 > t
402 yield {pubkey: e.pubkey, server: e.server, expiresAt: e.timestamp + (clampTtl e.ttl) * 1000, timestamp: e.timestamp}
403 let offlineEntries = do
404 e <- events
405 where e.eventType == "offline"
406 where not (e.server == "")
407 where not (e.pubkey == "")
408 where not (e.server == serverHost)
409 where e.timestamp <= t
410 where t - e.timestamp < (clampTtl e.ttl) * 1000
411 yield {pubkey: e.pubkey, server: e.server, timestamp: e.timestamp}
412 let filteredOnline = do
413 e <- onlineEntries
414 where count (do
415 o <- offlineEntries
416 where o.pubkey == e.pubkey
417 where o.server == e.server
418 where o.timestamp >= e.timestamp
419 yield o) == 0
420 yield {pubkey: e.pubkey, server: e.server, expiresAt: e.expiresAt}
421 let affectedKeys = union
422 (do
423 e <- onlineEntries
424 yield {pubkey: e.pubkey, server: e.server})
425 (do
426 e <- offlineEntries
427 yield {pubkey: e.pubkey, server: e.server})
428 let deduped = fold (\acc e ->
429 if count (do
430 a <- acc
431 where a.pubkey == e.pubkey
432 where a.server == e.server
433 where a.expiresAt >= e.expiresAt
434 yield a) > 0
435 then acc
436 else union
437 (do
438 a <- acc
439 where not (a.pubkey == e.pubkey && a.server == e.server)
440 yield a)
441 [e]) [] filteredOnline
442 atomic do
443 pruneExpired t
444 presence <- *presence
445 let cleaned = diff presence (do
446 p <- presence
447 k <- affectedKeys
448 where p.pubkey == k.pubkey
449 where p.server == k.server
450 yield p)
451 set *presence = if validRequest
452 then union cleaned deduped
453 else presence
454 let validEvents = do
455 e <- events
456 where not (e.server == "")
457 where not (e.pubkey == "")
458 where e.timestamp <= t
459 where e.timestamp + (clampTtl e.ttl) * 1000 > t
460 yield e
461 if validRequest && cappedHops > 1 && not (federationSecret == "") && count validEvents > 0
462 then do
463 peerServers <- atomic do
464 presence <- *presence
465 yield (fold (\acc p ->
466 if p.server == serverHost then acc
467 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
468 else union acc [p.server]) [] presence)
469 let senderServers = fold (\acc e ->
470 if count (do a <- acc; where a == e.server; yield a) > 0 then acc
471 else union acc [e.server]) (if fromServer == "" then [] else [fromServer]) events
472 let targets = do
473 s <- peerServers
474 where count (do ss <- senderServers; where ss == s; yield ss) == 0
475 yield s
476 sendToEach targets (\server ->
477 httpPost (federationScheme ++ server ++ "/federation/gossip")
478 {authorization: "Bearer " ++ federationSecret}
479 {events: validEvents, hopsRemaining: cappedHops - 1, fromServer: serverHost})
480 else yield {}
481 respond {ok: validRequest}
483 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
484 t <- now
485 let authorized = verifyFederationAuth authorization
486 let validOrigin = not (originServer == "") && not (originServer == serverHost)
487 let validFields = not (toKey == "") && not (fromKey == "") && not (encryptedBlob == "") && not (messageId == "")
488 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
489 atomic do
490 pruneExpired t
491 messages <- *messages
492 let exists = count (do
493 m <- messages
494 where m.messageId == messageId
495 where m.timestamp >= t - messageMaxAge
496 yield m) > 0
497 let shouldInsert = authorized && validOrigin && validFields && not exists
498 set *messages = if shouldInsert
499 then union messages
500 [{messageId: messageId, toKey: toKey, fromKey: fromKey,
501 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: t}]
502 else messages
503 respond {ok: authorized && validOrigin && validFields}
505 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
506 t <- now
507 let authorized = verifyFederationAuth authorization
508 let validAck = authorized && originServer == serverHost && not (fromServer == "") && not (fromServer == serverHost)
509 atomic do
510 pruneExpired t
511 messages <- *messages
512 presence <- *presence
513 set *messages = if validAck
514 then diff messages (do
515 m <- messages
516 mid <- messageIds
517 where m.messageId == mid
518 where count (do
519 p <- presence
520 where p.pubkey == m.toKey
521 where p.server == serverHost
522 where p.expiresAt > t
523 yield p) == 0
524 yield m)
525 else messages
526 respond {ok: validAck}
528-- ============================================
529-- Entry Point
530-- ============================================
532main = do
533 println "Skrepka relay server starting on port 8080..."
534 listen 8080 serve