objective categorical abstract machine language personal data server
Fix treating all endpoints as GET, xrpc deleteSession
+43
-11
+31
-10
bin/main.ml
+31
-10
bin/main.ml
···
1
1
open Pegasus
2
+
open Dream
2
3
3
4
let handlers =
4
-
[ ("/xrpc/_health", Api.Health.handler)
5
-
; ("/.well-known/did.json", Api.Well_known.did_json)
6
-
; ( "/xrpc/com.atproto.server.describeServer"
5
+
[ (* meta *)
6
+
(get, "/", Api.Root.handler)
7
+
; (get, "/robots.txt", Api.Robots.handler)
8
+
; (get, "/xrpc/_health", Api.Health.handler)
9
+
; (get, "/.well-known/did.json", Api.Well_known.did_json)
10
+
; (* unauthed *)
11
+
( get
12
+
, "/xrpc/com.atproto.server.describeServer"
7
13
, Api.Server.DescribeServer.handler )
8
-
; ("/xrpc/com.atproto.server.createSession", Api.Server.CreateSession.handler)
9
-
; ( "/xrpc/com.atproto.server.refreshSession"
14
+
; ( post
15
+
, "/xrpc/com.atproto.server.createSession"
16
+
, Api.Server.CreateSession.handler )
17
+
; ( get
18
+
, "/xrpc/com.atproto.sync.subscribeRepos"
19
+
, Api.Server.SubscribeRepos.handler )
20
+
; (* account *)
21
+
(get, "/xrpc/com.atproto.server.getSession", Api.Server.GetSession.handler)
22
+
; ( post
23
+
, "/xrpc/com.atproto.server.refreshSession"
10
24
, Api.Server.RefreshSession.handler )
11
-
; ("/xrpc/com.atproto.server.getSession", Api.Server.GetSession.handler)
12
-
; ("/xrpc/com.atproto.sync.subscribeRepos", Api.Server.SubscribeRepos.handler)
13
-
]
25
+
; ( post
26
+
, "/xrpc/com.atproto.server.deleteSession"
27
+
, Api.Server.DeleteSession.handler )
28
+
; (* preferences *)
29
+
( get
30
+
, "/xrpc/com.atproto.actor.getPreferences"
31
+
, Api.Actor.GetPreferences.handler )
32
+
; ( post
33
+
, "/xrpc/com.atproto.actor.putPreferences"
34
+
, Api.Actor.PutPreferences.handler ) ]
14
35
15
36
let main =
16
37
let%lwt db = Util.connect_sqlite Util.Constants.pegasus_db_location in
···
18
39
Dream.serve ~interface:"0.0.0.0" ~port:8008
19
40
@@ Dream.logger @@ Dream.router
20
41
@@ List.map
21
-
(fun (path, handler) ->
22
-
Dream.get path (fun req -> handler ({req; db} : Xrpc.init)) )
42
+
(fun (fn, path, handler) ->
43
+
fn path (fun req -> handler ({req; db} : Xrpc.init)) )
23
44
handlers
24
45
25
46
let () = Lwt_main.run main
+1
-1
pegasus/lib/api/server/createSession.ml
+1
-1
pegasus/lib/api/server/createSession.ml
+11
pegasus/lib/api/server/deleteSession.ml
+11
pegasus/lib/api/server/deleteSession.ml
···
1
+
let handler =
2
+
Xrpc.handler ~auth:Auth.Verifiers.refresh (fun {db; auth; _} ->
3
+
let did, jti =
4
+
match auth with
5
+
| Refresh {did; jti} ->
6
+
(did, jti)
7
+
| _ ->
8
+
failwith "non-refresh auth"
9
+
in
10
+
let%lwt () = Data_store.revoke_token ~did ~jti db in
11
+
Dream.empty `OK )