git.iko.soy/skrepka
on eeea40e help sign in
skrepka/server.knot
309 lines 10 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
11messageMaxAge = 86400000 -- 24 hours in milliseconds
12maxPresenceTtl = 3600 -- max presence TTL from gossip in seconds
14-- ============================================
15-- Types
16-- ============================================
18type PollEvent = {id: Text, eventType: Text, payload: Text}
20type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int, ttl: Int}
22-- ============================================
23-- Persisted State
24-- ============================================
26*challenges : [{pubkey: Text, challenge: Text, expiresAt: Int}]
28*sessions : [{token: Text, pubkey: Text, expiresAt: Int}]
30*messages : [{messageId: Text, toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int}]
32*presence : [{pubkey: Text, server: Text, expiresAt: Int}]
34-- ============================================
35-- Routes
36-- ============================================
38route AuthApi where
39 /auth
40 POST {pubkey: Text} /challenge
41 -> {challenge: Text}
42 = ReqChallenge
43 POST {pubkey: Text, challenge: Text, signature: Text} /verify
44 -> {token: Text, expiresAt: Int}
45 = VerifyAuth
47route ClientApi where
48 GET /poll headers {authorization: Text}
49 -> {events: [PollEvent], cursor: Text}
50 = Poll
51 /messages
52 POST {to: Text, encryptedBlob: Text, timestamp: Int} / headers {authorization: Text}
53 -> {status: Text, messageId: Text}
54 = SendMessage
55 POST {messageIds: [Text]} /ack headers {authorization: Text}
56 -> {ok: Bool}
57 = AckMessages
58 GET /lookup/{pubkey: Text} headers {authorization: Text}
59 -> {online: Bool, server: Text}
60 = LookupPresence
62route FederationApi where
63 /federation
64 POST {events: [GossipEvent], hopsRemaining: Int} /gossip headers {authorization: Text}
65 -> {ok: Bool}
66 = RecvGossip
67 POST {toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, messageId: Text} /forward headers {authorization: Text}
68 -> {ok: Bool}
69 = ForwardMessage
70 POST {messageIds: [Text], originServer: Text} /ack headers {authorization: Text}
71 -> {ok: Bool}
72 = FederationAck
74route Api = AuthApi | ClientApi | FederationApi
76-- ============================================
77-- Helpers
78-- ============================================
80genToken = do
81 a <- randomInt 2147483647
82 b <- randomInt 2147483647
83 c <- randomInt 2147483647
84 d <- randomInt 2147483647
85 yield (bytesToHex (textToBytes (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d)))
87lookupSession = \token t ->
88 single (do
89 s <- *sessions
90 where s.token == token
91 where s.expiresAt > t
92 yield s)
94extractToken = \authHeader ->
95 if take 7 authHeader == "Bearer "
96 then drop 7 authHeader
97 else ""
99verifyFederationAuth = \authorization ->
100 extractToken authorization == federationSecret && not (federationSecret == "")
102clampTtl = \ttl -> if ttl > maxPresenceTtl then maxPresenceTtl else ttl
104pruneExpired = \t -> do
105 set *challenges = do
106 c <- *challenges
107 where c.expiresAt > t
108 yield c
109 set *sessions = do
110 s <- *sessions
111 where s.expiresAt > t
112 yield s
113 set *presence = do
114 p <- *presence
115 where p.expiresAt > t
116 yield p
117 set *messages = do
118 m <- *messages
119 where m.timestamp > t - messageMaxAge
120 yield m
122-- ============================================
123-- Request Handler
124-- ============================================
126serve = \req -> case req of
128 ReqChallenge {pubkey, respond} -> do
129 challenge <- genToken
130 t <- now
131 pruneExpired t
132 set *challenges = union *challenges
133 [{pubkey: pubkey, challenge: challenge, expiresAt: t + 60000}]
134 respond {challenge: challenge}
136 VerifyAuth {pubkey, challenge, signature, respond} -> do
137 t <- now
138 case single (do
139 c <- *challenges
140 where c.pubkey == pubkey
141 where c.challenge == challenge
142 where c.expiresAt > t
143 yield c) of
144 Nothing {} ->
145 respond {token: "", expiresAt: 0}
146 _ -> 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}
167 Poll {authorization, respond} -> do
168 t <- now
169 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: ""}
183 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
184 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}
201 AckMessages {messageIds, authorization, respond} -> do
202 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 {})}
215 LookupPresence {pubkey, authorization, respond} -> do
216 t <- now
217 case lookupSession (extractToken authorization) t of
218 Nothing {} ->
219 respond {online: (False {}), server: ""}
220 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: ""}
228 else case single (do
229 p <- valid
230 where p.server == serverHost
231 yield p) of
232 Just {value: p} ->
233 respond {online: (True {}), server: p.server}
234 Nothing {} ->
235 case single valid of
236 Just {value: p} ->
237 respond {online: (True {}), server: p.server}
238 Nothing {} ->
239 respond {online: (True {}), server: ""}
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 {})}
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 {})}
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 {})}
303-- ============================================
304-- Entry Point
305-- ============================================
307main = do
308 println "Skrepka relay server starting on port 8080..."
309 listen 8080 serve