@@ -84,9 +84,9 @@ genToken = do
8484 d <- randomInt 2147483647
8585 yield (bytesToHex (textToBytes (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d)))
8686
87−lookupSession = \token t ->
87+lookupSession = \sessions token t ->
8888 single (do
89− s <- *sessions
89+ s <- sessions
9090 where s.token == token
9191 where s.expiresAt > t
9292 yield s)
@@ -102,20 +102,24 @@ verifyFederationAuth = \authorization ->
102102clampTtl = \ttl -> if ttl > maxPresenceTtl then maxPresenceTtl else ttl
103103
104104pruneExpired = \t -> do
105+ challenges <- *challenges
105106 set *challenges = do
106− c <- *challenges
107+ c <- challenges
107108 where c.expiresAt > t
108109 yield c
110+ sessions <- *sessions
109111 set *sessions = do
110− s <- *sessions
112+ s <- sessions
111113 where s.expiresAt > t
112114 yield s
115+ presence <- *presence
113116 set *presence = do
114− p <- *presence
117+ p <- presence
115118 where p.expiresAt > t
116119 yield p
120+ messages <- *messages
117121 set *messages = do
118− m <- *messages
122+ m <- messages
119123 where m.timestamp > t - messageMaxAge
120124 yield m
121125
@@ -129,176 +133,195 @@ serve = \req -> case req of
129133 challenge <- genToken
130134 t <- now
131135 pruneExpired t
132− set *challenges = union *challenges
136+ challenges <- *challenges
137+ set *challenges = union challenges
133138 [{pubkey: pubkey, challenge: challenge, expiresAt: t + 60000}]
134139 respond {challenge: challenge}
135140
136141 VerifyAuth {pubkey, challenge, signature, respond} -> do
137142 t <- now
138− case single (do
139− c <- *challenges
143+ challenges <- *challenges
144+ sessions <- *sessions
145+ presence <- *presence
146+ token <- genToken
147+ let expiry = t + 3600000
148+ let matched = single (do
149+ c <- challenges
140150 where c.pubkey == pubkey
141151 where c.challenge == challenge
142152 where c.expiresAt > t
143− yield c) of
144− Nothing {} ->
145− respond {token: "", expiresAt: 0}
153+ yield c)
154+ let sigValid = case matched of
155+ Nothing {} -> False {}
156+ _ -> verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
157+ set *challenges = case matched of
158+ Nothing {} -> challenges
146159 _ -> do
147− set *challenges = do
148− c <- *challenges
149− where not (c.pubkey == pubkey && c.challenge == challenge)
150− yield c
151− if verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
152− then do
153− token <- genToken
154− let expiry = t + 3600000
155− set *sessions = union *sessions
156− [{token: token, pubkey: pubkey, expiresAt: expiry}]
157− set *presence = union
158− (do
159− p <- *presence
160− where not (p.pubkey == pubkey && p.server == serverHost)
161− yield p)
162− [{pubkey: pubkey, server: serverHost, expiresAt: expiry}]
163− respond {token: token, expiresAt: expiry}
164− else
165− respond {token: "", expiresAt: 0}
160+ c <- challenges
161+ where not (c.pubkey == pubkey && c.challenge == challenge)
162+ yield c
163+ set *sessions = if sigValid
164+ then union sessions [{token: token, pubkey: pubkey, expiresAt: expiry}]
165+ else sessions
166+ set *presence = if sigValid
167+ then union
168+ (do
169+ p <- presence
170+ where not (p.pubkey == pubkey && p.server == serverHost)
171+ yield p)
172+ [{pubkey: pubkey, server: serverHost, expiresAt: expiry}]
173+ else presence
174+ let result = if sigValid
175+ then {token: token, expiresAt: expiry}
176+ else {token: "", expiresAt: 0}
177+ respond result
166178
167179 Poll {authorization, respond} -> do
168180 t <- now
169181 pruneExpired t
170− case lookupSession (extractToken authorization) t of
171− Nothing {} ->
172− respond {events: [], cursor: ""}
173− Just {value: session} -> do
174− let evts = do
175− m <- *messages
176− where m.toKey == session.pubkey
177− yield {id: m.messageId, eventType: "message",
178− payload: toJson {toKey: m.toKey, fromKey: m.fromKey,
179− encryptedBlob: m.encryptedBlob,
180− timestamp: m.timestamp}}
181− respond {events: evts, cursor: ""}
182+ sessions <- *sessions
183+ messages <- *messages
184+ let session = lookupSession sessions (extractToken authorization) t
185+ let evts = case session of
186+ Nothing {} -> []
187+ Just {value: s} -> do
188+ m <- messages
189+ where m.toKey == s.pubkey
190+ yield {id: m.messageId, eventType: "message",
191+ payload: toJson {toKey: m.toKey, fromKey: m.fromKey,
192+ encryptedBlob: m.encryptedBlob,
193+ timestamp: m.timestamp}}
194+ respond {events: evts, cursor: ""}
182195
183196 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
184197 t <- now
185− case lookupSession (extractToken authorization) t of
186− Nothing {} ->
187− respond {status: "unauthorized", messageId: ""}
188− Just {value: session} -> do
189− msgId <- genToken
190− set *messages = union *messages
191− [{messageId: msgId, toKey: to, fromKey: session.pubkey,
192− encryptedBlob: encryptedBlob, timestamp: t}]
193− let online = count (do
194− s <- *sessions
195− where s.pubkey == to
196− where s.expiresAt > t
197− yield s) > 0
198− respond {status: (if online then "delivered" else "queued"),
199− messageId: msgId}
198+ sessions <- *sessions
199+ messages <- *messages
200+ let session = lookupSession sessions (extractToken authorization) t
201+ msgId <- genToken
202+ set *messages = case session of
203+ Nothing {} -> messages
204+ Just {value: s} -> union messages
205+ [{messageId: msgId, toKey: to, fromKey: s.pubkey,
206+ encryptedBlob: encryptedBlob, timestamp: t}]
207+ let online = case session of
208+ Nothing {} -> False {}
209+ Just {value: _} -> count (do
210+ s <- sessions
211+ where s.pubkey == to
212+ where s.expiresAt > t
213+ yield s) > 0
214+ let result = case session of
215+ Nothing {} -> {status: "unauthorized", messageId: ""}
216+ _ -> {status: (if online then "delivered" else "queued"),
217+ messageId: msgId}
218+ respond result
200219
201220 AckMessages {messageIds, authorization, respond} -> do
202221 t <- now
203− case lookupSession (extractToken authorization) t of
204− Nothing {} ->
205− respond {ok: (False {})}
206− Just {value: session} -> do
207− set *messages = diff *messages (do
208− m <- *messages
209− mid <- messageIds
210− where m.messageId == mid
211− where m.toKey == session.pubkey
212− yield m)
213− respond {ok: (True {})}
222+ sessions <- *sessions
223+ messages <- *messages
224+ let session = lookupSession sessions (extractToken authorization) t
225+ set *messages = case session of
226+ Nothing {} -> messages
227+ Just {value: s} -> diff messages (do
228+ m <- messages
229+ mid <- messageIds
230+ where m.messageId == mid
231+ where m.toKey == s.pubkey
232+ yield m)
233+ let result = case session of
234+ Nothing {} -> {ok: (False {})}
235+ _ -> {ok: (True {})}
236+ respond result
214237
215238 LookupPresence {pubkey, authorization, respond} -> do
216239 t <- now
217− case lookupSession (extractToken authorization) t of
218− Nothing {} ->
219− respond {online: (False {}), server: ""}
240+ sessions <- *sessions
241+ presence <- *presence
242+ let session = lookupSession sessions (extractToken authorization) t
243+ let valid = do
244+ p <- presence
245+ where p.pubkey == pubkey
246+ where p.expiresAt > t
247+ yield p
248+ let result = case session of
249+ Nothing {} -> {online: (False {}), server: ""}
220250 Just {value: _} ->
221− let valid = do
222− p <- *presence
223− where p.pubkey == pubkey
224− where p.expiresAt > t
225− yield p
226− in if count valid == 0
227− then respond {online: (False {}), server: ""}
251+ if count valid == 0
252+ then {online: (False {}), server: ""}
228253 else case single (do
229254 p <- valid
230255 where p.server == serverHost
231256 yield p) of
232− Just {value: p} ->
233− respond {online: (True {}), server: p.server}
257+ Just {value: p} -> {online: (True {}), server: p.server}
234258 Nothing {} ->
235259 case single valid of
236− Just {value: p} ->
237− respond {online: (True {}), server: p.server}
238− Nothing {} ->
239− respond {online: (True {}), server: ""}
240−
241− RecvGossip {events, hopsRemaining, authorization, respond} ->
242− if not (verifyFederationAuth authorization)
243− then respond {ok: (False {})}
244− else if hopsRemaining < 1
245− then respond {ok: (False {})}
246− else do
247− t <- now
248− let onlineEntries = do
249− e <- events
250− where e.eventType == "online"
251− yield {pubkey: e.pubkey, server: e.server, expiresAt: t + clampTtl e.ttl * 1000}
252− let affectedKeys = do
253− e <- events
254− yield {pubkey: e.pubkey, server: e.server}
255− let cleaned = diff *presence (do
256− p <- *presence
257− k <- affectedKeys
258− where p.pubkey == k.pubkey
259− where p.server == k.server
260− yield p)
261− let deduped = do
262− e <- onlineEntries
263− where count (do
264− o <- onlineEntries
265− where o.pubkey == e.pubkey
266− where o.server == e.server
267− where o.expiresAt > e.expiresAt
268− yield o) == 0
269− yield e
270− set *presence = union cleaned deduped
271− respond {ok: (True {})}
272−
273− ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} ->
274− if not (verifyFederationAuth authorization)
275− then respond {ok: (False {})}
276− else do
277− t <- now
278− let clampedTs = if timestamp > t then t else timestamp
279− let exists = count (do
280− m <- *messages
281− where m.messageId == messageId
282− where m.timestamp > t - messageMaxAge
283− yield m) > 0
284− if exists
285− then respond {ok: (True {})}
286− else do
287− set *messages = union *messages
288− [{messageId: messageId, toKey: toKey, fromKey: fromKey,
289− encryptedBlob: encryptedBlob, timestamp: clampedTs}]
290− respond {ok: (True {})}
291−
292− FederationAck {messageIds, originServer, authorization, respond} ->
293− if not (verifyFederationAuth authorization)
294− then respond {ok: (False {})}
295− else do
296− set *messages = diff *messages (do
297− m <- *messages
298− mid <- messageIds
299− where m.messageId == mid
300− yield m)
301− respond {ok: (True {})}
260+ Just {value: p} -> {online: (True {}), server: p.server}
261+ Nothing {} -> {online: (True {}), server: ""}
262+ respond result
263+
264+ RecvGossip {events, hopsRemaining, authorization, respond} -> do
265+ t <- now
266+ presence <- *presence
267+ let authorized = verifyFederationAuth authorization
268+ let validRequest = authorized && hopsRemaining >= 1
269+ let onlineEntries = do
270+ e <- events
271+ where e.eventType == "online"
272+ yield {pubkey: e.pubkey, server: e.server, expiresAt: t + clampTtl e.ttl * 1000}
273+ let affectedKeys = do
274+ e <- events
275+ yield {pubkey: e.pubkey, server: e.server}
276+ let cleaned = diff presence (do
277+ p <- presence
278+ k <- affectedKeys
279+ where p.pubkey == k.pubkey
280+ where p.server == k.server
281+ yield p)
282+ let deduped = do
283+ e <- onlineEntries
284+ where count (do
285+ o <- onlineEntries
286+ where o.pubkey == e.pubkey
287+ where o.server == e.server
288+ where o.expiresAt > e.expiresAt
289+ yield o) == 0
290+ yield e
291+ set *presence = if validRequest
292+ then union cleaned deduped
293+ else presence
294+ respond {ok: validRequest}
295+
296+ ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
297+ t <- now
298+ messages <- *messages
299+ let authorized = verifyFederationAuth authorization
300+ let clampedTs = if timestamp > t then t else timestamp
301+ let exists = count (do
302+ m <- messages
303+ where m.messageId == messageId
304+ where m.timestamp > t - messageMaxAge
305+ yield m) > 0
306+ let shouldInsert = authorized && not exists
307+ set *messages = if shouldInsert
308+ then union messages
309+ [{messageId: messageId, toKey: toKey, fromKey: fromKey,
310+ encryptedBlob: encryptedBlob, timestamp: clampedTs}]
311+ else messages
312+ respond {ok: authorized}
313+
314+ FederationAck {messageIds, originServer, authorization, respond} -> do
315+ messages <- *messages
316+ let authorized = verifyFederationAuth authorization
317+ set *messages = if authorized
318+ then diff messages (do
319+ m <- messages
320+ mid <- messageIds
321+ where m.messageId == mid
322+ yield m)
323+ else messages
324+ respond {ok: authorized}
302325
303326-- ============================================
304327-- Entry Point