8bit.lol
forked from
futur.blue/pegasus
objective categorical abstract machine language personal data server
Implement OAuth
π΄ππ πΈπΆπ πππ use pdsls
futur.blue
+25
-2
bin/main.ml
+25
-2
bin/main.ml
···
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"
···
15
; ( get
16
, "/xrpc/com.atproto.identity.resolveHandle"
17
, Api.Identity.ResolveHandle.handler )
18
-
; (* account *)
19
( post
20
, "/xrpc/com.atproto.server.createInviteCode"
21
, Api.Server.CreateInviteCode.handler )
···
65
, "/xrpc/com.atproto.actor.putPreferences"
66
, Api.Actor.PutPreferences.handler ) ]
67
68
let main =
69
let%lwt db = Data_store.connect ~create:true () in
70
let%lwt () = Data_store.init db in
71
Dream.serve ~interface:"0.0.0.0" ~port:8008
72
@@ Dream.logger
73
@@ Xrpc.service_proxy_middleware db
74
-
@@ Dream.router
75
@@ List.map
76
(fun (fn, path, handler) ->
77
fn path (fun req -> handler ({req; db} : Xrpc.init)) )
78
handlers
79
80
let () = Lwt_main.run main
···
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
+
; ( get
11
+
, "/.well-known/oauth-protected-resource"
12
+
, Api.Well_known.oauth_protected_resource )
13
+
; ( get
14
+
, "/.well-known/oauth-authorization-server"
15
+
, Api.Well_known.oauth_authorization_server )
16
+
; (* oauth *)
17
+
(options, "/oauth/par", Api.Oauth_.Par.options_handler)
18
+
; (post, "/oauth/par", Api.Oauth_.Par.post_handler)
19
+
; (get, "/oauth/authorize", Api.Oauth_.Authorize.get_handler)
20
+
; (post, "/oauth/authorize", Api.Oauth_.Authorize.post_handler)
21
+
; (options, "/oauth/token", Api.Oauth_.Token.options_handler)
22
+
; (post, "/oauth/token", Api.Oauth_.Token.post_handler)
23
+
; (* account *)
24
+
(get, "/account/login", Api.Account_.Login.get_handler)
25
+
; (post, "/account/login", Api.Account_.Login.post_handler)
26
+
; (get, "/account/logout", Api.Account_.Logout.handler)
27
; (* unauthed *)
28
( get
29
, "/xrpc/com.atproto.server.describeServer"
···
32
; ( get
33
, "/xrpc/com.atproto.identity.resolveHandle"
34
, Api.Identity.ResolveHandle.handler )
35
+
; (* account management *)
36
( post
37
, "/xrpc/com.atproto.server.createInviteCode"
38
, Api.Server.CreateInviteCode.handler )
···
82
, "/xrpc/com.atproto.actor.putPreferences"
83
, Api.Actor.PutPreferences.handler ) ]
84
85
+
let static_routes =
86
+
[Dream.get "/public/**" (Dream.static "_build/default/public")]
87
+
88
let main =
89
let%lwt db = Data_store.connect ~create:true () in
90
let%lwt () = Data_store.init db in
91
Dream.serve ~interface:"0.0.0.0" ~port:8008
92
@@ Dream.logger
93
+
@@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey)
94
+
@@ Dream.cookie_sessions
95
@@ Xrpc.service_proxy_middleware db
96
+
@@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router
97
@@ List.map
98
(fun (fn, path, handler) ->
99
fn path (fun req -> handler ({req; db} : Xrpc.init)) )
100
handlers
101
+
@ static_routes
102
103
let () = Lwt_main.run main
+21
dune
+21
dune
···
···
1
+
(subdir
2
+
public/
3
+
(rule
4
+
(target index.css)
5
+
(deps
6
+
%{workspace_root}/tools/tailwindcss/tailwindcss
7
+
(:input %{workspace_root}/public/main.css)
8
+
(source_tree %{workspace_root}/public)
9
+
(source_tree %{workspace_root}/pegasus/lib/templates))
10
+
(action
11
+
(chdir
12
+
%{workspace_root}
13
+
(run
14
+
%{workspace_root}/tools/tailwindcss/tailwindcss
15
+
-m
16
+
-i
17
+
%{input}
18
+
-o
19
+
%{target})))))
20
+
21
+
(copy_files public/*)
+18
-1
dune-project
+18
-1
dune-project
···
30
(url "git+https://github.com/roddyyaga/ppx_rapper.git")
31
(package (name ppx_rapper_lwt)))
32
33
(package
34
(name pegasus)
35
(synopsis "An atproto Personal Data Server implementation")
···
46
(cohttp-lwt-unix (>= 6.1.1))
47
(dns-client (>= 10.2.0))
48
dream
49
(re (>= 1.13.2))
50
(safepass (>= 3.1))
51
(timedesc (>= 3.1.0))
52
(uuidm (>= 0.9.10))
53
(yojson (>= 3.0.0))
54
(lwt_ppx (>= 5.9.1))
55
(ppx_deriving_yojson (>= 3.9.1))
56
ppx_rapper
57
ppx_rapper_lwt
58
-
(alcotest :with-test)))
59
60
(package
61
(name mist)
···
97
(hacl-star (>= 0.7.2))
98
(mirage-crypto-ec (>= 2.0.1))
99
(multibase (>= 0.1.0))))
···
30
(url "git+https://github.com/roddyyaga/ppx_rapper.git")
31
(package (name ppx_rapper_lwt)))
32
33
+
34
(package
35
(name pegasus)
36
(synopsis "An atproto Personal Data Server implementation")
···
47
(cohttp-lwt-unix (>= 6.1.1))
48
(dns-client (>= 10.2.0))
49
dream
50
+
html_of_jsx
51
+
mlx
52
(re (>= 1.13.2))
53
(safepass (>= 3.1))
54
(timedesc (>= 3.1.0))
55
+
(uri (>= 4.4.0))
56
(uuidm (>= 0.9.10))
57
(yojson (>= 3.0.0))
58
(lwt_ppx (>= 5.9.1))
59
(ppx_deriving_yojson (>= 3.9.1))
60
ppx_rapper
61
ppx_rapper_lwt
62
+
(alcotest :with-test)
63
+
(ocamlformat-mlx :with-dev-setup)
64
+
(ocamlmerlin-mlx :with-dev-setup)))
65
66
(package
67
(name mist)
···
103
(hacl-star (>= 0.7.2))
104
(mirage-crypto-ec (>= 2.0.1))
105
(multibase (>= 0.1.0))))
106
+
107
+
(package
108
+
(name tailwindcss) (allow_empty))
109
+
110
+
(dialect
111
+
(name mlx)
112
+
(implementation
113
+
(extension mlx)
114
+
(merlin_reader mlx)
115
+
(preprocess
116
+
(run mlx-pp %{input-file}))))
+2
-2
ipld/lib/dag_cbor.ml
+2
-2
ipld/lib/dag_cbor.ml
+4
-4
ipld/test/test_dag_cbor.ml
+4
-4
ipld/test/test_dag_cbor.ml
···
3
let rec stringify_map m =
4
String_map.bindings m
5
|> List.map (fun (k, v) ->
6
-
Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) )
7
|> String.concat ", " |> Format.sprintf "{%s}"
8
9
and stringify_ipld_value (value : Dag_cbor.value) =
···
109
Hashtbl.add cases (to_base_16 (Dag_cbor.encode `Null)) (Bytes.of_string "f6") ;
110
cases
111
|> Hashtbl.iter (fun key value ->
112
-
Alcotest.(check bytes)
113
-
("encoded bytes for " ^ key)
114
-
value (Bytes.of_string key) )
115
116
let test_round_trip () =
117
let test_cid =
···
3
let rec stringify_map m =
4
String_map.bindings m
5
|> List.map (fun (k, v) ->
6
+
Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) )
7
|> String.concat ", " |> Format.sprintf "{%s}"
8
9
and stringify_ipld_value (value : Dag_cbor.value) =
···
109
Hashtbl.add cases (to_base_16 (Dag_cbor.encode `Null)) (Bytes.of_string "f6") ;
110
cases
111
|> Hashtbl.iter (fun key value ->
112
+
Alcotest.(check bytes)
113
+
("encoded bytes for " ^ key)
114
+
value (Bytes.of_string key) )
115
116
let test_round_trip () =
117
let test_cid =
+4
kleidos/kleidos.ml
+4
kleidos/kleidos.ml
+34
-33
mist/lib/mst.ml
+34
-33
mist/lib/mst.ml
···
239
| None, [] ->
240
Lwt.return 0
241
| Some left, [] -> (
242
-
match%lwt retrieve_node_raw t left with
243
-
| Some node ->
244
-
let%lwt height = get_node_height t node in
245
-
Lwt.return (height + 1)
246
-
| None ->
247
-
failwith ("couldn't find node " ^ Cid.to_string left) )
248
| _, leaf :: _ -> (
249
match leaf.p with
250
| 0 ->
···
497
let%lwt blocks =
498
match Util.at_index index seq with
499
| Some (Leaf (k, v, _)) when k = key -> (
500
-
(* include the found leaf block to prove existence *)
501
-
match%lwt Store.get_bytes t.blockstore v with
502
-
| Some leaf_bytes ->
503
-
Lwt.return (Block_map.set v leaf_bytes Block_map.empty)
504
-
| None ->
505
-
Lwt.return Block_map.empty )
506
| _ -> (
507
let prev =
508
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
···
529
let%lwt bm =
530
match left_leaf with
531
| Some cid_left -> (
532
-
match%lwt Store.get_bytes t.blockstore cid_left with
533
-
| Some b ->
534
-
Lwt.return
535
-
(Block_map.set cid_left b Block_map.empty)
536
-
| None ->
537
-
Lwt.return Block_map.empty )
538
| None ->
539
Lwt.return Block_map.empty
540
in
541
let%lwt bm =
542
match right_leaf with
543
| Some cid_right -> (
544
-
match%lwt Store.get_bytes t.blockstore cid_right with
545
-
| Some b ->
546
-
Lwt.return (Block_map.set cid_right b bm)
547
-
| None ->
548
-
Lwt.return bm )
549
| None ->
550
Lwt.return bm
551
in
···
571
| Some (Tree c) ->
572
proof_for_left_sibling t c key
573
| Some (Leaf (_, v_left, _)) -> (
574
-
match%lwt Store.get_bytes t.blockstore v_left with
575
-
| Some b ->
576
-
Lwt.return (Block_map.set v_left b Block_map.empty)
577
-
| None ->
578
-
Lwt.return Block_map.empty )
579
| _ ->
580
Lwt.return Block_map.empty
581
in
···
612
| Some (Tree c) ->
613
proof_for_right_sibling t c key
614
| Some (Leaf (_, v_right, _)) -> (
615
-
match%lwt Store.get_bytes t.blockstore v_right with
616
-
| Some b ->
617
-
Lwt.return (Block_map.set v_right b Block_map.empty)
618
-
| None ->
619
-
Lwt.return Block_map.empty )
620
| _ ->
621
Lwt.return Block_map.empty )
622
| None ->
···
239
| None, [] ->
240
Lwt.return 0
241
| Some left, [] -> (
242
+
match%lwt retrieve_node_raw t left with
243
+
| Some node ->
244
+
let%lwt height = get_node_height t node in
245
+
Lwt.return (height + 1)
246
+
| None ->
247
+
failwith ("couldn't find node " ^ Cid.to_string left) )
248
| _, leaf :: _ -> (
249
match leaf.p with
250
| 0 ->
···
497
let%lwt blocks =
498
match Util.at_index index seq with
499
| Some (Leaf (k, v, _)) when k = key -> (
500
+
(* include the found leaf block to prove existence *)
501
+
match%lwt
502
+
Store.get_bytes t.blockstore v
503
+
with
504
+
| Some leaf_bytes ->
505
+
Lwt.return (Block_map.set v leaf_bytes Block_map.empty)
506
+
| None ->
507
+
Lwt.return Block_map.empty )
508
| _ -> (
509
let prev =
510
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
···
531
let%lwt bm =
532
match left_leaf with
533
| Some cid_left -> (
534
+
match%lwt Store.get_bytes t.blockstore cid_left with
535
+
| Some b ->
536
+
Lwt.return (Block_map.set cid_left b Block_map.empty)
537
+
| None ->
538
+
Lwt.return Block_map.empty )
539
| None ->
540
Lwt.return Block_map.empty
541
in
542
let%lwt bm =
543
match right_leaf with
544
| Some cid_right -> (
545
+
match%lwt Store.get_bytes t.blockstore cid_right with
546
+
| Some b ->
547
+
Lwt.return (Block_map.set cid_right b bm)
548
+
| None ->
549
+
Lwt.return bm )
550
| None ->
551
Lwt.return bm
552
in
···
572
| Some (Tree c) ->
573
proof_for_left_sibling t c key
574
| Some (Leaf (_, v_left, _)) -> (
575
+
match%lwt Store.get_bytes t.blockstore v_left with
576
+
| Some b ->
577
+
Lwt.return (Block_map.set v_left b Block_map.empty)
578
+
| None ->
579
+
Lwt.return Block_map.empty )
580
| _ ->
581
Lwt.return Block_map.empty
582
in
···
613
| Some (Tree c) ->
614
proof_for_right_sibling t c key
615
| Some (Leaf (_, v_right, _)) -> (
616
+
match%lwt Store.get_bytes t.blockstore v_right with
617
+
| Some b ->
618
+
Lwt.return (Block_map.set v_right b Block_map.empty)
619
+
| None ->
620
+
Lwt.return Block_map.empty )
621
| _ ->
622
Lwt.return Block_map.empty )
623
| None ->
+7
-7
mist/test/test_util.ml
+7
-7
mist/test/test_util.ml
···
8
Hashtbl.add cases "app.bsky.feed.post/9adeb165882c" 8 ;
9
cases
10
|> Hashtbl.iter (fun key value ->
11
-
Alcotest.(check int)
12
-
("leading zeros on hash " ^ key)
13
-
value
14
-
(leading_zeros_on_hash key) )
15
16
let test_shared_prefix_length () =
17
let cases = Hashtbl.create 5 in
···
22
Hashtbl.add cases ("2653ae71", "0653ae71") 0 ;
23
cases
24
|> Hashtbl.iter (fun (a, b) value ->
25
-
Alcotest.(check int)
26
-
("prefix length between " ^ a ^ " and " ^ b)
27
-
value (shared_prefix_length a b) )
28
29
let () =
30
Alcotest.run "util"
···
8
Hashtbl.add cases "app.bsky.feed.post/9adeb165882c" 8 ;
9
cases
10
|> Hashtbl.iter (fun key value ->
11
+
Alcotest.(check int)
12
+
("leading zeros on hash " ^ key)
13
+
value
14
+
(leading_zeros_on_hash key) )
15
16
let test_shared_prefix_length () =
17
let cases = Hashtbl.create 5 in
···
22
Hashtbl.add cases ("2653ae71", "0653ae71") 0 ;
23
cases
24
|> Hashtbl.iter (fun (a, b) value ->
25
+
Alcotest.(check int)
26
+
("prefix length between " ^ a ^ " and " ^ b)
27
+
value (shared_prefix_length a b) )
28
29
let () =
30
Alcotest.run "util"
+5
pegasus.opam
+5
pegasus.opam
···
18
"cohttp-lwt-unix" {>= "6.1.1"}
19
"dns-client" {>= "10.2.0"}
20
"dream"
21
"re" {>= "1.13.2"}
22
"safepass" {>= "3.1"}
23
"timedesc" {>= "3.1.0"}
24
"uuidm" {>= "0.9.10"}
25
"yojson" {>= "3.0.0"}
26
"lwt_ppx" {>= "5.9.1"}
···
28
"ppx_rapper"
29
"ppx_rapper_lwt"
30
"alcotest" {with-test}
31
"odoc" {with-doc}
32
]
33
build: [
···
18
"cohttp-lwt-unix" {>= "6.1.1"}
19
"dns-client" {>= "10.2.0"}
20
"dream"
21
+
"html_of_jsx"
22
+
"mlx"
23
"re" {>= "1.13.2"}
24
"safepass" {>= "3.1"}
25
"timedesc" {>= "3.1.0"}
26
+
"uri" {>= "4.4.0"}
27
"uuidm" {>= "0.9.10"}
28
"yojson" {>= "3.0.0"}
29
"lwt_ppx" {>= "5.9.1"}
···
31
"ppx_rapper"
32
"ppx_rapper_lwt"
33
"alcotest" {with-test}
34
+
"ocamlformat-mlx" {with-dev-setup}
35
+
"ocamlmerlin-mlx" {with-dev-setup}
36
"odoc" {with-doc}
37
]
38
build: [
+49
pegasus/lib/api/account_/login.ml
+49
pegasus/lib/api/account_/login.ml
···
···
1
+
let get_handler =
2
+
Xrpc.handler (fun ctx ->
3
+
let redirect_url =
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 ())
12
+
in
13
+
Dream.html html )
14
+
15
+
let post_handler =
16
+
Xrpc.handler (fun ctx ->
17
+
let csrf_token = Dream.csrf_token ctx.req in
18
+
match%lwt Dream.form ctx.req with
19
+
| `Ok fields -> (
20
+
let identifier = List.assoc "identifier" fields in
21
+
let password = List.assoc "password" fields in
22
+
let redirect_url =
23
+
List.assoc_opt "redirect_url" fields
24
+
|> Option.value ~default:"/account"
25
+
in
26
+
let%lwt actor =
27
+
Data_store.try_login ~id:identifier ~password ctx.db
28
+
in
29
+
match actor with
30
+
| None ->
31
+
let html =
32
+
JSX.render
33
+
(Templates.Login.make ~redirect_url
34
+
~error:"Invalid username or password. Please try again."
35
+
~csrf_token () )
36
+
in
37
+
Dream.html ~status:`Unauthorized html
38
+
| Some {did; _} ->
39
+
let%lwt () = Dream.invalidate_session ctx.req in
40
+
let%lwt () = Dream.set_session_field ctx.req "did" did in
41
+
Dream.redirect ctx.req redirect_url )
42
+
| _ ->
43
+
let html =
44
+
JSX.render
45
+
(Templates.Login.make ~redirect_url:"/account"
46
+
~error:"Invalid credentials provided. Please try again."
47
+
~csrf_token () )
48
+
in
49
+
Dream.html ~status:`Unauthorized html )
+4
pegasus/lib/api/account_/logout.ml
+4
pegasus/lib/api/account_/logout.ml
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+6
-6
pegasus/lib/api/identity/resolveHandle.ml
+6
-6
pegasus/lib/api/identity/resolveHandle.ml
···
14
Dream.json @@ Yojson.Safe.to_string
15
@@ response_to_yojson {did= actor.did}
16
| None -> (
17
-
match%lwt Id_resolver.Handle.resolve handle with
18
-
| Ok did ->
19
-
Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did}
20
-
| Error e ->
21
-
Errors.log_exn (Failure e) ;
22
-
Errors.internal_error ~msg:"could not resolve handle" () ) )
···
14
Dream.json @@ Yojson.Safe.to_string
15
@@ response_to_yojson {did= actor.did}
16
| None -> (
17
+
match%lwt Id_resolver.Handle.resolve handle with
18
+
| Ok did ->
19
+
Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did}
20
+
| Error e ->
21
+
Errors.log_exn (Failure e) ;
22
+
Errors.internal_error ~msg:"could not resolve handle" () ) )
+55
-58
pegasus/lib/api/identity/updateHandle.ml
+55
-58
pegasus/lib/api/identity/updateHandle.ml
···
1
type request = {handle: string} [@@deriving yojson]
2
3
let handler =
4
-
Xrpc.handler ~auth:Authorization (fun {req; auth; db} ->
5
let did = Auth.get_authed_did_exn auth in
6
let%lwt body = Dream.body req in
7
let handle =
···
15
| Error e ->
16
raise e
17
| Ok () -> (
18
-
match%lwt Data_store.get_actor_by_identifier handle db with
19
-
| Some _ ->
20
-
Errors.invalid_request ~name:"InvalidHandle"
21
-
"handle already in use"
22
-
| None ->
23
-
let%lwt () = Data_store.update_actor_handle ~did ~handle db in
24
-
let%lwt _ =
25
-
if String.starts_with ~prefix:"did:plc:" did then
26
-
match%lwt Plc.get_audit_log did with
27
-
| Error e ->
28
-
Dream.error (fun log -> log ~request:req "%s" e) ;
29
-
Errors.internal_error ~msg:"failed to fetch did doc" ()
30
-
| Ok log -> (
31
-
let latest = List.rev log |> List.hd in
32
-
let aka =
33
-
match
34
-
List.mem ("at://" ^ handle)
35
-
latest.operation.also_known_as
36
-
with
37
-
| true ->
38
-
latest.operation.also_known_as
39
-
| false ->
40
-
("at://" ^ handle) :: latest.operation.also_known_as
41
-
in
42
-
let%lwt signing_key =
43
-
match%lwt Data_store.get_actor_by_identifier did db with
44
-
| Some {signing_key; _} ->
45
-
Lwt.return @@ Kleidos.parse_multikey_str signing_key
46
-
| _ ->
47
-
Errors.internal_error ()
48
-
in
49
-
let signed =
50
-
Plc.sign_operation signing_key
51
-
(Operation
52
-
{ type'= "plc_operation"
53
-
; prev= Some latest.cid
54
-
; also_known_as= aka
55
-
; rotation_keys= latest.operation.rotation_keys
56
-
; verification_methods=
57
-
latest.operation.verification_methods
58
-
; services= latest.operation.services } )
59
-
in
60
-
match%lwt Plc.submit_operation did signed with
61
-
| Ok _ ->
62
-
Lwt.return_unit
63
-
| Error (status, msg) ->
64
-
Dream.error (fun log ->
65
-
log ~request:req "%d %s" status msg ) ;
66
-
Errors.internal_error
67
-
~msg:"failed to submit plc operation" () )
68
-
else Lwt.return_unit
69
-
in
70
-
let () =
71
-
Ttl_cache.String_cache.remove Id_resolver.Did.cache did
72
-
in
73
-
let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in
74
-
Dream.empty `OK ) )
···
1
type request = {handle: string} [@@deriving yojson]
2
3
let handler =
4
+
Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->
5
let did = Auth.get_authed_did_exn auth in
6
let%lwt body = Dream.body req in
7
let handle =
···
15
| Error e ->
16
raise e
17
| Ok () -> (
18
+
match%lwt Data_store.get_actor_by_identifier handle db with
19
+
| Some _ ->
20
+
Errors.invalid_request ~name:"InvalidHandle" "handle already in use"
21
+
| None ->
22
+
let%lwt () = Data_store.update_actor_handle ~did ~handle db in
23
+
let%lwt _ =
24
+
if String.starts_with ~prefix:"did:plc:" did then
25
+
match%lwt Plc.get_audit_log did with
26
+
| Error e ->
27
+
Dream.error (fun log -> log ~request:req "%s" e) ;
28
+
Errors.internal_error ~msg:"failed to fetch did doc" ()
29
+
| Ok log -> (
30
+
let latest = List.rev log |> List.hd in
31
+
let aka =
32
+
match
33
+
List.mem ("at://" ^ handle)
34
+
latest.operation.also_known_as
35
+
with
36
+
| true ->
37
+
latest.operation.also_known_as
38
+
| false ->
39
+
("at://" ^ handle) :: latest.operation.also_known_as
40
+
in
41
+
let%lwt signing_key =
42
+
match%lwt Data_store.get_actor_by_identifier did db with
43
+
| Some {signing_key; _} ->
44
+
Lwt.return @@ Kleidos.parse_multikey_str signing_key
45
+
| _ ->
46
+
Errors.internal_error ()
47
+
in
48
+
let signed =
49
+
Plc.sign_operation signing_key
50
+
(Operation
51
+
{ type'= "plc_operation"
52
+
; prev= Some latest.cid
53
+
; also_known_as= aka
54
+
; rotation_keys= latest.operation.rotation_keys
55
+
; verification_methods=
56
+
latest.operation.verification_methods
57
+
; services= latest.operation.services } )
58
+
in
59
+
match%lwt Plc.submit_operation did signed with
60
+
| Ok _ ->
61
+
Lwt.return_unit
62
+
| Error (status, msg) ->
63
+
Dream.error (fun log ->
64
+
log ~request:req "%d %s" status msg ) ;
65
+
Errors.internal_error
66
+
~msg:"failed to submit plc operation" () )
67
+
else Lwt.return_unit
68
+
in
69
+
let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in
70
+
let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in
71
+
Dream.empty `OK ) )
+41
pegasus/lib/api/oauth_/par.ml
+41
pegasus/lib/api/oauth_/par.ml
···
···
1
+
open Oauth
2
+
open Oauth.Types
3
+
4
+
let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)
5
+
6
+
let post_handler =
7
+
Xrpc.handler ~auth:DPoP (fun ctx ->
8
+
let proof = Auth.get_dpop_proof_exn ctx.auth in
9
+
let%lwt req = Xrpc.parse_body ctx.req par_request_of_yojson in
10
+
let%lwt client =
11
+
try%lwt Client.fetch_client_metadata req.client_id
12
+
with e ->
13
+
Errors.log_exn ~req:ctx.req e ;
14
+
Errors.invalid_request "failed to fetch client metadata"
15
+
in
16
+
if req.response_type <> "code" then
17
+
Errors.invalid_request "only response_type=code supported"
18
+
else if req.code_challenge_method <> "S256" then
19
+
Errors.invalid_request "only code_challenge_method=S256 supported"
20
+
else if not (List.mem req.redirect_uri client.redirect_uris) then
21
+
Errors.invalid_request "invalid redirect_uri"
22
+
else
23
+
let request_id =
24
+
"req-"
25
+
^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ())
26
+
in
27
+
let request_uri = Constants.request_uri_prefix ^ request_id in
28
+
let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in
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 () }
36
+
in
37
+
let%lwt () = Queries.insert_par_request ctx.db request in
38
+
Dream.json ~status:`Created
39
+
@@ Yojson.Safe.to_string
40
+
@@ `Assoc
41
+
[("request_uri", `String request_uri); ("expires_in", `Int 300)] )
+179
pegasus/lib/api/oauth_/token.ml
+179
pegasus/lib/api/oauth_/token.ml
···
···
1
+
open Oauth
2
+
3
+
let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)
4
+
5
+
let post_handler =
6
+
Xrpc.handler ~auth:DPoP (fun ctx ->
7
+
let%lwt req = Xrpc.parse_body ctx.req Types.token_request_of_yojson in
8
+
let proof = Auth.get_dpop_proof_exn ctx.auth in
9
+
match req.grant_type with
10
+
| "authorization_code" -> (
11
+
match req.code with
12
+
| None ->
13
+
Errors.invalid_request "code required"
14
+
| Some code -> (
15
+
let%lwt code_record = Queries.consume_auth_code ctx.db code in
16
+
match code_record with
17
+
| None ->
18
+
Errors.invalid_request "invalid code"
19
+
| Some code_rec -> (
20
+
if Util.now_ms () > code_rec.expires_at then
21
+
Errors.invalid_request "code expired"
22
+
else
23
+
match code_rec.authorized_by with
24
+
| None ->
25
+
Errors.invalid_request "code not authorized"
26
+
| Some did -> (
27
+
let%lwt par_req =
28
+
Queries.get_par_request ctx.db code_rec.request_id
29
+
in
30
+
match par_req with
31
+
| None ->
32
+
Errors.internal_error ~msg:"request not found" ()
33
+
| Some par_record ->
34
+
let orig_req =
35
+
Yojson.Safe.from_string par_record.request_data
36
+
|> Types.par_request_of_yojson |> Result.get_ok
37
+
in
38
+
( match req.redirect_uri with
39
+
| None ->
40
+
Errors.invalid_request "redirect_uri required"
41
+
| Some uri when uri <> orig_req.redirect_uri ->
42
+
Errors.invalid_request "redirect_uri mismatch"
43
+
| _ ->
44
+
() ) ;
45
+
( match req.code_verifier with
46
+
| None ->
47
+
Errors.invalid_request "code_verifier required"
48
+
| Some verifier ->
49
+
let computed =
50
+
Digestif.SHA256.digest_string verifier
51
+
|> Digestif.SHA256.to_raw_string
52
+
|> Base64.(
53
+
encode_exn ~pad:false
54
+
~alphabet:uri_safe_alphabet )
55
+
in
56
+
if orig_req.code_challenge <> computed then
57
+
Errors.invalid_request "invalid code_verifier"
58
+
) ;
59
+
( match par_record.dpop_jkt with
60
+
| Some stored when stored <> proof.jkt ->
61
+
Errors.invalid_request "DPoP key mismatch"
62
+
| _ ->
63
+
() ) ;
64
+
let token_id =
65
+
"tok-"
66
+
^ Uuidm.to_string
67
+
(Uuidm.v4_gen
68
+
(Random.State.make_self_init ())
69
+
() )
70
+
in
71
+
let refresh_token =
72
+
"ref-"
73
+
^ Uuidm.to_string
74
+
(Uuidm.v4_gen
75
+
(Random.State.make_self_init ())
76
+
() )
77
+
in
78
+
let now_sec = int_of_float (Unix.gettimeofday ()) in
79
+
let expires_in =
80
+
Constants.access_token_expiry_ms / 1000
81
+
in
82
+
let exp_sec = now_sec + expires_in in
83
+
let expires_at = exp_sec * 1000 in
84
+
let claims =
85
+
`Assoc
86
+
[ ("jti", `String token_id)
87
+
; ("sub", `String did)
88
+
; ("iat", `Int now_sec)
89
+
; ("exp", `Int exp_sec)
90
+
; ("scope", `String orig_req.scope)
91
+
; ("aud", `String ("https://" ^ Env.hostname))
92
+
; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ]
93
+
in
94
+
let access_token =
95
+
Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key
96
+
in
97
+
let%lwt () =
98
+
Queries.insert_oauth_token ctx.db
99
+
{ refresh_token
100
+
; client_id= req.client_id
101
+
; did
102
+
; dpop_jkt= proof.jkt
103
+
; scope= orig_req.scope
104
+
; expires_at }
105
+
in
106
+
let nonce = Dpop.next_nonce () in
107
+
Dream.json
108
+
~headers:
109
+
[ ("DPoP-Nonce", nonce)
110
+
; ("Access-Control-Expose-Headers", "DPoP-Nonce")
111
+
; ("Cache-Control", "no-store") ]
112
+
@@ Yojson.Safe.to_string
113
+
@@ `Assoc
114
+
[ ("access_token", `String access_token)
115
+
; ("token_type", `String "DPoP")
116
+
; ("refresh_token", `String refresh_token)
117
+
; ("expires_in", `Int expires_in)
118
+
; ("scope", `String orig_req.scope)
119
+
; ("sub", `String did) ] ) ) ) )
120
+
| "refresh_token" -> (
121
+
match req.refresh_token with
122
+
| None ->
123
+
Errors.invalid_request "refresh_token required"
124
+
| Some refresh_token -> (
125
+
let%lwt token_record =
126
+
Queries.get_oauth_token_by_refresh ctx.db refresh_token
127
+
in
128
+
match token_record with
129
+
| None ->
130
+
Errors.invalid_request "invalid refresh token"
131
+
| Some session ->
132
+
if session.client_id <> req.client_id then
133
+
Errors.invalid_request "client_id mismatch"
134
+
else if session.dpop_jkt <> proof.jkt then
135
+
Errors.invalid_request "DPoP key mismatch"
136
+
else
137
+
let new_token_id =
138
+
"tok-"
139
+
^ Uuidm.to_string
140
+
(Uuidm.v4_gen (Random.State.make_self_init ()) ())
141
+
in
142
+
let new_refresh =
143
+
"ref-"
144
+
^ Uuidm.to_string
145
+
(Uuidm.v4_gen (Random.State.make_self_init ()) ())
146
+
in
147
+
let now_sec = int_of_float (Unix.gettimeofday ()) in
148
+
let expires_in = Constants.access_token_expiry_ms / 1000 in
149
+
let exp_sec = now_sec + expires_in in
150
+
let new_expires_at = exp_sec * 1000 in
151
+
let claims =
152
+
`Assoc
153
+
[ ("jti", `String new_token_id)
154
+
; ("sub", `String session.did)
155
+
; ("iat", `Int now_sec)
156
+
; ("exp", `Int exp_sec)
157
+
; ("scope", `String session.scope)
158
+
; ("aud", `String ("https://" ^ Env.hostname))
159
+
; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ]
160
+
in
161
+
let new_access_token =
162
+
Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key
163
+
in
164
+
let%lwt () =
165
+
Queries.update_oauth_token ctx.db
166
+
~old_refresh_token:refresh_token
167
+
~new_refresh_token:new_refresh ~expires_at:new_expires_at
168
+
in
169
+
Dream.json ~headers:[("Cache-Control", "no-store")]
170
+
@@ Yojson.Safe.to_string
171
+
@@ `Assoc
172
+
[ ("access_token", `String new_access_token)
173
+
; ("token_type", `String "DPoP")
174
+
; ("refresh_token", `String new_refresh)
175
+
; ("expires_in", `Int expires_in)
176
+
; ("scope", `String session.scope)
177
+
; ("sub", `String session.did) ] ) )
178
+
| _ ->
179
+
Errors.invalid_request ("unsupported grant_type: " ^ req.grant_type) )
+10
-10
pegasus/lib/api/repo/createAccount.ml
+10
-10
pegasus/lib/api/repo/createAccount.ml
···
57
let%lwt did =
58
match input.did with
59
| Some did -> (
60
-
match%lwt Data_store.get_actor_by_identifier did ctx.db with
61
-
| Some _ ->
62
-
Errors.invalid_request "an account with that did already exists"
63
-
| None ->
64
-
Lwt.return did )
65
| None -> (
66
let sk_did = Kleidos.K256.pubkey_to_did_key signing_pubkey in
67
let rotation_did_keys =
···
79
let%lwt _ =
80
match input.invite_code with
81
| Some code -> (
82
-
match%lwt Data_store.use_invite ~code ctx.db with
83
-
| Some _ ->
84
-
Lwt.return ()
85
-
| None ->
86
-
failwith "failed to use invite code" )
87
| None ->
88
Lwt.return ()
89
in
···
57
let%lwt did =
58
match input.did with
59
| Some did -> (
60
+
match%lwt Data_store.get_actor_by_identifier did ctx.db with
61
+
| Some _ ->
62
+
Errors.invalid_request "an account with that did already exists"
63
+
| None ->
64
+
Lwt.return did )
65
| None -> (
66
let sk_did = Kleidos.K256.pubkey_to_did_key signing_pubkey in
67
let rotation_did_keys =
···
79
let%lwt _ =
80
match input.invite_code with
81
| Some code -> (
82
+
match%lwt Data_store.use_invite ~code ctx.db with
83
+
| Some _ ->
84
+
Lwt.return ()
85
+
| None ->
86
+
failwith "failed to use invite code" )
87
| None ->
88
Lwt.return ()
89
in
+1
-1
pegasus/lib/api/server/createSession.ml
+1
-1
pegasus/lib/api/server/createSession.ml
+1
-1
pegasus/lib/api/server/getServiceAuth.ml
+1
-1
pegasus/lib/api/server/getServiceAuth.ml
+57
-2
pegasus/lib/api/well_known.ml
+57
-2
pegasus/lib/api/well_known.ml
···
1
+
open struct
2
+
let make_url pth =
3
+
Uri.(make ~scheme:"https" ~host:Env.hostname ~path:pth () |> to_string)
4
+
5
+
let pds_url = `String (make_url "")
6
+
end
7
+
8
let did_json =
9
Xrpc.handler (fun _ ->
10
Dream.json @@ Yojson.Safe.to_string
···
15
, `Assoc
16
[ ("id", `String "#atproto_pds")
17
; ("type", `String "AtprotoPersonalDataServer")
18
+
; ("serviceEndpoint", pds_url) ] ) ] )
19
+
20
+
let oauth_protected_resource =
21
+
Xrpc.handler (fun _ ->
22
+
Dream.json @@ Yojson.Safe.to_string
23
+
@@ `Assoc
24
+
[ ("authorization_servers", `List [pds_url])
25
+
; ("bearer_methods_supported", `List [`String "header"])
26
+
; ("resource", pds_url)
27
+
; ("resource_documentation", `String "https://atproto.com")
28
+
; ("scopes_supported", `List []) ] )
29
+
30
+
let oauth_authorization_server =
31
+
Xrpc.handler (fun _ ->
32
+
Dream.json @@ Yojson.Safe.to_string
33
+
@@ `Assoc
34
+
[ ("issuer", pds_url)
35
+
; ("authorization_endpoint", `String (make_url "/oauth/authorize"))
36
+
; ("token_endpoint", `String (make_url "/oauth/token"))
37
+
; ( "pushed_authorization_request_endpoint"
38
+
, `String (make_url "/oauth/par") )
39
+
; ("require_pushed_authorization_requests", `Bool true)
40
+
; ( "scopes_supported"
41
+
, `List
42
+
[ `String "atproto"
43
+
; `String "transition:email"
44
+
; `String "transition:generic"
45
+
; `String "transition:chat.bsky" ] )
46
+
; ("subject_types_supported", `List [`String "public"])
47
+
; ("response_types_supported", `List [`String "code"])
48
+
; ( "response_modes_supported"
49
+
, `List [`String "query"; `String "fragment"] )
50
+
; ( "grant_types_supported"
51
+
, `List [`String "authorization_code"; `String "refresh_token"] )
52
+
; ("code_challenge_methods_supported", `List [`String "S256"])
53
+
; ("ui_locales_supported", `List [`String "en-US"])
54
+
; ( "display_values_supported"
55
+
, `List [`String "page"; `String "popup"; `String "touch"] )
56
+
; ("authorization_response_iss_parameter_supported", `Bool true)
57
+
; ( "request_object_signing_alg_values_supported"
58
+
, `List [`String "ES256"; `String "ES256K"] )
59
+
; ("request_object_encryption_alg_values_supported", `List [])
60
+
; ("request_object_encryption_enc_values_supported", `List [])
61
+
; ( "token_endpoint_auth_methods_supported"
62
+
, `List [`String "none"; `String "private_key_jwt"] )
63
+
; ( "token_endpoint_auth_signing_alg_values_supported"
64
+
, `List [`String "ES256"; `String "ES256K"] )
65
+
; ( "dpop_signing_alg_values_supported"
66
+
, `List [`String "ES256"; `String "ES256K"] )
67
+
; ("client_id_metadata_document_supported", `Bool true) ] )
+145
-55
pegasus/lib/auth.ml
+145
-55
pegasus/lib/auth.ml
···
15
| Admin
16
| Access of {did: string}
17
| Refresh of {did: string; jti: string}
18
19
let verify_bearer_jwt t token expected_scope =
20
match Jwt.verify_jwt token Env.jwt_key with
···
42
match credentials with
43
| Admin ->
44
true
45
-
| Access {did= creds} when creds = did ->
46
true
47
| Refresh {did= creds; _} when creds = did && refresh ->
48
true
···
50
false
51
52
let get_authed_did_exn = function
53
-
| Access {did} ->
54
did
55
| Refresh {did; _} ->
56
did
57
| _ ->
58
-
Errors.auth_required "Invalid authorization header"
59
60
let get_session_info identifier db =
61
let%lwt actor =
···
84
module Verifiers = struct
85
open struct
86
let parse_header req expected_type =
87
-
match Dream.header req "authorization" with
88
| Some header -> (
89
match String.split_on_char ' ' header with
90
| [typ; token]
···
95
Error "invalid authorization header" )
96
| None ->
97
Error "missing authorization header"
98
99
-
let parse_basic req =
100
-
match parse_header req "Basic" with
101
-
| Ok token -> (
102
-
match Base64.decode token with
103
-
| Ok decoded -> (
104
-
match Str.bounded_split (Str.regexp_string ":") decoded 2 with
105
-
| [username; password] ->
106
-
Ok (username, password)
107
-
| _ ->
108
-
Error "invalid basic authorization header" )
109
-
| Error _ ->
110
Error "invalid basic authorization header" )
111
| Error _ ->
112
-
Error "invalid basic authorization header"
113
114
-
let parse_bearer req = parse_header req "Bearer"
115
-
end
116
117
type ctx = {req: Dream.request; db: Data_store.t}
118
···
122
fun {req; _} ->
123
match Dream.header req "authorization" with
124
| Some _ ->
125
-
Lwt.return_error @@ Errors.auth_required "Invalid authorization header"
126
| None ->
127
Lwt.return_ok Unauthenticated
128
···
134
| "admin", p when p = Env.admin_password ->
135
Lwt.return_ok Admin
136
| _ ->
137
-
Lwt.return_error @@ Errors.auth_required "Invalid credentials" )
138
| Error _ ->
139
-
Lwt.return_error @@ Errors.auth_required "Invalid authorization header"
140
141
-
let access : verifier =
142
fun {req; db} ->
143
match parse_bearer req with
144
| Ok jwt -> (
145
-
match%lwt verify_bearer_jwt db jwt "com.atproto.access" with
146
-
| Ok {sub= did; _} -> (
147
-
match%lwt Data_store.get_actor_by_identifier did db with
148
-
| Some {deactivated_at= None; _} ->
149
-
Lwt.return_ok (Access {did})
150
-
| Some {deactivated_at= Some _; _} ->
151
-
Lwt.return_error
152
-
@@ Errors.auth_required ~name:"AccountDeactivated"
153
-
"Account is deactivated"
154
-
| None ->
155
-
Lwt.return_error @@ Errors.auth_required "Invalid credentials" )
156
-
| Error _ ->
157
-
Lwt.return_error @@ Errors.auth_required "Invalid credentials" )
158
| Error _ ->
159
-
Lwt.return_error @@ Errors.auth_required "Invalid authorization header"
160
161
let refresh : verifier =
162
fun {req; db} ->
163
match parse_bearer req with
164
| Ok jwt -> (
165
-
match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with
166
-
| Ok {sub= did; jti; _} -> (
167
-
match%lwt Data_store.get_actor_by_identifier did db with
168
-
| Some {deactivated_at= None; _} ->
169
-
Lwt.return_ok (Refresh {did; jti})
170
-
| Some {deactivated_at= Some _; _} ->
171
-
Lwt.return_error
172
-
@@ Errors.auth_required ~name:"AccountDeactivated"
173
-
"Account is deactivated"
174
-
| None ->
175
-
Lwt.return_error @@ Errors.auth_required "Invalid credentials" )
176
-
| Error "" | Error _ ->
177
-
Lwt.return_error @@ Errors.auth_required "Invalid credentials" )
178
| Error _ ->
179
-
Lwt.return_error @@ Errors.auth_required "Invalid authorization header"
180
181
let authorization : verifier =
182
fun ctx ->
···
187
| Some ("Basic" :: _) ->
188
admin ctx
189
| Some ("Bearer" :: _) ->
190
-
access ctx
191
| _ ->
192
Lwt.return_error
193
@@ Errors.auth_required ~name:"InvalidToken"
194
-
"Unexpected authorization type"
195
196
let any : verifier =
197
fun ctx -> try authorization ctx with _ -> unauthenticated ctx
198
199
-
type t = Unauthenticated | Admin | Access | Refresh | Authorization | Any
200
201
let of_t = function
202
| Unauthenticated ->
203
unauthenticated
204
| Admin ->
205
admin
206
-
| Access ->
207
-
access
208
| Refresh ->
209
refresh
210
| Authorization ->
···
15
| Admin
16
| Access of {did: string}
17
| Refresh of {did: string; jti: string}
18
+
| OAuth of {did: string; proof: Oauth.Dpop.proof}
19
+
| DPoP of {proof: Oauth.Dpop.proof}
20
21
let verify_bearer_jwt t token expected_scope =
22
match Jwt.verify_jwt token Env.jwt_key with
···
44
match credentials with
45
| Admin ->
46
true
47
+
| (Access {did= creds} | OAuth {did= creds; _}) when creds = did ->
48
true
49
| Refresh {did= creds; _} when creds = did && refresh ->
50
true
···
52
false
53
54
let get_authed_did_exn = function
55
+
| Access {did} | OAuth {did; _} ->
56
did
57
| Refresh {did; _} ->
58
did
59
| _ ->
60
+
Errors.auth_required "invalid authorization header"
61
+
62
+
let get_dpop_proof_exn = function
63
+
| OAuth {proof; _} | DPoP {proof} ->
64
+
proof
65
+
| _ ->
66
+
Errors.invalid_request "invalid DPoP header"
67
68
let get_session_info identifier db =
69
let%lwt actor =
···
92
module Verifiers = struct
93
open struct
94
let parse_header req expected_type =
95
+
match Dream.header req "Authorization" with
96
| Some header -> (
97
match String.split_on_char ' ' header with
98
| [typ; token]
···
103
Error "invalid authorization header" )
104
| None ->
105
Error "missing authorization header"
106
+
end
107
108
+
let parse_basic req =
109
+
match parse_header req "Basic" with
110
+
| Ok token -> (
111
+
match Base64.decode token with
112
+
| Ok decoded -> (
113
+
match Str.bounded_split (Str.regexp_string ":") decoded 2 with
114
+
| [username; password] ->
115
+
Ok (username, password)
116
+
| _ ->
117
Error "invalid basic authorization header" )
118
| Error _ ->
119
+
Error "invalid basic authorization header" )
120
+
| Error _ ->
121
+
Error "invalid basic authorization header"
122
123
+
let parse_bearer req = parse_header req "Bearer"
124
+
125
+
let parse_dpop req = parse_header req "DPoP"
126
127
type ctx = {req: Dream.request; db: Data_store.t}
128
···
132
fun {req; _} ->
133
match Dream.header req "authorization" with
134
| Some _ ->
135
+
Lwt.return_error @@ Errors.auth_required "invalid authorization header"
136
| None ->
137
Lwt.return_ok Unauthenticated
138
···
144
| "admin", p when p = Env.admin_password ->
145
Lwt.return_ok Admin
146
| _ ->
147
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
148
| Error _ ->
149
+
Lwt.return_error @@ Errors.auth_required "invalid authorization header"
150
151
+
let bearer : verifier =
152
fun {req; db} ->
153
match parse_bearer req with
154
| Ok jwt -> (
155
+
match%lwt verify_bearer_jwt db jwt "com.atproto.access" with
156
+
| Ok {sub= did; _} -> (
157
+
match%lwt Data_store.get_actor_by_identifier did db with
158
+
| Some {deactivated_at= None; _} ->
159
+
Lwt.return_ok (Access {did})
160
+
| Some {deactivated_at= Some _; _} ->
161
+
Lwt.return_error
162
+
@@ Errors.auth_required ~name:"AccountDeactivated"
163
+
"account is deactivated"
164
+
| None ->
165
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
166
+
| Error _ ->
167
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
168
| Error _ ->
169
+
Lwt.return_error @@ Errors.auth_required "invalid authorization header"
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 =
187
+
fun {req; db} ->
188
+
match parse_dpop req with
189
+
| Error e ->
190
+
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
191
+
| Ok token -> (
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
197
+
| Error e ->
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"
220
+
in
221
+
match session with
222
+
| Ok {active= Some true; _} ->
223
+
Lwt.return_ok (OAuth {did; proof})
224
+
| Ok _ ->
225
+
Lwt.return_error
226
+
@@ Errors.auth_required ~name:"AccountDeactivated"
227
+
"account is deactivated"
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" )
236
237
let refresh : verifier =
238
fun {req; db} ->
239
match parse_bearer req with
240
| Ok jwt -> (
241
+
match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with
242
+
| Ok {sub= did; jti; _} -> (
243
+
match%lwt Data_store.get_actor_by_identifier did db with
244
+
| Some {deactivated_at= None; _} ->
245
+
Lwt.return_ok (Refresh {did; jti})
246
+
| Some {deactivated_at= Some _; _} ->
247
+
Lwt.return_error
248
+
@@ Errors.auth_required ~name:"AccountDeactivated"
249
+
"account is deactivated"
250
+
| None ->
251
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
252
+
| Error "" | Error _ ->
253
+
Lwt.return_error @@ Errors.auth_required "invalid credentials" )
254
| Error _ ->
255
+
Lwt.return_error @@ Errors.auth_required "invalid authorization header"
256
257
let authorization : verifier =
258
fun ctx ->
···
263
| Some ("Basic" :: _) ->
264
admin ctx
265
| Some ("Bearer" :: _) ->
266
+
bearer ctx
267
+
| Some ("DPoP" :: _) ->
268
+
oauth ctx
269
| _ ->
270
Lwt.return_error
271
@@ Errors.auth_required ~name:"InvalidToken"
272
+
"unexpected authorization type"
273
274
let any : verifier =
275
fun ctx -> try authorization ctx with _ -> unauthenticated ctx
276
277
+
type t =
278
+
| Unauthenticated
279
+
| Admin
280
+
| Bearer
281
+
| DPoP
282
+
| OAuth
283
+
| Refresh
284
+
| Authorization
285
+
| Any
286
287
let of_t = function
288
| Unauthenticated ->
289
unauthenticated
290
| Admin ->
291
admin
292
+
| Bearer ->
293
+
bearer
294
+
| DPoP ->
295
+
dpop
296
+
| OAuth ->
297
+
oauth
298
| Refresh ->
299
refresh
300
| Authorization ->
+115
-23
pegasus/lib/data_store.ml
+115
-23
pegasus/lib/data_store.ml
···
36
created_at INTEGER NOT NULL,
37
deactivated_at INTEGER
38
)
39
-
|sql}]
40
() conn
41
in
42
let$! () =
···
52
[%rapper
53
execute
54
{sql| CREATE TABLE IF NOT EXISTS invite_codes (
55
-
code TEXT PRIMARY KEY,
56
-
did TEXT NOT NULL,
57
-
remaining INTEGER NOT NULL
58
-
)
59
-
|sql}]
60
() conn
61
in
62
let$! () =
63
[%rapper
64
execute
65
{sql| CREATE TABLE IF NOT EXISTS firehose (
66
-
seq INTEGER PRIMARY KEY,
67
-
time INTEGER NOT NULL,
68
-
t TEXT NOT NULL,
69
-
data BLOB NOT NULL
70
-
)
71
-
|sql}]
72
() conn
73
in
74
-
[%rapper
75
-
execute
76
-
(* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)
77
-
{sql| CREATE TABLE IF NOT EXISTS revoked_tokens (
78
-
did TEXT NOT NULL,
79
-
jti TEXT NOT NULL,
80
-
revoked_at INTEGER NOT NULL,
81
-
PRIMARY KEY (did, jti)
82
-
)
83
-
|sql}]
84
-
() conn
85
86
let create_actor =
87
[%rapper
···
221
type t = Util.caqti_pool
222
223
let connect ?create ?write () : t Lwt.t =
224
Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location
225
226
let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables
···
36
created_at INTEGER NOT NULL,
37
deactivated_at INTEGER
38
)
39
+
|sql}]
40
() conn
41
in
42
let$! () =
···
52
[%rapper
53
execute
54
{sql| CREATE TABLE IF NOT EXISTS invite_codes (
55
+
code TEXT PRIMARY KEY,
56
+
did TEXT NOT NULL,
57
+
remaining INTEGER NOT NULL
58
+
)
59
+
|sql}]
60
() conn
61
in
62
let$! () =
63
[%rapper
64
execute
65
{sql| CREATE TABLE IF NOT EXISTS firehose (
66
+
seq INTEGER PRIMARY KEY,
67
+
time INTEGER NOT NULL,
68
+
t TEXT NOT NULL,
69
+
data BLOB NOT NULL
70
+
)
71
+
|sql}]
72
() conn
73
in
74
+
let$! () =
75
+
[%rapper
76
+
execute
77
+
(* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)
78
+
{sql| CREATE TABLE IF NOT EXISTS revoked_tokens (
79
+
did TEXT NOT NULL,
80
+
jti TEXT NOT NULL,
81
+
revoked_at INTEGER NOT NULL,
82
+
PRIMARY KEY (did, jti)
83
+
)
84
+
|sql}]
85
+
() conn
86
+
in
87
+
let$! () =
88
+
[%rapper
89
+
execute
90
+
{sql| CREATE TABLE IF NOT EXISTS oauth_requests (
91
+
request_id TEXT PRIMARY KEY,
92
+
client_id TEXT NOT NULL,
93
+
request_data TEXT NOT NULL,
94
+
dpop_jkt TEXT,
95
+
expires_at INTEGER NOT NULL,
96
+
created_at INTEGER NOT NULL
97
+
)
98
+
|sql}]
99
+
() conn
100
+
in
101
+
let$! () =
102
+
[%rapper
103
+
execute
104
+
{sql| CREATE TABLE IF NOT EXISTS oauth_codes (
105
+
code TEXT PRIMARY KEY,
106
+
request_id TEXT NOT NULL REFERENCES oauth_requests(request_id) ON DELETE CASCADE,
107
+
authorized_by TEXT,
108
+
authorized_at INTEGER,
109
+
expires_at INTEGER NOT NULL,
110
+
used BOOLEAN DEFAULT FALSE
111
+
)
112
+
|sql}]
113
+
() conn
114
+
in
115
+
let$! () =
116
+
[%rapper
117
+
execute
118
+
{sql| CREATE TABLE IF NOT EXISTS oauth_tokens (
119
+
refresh_token TEXT UNIQUE NOT NULL,
120
+
client_id TEXT NOT NULL,
121
+
did TEXT NOT NULL,
122
+
dpop_jkt TEXT,
123
+
scope TEXT NOT NULL,
124
+
expires_at INTEGER NOT NULL
125
+
)
126
+
|sql}]
127
+
() conn
128
+
in
129
+
let$! () =
130
+
[%rapper
131
+
execute
132
+
{sql| CREATE INDEX IF NOT EXISTS oauth_requests_expires_idx ON oauth_requests(expires_at);
133
+
CREATE INDEX IF NOT EXISTS oauth_codes_expires_idx ON oauth_codes(expires_at);
134
+
CREATE INDEX IF NOT EXISTS oauth_tokens_refresh_idx ON oauth_tokens(refresh_token);
135
+
|sql}]
136
+
() conn
137
+
in
138
+
let$! () =
139
+
[%rapper
140
+
execute
141
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests
142
+
AFTER INSERT ON oauth_requests
143
+
BEGIN
144
+
DELETE FROM oauth_requests WHERE expires_at < unixepoch() * 1000;
145
+
END
146
+
|sql}
147
+
syntax_off]
148
+
() conn
149
+
in
150
+
let$! () =
151
+
[%rapper
152
+
execute
153
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes
154
+
AFTER INSERT ON oauth_codes
155
+
BEGIN
156
+
DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000 OR used = 1;
157
+
END
158
+
|sql}
159
+
syntax_off]
160
+
() conn
161
+
in
162
+
let$! () =
163
+
[%rapper
164
+
execute
165
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens
166
+
AFTER INSERT ON oauth_tokens
167
+
BEGIN
168
+
DELETE FROM oauth_tokens WHERE expires_at < unixepoch() * 1000;
169
+
END
170
+
|sql}
171
+
syntax_off]
172
+
() conn
173
+
in
174
+
Lwt.return_ok ()
175
176
let create_actor =
177
[%rapper
···
311
type t = Util.caqti_pool
312
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 ;
316
Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location
317
318
let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables
+3
-1
pegasus/lib/dune
+3
-1
pegasus/lib/dune
···
9
cohttp-lwt-unix
10
dns-client.unix
11
dream
12
+
html_of_jsx
13
ipld
14
kleidos
15
lwt
···
19
safepass
20
str
21
timedesc
22
+
uri
23
uuidm
24
yojson
25
lwt_ppx
26
ppx_deriving_yojson.runtime
27
ppx_rapper_lwt)
28
(preprocess
29
+
(pps html_of_jsx.ppx lwt_ppx ppx_deriving_yojson ppx_rapper)))
30
31
(include_subdirs qualified)
+26
-6
pegasus/lib/env.ml
+26
-6
pegasus/lib/env.ml
···
1
let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR"
2
3
-
let hostname = Sys.getenv "PDS_HOSTNAME"
4
5
let did =
6
Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID"
7
8
-
let invite_required = Sys.getenv "INVITE_CODE_REQUIRED" = "true"
9
10
-
let rotation_key =
11
-
Sys.getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str
12
13
-
let jwt_key = Sys.getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str
14
15
-
let admin_password = Sys.getenv "ADMIN_PASSWORD"
···
1
+
let getenv name =
2
+
try Sys.getenv name
3
+
with Not_found -> failwith ("Missing environment variable " ^ name)
4
+
5
let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR"
6
7
+
let hostname = getenv "PDS_HOSTNAME"
8
9
let did =
10
Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID"
11
12
+
let invite_required = getenv "INVITE_CODE_REQUIRED" = "true"
13
14
+
let rotation_key = getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str
15
16
+
let jwt_key = getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str
17
18
+
let admin_password = getenv "ADMIN_PASSWORD"
19
+
20
+
let dpop_nonce_secret =
21
+
match Sys.getenv_opt "DPOP_NONCE_SECRET" with
22
+
| Some sec ->
23
+
let secret =
24
+
Base64.(decode_exn ~alphabet:uri_safe_alphabet ~pad:false) sec
25
+
|> Bytes.of_string
26
+
in
27
+
if Bytes.length secret = 32 then secret
28
+
else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64uri"
29
+
| None ->
30
+
let secret = Mirage_crypto_rng_unix.getrandom 32 in
31
+
Dream.warning (fun log ->
32
+
log "DPOP_NONCE_SECRET not set; using DPOP_NONCE_SECRET=%s"
33
+
( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret
34
+
|> Result.get_ok ) ) ;
35
+
Bytes.of_string secret
+6
pegasus/lib/errors.ml
+6
pegasus/lib/errors.ml
···
4
5
exception AuthError of (string * string)
6
7
let is_xrpc_error = function
8
| InvalidRequestError _ | InternalServerError _ | AuthError _ ->
9
true
···
19
20
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
21
22
let exn_to_response exn =
23
let format_response error msg status =
24
Dream.json ~status @@ Yojson.Safe.to_string
···
31
format_response error message `Internal_Server_Error
32
| AuthError (error, message) ->
33
format_response error message `Unauthorized
34
| _ ->
35
format_response "InternalServerError" "Internal server error"
36
`Internal_Server_Error
···
4
5
exception AuthError of (string * string)
6
7
+
exception UseDpopNonceError
8
+
9
let is_xrpc_error = function
10
| InvalidRequestError _ | InternalServerError _ | AuthError _ ->
11
true
···
21
22
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
23
24
+
let use_dpop_nonce () = raise UseDpopNonceError
25
+
26
let exn_to_response exn =
27
let format_response error msg status =
28
Dream.json ~status @@ Yojson.Safe.to_string
···
35
format_response error message `Internal_Server_Error
36
| AuthError (error, message) ->
37
format_response error message `Unauthorized
38
+
| UseDpopNonceError ->
39
+
Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|}
40
| _ ->
41
format_response "InternalServerError" "Internal server error"
42
`Internal_Server_Error
+3
-4
pegasus/lib/id_resolver.ml
+3
-4
pegasus/lib/id_resolver.ml
···
1
open Cohttp_lwt
2
-
open Cohttp_lwt_unix
3
4
let did_regex =
5
Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|}
···
12
let uri =
13
Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did")
14
in
15
-
let%lwt {status; _}, body = Client.get uri in
16
match status with
17
| `OK ->
18
let%lwt did = Body.to_string body in
···
164
~path:(Uri.pct_encode did) ()
165
in
166
let%lwt {status; _}, body =
167
-
Client.get uri
168
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
169
in
170
match status with
···
186
~path:"/.well-known/did.json" ()
187
in
188
let%lwt {status; _}, body =
189
-
Client.get uri
190
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
191
in
192
match status with
···
1
open Cohttp_lwt
2
3
let did_regex =
4
Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|}
···
11
let uri =
12
Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did")
13
in
14
+
let%lwt {status; _}, body = Util.http_get uri in
15
match status with
16
| `OK ->
17
let%lwt did = Body.to_string body in
···
163
~path:(Uri.pct_encode did) ()
164
in
165
let%lwt {status; _}, body =
166
+
Util.http_get uri
167
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
168
in
169
match status with
···
185
~path:"/.well-known/did.json" ()
186
in
187
let%lwt {status; _}, body =
188
+
Util.http_get uri
189
~headers:(Cohttp.Header.of_list [("Accept", "application/json")])
190
in
191
match status with
+20
-26
pegasus/lib/jwt.ml
+20
-26
pegasus/lib/jwt.ml
···
19
let b64_decode str =
20
match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with
21
| Ok s ->
22
-
Ok s
23
| Error (`Msg e) ->
24
-
Error e
25
26
let extract_signature_components signature =
27
if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature"
···
30
let s = Bytes.sub signature 32 32 in
31
(r, s)
32
33
-
let sign_jwt payload signing_key =
34
let _, (module Curve : Kleidos.CURVE) = signing_key in
35
let alg =
36
match Curve.name with
···
51
failwith "invalid curve"
52
in
53
let header_json =
54
-
`Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String "JWT")]
55
in
56
let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in
57
let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in
···
65
let decode_jwt jwt =
66
match String.split_on_char '.' jwt with
67
| [header_b64; payload_b64; _] -> (
68
-
match (b64_decode header_b64, b64_decode payload_b64) with
69
-
| Ok header_str, Ok payload_str -> (
70
-
try
71
-
let header = Yojson.Safe.from_string header_str in
72
-
let payload = Yojson.Safe.from_string payload_str in
73
-
Ok (header, payload)
74
-
with _ -> Error "invalid json in jwt" )
75
-
| Error e, _ | _, Error e ->
76
-
Error e )
77
| _ ->
78
Error "invalid jwt format"
79
80
let verify_jwt jwt pubkey =
81
match String.split_on_char '.' jwt with
82
-
| [header_b64; payload_b64; signature_b64] -> (
83
-
match b64_decode signature_b64 with
84
-
| Error e ->
85
-
Error e
86
-
| Ok signature_str ->
87
-
let signature = Bytes.of_string signature_str in
88
-
let signing_input = header_b64 ^ "." ^ payload_b64 in
89
-
let verified =
90
-
Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature
91
-
in
92
-
if verified then decode_jwt jwt
93
-
else Error "jwt signature verification failed" )
94
| _ ->
95
Error "invalid jwt format"
96
···
98
let now_s = int_of_float (Unix.gettimeofday ()) in
99
let access_exp = now_s + Defaults.access_token_exp in
100
let refresh_exp = now_s + Defaults.refresh_token_exp in
101
-
let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in
102
let access_payload =
103
symmetric_jwt_to_yojson
104
{ scope= "com.atproto.access"
···
19
let b64_decode str =
20
match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with
21
| Ok s ->
22
+
s
23
| Error (`Msg e) ->
24
+
failwith e
25
26
let extract_signature_components signature =
27
if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature"
···
30
let s = Bytes.sub signature 32 32 in
31
(r, s)
32
33
+
let sign_jwt payload ?(typ = "JWT") signing_key =
34
let _, (module Curve : Kleidos.CURVE) = signing_key in
35
let alg =
36
match Curve.name with
···
51
failwith "invalid curve"
52
in
53
let header_json =
54
+
`Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String typ)]
55
in
56
let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in
57
let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in
···
65
let decode_jwt jwt =
66
match String.split_on_char '.' jwt with
67
| [header_b64; payload_b64; _] -> (
68
+
try
69
+
let header = Yojson.Safe.from_string (b64_decode header_b64) in
70
+
let payload = Yojson.Safe.from_string (b64_decode payload_b64) in
71
+
Ok (header, payload)
72
+
with _ -> Error "invalid jwt" )
73
| _ ->
74
Error "invalid jwt format"
75
76
let verify_jwt jwt pubkey =
77
match String.split_on_char '.' jwt with
78
+
| [header_b64; payload_b64; signature_b64] ->
79
+
let signature = Bytes.of_string (b64_decode signature_b64) in
80
+
let signing_input = header_b64 ^ "." ^ payload_b64 in
81
+
let verified =
82
+
Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature
83
+
in
84
+
if verified then decode_jwt jwt
85
+
else Error "jwt signature verification failed"
86
| _ ->
87
Error "invalid jwt format"
88
···
90
let now_s = int_of_float (Unix.gettimeofday ()) in
91
let access_exp = now_s + Defaults.access_token_exp in
92
let refresh_exp = now_s + Defaults.refresh_token_exp in
93
+
let jti =
94
+
Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string
95
+
in
96
let access_payload =
97
symmetric_jwt_to_yojson
98
{ scope= "com.atproto.access"
+45
pegasus/lib/oauth/client.ml
+45
pegasus/lib/oauth/client.ml
···
···
1
+
open Types
2
+
3
+
let fetch_client_metadata client_id : client_metadata Lwt.t =
4
+
let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in
5
+
if status <> `OK then
6
+
let%lwt () = Cohttp_lwt.Body.drain_body res in
7
+
failwith
8
+
(Printf.sprintf "client metadata not found; http %d"
9
+
(Cohttp.Code.code_of_status status) )
10
+
else
11
+
let%lwt body = Cohttp_lwt.Body.to_string res in
12
+
let json = Yojson.Safe.from_string body 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
20
+
if metadata.client_id <> client_id then failwith "client_id mismatch"
21
+
else
22
+
let scopes = String.split_on_char ' ' metadata.scope in
23
+
if not (List.mem "atproto" scopes) then
24
+
failwith "scope must include 'atproto'"
25
+
else
26
+
List.iter
27
+
(function
28
+
| "authorization_code" | "refresh_token" ->
29
+
()
30
+
| grant ->
31
+
failwith ("invalid grant type: " ^ grant) )
32
+
metadata.grant_types ;
33
+
List.iter
34
+
(fun uri ->
35
+
let u = Uri.of_string uri in
36
+
let host = Uri.host u in
37
+
match Uri.scheme u with
38
+
| Some "https" when host <> Some "localhost" ->
39
+
()
40
+
| Some "http" when host = Some "127.0.0.1" || host = Some "[::1]" ->
41
+
()
42
+
| _ ->
43
+
failwith ("invalid redirect_uri: " ^ uri) )
44
+
metadata.redirect_uris ;
45
+
Lwt.return metadata
+15
pegasus/lib/oauth/constants.ml
+15
pegasus/lib/oauth/constants.ml
···
···
1
+
let max_dpop_age_s = 60
2
+
3
+
let dpop_rotation_interval_ms = 60_000L
4
+
5
+
let jti_ttl_s = 3600
6
+
7
+
let jti_cache_size = 10_000
8
+
9
+
let par_request_ttl_ms = 300_000
10
+
11
+
let code_expiry_ms = 300_000
12
+
13
+
let access_token_expiry_ms = 60 * 60 * 1000
14
+
15
+
let request_uri_prefix = "urn:ietf:params:oauth:request_uri:"
+204
pegasus/lib/oauth/dpop.ml
+204
pegasus/lib/oauth/dpop.ml
···
···
1
+
type nonce_state =
2
+
{ secret: bytes
3
+
; mutable counter: int64
4
+
; mutable prev: string
5
+
; mutable curr: string
6
+
; mutable next: string
7
+
; rotation_interval_ms: int64 }
8
+
9
+
type ec_jwk = {crv: string; kty: string; x: string; y: string}
10
+
[@@deriving yojson]
11
+
12
+
type proof = {jti: string; jkt: string; htm: string; htu: string}
13
+
[@@deriving yojson]
14
+
15
+
let jti_cache : (string, int) Hashtbl.t =
16
+
Hashtbl.create Constants.jti_cache_size
17
+
18
+
let cleanup_jti_cache () =
19
+
let now = int_of_float (Unix.gettimeofday ()) in
20
+
Hashtbl.filter_map_inplace
21
+
(fun _ expires_at -> if expires_at > now then Some expires_at else None)
22
+
jti_cache
23
+
24
+
let compute_nonce secret counter =
25
+
let data = Bytes.create 8 in
26
+
Bytes.set_int64_be data 0 counter ;
27
+
Digestif.SHA256.(
28
+
hmac_bytes ~key:(Bytes.to_string secret) data
29
+
|> to_raw_string |> Jwt.b64_encode )
30
+
31
+
let create_nonce_state secret =
32
+
let counter =
33
+
Int64.div
34
+
(Int64.of_float (Unix.gettimeofday () *. 1000.))
35
+
Constants.dpop_rotation_interval_ms
36
+
in
37
+
{ secret
38
+
; counter
39
+
; prev= compute_nonce secret (Int64.pred counter)
40
+
; curr= compute_nonce secret counter
41
+
; next= compute_nonce secret (Int64.succ counter)
42
+
; rotation_interval_ms= Constants.dpop_rotation_interval_ms }
43
+
44
+
let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret)
45
+
46
+
let next_nonce () =
47
+
let now_counter =
48
+
Int64.div
49
+
(Int64.of_float (Unix.gettimeofday () *. 1000.))
50
+
!nonce_state.rotation_interval_ms
51
+
in
52
+
if now_counter <> !nonce_state.counter then (
53
+
!nonce_state.prev <- !nonce_state.curr ;
54
+
!nonce_state.curr <- !nonce_state.next ;
55
+
!nonce_state.next <-
56
+
compute_nonce !nonce_state.secret (Int64.succ now_counter) ;
57
+
!nonce_state.counter <- now_counter ) ;
58
+
!nonce_state.next
59
+
60
+
let verify_nonce nonce =
61
+
let valid =
62
+
nonce = !nonce_state.prev || nonce = !nonce_state.curr
63
+
|| nonce = !nonce_state.next
64
+
in
65
+
ignore next_nonce ; valid
66
+
67
+
let add_jti jti =
68
+
let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in
69
+
if Hashtbl.mem jti_cache jti then false (* replay *)
70
+
else (
71
+
Hashtbl.add jti_cache jti expires_at ;
72
+
(* clean up every once in a while *)
73
+
if Hashtbl.length jti_cache mod 100 = 0 then cleanup_jti_cache () ;
74
+
true )
75
+
76
+
let normalize_url url =
77
+
let uri = Uri.of_string url in
78
+
Uri.make ~scheme:"https"
79
+
~host:(Uri.host uri |> Option.value ~default:Env.hostname)
80
+
~path:(Uri.path uri) ()
81
+
|> Uri.to_string
82
+
83
+
let compute_jwk_thumbprint jwk =
84
+
let {crv; kty; x; y} = jwk in
85
+
let tp =
86
+
(* keys must be in lexicographic order *)
87
+
Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y
88
+
in
89
+
Digestif.SHA256.(digest_string tp |> to_raw_string |> Jwt.b64_encode)
90
+
91
+
let verify_signature jwt jwk =
92
+
let parts = String.split_on_char '.' jwt in
93
+
match parts with
94
+
| [header_b64; payload_b64; sig_b64] ->
95
+
let signing_input = header_b64 ^ "." ^ payload_b64 in
96
+
let msg = Bytes.of_string signing_input in
97
+
let {x; y; crv; _} = jwk in
98
+
let x = x |> Jwt.b64_decode |> Bytes.of_string in
99
+
let y = y |> Jwt.b64_decode |> Bytes.of_string in
100
+
let pubkey = Bytes.cat (Bytes.of_string "\x04") (Bytes.cat x y) in
101
+
let pubkey =
102
+
( pubkey
103
+
, match crv with
104
+
| "secp256k1" ->
105
+
(module Kleidos.K256 : Kleidos.CURVE)
106
+
| "P-256" ->
107
+
(module Kleidos.P256 : Kleidos.CURVE)
108
+
| _ ->
109
+
failwith "unsupported algorithm" )
110
+
in
111
+
let sig_bytes = Jwt.b64_decode sig_b64 |> Bytes.of_string in
112
+
let r = Bytes.sub sig_bytes 0 32 in
113
+
let s = Bytes.sub sig_bytes 32 32 in
114
+
let signature = Bytes.cat r s in
115
+
Kleidos.verify ~pubkey ~msg ~signature
116
+
| _ ->
117
+
false
118
+
119
+
let verify_dpop_proof ~mthd ~url ~dpop_header ?access_token () =
120
+
match dpop_header with
121
+
| None ->
122
+
Error "missing dpop header"
123
+
| Some jwt -> (
124
+
let open Yojson.Safe.Util in
125
+
match String.split_on_char '.' jwt with
126
+
| [header_b64; payload_b64; _] -> (
127
+
let header = Yojson.Safe.from_string (Jwt.b64_decode header_b64) in
128
+
let payload = Yojson.Safe.from_string (Jwt.b64_decode payload_b64) in
129
+
let typ = header |> member "typ" |> to_string in
130
+
if typ <> "dpop+jwt" then Error "invalid typ in dpop proof"
131
+
else
132
+
let alg = header |> member "alg" |> to_string in
133
+
if alg <> "ES256" && alg <> "ES256K" then
134
+
Error "only es256 and es256k supported for dpop"
135
+
else
136
+
let jwk =
137
+
header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok
138
+
in
139
+
if
140
+
not
141
+
( match (alg, jwk.crv) with
142
+
| "ES256", "P-256" ->
143
+
true
144
+
| "ES256K", "secp256k1" ->
145
+
true
146
+
| _ ->
147
+
false )
148
+
then
149
+
Error
150
+
(Printf.sprintf "algorithm %s doesn't match curve %s" alg
151
+
jwk.crv )
152
+
else
153
+
let jti = payload |> member "jti" |> to_string in
154
+
let htm = payload |> member "htm" |> to_string in
155
+
let htu = payload |> member "htu" |> to_string in
156
+
let iat = payload |> member "iat" |> to_int in
157
+
let nonce_claim =
158
+
payload |> member "nonce" |> to_string_option
159
+
in
160
+
match nonce_claim with
161
+
(* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
162
+
| None ->
163
+
Error "use_dpop_nonce"
164
+
| Some n when not (verify_nonce n) ->
165
+
Error "use_dpop_nonce"
166
+
| Some _ -> (
167
+
if htm <> mthd then Error "htm mismatch"
168
+
else if
169
+
not (String.equal (normalize_url htu) (normalize_url url))
170
+
then Error "htu mismatch"
171
+
else
172
+
let now = int_of_float (Unix.gettimeofday ()) in
173
+
if now - iat > Constants.max_dpop_age_s then
174
+
Error "dpop proof too old"
175
+
else if iat - now > 5 then Error "dpop proof in future"
176
+
else if not (add_jti jti) then
177
+
Error "dpop proof replay detected"
178
+
else if not (verify_signature jwt jwk) then
179
+
Error "invalid dpop signature"
180
+
else
181
+
let jkt = compute_jwk_thumbprint jwk in
182
+
(* verify ath if access token is provided *)
183
+
match access_token with
184
+
| Some token ->
185
+
let ath_claim =
186
+
payload |> member "ath" |> to_string_option
187
+
in
188
+
let expected_ath =
189
+
Digestif.SHA256.(
190
+
digest_string token |> to_raw_string
191
+
|> Jwt.b64_encode )
192
+
in
193
+
if Some expected_ath <> ath_claim then
194
+
Error "ath mismatch"
195
+
else Ok {jti; jkt; htm; htu}
196
+
| None ->
197
+
let ath_claim =
198
+
payload |> member "ath" |> to_string_option
199
+
in
200
+
if ath_claim <> None then
201
+
Error "ath claim not allowed without access token"
202
+
else Ok {jti; jkt; htm; htu} ) )
203
+
| _ ->
204
+
Error "invalid dpop jwt" )
+138
pegasus/lib/oauth/queries.ml
+138
pegasus/lib/oauth/queries.ml
···
···
1
+
[@@@warning "-missing-record-field-pattern"]
2
+
3
+
open Types
4
+
5
+
let insert_par_request conn req =
6
+
Util.use_pool conn
7
+
@@ [%rapper
8
+
execute
9
+
{sql|
10
+
INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at)
11
+
VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string?{dpop_jkt}, %int{expires_at}, %int{created_at})
12
+
|sql}
13
+
record_in]
14
+
req
15
+
16
+
let get_par_request conn request_id =
17
+
Util.use_pool conn
18
+
@@ [%rapper
19
+
get_opt
20
+
{sql|
21
+
SELECT @string{request_id}, @string{client_id}, @string{request_data},
22
+
@string?{dpop_jkt}, @int{expires_at}, @int{created_at}
23
+
FROM oauth_requests
24
+
WHERE request_id = %string{request_id}
25
+
AND expires_at > %int{now}
26
+
|sql}
27
+
record_out]
28
+
~request_id ~now:(Util.now_ms ())
29
+
30
+
let insert_auth_code conn code =
31
+
Util.use_pool conn
32
+
@@ [%rapper
33
+
execute
34
+
{sql|
35
+
INSERT INTO oauth_codes (code, request_id, authorized_by, authorized_at, expires_at, used)
36
+
VALUES (%string{code}, %string{request_id}, %string?{authorized_by}, %int?{authorized_at}, %int{expires_at}, 0)
37
+
|sql}
38
+
record_in]
39
+
code
40
+
41
+
let get_auth_code conn code =
42
+
Util.use_pool conn
43
+
@@ [%rapper
44
+
get_opt
45
+
{sql|
46
+
SELECT @string{code}, @string{request_id}, @string?{authorized_by},
47
+
@int?{authorized_at}, @int{expires_at}, @bool{used}
48
+
FROM oauth_codes
49
+
WHERE code = %string{code}
50
+
|sql}
51
+
record_out]
52
+
~code
53
+
54
+
let activate_auth_code conn code did =
55
+
let authorized_at = Util.now_ms () in
56
+
Util.use_pool conn
57
+
@@ [%rapper
58
+
execute
59
+
{sql|
60
+
UPDATE oauth_codes
61
+
SET authorized_by = %string{did},
62
+
authorized_at = %int{authorized_at}
63
+
WHERE code = %string{code}
64
+
|sql}]
65
+
~did ~authorized_at ~code
66
+
67
+
let consume_auth_code conn code =
68
+
Util.use_pool conn
69
+
@@ [%rapper
70
+
get_opt
71
+
{sql|
72
+
UPDATE oauth_codes
73
+
SET used = 1
74
+
WHERE code = %string{code} AND used = 0
75
+
RETURNING @string{code}, @string{request_id}, @string?{authorized_by},
76
+
@int?{authorized_at}, @int{expires_at}, @bool{used}
77
+
|sql}
78
+
record_out]
79
+
~code
80
+
81
+
let insert_oauth_token conn token =
82
+
Util.use_pool conn
83
+
@@ [%rapper
84
+
execute
85
+
{sql|
86
+
INSERT INTO oauth_tokens (refresh_token, client_id, did, dpop_jkt, scope, expires_at)
87
+
VALUES (%string{refresh_token}, %string{client_id}, %string{did}, %string{dpop_jkt}, %string{scope}, %int{expires_at})
88
+
|sql}
89
+
record_in]
90
+
token
91
+
92
+
let get_oauth_token_by_refresh conn refresh_token =
93
+
Util.use_pool conn
94
+
@@ [%rapper
95
+
get_opt
96
+
{sql|
97
+
SELECT @string{refresh_token}, @string{client_id}, @string{did},
98
+
@string{dpop_jkt}, @string{scope}, @int{expires_at}
99
+
FROM oauth_tokens
100
+
WHERE refresh_token = %string{refresh_token}
101
+
|sql}
102
+
record_out]
103
+
~refresh_token
104
+
105
+
let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at =
106
+
Util.use_pool conn
107
+
@@ [%rapper
108
+
execute
109
+
{sql|
110
+
UPDATE oauth_tokens
111
+
SET refresh_token = %string{new_refresh_token},
112
+
expires_at = %int{expires_at}
113
+
WHERE refresh_token = %string{old_refresh_token}
114
+
|sql}]
115
+
~new_refresh_token ~expires_at ~old_refresh_token
116
+
117
+
let delete_oauth_token_by_refresh conn refresh_token =
118
+
Util.use_pool conn
119
+
@@ [%rapper
120
+
execute
121
+
{sql|
122
+
DELETE FROM oauth_tokens WHERE refresh_token = %string{refresh_token}
123
+
|sql}]
124
+
~refresh_token
125
+
126
+
let get_oauth_tokens_by_did conn did =
127
+
Util.use_pool conn
128
+
@@ [%rapper
129
+
get_many
130
+
{sql|
131
+
SELECT @string{refresh_token}, @string{client_id}, @string{did},
132
+
@string{dpop_jkt}, @string{scope}, @int{expires_at}
133
+
FROM oauth_tokens
134
+
WHERE did = %string{did}
135
+
ORDER BY expires_at ASC
136
+
|sql}
137
+
record_out]
138
+
~did
+71
pegasus/lib/oauth/types.ml
+71
pegasus/lib/oauth/types.ml
···
···
1
+
type par_request =
2
+
{ client_id: string
3
+
; response_type: string
4
+
; response_mode: string option [@default None]
5
+
; redirect_uri: string
6
+
; scope: string
7
+
; state: string
8
+
; code_challenge: string
9
+
; code_challenge_method: string
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
+
[@@deriving yojson {strict= false}]
15
+
16
+
type token_request =
17
+
{ grant_type: string
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
+
; client_id: string
23
+
; client_assertion_type: string option [@default None]
24
+
; client_assertion: string option [@default None] }
25
+
[@@deriving yojson {strict= false}]
26
+
27
+
type client_metadata =
28
+
{ client_id: string
29
+
; client_name: string option [@default None]
30
+
; client_uri: string
31
+
; redirect_uris: string list
32
+
; grant_types: string list
33
+
; response_types: string list
34
+
; scope: string
35
+
; token_endpoint_auth_method: string
36
+
; token_endpoint_auth_signing_alg: string option [@default None]
37
+
; application_type: string
38
+
; dpop_bound_access_tokens: bool
39
+
; jwks_uri: string option [@default None]
40
+
; jwks: Yojson.Safe.t option [@default None] }
41
+
[@@deriving yojson {strict= false}]
42
+
43
+
type dpop_proof = {jti: string; jkt: string; htm: string; htu: string}
44
+
[@@deriving yojson {strict= false}]
45
+
46
+
type oauth_request =
47
+
{ request_id: string
48
+
; client_id: string
49
+
; request_data: string
50
+
; dpop_jkt: string option [@default None]
51
+
; expires_at: int
52
+
; created_at: int }
53
+
[@@deriving yojson {strict= false}]
54
+
55
+
type oauth_code =
56
+
{ code: string
57
+
; request_id: string
58
+
; authorized_by: string option [@default None]
59
+
; authorized_at: int option [@default None]
60
+
; expires_at: int
61
+
; used: bool }
62
+
[@@deriving yojson {strict= false}]
63
+
64
+
type oauth_token =
65
+
{ refresh_token: string
66
+
; client_id: string
67
+
; did: string
68
+
; dpop_jkt: string
69
+
; scope: string
70
+
; expires_at: int }
71
+
[@@deriving yojson {strict= false}]
+1
-1
pegasus/lib/plc.ml
+1
-1
pegasus/lib/plc.ml
+11
-11
pegasus/lib/repository.ml
+11
-11
pegasus/lib/repository.ml
···
180
let%lwt map = get_map t in
181
String_map.bindings map
182
|> List.filter (fun (path, _) ->
183
-
String.starts_with ~prefix:(path ^ "/") collection )
184
|> Lwt_list.fold_left_s
185
(fun acc (path, cid) ->
186
match%lwt User_store.get_record t.db path with
···
320
let%lwt () =
321
match old_cid with
322
| Some _ -> (
323
-
match%lwt User_store.get_record t.db path with
324
-
| Some record ->
325
-
let refs =
326
-
Util.find_blob_refs record.value
327
-
|> List.map (fun (r : Mist.Blob_ref.t) -> r.ref)
328
-
in
329
-
let%lwt () = User_store.clear_blob_refs t.db path refs in
330
-
Lwt.return_unit
331
-
| None ->
332
-
Lwt.return_unit )
333
| None ->
334
Lwt.return_unit
335
in
···
180
let%lwt map = get_map t in
181
String_map.bindings map
182
|> List.filter (fun (path, _) ->
183
+
String.starts_with ~prefix:(path ^ "/") collection )
184
|> Lwt_list.fold_left_s
185
(fun acc (path, cid) ->
186
match%lwt User_store.get_record t.db path with
···
320
let%lwt () =
321
match old_cid with
322
| Some _ -> (
323
+
match%lwt User_store.get_record t.db path with
324
+
| Some record ->
325
+
let refs =
326
+
Util.find_blob_refs record.value
327
+
|> List.map (fun (r : Mist.Blob_ref.t) -> r.ref)
328
+
in
329
+
let%lwt () = User_store.clear_blob_refs t.db path refs in
330
+
Lwt.return_unit
331
+
| None ->
332
+
Lwt.return_unit )
333
| None ->
334
Lwt.return_unit
335
in
+28
-28
pegasus/lib/sequencer.ml
+28
-28
pegasus/lib/sequencer.ml
···
330
let blobs =
331
j |> member "blobs" |> to_list
332
|> List.filter_map (fun x ->
333
-
match Cid.of_yojson x with Ok c -> Some c | _ -> None )
334
in
335
let prev_data =
336
match j |> member "prevData" with
···
342
let ops =
343
j |> member "ops" |> to_list
344
|> List.map (fun opj ->
345
-
let action =
346
-
match opj |> member "action" |> to_string with
347
-
| "create" ->
348
-
`Create
349
-
| "update" ->
350
-
`Update
351
-
| "delete" ->
352
-
`Delete
353
-
| _ ->
354
-
`Create
355
-
in
356
-
let path = opj |> member "path" |> to_string in
357
-
let cid =
358
-
match opj |> member "cid" with
359
-
| `Null ->
360
-
None
361
-
| v -> (
362
-
match Cid.of_yojson v with Ok c -> Some c | _ -> None )
363
-
in
364
-
let prev =
365
-
match opj |> member "prev" with
366
-
| `Null ->
367
-
None
368
-
| v -> (
369
-
match Cid.of_yojson v with Ok c -> Some c | _ -> None )
370
-
in
371
-
{action; path; cid; prev} )
372
in
373
Ok
374
{ rebase
···
330
let blobs =
331
j |> member "blobs" |> to_list
332
|> List.filter_map (fun x ->
333
+
match Cid.of_yojson x with Ok c -> Some c | _ -> None )
334
in
335
let prev_data =
336
match j |> member "prevData" with
···
342
let ops =
343
j |> member "ops" |> to_list
344
|> List.map (fun opj ->
345
+
let action =
346
+
match opj |> member "action" |> to_string with
347
+
| "create" ->
348
+
`Create
349
+
| "update" ->
350
+
`Update
351
+
| "delete" ->
352
+
`Delete
353
+
| _ ->
354
+
`Create
355
+
in
356
+
let path = opj |> member "path" |> to_string in
357
+
let cid =
358
+
match opj |> member "cid" with
359
+
| `Null ->
360
+
None
361
+
| v -> (
362
+
match Cid.of_yojson v with Ok c -> Some c | _ -> None )
363
+
in
364
+
let prev =
365
+
match opj |> member "prev" with
366
+
| `Null ->
367
+
None
368
+
| v -> (
369
+
match Cid.of_yojson v with Ok c -> Some c | _ -> None )
370
+
in
371
+
{action; path; cid; prev} )
372
in
373
Ok
374
{ rebase
+56
pegasus/lib/templates/components/input.mlx
+56
pegasus/lib/templates/components/input.mlx
···
···
1
+
open JSX
2
+
3
+
(* putting this inline messes with ocamlformat-mlx *)
4
+
let req_marker = " *"
5
+
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
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
23
+
<div>
24
+
( match label with
25
+
| Some label ->
26
+
<div
27
+
class_=( "flex justify-between text-sm"
28
+
^ if sr_only then " sr-only" else "" )>
29
+
<label for_=id class_="text-mist-100">
30
+
( if required then
31
+
list
32
+
[ string label
33
+
; <span class_="text-phoenix-100">(string req_marker)</span>
34
+
]
35
+
else string label )
36
+
</label>
37
+
( if required then null
38
+
else <span class_="text-mist-80">"optional"</span> )
39
+
</div>
40
+
| None ->
41
+
null )
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> )
56
+
</div>
+11
pegasus/lib/templates/icons/circle_alert.mlx
+11
pegasus/lib/templates/icons/circle_alert.mlx
+16
pegasus/lib/templates/layout.mlx
+16
pegasus/lib/templates/layout.mlx
···
···
1
+
open JSX
2
+
3
+
let make ?(title = "Pegasus") ~children () =
4
+
<html lang="en">
5
+
<head>
6
+
<meta charset="utf-8" />
7
+
<meta name="viewport" content="width=device-width, initial-scale=1" />
8
+
<link rel="stylesheet" href="/public/index.css" />
9
+
<title>(string title)</title>
10
+
</head>
11
+
<body
12
+
class_="bg-feather-100 font-sans font-normal text-base tracking-normal \
13
+
flex items-center justify-center min-h-screen">
14
+
children
15
+
</body>
16
+
</html>
+35
pegasus/lib/templates/login.mlx
+35
pegasus/lib/templates/login.mlx
···
···
1
+
open JSX
2
+
open Components
3
+
4
+
let make ~redirect_url ?error ~csrf_token () =
5
+
<Layout title="Login">
6
+
<main class_="w-full h-auto max-w-xs px-4 sm:px-0">
7
+
<h1 class_="text-2xl font-serif text-mana-200 mb-2">"sign in"</h1>
8
+
<span class_="w-full text-balance text-mist-100">
9
+
"Enter your handle, email address, or DID, and your password."
10
+
</span>
11
+
<form method_="post" class_="w-full flex flex-col mt-4 mb-2 gap-y-2">
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 )
23
+
<Button type_="submit" class_="mt-2">"sign in"</Button>
24
+
</form>
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>
34
+
</main>
35
+
</Layout>
+2
-2
pegasus/lib/user_store.ml
+2
-2
pegasus/lib/user_store.ml
···
386
let get_record t path : record option Lwt.t =
387
Util.use_pool t.db @@ Queries.get_record ~path
388
>|= Option.map (fun (cid, data, since) ->
389
-
{path; cid; value= Lex.of_cbor data; since} )
390
391
let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection :
392
record list Lwt.t =
···
395
in
396
Util.use_pool t.db @@ fn ~collection ~limit ~cursor
397
>|= List.map (fun (path, cid, data, since) ->
398
-
{path; cid; value= Lex.of_cbor data; since} )
399
400
let put_record t record path : (Cid.t * bytes) Lwt.t =
401
let cid, data = Lex.to_cbor_block record in
···
386
let get_record t path : record option Lwt.t =
387
Util.use_pool t.db @@ Queries.get_record ~path
388
>|= Option.map (fun (cid, data, since) ->
389
+
{path; cid; value= Lex.of_cbor data; since} )
390
391
let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection :
392
record list Lwt.t =
···
395
in
396
Util.use_pool t.db @@ fn ~collection ~limit ~cursor
397
>|= List.map (fun (path, cid, data, since) ->
398
+
{path; cid; value= Lex.of_cbor data; since} )
399
400
let put_record t record path : (Cid.t * bytes) Lwt.t =
401
let cid, data = Lex.to_cbor_block record in
+59
-19
pegasus/lib/util.ml
+59
-19
pegasus/lib/util.ml
···
287
let is_none = function None -> true | _ -> false
288
289
let validate_handle handle =
290
-
if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then
291
-
Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix"))
292
else
293
-
let front =
294
-
String.sub handle 0
295
-
(String.length handle - (String.length Env.hostname + 1))
296
-
in
297
-
if String.contains front '.' then
298
-
Error
299
-
(Errors.InvalidRequestError
300
-
("InvalidHandle", "invalid characters in handle") )
301
-
else
302
-
match String.length front with
303
-
| l when l < 3 ->
304
-
Error
305
-
(Errors.InvalidRequestError ("InvalidHandle", "handle too short"))
306
-
| l when l > 18 ->
307
-
Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long"))
308
-
| _ ->
309
-
Ok ()
310
311
let mkfile_p path ~perm =
312
Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ;
···
324
valid )
325
did_keys
326
<> None
···
287
let is_none = function None -> true | _ -> false
288
289
let validate_handle handle =
290
+
let front =
291
+
String.sub handle 0 (String.length handle - (String.length Env.hostname + 1))
292
+
in
293
+
if String.contains front '.' then
294
+
Error
295
+
(Errors.InvalidRequestError
296
+
("InvalidHandle", "invalid characters in handle") )
297
else
298
+
match String.length front with
299
+
| l when l < 3 ->
300
+
Error (Errors.InvalidRequestError ("InvalidHandle", "handle too short"))
301
+
| l when l > 18 ->
302
+
Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long"))
303
+
| _ ->
304
+
Ok ()
305
306
let mkfile_p path ~perm =
307
Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ;
···
319
valid )
320
did_keys
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]))
+33
-15
pegasus/lib/xrpc.ml
+33
-15
pegasus/lib/xrpc.ml
···
10
let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =
11
let open Errors in
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
25
26
let parse_query (req : Dream.request)
27
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =
···
29
let queries = Dream.all_queries req in
30
let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in
31
query_json |> of_yojson |> Result.get_ok
32
-
with _ -> Errors.invalid_request "Invalid query string"
33
34
let parse_body (req : Dream.request)
35
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
36
try%lwt
37
let%lwt body = Dream.body req in
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"
42
43
let service_proxy (ctx : context) (proxy_header : string) =
44
let did = Auth.get_authed_did_exn ctx.auth in
···
87
let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in
88
match Dream.method_ ctx.req with
89
| `GET -> (
90
-
let%lwt res, body = Client.get uri ~headers in
91
match res.status with
92
| `OK ->
93
let%lwt body = Body.to_string body in
···
121
let service_proxy_middleware db inner_handler req =
122
match Dream.header req "atproto-proxy" with
123
| Some header ->
124
-
handler ~auth:Access (fun ctx -> service_proxy ctx header) {req; db}
125
| None ->
126
inner_handler req
127
128
let resolve_repo_did ctx repo =
129
if String.starts_with ~prefix:"did:" repo then Lwt.return repo
···
10
let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =
11
let open Errors in
12
let auth = Auth.Verifiers.of_t auth in
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
26
let parse_query (req : Dream.request)
27
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =
···
29
let queries = Dream.all_queries req in
30
let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in
31
query_json |> of_yojson |> Result.get_ok
32
+
with _ -> Errors.invalid_request "invalid query string"
33
34
let parse_body (req : Dream.request)
35
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
36
try%lwt
37
let%lwt body = Dream.body req in
38
body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return
39
+
with _ -> Errors.invalid_request "invalid request body"
40
41
let service_proxy (ctx : context) (proxy_header : string) =
42
let did = Auth.get_authed_did_exn ctx.auth in
···
85
let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in
86
match Dream.method_ ctx.req with
87
| `GET -> (
88
+
let%lwt res, body = Util.http_get uri ~headers in
89
match res.status with
90
| `OK ->
91
let%lwt body = Body.to_string body in
···
119
let service_proxy_middleware db inner_handler req =
120
match Dream.header req "atproto-proxy" with
121
| Some header ->
122
+
handler ~auth:Authorization (fun ctx -> service_proxy ctx header) {req; db}
123
| None ->
124
inner_handler req
125
+
126
+
let dpop_middleware inner_handler req =
127
+
let%lwt res = inner_handler req in
128
+
match Dream.header req "DPoP" with
129
+
| Some _ ->
130
+
Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;
131
+
Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ;
132
+
Lwt.return res
133
+
| None ->
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
145
146
let resolve_repo_did ctx repo =
147
if String.starts_with ~prefix:"did:" repo then Lwt.return repo
public/fonts/Fragment.woff
public/fonts/Fragment.woff
This is a binary file and will not be displayed.
public/fonts/Fragment.woff2
public/fonts/Fragment.woff2
This is a binary file and will not be displayed.
+48
public/main.css
+48
public/main.css
···
···
1
+
@import "tailwindcss" source("../pegasus/lib/templates");
2
+
3
+
@font-face {
4
+
font-family: "Fragment";
5
+
src:
6
+
url("fonts/Fragment.woff2") format("woff2"),
7
+
url("fonts/Fragment.woff") format("woff");
8
+
font-weight: normal;
9
+
font-style: normal;
10
+
font-display: swap;
11
+
}
12
+
13
+
@font-face {
14
+
font-family: "Geist";
15
+
src: url("https://fonts.gstatic.com/s/geist/v4/gyByhwUxId8gMEwcGFWNOITd.woff2")
16
+
format("woff2");
17
+
font-weight: 300 400;
18
+
font-style: normal;
19
+
font-display: swap;
20
+
}
21
+
22
+
@theme {
23
+
--font-serif: Fragment, Georgia, "Times New Roman", Times, serif;
24
+
--font-sans: Geist, Helvetica, -apple-system, system-ui, sans-serif;
25
+
--font-weight-normal: 300;
26
+
--font-weight-medium: 400;
27
+
28
+
--tracking-normal: 0.01em;
29
+
30
+
--color-*: initial;
31
+
--color-white: #fff;
32
+
--color-feather-100: #c8cfd2;
33
+
--color-phoenix-40: #e499a6;
34
+
--color-phoenix-100: #db4c64;
35
+
--color-mana-40: #9b9eaa;
36
+
--color-mana-100: #6558a1;
37
+
--color-mana-200: #312b4d;
38
+
--color-mist-20: #ecedf8;
39
+
--color-mist-40: #dee1e3;
40
+
--color-mist-60: #a4a9ac;
41
+
--color-mist-80: #737579;
42
+
--color-mist-100: #4f4f53;
43
+
44
+
--shadow-whisper: inset 0 0 1em #97baff8c;
45
+
--shadow-shimmer: inset 0 0 1em #79a7ed99;
46
+
--shadow-glow: inset 0 0 2em #2d37ba73;
47
+
--shadow-bleed: inset 0 0 2em #db4c6466;
48
+
}
+27
tailwindcss.opam
+27
tailwindcss.opam
···
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
maintainer: ["futurGH"]
4
+
authors: ["futurGH"]
5
+
license: "MPL-2.0"
6
+
homepage: "https://github.com/futurGH/pegasus"
7
+
bug-reports: "https://github.com/futurGH/pegasus/issues"
8
+
depends: [
9
+
"dune" {>= "3.20"}
10
+
"odoc" {with-doc}
11
+
]
12
+
build: [
13
+
["dune" "subst"] {dev}
14
+
[
15
+
"dune"
16
+
"build"
17
+
"-p"
18
+
name
19
+
"-j"
20
+
jobs
21
+
"@install"
22
+
"@runtest" {with-test}
23
+
"@doc" {with-doc}
24
+
]
25
+
]
26
+
dev-repo: "git+https://github.com/futurGH/pegasus.git"
27
+
x-maintenance-intent: ["(latest)"]
+88
tools/tailwindcss/dune
+88
tools/tailwindcss/dune
···
···
1
+
(rule
2
+
(target tailwindcss-linux-x64)
3
+
(action
4
+
(progn
5
+
(with-stdout-to
6
+
%{target}
7
+
(bash
8
+
"cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))
9
+
(run chmod +x %{target}))))
10
+
11
+
(rule
12
+
(target tailwindcss-linux-arm64)
13
+
(action
14
+
(progn
15
+
(with-stdout-to
16
+
%{target}
17
+
(bash
18
+
"cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))
19
+
(run chmod +x %{target}))))
20
+
21
+
(rule
22
+
(target tailwindcss-macos-x64)
23
+
(action
24
+
(progn
25
+
(with-stdout-to
26
+
%{target}
27
+
(bash
28
+
"cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))
29
+
(run chmod +x %{target}))))
30
+
31
+
(rule
32
+
(target tailwindcss-macos-arm64)
33
+
(action
34
+
(progn
35
+
(with-stdout-to
36
+
%{target}
37
+
(bash
38
+
"cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))
39
+
(run chmod +x %{target}))))
40
+
41
+
(rule
42
+
(enabled_if
43
+
(and
44
+
(= %{architecture} amd64)
45
+
(= %{system} linux)))
46
+
(target tailwindcss)
47
+
(deps tailwindcss-linux-x64)
48
+
(action
49
+
(copy %{deps} tailwindcss)))
50
+
51
+
(rule
52
+
(enabled_if
53
+
(and
54
+
(= %{architecture} arm64)
55
+
(= %{system} linux)))
56
+
(target tailwindcss)
57
+
(deps tailwindcss-linux-arm64)
58
+
(action
59
+
(copy %{deps} tailwindcss)))
60
+
61
+
(rule
62
+
(enabled_if
63
+
(and
64
+
(= %{architecture} amd64)
65
+
(= %{system} macosx)))
66
+
(target tailwindcss)
67
+
(deps tailwindcss-macos-x64)
68
+
(action
69
+
(copy %{deps} tailwindcss)))
70
+
71
+
(rule
72
+
(enabled_if
73
+
(and
74
+
(= %{architecture} arm64)
75
+
(= %{system} macosx)))
76
+
(target tailwindcss)
77
+
(deps tailwindcss-macos-arm64)
78
+
(action
79
+
(copy %{deps} tailwindcss)))
80
+
81
+
(alias
82
+
(name default)
83
+
(deps tailwindcss))
84
+
85
+
(install
86
+
(section bin)
87
+
(package tailwindcss)
88
+
(files tailwindcss))