objective categorical abstract machine language personal data server
xrpc getSession, refreshSession
+86
-7
+4
bin/main.ml
+4
bin/main.ml
···
3
3
let handlers =
4
4
[ ( "/xrpc/com.atproto.server.describeServer"
5
5
, Api.Server.DescribeServer.handler )
6
+
; ("/xrpc/com.atproto.server.createSession", Api.Server.CreateSession.handler)
7
+
; ( "/xrpc/com.atproto.server.refreshSession"
8
+
, Api.Server.RefreshSession.handler )
9
+
; ("/xrpc/com.atproto.server.getSession", Api.Server.GetSession.handler)
6
10
; ("/xrpc/com.atproto.sync.subscribeRepos", Api.Server.SubscribeRepos.handler)
7
11
]
8
12
+5
-5
pegasus/lib/api/server/createSession.ml
+5
-5
pegasus/lib/api/server/createSession.ml
···
2
2
{ identifier: string
3
3
; password: string
4
4
; auth_factor_token: string option [@key "authFactorToken"] }
5
-
[@@deriving yojson]
5
+
[@@deriving yojson {strict= false}]
6
6
7
7
type response =
8
8
{ access_jwt: string [@key "accessJwt"]
···
12
12
; email: string
13
13
; email_confirmed: bool [@key "emailConfirmed"]
14
14
; email_auth_factor: bool [@key "emailAuthFactor"]
15
-
; active: bool
15
+
; active: bool option
16
16
; status: string option }
17
-
[@@deriving yojson]
17
+
[@@deriving yojson {strict= false}]
18
18
19
19
let handler =
20
20
Xrpc.handler ~auth:Auth.Verifiers.authorization (fun {req; db; auth} ->
···
30
30
let active, status =
31
31
match actor.deactivated_at with
32
32
| None ->
33
-
(true, None)
33
+
(Some true, None)
34
34
| Some _ ->
35
-
(false, Some "deactivated")
35
+
(Some false, Some "deactivated")
36
36
in
37
37
Dream.json @@ Yojson.Safe.to_string
38
38
@@ response_to_yojson
+9
pegasus/lib/api/server/getSession.ml
+9
pegasus/lib/api/server/getSession.ml
···
1
+
type response = Auth.session_info
2
+
3
+
let handler =
4
+
Xrpc.handler ~auth:Auth.Verifiers.access (fun {db; auth; _} ->
5
+
let did =
6
+
match auth with Access {did} -> did | _ -> failwith "non-access auth"
7
+
in
8
+
let%lwt session = Auth.get_session_info did db in
9
+
Dream.json @@ Yojson.Safe.to_string @@ Auth.session_info_to_yojson session )
+24
pegasus/lib/api/server/refreshSession.ml
+24
pegasus/lib/api/server/refreshSession.ml
···
1
+
type response =
2
+
{ access_jwt: string [@key "accessJwt"]
3
+
; refresh_jwt: string [@key "refreshJwt"]
4
+
; handle: string
5
+
; did: string
6
+
; active: bool option
7
+
; status: string option }
8
+
[@@deriving yojson {strict= false}]
9
+
10
+
let handler =
11
+
Xrpc.handler ~auth:Auth.Verifiers.refresh (fun {db; auth; _} ->
12
+
let did, jti =
13
+
match auth with
14
+
| Refresh {did; jti} ->
15
+
(did, jti)
16
+
| _ ->
17
+
failwith "non-refresh auth"
18
+
in
19
+
let%lwt () = Data_store.revoke_token ~did ~jti db in
20
+
let%lwt {handle; did; active; status; _} = Auth.get_session_info did db in
21
+
let access_jwt, refresh_jwt = Auth.generate_jwt did in
22
+
Dream.json @@ Yojson.Safe.to_string
23
+
@@ response_to_yojson
24
+
{access_jwt; refresh_jwt; handle; did; active; status} )
+34
pegasus/lib/auth.ml
+34
pegasus/lib/auth.ml
···
3
3
type symmetric_jwt =
4
4
{scope: string; aud: string; sub: string; iat: int; exp: int; jti: string}
5
5
6
+
type session_info =
7
+
{ handle: string
8
+
; did: string
9
+
; email: string
10
+
; email_confirmed: bool [@key "emailConfirmed"]
11
+
; email_auth_factor: bool [@key "emailAuthFactor"]
12
+
; active: bool option
13
+
; status: string option }
14
+
[@@deriving yojson {strict= false}]
15
+
6
16
type credentials =
7
17
| Unauthenticated
8
18
| Admin
···
87
97
true
88
98
| _ ->
89
99
false
100
+
101
+
let get_session_info identifier db =
102
+
let%lwt actor =
103
+
match%lwt Data_store.get_actor_by_identifier identifier db with
104
+
| Some actor ->
105
+
Lwt.return actor
106
+
| None ->
107
+
failwith "actor not found"
108
+
in
109
+
let active, status =
110
+
match actor.deactivated_at with
111
+
| None ->
112
+
(Some true, None)
113
+
| Some _ ->
114
+
(Some false, Some "deactivated")
115
+
in
116
+
Lwt.return
117
+
{ did= actor.did
118
+
; handle= actor.handle
119
+
; email= actor.email
120
+
; email_confirmed= true
121
+
; email_auth_factor= true
122
+
; active
123
+
; status }
90
124
91
125
module Verifiers = struct
92
126
open Util.Exceptions
+9
-1
pegasus/lib/data_store.ml
+9
-1
pegasus/lib/data_store.ml
···
165
165
let get_revoked_token =
166
166
[%rapper
167
167
get_opt
168
-
{sql| SELECT @int{revoked_at} FROM tokens WHERE did = %string{did} AND jti = %string{jti} |sql}]
168
+
{sql| SELECT @int{revoked_at} FROM revoked_tokens WHERE did = %string{did} AND jti = %string{jti} |sql}]
169
+
170
+
let revoke_token =
171
+
[%rapper
172
+
execute
173
+
{sql| INSERT INTO revoked_tokens (did, jti, revoked_at) VALUES (%string{did}, %string{jti}, %int{now}) |sql}]
169
174
end
170
175
171
176
type t = (module Rapper_helper.CONNECTION)
···
224
229
(* jwts *)
225
230
let is_token_revoked conn ~did ~jti =
226
231
unwrap @@ Queries.get_revoked_token conn ~did ~jti
232
+
233
+
let revoke_token conn ~did ~jti =
234
+
unwrap @@ Queries.revoke_token conn ~did ~jti ~now:(Util.now_ms ())