objective categorical abstract machine language personal data server
/oauth/authorize
+403
-202
+5
-3
bin/main.ml
+5
-3
bin/main.ml
···
14
14
, "/.well-known/oauth-authorization-server"
15
15
, Api.Well_known.oauth_authorization_server )
16
16
; (* oauth *)
17
-
(get, "/oauth/par", Api.Oauth_.Par.handler)
17
+
(options, "/oauth/par", Api.Oauth_.Par.options_handler)
18
+
; (post, "/oauth/par", Api.Oauth_.Par.post_handler)
18
19
; (get, "/oauth/authorize", Api.Oauth_.Authorize.get_handler)
19
20
; (post, "/oauth/authorize", Api.Oauth_.Authorize.post_handler)
20
-
; (post, "/oauth/token", Api.Oauth_.Token.handler)
21
+
; (options, "/oauth/token", Api.Oauth_.Token.options_handler)
22
+
; (post, "/oauth/token", Api.Oauth_.Token.post_handler)
21
23
; (* account *)
22
24
(get, "/account/login", Api.Account_.Login.get_handler)
23
25
; (post, "/account/login", Api.Account_.Login.post_handler)
···
91
93
@@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey)
92
94
@@ Dream.cookie_sessions
93
95
@@ Xrpc.service_proxy_middleware db
94
-
@@ Xrpc.dpop_middleware @@ Dream.router
96
+
@@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router
95
97
@@ List.map
96
98
(fun (fn, path, handler) ->
97
99
fn path (fun req -> handler ({req; db} : Xrpc.init)) )
+16
-6
pegasus/lib/api/account_/login.ml
+16
-6
pegasus/lib/api/account_/login.ml
···
1
1
let get_handler =
2
2
Xrpc.handler (fun ctx ->
3
3
let redirect_url =
4
-
Dream.query ctx.req "redirect_url" |> Option.value ~default:"/"
4
+
if List.length @@ Dream.all_queries ctx.req > 0 then
5
+
Uri.make ~path:"/oauth/authorize" ~query:(Util.copy_query ctx.req) ()
6
+
|> Uri.to_string
7
+
else "/account"
8
+
in
9
+
let csrf_token = Dream.csrf_token ctx.req in
10
+
let html =
11
+
JSX.render (Templates.Login.make ~redirect_url ~csrf_token ())
5
12
in
6
-
let html = JSX.render (Templates.Login.make ~redirect_url ()) in
7
13
Dream.html html )
8
14
9
15
let post_handler =
10
16
Xrpc.handler (fun ctx ->
17
+
let csrf_token = Dream.csrf_token ctx.req in
11
18
match%lwt Dream.form ctx.req with
12
19
| `Ok fields -> (
13
20
let identifier = List.assoc "identifier" fields in
14
21
let password = List.assoc "password" fields in
15
22
let redirect_url =
16
-
List.assoc_opt "redirect_url" fields |> Option.value ~default:"/"
23
+
List.assoc_opt "redirect_url" fields
24
+
|> Option.value ~default:"/account"
17
25
in
18
26
let%lwt actor =
19
27
Data_store.try_login ~id:identifier ~password ctx.db
···
23
31
let html =
24
32
JSX.render
25
33
(Templates.Login.make ~redirect_url
26
-
~error:"Invalid username or password. Please try again." () )
34
+
~error:"Invalid username or password. Please try again."
35
+
~csrf_token () )
27
36
in
28
37
Dream.html ~status:`Unauthorized html
29
38
| Some {did; _} ->
···
33
42
| _ ->
34
43
let html =
35
44
JSX.render
36
-
(Templates.Login.make ~redirect_url:"/"
37
-
~error:"Invalid credentials provided. Please try again." () )
45
+
(Templates.Login.make ~redirect_url:"/account"
46
+
~error:"Invalid credentials provided. Please try again."
47
+
~csrf_token () )
38
48
in
39
49
Dream.html ~status:`Unauthorized html )
+1
-1
pegasus/lib/api/account_/logout.ml
+1
-1
pegasus/lib/api/account_/logout.ml
+14
-21
pegasus/lib/api/oauth_/par.ml
+14
-21
pegasus/lib/api/oauth_/par.ml
···
1
1
open Oauth
2
+
open Oauth.Types
2
3
3
-
type request =
4
-
{ client_id: string
5
-
; response_type: string
6
-
; redirect_uri: string
7
-
; scope: string
8
-
; state: string
9
-
; code_challenge: string
10
-
; code_challenge_method: string
11
-
; login_hint: string option }
12
-
[@@deriving yojson]
4
+
let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)
13
5
14
-
let handler =
6
+
let post_handler =
15
7
Xrpc.handler ~auth:DPoP (fun ctx ->
16
8
let proof = Auth.get_dpop_proof_exn ctx.auth in
17
-
let%lwt req = Xrpc.parse_body ctx.req request_of_yojson in
9
+
let%lwt req = Xrpc.parse_body ctx.req par_request_of_yojson in
18
10
let%lwt client =
19
11
try%lwt Client.fetch_client_metadata req.client_id
20
12
with e ->
···
29
21
Errors.invalid_request "invalid redirect_uri"
30
22
else
31
23
let request_id =
32
-
"req-" ^ Uuidm.to_string (Uuidm.v4_gen (Random.get_state ()) ())
24
+
"req-"
25
+
^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ())
33
26
in
34
27
let request_uri = Constants.request_uri_prefix ^ request_id in
35
28
let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in
36
-
let%lwt () =
37
-
Queries.insert_par_request ctx.db
38
-
{ request_id
39
-
; client_id= req.client_id
40
-
; request_data= Yojson.Safe.to_string (request_to_yojson req)
41
-
; dpop_jkt= Some proof.jkt
42
-
; expires_at
43
-
; created_at= Util.now_ms () }
29
+
let request : oauth_request =
30
+
{ request_id
31
+
; client_id= req.client_id
32
+
; request_data= Yojson.Safe.to_string (par_request_to_yojson req)
33
+
; dpop_jkt= Some proof.jkt
34
+
; expires_at
35
+
; created_at= Util.now_ms () }
44
36
in
37
+
let%lwt () = Queries.insert_par_request ctx.db request in
45
38
Dream.json ~status:`Created
46
39
@@ Yojson.Safe.to_string
47
40
@@ `Assoc
+17
-7
pegasus/lib/api/oauth_/token.ml
+17
-7
pegasus/lib/api/oauth_/token.ml
···
1
1
open Oauth
2
2
3
-
let handler =
3
+
let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)
4
+
5
+
let post_handler =
4
6
Xrpc.handler ~auth:DPoP (fun ctx ->
5
7
let%lwt req = Xrpc.parse_body ctx.req Types.token_request_of_yojson in
6
8
let proof = Auth.get_dpop_proof_exn ctx.auth in
···
47
49
let computed =
48
50
Digestif.SHA256.digest_string verifier
49
51
|> Digestif.SHA256.to_raw_string
50
-
|> Base64.encode_exn ~pad:false
52
+
|> Base64.(
53
+
encode_exn ~pad:false
54
+
~alphabet:uri_safe_alphabet )
51
55
in
52
56
if orig_req.code_challenge <> computed then
53
57
Errors.invalid_request "invalid code_verifier"
···
60
64
let token_id =
61
65
"tok-"
62
66
^ Uuidm.to_string
63
-
(Uuidm.v4_gen (Random.get_state ()) ())
67
+
(Uuidm.v4_gen
68
+
(Random.State.make_self_init ())
69
+
() )
64
70
in
65
71
let refresh_token =
66
72
"ref-"
67
73
^ Uuidm.to_string
68
-
(Uuidm.v4_gen (Random.get_state ()) ())
74
+
(Uuidm.v4_gen
75
+
(Random.State.make_self_init ())
76
+
() )
69
77
in
70
78
let now_sec = int_of_float (Unix.gettimeofday ()) in
71
79
let expires_in =
···
128
136
else
129
137
let new_token_id =
130
138
"tok-"
131
-
^ Uuidm.to_string (Uuidm.v4_gen (Random.get_state ()) ())
139
+
^ Uuidm.to_string
140
+
(Uuidm.v4_gen (Random.State.make_self_init ()) ())
132
141
in
133
142
let new_refresh =
134
143
"ref-"
135
-
^ Uuidm.to_string (Uuidm.v4_gen (Random.get_state ()) ())
144
+
^ Uuidm.to_string
145
+
(Uuidm.v4_gen (Random.State.make_self_init ()) ())
136
146
in
137
147
let now_sec = int_of_float (Unix.gettimeofday ()) in
138
148
let expires_in = Constants.access_token_expiry_ms / 1000 in
···
153
163
in
154
164
let%lwt () =
155
165
Queries.update_oauth_token ctx.db
156
-
~old_refresh_token:refresh_token ~new_token_id
166
+
~old_refresh_token:refresh_token
157
167
~new_refresh_token:new_refresh ~expires_at:new_expires_at
158
168
in
159
169
Dream.json ~headers:[("Cache-Control", "no-store")]
+61
-40
pegasus/lib/auth.ml
+61
-40
pegasus/lib/auth.ml
···
16
16
| Access of {did: string}
17
17
| Refresh of {did: string; jti: string}
18
18
| OAuth of {did: string; proof: Oauth.Dpop.proof}
19
+
| DPoP of {proof: Oauth.Dpop.proof}
19
20
20
21
let verify_bearer_jwt t token expected_scope =
21
22
match Jwt.verify_jwt token Env.jwt_key with
···
59
60
Errors.auth_required "invalid authorization header"
60
61
61
62
let get_dpop_proof_exn = function
62
-
| OAuth {proof; _} ->
63
+
| OAuth {proof; _} | DPoP {proof} ->
63
64
proof
64
65
| _ ->
65
66
Errors.invalid_request "invalid DPoP header"
···
168
169
Lwt.return_error @@ Errors.auth_required "invalid authorization header"
169
170
170
171
let dpop : verifier =
172
+
fun {req; _} ->
173
+
let dpop_header = Dream.header req "DPoP" in
174
+
match
175
+
Oauth.Dpop.verify_dpop_proof
176
+
~mthd:(Dream.method_to_string @@ Dream.method_ req)
177
+
~url:(Dream.target req) ~dpop_header ()
178
+
with
179
+
| Error "use_dpop_nonce" ->
180
+
Lwt.return_error @@ Errors.use_dpop_nonce ()
181
+
| Error e ->
182
+
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
183
+
| Ok proof ->
184
+
Lwt.return_ok (DPoP {proof})
185
+
186
+
let oauth : verifier =
171
187
fun {req; db} ->
172
188
match parse_dpop req with
173
189
| Error e ->
174
-
Errors.invalid_request ("dpop error: " ^ e)
190
+
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
175
191
| Ok token -> (
176
-
let dpop_header = Dream.header req "DPoP" in
177
-
match
178
-
Oauth.Dpop.verify_dpop_proof
179
-
~mthd:(Dream.method_to_string @@ Dream.method_ req)
180
-
~url:(Dream.target req) ~dpop_header ~access_token:token ()
181
-
with
182
-
| Error "use_dpop_nonce" ->
183
-
Lwt.return_error
184
-
(* error must be this object; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
185
-
@@ Errors.invalid_request {|{ "error": "use_dpop_nonce" }|}
192
+
match%lwt dpop {req; db} with
193
+
| Error e ->
194
+
Lwt.return_error e
195
+
| Ok (DPoP {proof}) -> (
196
+
match Jwt.verify_jwt token Env.jwt_key with
186
197
| Error e ->
187
-
Errors.invalid_request ("dpop error: " ^ e)
188
-
| Ok proof -> (
189
-
match Jwt.verify_jwt token Env.jwt_key with
190
-
| Error e ->
191
-
Lwt.return_error @@ Errors.auth_required e
192
-
| Ok (_header, claims) -> (
193
-
let open Yojson.Safe.Util in
194
-
try
195
-
let did = claims |> member "sub" |> to_string in
196
-
let exp = claims |> member "exp" |> to_int in
197
-
let jkt_claim =
198
-
claims |> member "cnf" |> member "jkt" |> to_string
198
+
Lwt.return_error @@ Errors.auth_required e
199
+
| Ok (_header, claims) -> (
200
+
let open Yojson.Safe.Util in
201
+
try
202
+
let did = claims |> member "sub" |> to_string in
203
+
let exp = claims |> member "exp" |> to_int in
204
+
let jkt_claim =
205
+
claims |> member "cnf" |> member "jkt" |> to_string
206
+
in
207
+
let now = int_of_float (Unix.gettimeofday ()) in
208
+
if jkt_claim <> proof.jkt then
209
+
Lwt.return_error @@ Errors.auth_required "dpop key mismatch"
210
+
else if exp < now then
211
+
Lwt.return_error @@ Errors.auth_required "token expired"
212
+
else
213
+
let%lwt session =
214
+
try%lwt
215
+
let%lwt sess = get_session_info did db in
216
+
Lwt.return_ok sess
217
+
with _ ->
218
+
Lwt.return_error
219
+
@@ Errors.auth_required "invalid credentials"
199
220
in
200
-
let now = int_of_float (Unix.gettimeofday ()) in
201
-
if jkt_claim <> proof.jkt then
202
-
Lwt.return_error @@ Errors.auth_required "dpop key mismatch"
203
-
else if exp < now then
204
-
Lwt.return_error @@ Errors.auth_required "token expired"
205
-
else
206
-
let%lwt {active; _} =
207
-
try%lwt get_session_info did db
208
-
with _ -> Errors.auth_required "invalid credentials"
209
-
in
210
-
if active <> Some true then
221
+
match session with
222
+
| Ok {active= Some true; _} ->
223
+
Lwt.return_ok (OAuth {did; proof})
224
+
| Ok _ ->
211
225
Lwt.return_error
212
226
@@ Errors.auth_required ~name:"AccountDeactivated"
213
227
"account is deactivated"
214
-
else Lwt.return_ok (Access {did})
215
-
with _ ->
216
-
Lwt.return_error @@ Errors.auth_required "malformed JWT claims"
217
-
) ) )
228
+
| Error _ ->
229
+
Lwt.return_error
230
+
@@ Errors.auth_required "invalid credentials"
231
+
with _ ->
232
+
Lwt.return_error @@ Errors.auth_required "malformed JWT claims" )
233
+
)
234
+
| Ok _ ->
235
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
218
236
219
237
let refresh : verifier =
220
238
fun {req; db} ->
···
247
265
| Some ("Bearer" :: _) ->
248
266
bearer ctx
249
267
| Some ("DPoP" :: _) ->
250
-
dpop ctx
268
+
oauth ctx
251
269
| _ ->
252
270
Lwt.return_error
253
271
@@ Errors.auth_required ~name:"InvalidToken"
···
261
279
| Admin
262
280
| Bearer
263
281
| DPoP
282
+
| OAuth
264
283
| Refresh
265
284
| Authorization
266
285
| Any
···
274
293
bearer
275
294
| DPoP ->
276
295
dpop
296
+
| OAuth ->
297
+
oauth
277
298
| Refresh ->
278
299
refresh
279
300
| Authorization ->
+3
-1
pegasus/lib/data_store.ml
+3
-1
pegasus/lib/data_store.ml
···
103
103
execute
104
104
{sql| CREATE TABLE IF NOT EXISTS oauth_codes (
105
105
code TEXT PRIMARY KEY,
106
-
request_id TEXT NOT NULL REFERENCES oauth_requests(request_id),
106
+
request_id TEXT NOT NULL REFERENCES oauth_requests(request_id) ON DELETE CASCADE,
107
107
authorized_by TEXT,
108
108
authorized_at INTEGER,
109
109
expires_at INTEGER NOT NULL,
···
311
311
type t = Util.caqti_pool
312
312
313
313
let connect ?create ?write () : t Lwt.t =
314
+
if create = Some true then
315
+
Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ;
314
316
Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location
315
317
316
318
let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables
+3
-2
pegasus/lib/env.ml
+3
-2
pegasus/lib/env.ml
···
21
21
match Sys.getenv_opt "DPOP_NONCE_SECRET" with
22
22
| Some sec ->
23
23
let secret =
24
-
Base64.(decode_exn ~alphabet:uri_safe_alphabet) sec |> Bytes.of_string
24
+
Base64.(decode_exn ~alphabet:uri_safe_alphabet ~pad:false) sec
25
+
|> Bytes.of_string
25
26
in
26
27
if Bytes.length secret = 32 then secret
27
-
else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64"
28
+
else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64uri"
28
29
| None ->
29
30
let secret = Mirage_crypto_rng_unix.getrandom 32 in
30
31
Dream.warning (fun log ->
+6
pegasus/lib/errors.ml
+6
pegasus/lib/errors.ml
···
4
4
5
5
exception AuthError of (string * string)
6
6
7
+
exception UseDpopNonceError
8
+
7
9
let is_xrpc_error = function
8
10
| InvalidRequestError _ | InternalServerError _ | AuthError _ ->
9
11
true
···
19
21
20
22
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
21
23
24
+
let use_dpop_nonce () = raise UseDpopNonceError
25
+
22
26
let exn_to_response exn =
23
27
let format_response error msg status =
24
28
Dream.json ~status @@ Yojson.Safe.to_string
···
31
35
format_response error message `Internal_Server_Error
32
36
| AuthError (error, message) ->
33
37
format_response error message `Unauthorized
38
+
| UseDpopNonceError ->
39
+
Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|}
34
40
| _ ->
35
41
format_response "InternalServerError" "Internal server error"
36
42
`Internal_Server_Error
+3
-4
pegasus/lib/id_resolver.ml
+3
-4
pegasus/lib/id_resolver.ml
···
1
1
open Cohttp_lwt
2
-
open Cohttp_lwt_unix
3
2
4
3
let did_regex =
5
4
Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|}
···
12
11
let uri =
13
12
Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did")
14
13
in
15
-
let%lwt {status; _}, body = Client.get uri in
14
+
let%lwt {status; _}, body = Util.http_get uri in
16
15
match status with
17
16
| `OK ->
18
17
let%lwt did = Body.to_string body in
···
164
163
~path:(Uri.pct_encode did) ()
165
164
in
166
165
let%lwt {status; _}, body =
167
-
Client.get uri
166
+
Util.http_get uri
168
167
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
169
168
in
170
169
match status with
···
186
185
~path:"/.well-known/did.json" ()
187
186
in
188
187
let%lwt {status; _}, body =
189
-
Client.get uri
188
+
Util.http_get uri
190
189
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
191
190
in
192
191
match status with
+3
-1
pegasus/lib/jwt.ml
+3
-1
pegasus/lib/jwt.ml
···
90
90
let now_s = int_of_float (Unix.gettimeofday ()) in
91
91
let access_exp = now_s + Defaults.access_token_exp in
92
92
let refresh_exp = now_s + Defaults.refresh_token_exp in
93
-
let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in
93
+
let jti =
94
+
Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string
95
+
in
94
96
let access_payload =
95
97
symmetric_jwt_to_yojson
96
98
{ scope= "com.atproto.access"
+8
-4
pegasus/lib/oauth/client.ml
+8
-4
pegasus/lib/oauth/client.ml
···
1
1
open Types
2
2
3
3
let fetch_client_metadata client_id : client_metadata Lwt.t =
4
-
let%lwt {status; _}, res =
5
-
Cohttp_lwt_unix.Client.get (Uri.of_string client_id)
6
-
in
4
+
let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in
7
5
if status <> `OK then
8
6
let%lwt () = Cohttp_lwt.Body.drain_body res in
9
7
failwith
···
12
10
else
13
11
let%lwt body = Cohttp_lwt.Body.to_string res in
14
12
let json = Yojson.Safe.from_string body in
15
-
let metadata = client_metadata_of_yojson json |> Result.get_ok in
13
+
let metadata =
14
+
match client_metadata_of_yojson json with
15
+
| Ok metadata ->
16
+
metadata
17
+
| Error err ->
18
+
failwith err
19
+
in
16
20
if metadata.client_id <> client_id then failwith "client_id mismatch"
17
21
else
18
22
let scopes = String.split_on_char ' ' metadata.scope in
+4
-6
pegasus/lib/oauth/queries.ml
+4
-6
pegasus/lib/oauth/queries.ml
···
60
60
UPDATE oauth_codes
61
61
SET authorized_by = %string{did},
62
62
authorized_at = %int{authorized_at}
63
-
WHERE code = %string{code} AND authorized_by = NULL
63
+
WHERE code = %string{code}
64
64
|sql}]
65
65
~did ~authorized_at ~code
66
66
···
102
102
record_out]
103
103
~refresh_token
104
104
105
-
let update_oauth_token conn ~old_refresh_token ~new_token_id ~new_refresh_token
106
-
~expires_at =
105
+
let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at =
107
106
Util.use_pool conn
108
107
@@ [%rapper
109
108
execute
110
109
{sql|
111
110
UPDATE oauth_tokens
112
-
SET token_id = %string{new_token_id},
113
-
refresh_token = %string{new_refresh_token},
111
+
SET refresh_token = %string{new_refresh_token},
114
112
expires_at = %int{expires_at}
115
113
WHERE refresh_token = %string{old_refresh_token}
116
114
|sql}]
117
-
~new_token_id ~new_refresh_token ~expires_at ~old_refresh_token
115
+
~new_refresh_token ~expires_at ~old_refresh_token
118
116
119
117
let delete_oauth_token_by_refresh conn refresh_token =
120
118
Util.use_pool conn
+18
-18
pegasus/lib/oauth/types.ml
+18
-18
pegasus/lib/oauth/types.ml
···
1
1
type par_request =
2
2
{ client_id: string
3
3
; response_type: string
4
-
; response_mode: string option
4
+
; response_mode: string option [@default None]
5
5
; redirect_uri: string
6
6
; scope: string
7
7
; state: string
8
8
; code_challenge: string
9
9
; code_challenge_method: string
10
-
; login_hint: string option
11
-
; dpop_jkt: string option
12
-
; client_assertion_type: string option
13
-
; client_assertion: string option }
10
+
; login_hint: string option [@default None]
11
+
; dpop_jkt: string option [@default None]
12
+
; client_assertion_type: string option [@default None]
13
+
; client_assertion: string option [@default None] }
14
14
[@@deriving yojson {strict= false}]
15
15
16
16
type token_request =
17
17
{ grant_type: string
18
-
; code: string option
19
-
; redirect_uri: string option
20
-
; code_verifier: string option
21
-
; refresh_token: string option
18
+
; code: string option [@default None]
19
+
; redirect_uri: string option [@default None]
20
+
; code_verifier: string option [@default None]
21
+
; refresh_token: string option [@default None]
22
22
; client_id: string
23
-
; client_assertion_type: string option
24
-
; client_assertion: string option }
23
+
; client_assertion_type: string option [@default None]
24
+
; client_assertion: string option [@default None] }
25
25
[@@deriving yojson {strict= false}]
26
26
27
27
type client_metadata =
28
28
{ client_id: string
29
-
; client_name: string option
29
+
; client_name: string option [@default None]
30
30
; client_uri: string
31
31
; redirect_uris: string list
32
32
; grant_types: string list
33
33
; response_types: string list
34
34
; scope: string
35
35
; token_endpoint_auth_method: string
36
-
; token_endpoint_auth_signing_alg: string option
36
+
; token_endpoint_auth_signing_alg: string option [@default None]
37
37
; application_type: string
38
38
; dpop_bound_access_tokens: bool
39
-
; jwks_uri: string option
40
-
; jwks: Yojson.Safe.t option }
39
+
; jwks_uri: string option [@default None]
40
+
; jwks: Yojson.Safe.t option [@default None] }
41
41
[@@deriving yojson {strict= false}]
42
42
43
43
type dpop_proof = {jti: string; jkt: string; htm: string; htu: string}
···
47
47
{ request_id: string
48
48
; client_id: string
49
49
; request_data: string
50
-
; dpop_jkt: string option
50
+
; dpop_jkt: string option [@default None]
51
51
; expires_at: int
52
52
; created_at: int }
53
53
[@@deriving yojson {strict= false}]
···
55
55
type oauth_code =
56
56
{ code: string
57
57
; request_id: string
58
-
; authorized_by: string option
59
-
; authorized_at: int option
58
+
; authorized_by: string option [@default None]
59
+
; authorized_at: int option [@default None]
60
60
; expires_at: int
61
61
; used: bool }
62
62
[@@deriving yojson {strict= false}]
+1
-1
pegasus/lib/plc.ml
+1
-1
pegasus/lib/plc.ml
···
302
302
did
303
303
in
304
304
let headers = Http.Header.init_with "Accept" "application/json" in
305
-
let%lwt res, body = Client.get ~headers uri in
305
+
let%lwt res, body = Util.http_get ~headers uri in
306
306
match res.status with
307
307
| `OK ->
308
308
let%lwt body = Body.to_string body in
+30
-23
pegasus/lib/templates/components/input.mlx
+30
-23
pegasus/lib/templates/components/input.mlx
···
3
3
(* putting this inline messes with ocamlformat-mlx *)
4
4
let req_marker = " *"
5
5
6
-
let make ~id ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false) ?value
7
-
?placeholder ?(required = false) ?(disabled = false) ?trailing () =
6
+
let make ?id ~name ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false)
7
+
?value ?placeholder ?(required = false) ?(disabled = false) ?trailing () =
8
+
let id = Option.value id ~default:name in
8
9
let placeholder = if label <> None && sr_only then label else placeholder in
10
+
let input =
11
+
<input
12
+
id
13
+
type_
14
+
name
15
+
?placeholder
16
+
required
17
+
disabled
18
+
?value
19
+
class_="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \
20
+
placeholder:font-medium focus-visible:outline-none"
21
+
/>
22
+
in
9
23
<div>
10
24
( match label with
11
25
| Some label ->
···
25
39
</div>
26
40
| None ->
27
41
null )
28
-
<div
29
-
class_=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \
30
-
outline-mana-40 disabled:outline-mana-40/20 \
31
-
disabled:bg-mana-40/20 focus-within:outline-2 \
32
-
focus-within:outline-mana-100" ^ class_ )>
33
-
<input
34
-
id
35
-
type_
36
-
?placeholder
37
-
required
38
-
disabled
39
-
?value
40
-
class_="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \
41
-
placeholder:font-medium focus:outline-none"
42
-
/>
43
-
( match trailing with
44
-
| Some trailing ->
45
-
<div class_="shrink-0 text-mist-100 select-none">trailing</div>
46
-
| None ->
47
-
null )
48
-
</div>
42
+
( if type_ = "hidden" then input
43
+
else
44
+
<div
45
+
class_=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \
46
+
outline-mana-40 disabled:outline-mana-40/20 \
47
+
disabled:bg-mana-40/20 focus-within:outline-2 \
48
+
focus-within:outline-mana-100" ^ class_ )>
49
+
input
50
+
( match trailing with
51
+
| Some trailing ->
52
+
<div class_="shrink-0 text-mist-100 select-none">trailing</div>
53
+
| None ->
54
+
null )
55
+
</div> )
49
56
</div>
+21
-7
pegasus/lib/templates/login.mlx
+21
-7
pegasus/lib/templates/login.mlx
···
1
1
open JSX
2
2
open Components
3
3
4
-
let make ~redirect_url ?error () =
5
-
let _r = redirect_url in
6
-
let _e = error in
4
+
let make ~redirect_url ?error ~csrf_token () =
7
5
<Layout title="Login">
8
6
<main class_="w-full h-auto max-w-xs px-4 sm:px-0">
9
7
<h1 class_="text-2xl font-serif text-mana-200 mb-2">"sign in"</h1>
···
11
9
"Enter your handle, email address, or DID, and your password."
12
10
</span>
13
11
<form method_="post" class_="w-full flex flex-col mt-4 mb-2 gap-y-2">
14
-
<Input sr_only=true id="identifier" type_="text" label="identifier" />
15
-
<Input sr_only=true id="password" type_="password" label="password" />
16
-
(match error with | Some error -> <span class_="inline-flex items-center text-phoenix-100 text-sm">(list [ <Icons.Circle_alert class_="w-4 h-4 mr-2" />; (string error)]) </span> | None -> null)
12
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
13
+
<Input sr_only=true name="identifier" type_="text" label="identifier" />
14
+
<Input sr_only=true name="password" type_="password" label="password" />
15
+
<input type_="hidden" name="redirect_url" value=redirect_url />
16
+
( match error with
17
+
| Some error ->
18
+
<span class_="inline-flex items-center text-phoenix-100 text-sm">
19
+
<Icons.Circle_alert class_="w-4 h-4 mr-2" /> (string error)
20
+
</span>
21
+
| None ->
22
+
null )
17
23
<Button type_="submit" class_="mt-2">"sign in"</Button>
18
24
</form>
19
-
<span class_="text-sm text-mist-100">"Or "<a href="/account/signup" class_="text-mana-100 underline decoration-mana-100 hover:text-mana-200">"create an account"</a>"."</span>
25
+
<span class_="text-sm text-mist-100">
26
+
"Or "
27
+
<a
28
+
href="/account/signup"
29
+
class_="text-mana-100 underline hover:text-mana-200">
30
+
"create an account"
31
+
</a>
32
+
"."
33
+
</span>
20
34
</main>
21
35
</Layout>
+45
pegasus/lib/util.ml
+45
pegasus/lib/util.ml
···
319
319
valid )
320
320
did_keys
321
321
<> None
322
+
323
+
let rec http_get ?(max_redirects = 5) ?headers uri =
324
+
let%lwt ans = Cohttp_lwt_unix.Client.get ?headers uri in
325
+
follow_redirect ~max_redirects uri ans
326
+
327
+
and follow_redirect ~max_redirects request_uri (response, body) =
328
+
let status = Http.Response.status response in
329
+
(* the unconsumed body would otherwise leak memory *)
330
+
let%lwt () =
331
+
if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
332
+
in
333
+
match status with
334
+
| `OK ->
335
+
Lwt.return (response, body)
336
+
| `Permanent_redirect | `Moved_permanently ->
337
+
handle_redirect ~permanent:true ~max_redirects request_uri response
338
+
| `Found | `Temporary_redirect ->
339
+
handle_redirect ~permanent:false ~max_redirects request_uri response
340
+
| `Not_found | `Gone ->
341
+
failwith "not found"
342
+
| status ->
343
+
Printf.ksprintf failwith "unhandled status: %s"
344
+
(Cohttp.Code.string_of_status status)
345
+
346
+
and handle_redirect ~permanent ~max_redirects request_uri response =
347
+
if max_redirects <= 0 then failwith "too many redirects"
348
+
else
349
+
let headers = Http.Response.headers response in
350
+
let location = Http.Header.get headers "location" in
351
+
match location with
352
+
| None ->
353
+
failwith "redirection without Location header"
354
+
| Some url ->
355
+
let uri = Uri.of_string url in
356
+
let%lwt () =
357
+
if permanent then
358
+
Logs_lwt.warn (fun m ->
359
+
m "Permanent redirection from %s to %s"
360
+
(Uri.to_string request_uri)
361
+
url )
362
+
else Lwt.return_unit
363
+
in
364
+
http_get uri ~max_redirects:(max_redirects - 1)
365
+
366
+
let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v]))
+28
-20
pegasus/lib/xrpc.ml
+28
-20
pegasus/lib/xrpc.ml
···
10
10
let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =
11
11
let open Errors in
12
12
let auth = Auth.Verifiers.of_t auth in
13
-
match%lwt auth init with
14
-
| Ok creds -> (
15
-
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
16
-
with e ->
17
-
( match is_xrpc_error e with
18
-
| true ->
19
-
()
20
-
| false ->
21
-
log_exn ~req:init.req e ) ;
22
-
exn_to_response e )
23
-
| Error e ->
24
-
exn_to_response e
13
+
try%lwt
14
+
match%lwt auth init with
15
+
| Ok creds -> (
16
+
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
17
+
with e ->
18
+
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
19
+
exn_to_response e )
20
+
| Error e ->
21
+
exn_to_response e
22
+
with e ->
23
+
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
24
+
exn_to_response e
25
25
26
26
let parse_query (req : Dream.request)
27
27
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =
···
29
29
let queries = Dream.all_queries req in
30
30
let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in
31
31
query_json |> of_yojson |> Result.get_ok
32
-
with _ -> Errors.invalid_request "Invalid query string"
32
+
with _ -> Errors.invalid_request "invalid query string"
33
33
34
34
let parse_body (req : Dream.request)
35
35
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
36
36
try%lwt
37
37
let%lwt body = Dream.body req in
38
38
body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return
39
-
with e ->
40
-
Errors.log_exn e ;
41
-
Errors.invalid_request "Invalid request body"
39
+
with _ -> Errors.invalid_request "invalid request body"
42
40
43
41
let service_proxy (ctx : context) (proxy_header : string) =
44
42
let did = Auth.get_authed_did_exn ctx.auth in
···
87
85
let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in
88
86
match Dream.method_ ctx.req with
89
87
| `GET -> (
90
-
let%lwt res, body = Client.get uri ~headers in
88
+
let%lwt res, body = Util.http_get uri ~headers in
91
89
match res.status with
92
90
| `OK ->
93
91
let%lwt body = Body.to_string body in
···
127
125
128
126
let dpop_middleware inner_handler req =
129
127
let%lwt res = inner_handler req in
130
-
match Auth.Verifiers.parse_dpop req with
131
-
| Ok _ ->
128
+
match Dream.header req "DPoP" with
129
+
| Some _ ->
132
130
Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;
133
131
Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ;
134
132
Lwt.return res
135
-
| Error _ ->
133
+
| None ->
136
134
Lwt.return res
135
+
136
+
let cors_middleware inner_handler req =
137
+
let%lwt res = inner_handler req in
138
+
Dream.add_header res "Access-Control-Allow-Origin" "*" ;
139
+
Dream.add_header res "Access-Control-Allow-Methods"
140
+
"GET, POST, PUT, DELETE, OPTIONS" ;
141
+
Dream.add_header res "Access-Control-Allow-Headers"
142
+
"Content-Type, Authorization, DPoP" ;
143
+
Dream.add_header res "Access-Control-Max-Age" "86400" ;
144
+
Lwt.return res
137
145
138
146
let resolve_repo_did ctx repo =
139
147
if String.starts_with ~prefix:"did:" repo then Lwt.return repo
+2
public/main.css
+2
public/main.css
···
30
30
--color-*: initial;
31
31
--color-white: #fff;
32
32
--color-feather-100: #c8cfd2;
33
+
--color-phoenix-40: #e499a6;
33
34
--color-phoenix-100: #db4c64;
34
35
--color-mana-40: #9b9eaa;
35
36
--color-mana-100: #6558a1;
···
43
44
--shadow-whisper: inset 0 0 1em #97baff8c;
44
45
--shadow-shimmer: inset 0 0 1em #79a7ed99;
45
46
--shadow-glow: inset 0 0 2em #2d37ba73;
47
+
--shadow-bleed: inset 0 0 2em #db4c6466;
46
48
}