Implement OAuth #2

+1

.ocamlformat

··· 1 1 profile = ocamlformat 2 2 + version = 0.27.0

+2 -25

bin/main.ml

··· 7 7 ; (get, "/robots.txt", Api.Robots.handler) 8 8 ; (get, "/xrpc/_health", Api.Health.handler) 9 9 ; (get, "/.well-known/did.json", Api.Well_known.did_json) 10 10 - ; ( get 11 11 - , "/.well-known/oauth-protected-resource" 12 12 - , Api.Well_known.oauth_protected_resource ) 13 13 - ; ( get 14 14 - , "/.well-known/oauth-authorization-server" 15 15 - , Api.Well_known.oauth_authorization_server ) 16 16 - ; (* oauth *) 17 17 - (options, "/oauth/par", Api.Oauth_.Par.options_handler) 18 18 - ; (post, "/oauth/par", Api.Oauth_.Par.post_handler) 19 19 - ; (get, "/oauth/authorize", Api.Oauth_.Authorize.get_handler) 20 20 - ; (post, "/oauth/authorize", Api.Oauth_.Authorize.post_handler) 21 21 - ; (options, "/oauth/token", Api.Oauth_.Token.options_handler) 22 22 - ; (post, "/oauth/token", Api.Oauth_.Token.post_handler) 23 23 - ; (* account *) 24 24 - (get, "/account/login", Api.Account_.Login.get_handler) 25 25 - ; (post, "/account/login", Api.Account_.Login.post_handler) 26 26 - ; (get, "/account/logout", Api.Account_.Logout.handler) 27 10 ; (* unauthed *) 28 11 ( get 29 12 , "/xrpc/com.atproto.server.describeServer" ··· 32 15 ; ( get 33 16 , "/xrpc/com.atproto.identity.resolveHandle" 34 17 , Api.Identity.ResolveHandle.handler ) 35 35 - ; (* account management *) 18 18 + ; (* account *) 36 19 ( post 37 20 , "/xrpc/com.atproto.server.createInviteCode" 38 21 , Api.Server.CreateInviteCode.handler ) ··· 82 65 , "/xrpc/com.atproto.actor.putPreferences" 83 66 , Api.Actor.PutPreferences.handler ) ] 84 67 85 85 - let static_routes = 86 86 - [Dream.get "/public/**" (Dream.static "_build/default/public")] 87 87 - 88 68 let main = 89 69 let%lwt db = Data_store.connect ~create:true () in 90 70 let%lwt () = Data_store.init db in 91 71 Dream.serve ~interface:"0.0.0.0" ~port:8008 92 72 @@ Dream.logger 93 93 - @@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey) 94 94 - @@ Dream.cookie_sessions 95 73 @@ Xrpc.service_proxy_middleware db 96 96 - @@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router 74 74 + @@ Dream.router 97 75 @@ List.map 98 76 (fun (fn, path, handler) -> 99 77 fn path (fun req -> handler ({req; db} : Xrpc.init)) ) 100 78 handlers 101 101 - @ static_routes 102 79 103 80 let () = Lwt_main.run main

-21

dune

··· 1 1 - (subdir 2 2 - public/ 3 3 - (rule 4 4 - (target index.css) 5 5 - (deps 6 6 - %{workspace_root}/tools/tailwindcss/tailwindcss 7 7 - (:input %{workspace_root}/public/main.css) 8 8 - (source_tree %{workspace_root}/public) 9 9 - (source_tree %{workspace_root}/pegasus/lib/templates)) 10 10 - (action 11 11 - (chdir 12 12 - %{workspace_root} 13 13 - (run 14 14 - %{workspace_root}/tools/tailwindcss/tailwindcss 15 15 - -m 16 16 - -i 17 17 - %{input} 18 18 - -o 19 19 - %{target}))))) 20 20 - 21 21 - (copy_files public/*)

+2 -18

dune-project

··· 30 30 (url "git+https://github.com/roddyyaga/ppx_rapper.git") 31 31 (package (name ppx_rapper_lwt))) 32 32 33 33 - 34 33 (package 35 34 (name pegasus) 36 35 (synopsis "An atproto Personal Data Server implementation") ··· 47 46 (cohttp-lwt-unix (>= 6.1.1)) 48 47 (dns-client (>= 10.2.0)) 49 48 dream 50 50 - html_of_jsx 51 51 - mlx 49 49 + (jwto (>= 0.4.0)) 52 50 (re (>= 1.13.2)) 53 51 (safepass (>= 3.1)) 54 52 (timedesc (>= 3.1.0)) 55 55 - (uri (>= 4.4.0)) 56 53 (uuidm (>= 0.9.10)) 57 54 (yojson (>= 3.0.0)) 58 55 (lwt_ppx (>= 5.9.1)) 59 56 (ppx_deriving_yojson (>= 3.9.1)) 60 57 ppx_rapper 61 58 ppx_rapper_lwt 62 62 - (alcotest :with-test) 63 63 - (ocamlformat-mlx :with-dev-setup) 64 64 - (ocamlmerlin-mlx :with-dev-setup))) 59 59 + (alcotest :with-test))) 65 60 66 61 (package 67 62 (name mist) ··· 103 98 (hacl-star (>= 0.7.2)) 104 99 (mirage-crypto-ec (>= 2.0.1)) 105 100 (multibase (>= 0.1.0)))) 106 106 - 107 107 - (package 108 108 - (name tailwindcss) (allow_empty)) 109 109 - 110 110 - (dialect 111 111 - (name mlx) 112 112 - (implementation 113 113 - (extension mlx) 114 114 - (merlin_reader mlx) 115 115 - (preprocess 116 116 - (run mlx-pp %{input-file}))))

+2 -2

ipld/lib/dag_cbor.ml

··· 197 197 write_type_and_argument t 5 (Int64.of_int len) ; 198 198 ordered_map_keys m 199 199 |> List.iter (fun k -> 200 200 - write_string t k ; 201 201 - write_value t (String_map.find k m) ) 200 200 + write_string t k ; 201 201 + write_value t (String_map.find k m) ) 202 202 | `Link cid -> 203 203 write_cid t cid 204 204

+4 -4

ipld/test/test_dag_cbor.ml

··· 3 3 let rec stringify_map m = 4 4 String_map.bindings m 5 5 |> List.map (fun (k, v) -> 6 6 - Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) ) 6 6 + Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) ) 7 7 |> String.concat ", " |> Format.sprintf "{%s}" 8 8 9 9 and stringify_ipld_value (value : Dag_cbor.value) = ··· 109 109 Hashtbl.add cases (to_base_16 (Dag_cbor.encode `Null)) (Bytes.of_string "f6") ; 110 110 cases 111 111 |> Hashtbl.iter (fun key value -> 112 112 - Alcotest.(check bytes) 113 113 - ("encoded bytes for " ^ key) 114 114 - value (Bytes.of_string key) ) 112 112 + Alcotest.(check bytes) 113 113 + ("encoded bytes for " ^ key) 114 114 + value (Bytes.of_string key) ) 115 115 116 116 let test_round_trip () = 117 117 let test_cid =

-8

kleidos/kleidos.ml

··· 213 213 let privkey, (module Curve : CURVE) = privkey in 214 214 Curve.sign ~privkey ~msg 215 215 216 216 - let verify ~pubkey ~msg ~signature : bool = 217 217 - let pubkey, (module Curve : CURVE) = pubkey in 218 218 - Curve.verify ~pubkey ~msg ~signature 219 219 - 220 216 let pubkey_to_did_key pubkey : string = 221 217 let pubkey, (module Curve : CURVE) = pubkey in 222 218 Curve.pubkey_to_did_key pubkey 223 223 - 224 224 - let privkey_to_multikey privkey : string = 225 225 - let privkey, (module Curve : CURVE) = privkey in 226 226 - Curve.privkey_to_multikey privkey

+33 -34

mist/lib/mst.ml

··· 239 239 | None, [] -> 240 240 Lwt.return 0 241 241 | Some left, [] -> ( 242 242 - match%lwt retrieve_node_raw t left with 243 243 - | Some node -> 244 244 - let%lwt height = get_node_height t node in 245 245 - Lwt.return (height + 1) 246 246 - | None -> 247 247 - failwith ("couldn't find node " ^ Cid.to_string left) ) 242 242 + match%lwt retrieve_node_raw t left with 243 243 + | Some node -> 244 244 + let%lwt height = get_node_height t node in 245 245 + Lwt.return (height + 1) 246 246 + | None -> 247 247 + failwith ("couldn't find node " ^ Cid.to_string left) ) 248 248 | _, leaf :: _ -> ( 249 249 match leaf.p with 250 250 | 0 -> ··· 497 497 let%lwt blocks = 498 498 match Util.at_index index seq with 499 499 | Some (Leaf (k, v, _)) when k = key -> ( 500 500 - (* include the found leaf block to prove existence *) 501 501 - match%lwt 502 502 - Store.get_bytes t.blockstore v 503 503 - with 504 504 - | Some leaf_bytes -> 505 505 - Lwt.return (Block_map.set v leaf_bytes Block_map.empty) 506 506 - | None -> 507 507 - Lwt.return Block_map.empty ) 500 500 + (* include the found leaf block to prove existence *) 501 501 + match%lwt Store.get_bytes t.blockstore v with 502 502 + | Some leaf_bytes -> 503 503 + Lwt.return (Block_map.set v leaf_bytes Block_map.empty) 504 504 + | None -> 505 505 + Lwt.return Block_map.empty ) 508 506 | _ -> ( 509 507 let prev = 510 508 if index - 1 >= 0 then Util.at_index (index - 1) seq else None ··· 531 529 let%lwt bm = 532 530 match left_leaf with 533 531 | Some cid_left -> ( 534 534 - match%lwt Store.get_bytes t.blockstore cid_left with 535 535 - | Some b -> 536 536 - Lwt.return (Block_map.set cid_left b Block_map.empty) 537 537 - | None -> 538 538 - Lwt.return Block_map.empty ) 532 532 + match%lwt Store.get_bytes t.blockstore cid_left with 533 533 + | Some b -> 534 534 + Lwt.return 535 535 + (Block_map.set cid_left b Block_map.empty) 536 536 + | None -> 537 537 + Lwt.return Block_map.empty ) 539 538 | None -> 540 539 Lwt.return Block_map.empty 541 540 in 542 541 let%lwt bm = 543 542 match right_leaf with 544 543 | Some cid_right -> ( 545 545 - match%lwt Store.get_bytes t.blockstore cid_right with 546 546 - | Some b -> 547 547 - Lwt.return (Block_map.set cid_right b bm) 548 548 - | None -> 549 549 - Lwt.return bm ) 544 544 + match%lwt Store.get_bytes t.blockstore cid_right with 545 545 + | Some b -> 546 546 + Lwt.return (Block_map.set cid_right b bm) 547 547 + | None -> 548 548 + Lwt.return bm ) 550 549 | None -> 551 550 Lwt.return bm 552 551 in ··· 572 571 | Some (Tree c) -> 573 572 proof_for_left_sibling t c key 574 573 | Some (Leaf (_, v_left, _)) -> ( 575 575 - match%lwt Store.get_bytes t.blockstore v_left with 576 576 - | Some b -> 577 577 - Lwt.return (Block_map.set v_left b Block_map.empty) 578 578 - | None -> 579 579 - Lwt.return Block_map.empty ) 574 574 + match%lwt Store.get_bytes t.blockstore v_left with 575 575 + | Some b -> 576 576 + Lwt.return (Block_map.set v_left b Block_map.empty) 577 577 + | None -> 578 578 + Lwt.return Block_map.empty ) 580 579 | _ -> 581 580 Lwt.return Block_map.empty 582 581 in ··· 613 612 | Some (Tree c) -> 614 613 proof_for_right_sibling t c key 615 614 | Some (Leaf (_, v_right, _)) -> ( 616 616 - match%lwt Store.get_bytes t.blockstore v_right with 617 617 - | Some b -> 618 618 - Lwt.return (Block_map.set v_right b Block_map.empty) 619 619 - | None -> 620 620 - Lwt.return Block_map.empty ) 615 615 + match%lwt Store.get_bytes t.blockstore v_right with 616 616 + | Some b -> 617 617 + Lwt.return (Block_map.set v_right b Block_map.empty) 618 618 + | None -> 619 619 + Lwt.return Block_map.empty ) 621 620 | _ -> 622 621 Lwt.return Block_map.empty ) 623 622 | None ->

+7 -7

mist/test/test_util.ml

··· 8 8 Hashtbl.add cases "app.bsky.feed.post/9adeb165882c" 8 ; 9 9 cases 10 10 |> Hashtbl.iter (fun key value -> 11 11 - Alcotest.(check int) 12 12 - ("leading zeros on hash " ^ key) 13 13 - value 14 14 - (leading_zeros_on_hash key) ) 11 11 + Alcotest.(check int) 12 12 + ("leading zeros on hash " ^ key) 13 13 + value 14 14 + (leading_zeros_on_hash key) ) 15 15 16 16 let test_shared_prefix_length () = 17 17 let cases = Hashtbl.create 5 in ··· 22 22 Hashtbl.add cases ("2653ae71", "0653ae71") 0 ; 23 23 cases 24 24 |> Hashtbl.iter (fun (a, b) value -> 25 25 - Alcotest.(check int) 26 26 - ("prefix length between " ^ a ^ " and " ^ b) 27 27 - value (shared_prefix_length a b) ) 25 25 + Alcotest.(check int) 26 26 + ("prefix length between " ^ a ^ " and " ^ b) 27 27 + value (shared_prefix_length a b) ) 28 28 29 29 let () = 30 30 Alcotest.run "util"

+1 -5

pegasus.opam

··· 18 18 "cohttp-lwt-unix" {>= "6.1.1"} 19 19 "dns-client" {>= "10.2.0"} 20 20 "dream" 21 21 - "html_of_jsx" 22 22 - "mlx" 21 21 + "jwto" {>= "0.4.0"} 23 22 "re" {>= "1.13.2"} 24 23 "safepass" {>= "3.1"} 25 24 "timedesc" {>= "3.1.0"} 26 26 - "uri" {>= "4.4.0"} 27 25 "uuidm" {>= "0.9.10"} 28 26 "yojson" {>= "3.0.0"} 29 27 "lwt_ppx" {>= "5.9.1"} ··· 31 29 "ppx_rapper" 32 30 "ppx_rapper_lwt" 33 31 "alcotest" {with-test} 34 34 - "ocamlformat-mlx" {with-dev-setup} 35 35 - "ocamlmerlin-mlx" {with-dev-setup} 36 32 "odoc" {with-doc} 37 33 ] 38 34 build: [

-49

pegasus/lib/api/account_/login.ml

··· 1 1 - let get_handler = 2 2 - Xrpc.handler (fun ctx -> 3 3 - let redirect_url = 4 4 - if List.length @@ Dream.all_queries ctx.req > 0 then 5 5 - Uri.make ~path:"/oauth/authorize" ~query:(Util.copy_query ctx.req) () 6 6 - |> Uri.to_string 7 7 - else "/account" 8 8 - in 9 9 - let csrf_token = Dream.csrf_token ctx.req in 10 10 - let html = 11 11 - JSX.render (Templates.Login.make ~redirect_url ~csrf_token ()) 12 12 - in 13 13 - Dream.html html ) 14 14 - 15 15 - let post_handler = 16 16 - Xrpc.handler (fun ctx -> 17 17 - let csrf_token = Dream.csrf_token ctx.req in 18 18 - match%lwt Dream.form ctx.req with 19 19 - | `Ok fields -> ( 20 20 - let identifier = List.assoc "identifier" fields in 21 21 - let password = List.assoc "password" fields in 22 22 - let redirect_url = 23 23 - List.assoc_opt "redirect_url" fields 24 24 - |> Option.value ~default:"/account" 25 25 - in 26 26 - let%lwt actor = 27 27 - Data_store.try_login ~id:identifier ~password ctx.db 28 28 - in 29 29 - match actor with 30 30 - | None -> 31 31 - let html = 32 32 - JSX.render 33 33 - (Templates.Login.make ~redirect_url 34 34 - ~error:"Invalid username or password. Please try again." 35 35 - ~csrf_token () ) 36 36 - in 37 37 - Dream.html ~status:`Unauthorized html 38 38 - | Some {did; _} -> 39 39 - let%lwt () = Dream.invalidate_session ctx.req in 40 40 - let%lwt () = Dream.set_session_field ctx.req "did" did in 41 41 - Dream.redirect ctx.req redirect_url ) 42 42 - | _ -> 43 43 - let html = 44 44 - JSX.render 45 45 - (Templates.Login.make ~redirect_url:"/account" 46 46 - ~error:"Invalid credentials provided. Please try again." 47 47 - ~csrf_token () ) 48 48 - in 49 49 - Dream.html ~status:`Unauthorized html )

-4

pegasus/lib/api/account_/logout.ml

··· 1 1 - let handler = 2 2 - Xrpc.handler (fun ctx -> 3 3 - let%lwt () = Dream.invalidate_session ctx.req in 4 4 - Dream.redirect ctx.req "/account/login" )

+1 -1

pegasus/lib/api/actor/putPreferences.ml

··· 1 1 let handler = 2 2 - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> 2 2 + Xrpc.handler ~auth:Authorization (fun {req; db; auth} -> 3 3 let did = Auth.get_authed_did_exn auth in 4 4 let%lwt body = Dream.body req in 5 5 let prefs =

+6 -6

pegasus/lib/api/identity/resolveHandle.ml

··· 14 14 Dream.json @@ Yojson.Safe.to_string 15 15 @@ response_to_yojson {did= actor.did} 16 16 | None -> ( 17 17 - match%lwt Id_resolver.Handle.resolve handle with 18 18 - | Ok did -> 19 19 - Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did} 20 20 - | Error e -> 21 21 - Errors.log_exn (Failure e) ; 22 22 - Errors.internal_error ~msg:"could not resolve handle" () ) ) 17 17 + match%lwt Id_resolver.Handle.resolve handle with 18 18 + | Ok did -> 19 19 + Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did} 20 20 + | Error e -> 21 21 + Errors.log_exn (Failure e) ; 22 22 + Errors.internal_error ~msg:"could not resolve handle" () ) )

+58 -55

pegasus/lib/api/identity/updateHandle.ml

··· 1 1 type request = {handle: string} [@@deriving yojson] 2 2 3 3 let handler = 4 4 - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> 4 4 + Xrpc.handler ~auth:Authorization (fun {req; auth; db} -> 5 5 let did = Auth.get_authed_did_exn auth in 6 6 let%lwt body = Dream.body req in 7 7 let handle = ··· 15 15 | Error e -> 16 16 raise e 17 17 | Ok () -> ( 18 18 - match%lwt Data_store.get_actor_by_identifier handle db with 19 19 - | Some _ -> 20 20 - Errors.invalid_request ~name:"InvalidHandle" "handle already in use" 21 21 - | None -> 22 22 - let%lwt () = Data_store.update_actor_handle ~did ~handle db in 23 23 - let%lwt _ = 24 24 - if String.starts_with ~prefix:"did:plc:" did then 25 25 - match%lwt Plc.get_audit_log did with 26 26 - | Error e -> 27 27 - Dream.error (fun log -> log ~request:req "%s" e) ; 28 28 - Errors.internal_error ~msg:"failed to fetch did doc" () 29 29 - | Ok log -> ( 30 30 - let latest = List.rev log |> List.hd in 31 31 - let aka = 32 32 - match 33 33 - List.mem ("at://" ^ handle) 34 34 - latest.operation.also_known_as 35 35 - with 36 36 - | true -> 37 37 - latest.operation.also_known_as 38 38 - | false -> 39 39 - ("at://" ^ handle) :: latest.operation.also_known_as 40 40 - in 41 41 - let%lwt signing_key = 42 42 - match%lwt Data_store.get_actor_by_identifier did db with 43 43 - | Some {signing_key; _} -> 44 44 - Lwt.return @@ Kleidos.parse_multikey_str signing_key 45 45 - | _ -> 46 46 - Errors.internal_error () 47 47 - in 48 48 - let signed = 49 49 - Plc.sign_operation signing_key 50 50 - (Operation 51 51 - { type'= "plc_operation" 52 52 - ; prev= Some latest.cid 53 53 - ; also_known_as= aka 54 54 - ; rotation_keys= latest.operation.rotation_keys 55 55 - ; verification_methods= 56 56 - latest.operation.verification_methods 57 57 - ; services= latest.operation.services } ) 58 58 - in 59 59 - match%lwt Plc.submit_operation did signed with 60 60 - | Ok _ -> 61 61 - Lwt.return_unit 62 62 - | Error (status, msg) -> 63 63 - Dream.error (fun log -> 64 64 - log ~request:req "%d %s" status msg ) ; 65 65 - Errors.internal_error 66 66 - ~msg:"failed to submit plc operation" () ) 67 67 - else Lwt.return_unit 68 68 - in 69 69 - let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in 70 70 - let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in 71 71 - Dream.empty `OK ) ) 18 18 + match%lwt Data_store.get_actor_by_identifier handle db with 19 19 + | Some _ -> 20 20 + Errors.invalid_request ~name:"InvalidHandle" 21 21 + "handle already in use" 22 22 + | None -> 23 23 + let%lwt () = Data_store.update_actor_handle ~did ~handle db in 24 24 + let%lwt _ = 25 25 + if String.starts_with ~prefix:"did:plc:" did then 26 26 + match%lwt Plc.get_audit_log did with 27 27 + | Error e -> 28 28 + Dream.error (fun log -> log ~request:req "%s" e) ; 29 29 + Errors.internal_error ~msg:"failed to fetch did doc" () 30 30 + | Ok log -> ( 31 31 + let latest = List.rev log |> List.hd in 32 32 + let aka = 33 33 + match 34 34 + List.mem ("at://" ^ handle) 35 35 + latest.operation.also_known_as 36 36 + with 37 37 + | true -> 38 38 + latest.operation.also_known_as 39 39 + | false -> 40 40 + ("at://" ^ handle) :: latest.operation.also_known_as 41 41 + in 42 42 + let%lwt signing_key = 43 43 + match%lwt Data_store.get_actor_by_identifier did db with 44 44 + | Some {signing_key; _} -> 45 45 + Lwt.return @@ Kleidos.parse_multikey_str signing_key 46 46 + | _ -> 47 47 + Errors.internal_error () 48 48 + in 49 49 + let signed = 50 50 + Plc.sign_operation signing_key 51 51 + (Operation 52 52 + { type'= "plc_operation" 53 53 + ; prev= Some latest.cid 54 54 + ; also_known_as= aka 55 55 + ; rotation_keys= latest.operation.rotation_keys 56 56 + ; verification_methods= 57 57 + latest.operation.verification_methods 58 58 + ; services= latest.operation.services } ) 59 59 + in 60 60 + match%lwt Plc.submit_operation did signed with 61 61 + | Ok _ -> 62 62 + Lwt.return_unit 63 63 + | Error (status, msg) -> 64 64 + Dream.error (fun log -> 65 65 + log ~request:req "%d %s" status msg ) ; 66 66 + Errors.internal_error 67 67 + ~msg:"failed to submit plc operation" () ) 68 68 + else Lwt.return_unit 69 69 + in 70 70 + let () = 71 71 + Ttl_cache.String_cache.remove Id_resolver.Did.cache did 72 72 + in 73 73 + let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in 74 74 + Dream.empty `OK ) )

-184

pegasus/lib/api/oauth_/authorize.ml

··· 1 1 - open Oauth 2 2 - open Oauth.Types 3 3 - 4 4 - let get_session_user (ctx : Xrpc.context) = 5 5 - match Dream.session_field ctx.req "did" with 6 6 - | Some did -> 7 7 - Lwt.return_some did 8 8 - | None -> 9 9 - Lwt.return_none 10 10 - 11 11 - let get_handler = 12 12 - Xrpc.handler (fun ctx -> 13 13 - let login_redirect = 14 14 - Uri.make ~path:"/account/login" ~query:(Util.copy_query ctx.req) () 15 15 - |> Uri.to_string |> Dream.redirect ctx.req 16 16 - in 17 17 - let client_id = Dream.query ctx.req "client_id" in 18 18 - let request_uri = Dream.query ctx.req "request_uri" in 19 19 - match (client_id, request_uri) with 20 20 - | None, _ | _, None -> 21 21 - login_redirect 22 22 - | Some client_id, Some request_uri -> ( 23 23 - let prefix = Constants.request_uri_prefix in 24 24 - if not (String.starts_with ~prefix request_uri) then login_redirect 25 25 - else 26 26 - let request_id = 27 27 - String.sub request_uri (String.length prefix) 28 28 - (String.length request_uri - String.length prefix) 29 29 - in 30 30 - match%lwt Queries.get_par_request ctx.db request_id with 31 31 - | None -> 32 32 - login_redirect 33 33 - | Some req_record -> ( 34 34 - if req_record.client_id <> client_id then login_redirect 35 35 - else 36 36 - let req = 37 37 - Yojson.Safe.from_string req_record.request_data 38 38 - |> par_request_of_yojson 39 39 - |> Result.map_error (fun _ -> 40 40 - Errors.internal_error ~msg:"failed to parse par request" 41 41 - () ) 42 42 - |> Result.get_ok 43 43 - in 44 44 - let%lwt metadata = 45 45 - try%lwt Client.fetch_client_metadata client_id 46 46 - with _ -> 47 47 - Errors.internal_error 48 48 - ~msg:"failed to fetch client metadata" () 49 49 - in 50 50 - let code = 51 51 - "cod-" 52 52 - ^ Uuidm.to_string 53 53 - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 54 54 - in 55 55 - let expires_at = Util.now_ms () + Constants.code_expiry_ms in 56 56 - let%lwt () = 57 57 - Queries.insert_auth_code ctx.db 58 58 - { code 59 59 - ; request_id 60 60 - ; authorized_by= None 61 61 - ; authorized_at= None 62 62 - ; expires_at 63 63 - ; used= false } 64 64 - in 65 65 - match%lwt get_session_user ctx with 66 66 - | None -> 67 67 - login_redirect 68 68 - | Some did -> ( 69 69 - match req.login_hint with 70 70 - | Some hint when hint <> did -> 71 71 - login_redirect 72 72 - | _ -> 73 73 - let%lwt handle = 74 74 - match%lwt 75 75 - Data_store.get_actor_by_identifier did ctx.db 76 76 - with 77 77 - | Some {handle; _} -> 78 78 - Lwt.return handle 79 79 - | None -> 80 80 - Errors.internal_error 81 81 - ~msg:"failed to resolve user" () 82 82 - in 83 83 - let scopes = String.split_on_char ' ' req.scope in 84 84 - let csrf_token = Dream.csrf_token ctx.req in 85 85 - let html = 86 86 - JSX.render 87 87 - (Templates.Oauth_authorize.make ~metadata ~handle 88 88 - ~scopes ~code ~request_uri ~csrf_token () ) 89 89 - in 90 90 - Dream.html html ) ) ) ) 91 91 - 92 92 - let post_handler = 93 93 - Xrpc.handler (fun ctx -> 94 94 - match%lwt get_session_user ctx with 95 95 - | None -> 96 96 - Errors.auth_required "missing authentication" 97 97 - | Some user_did -> ( 98 98 - match%lwt Dream.form ctx.req with 99 99 - | `Ok fields -> ( 100 100 - let action = List.assoc_opt "action" fields in 101 101 - let code = List.assoc_opt "code" fields in 102 102 - let request_uri = List.assoc_opt "request_uri" fields in 103 103 - match (action, code, request_uri) with 104 104 - | Some "deny", _, Some request_uri -> ( 105 105 - let prefix = Constants.request_uri_prefix in 106 106 - let request_id = 107 107 - String.sub request_uri (String.length prefix) 108 108 - (String.length request_uri - String.length prefix) 109 109 - in 110 110 - let%lwt req_record = 111 111 - Queries.get_par_request ctx.db request_id 112 112 - in 113 113 - match req_record with 114 114 - | Some rec_ -> 115 115 - let req = 116 116 - Yojson.Safe.from_string rec_.request_data 117 117 - |> par_request_of_yojson |> Result.get_ok 118 118 - in 119 119 - let params = 120 120 - [ ("error", "access_denied") 121 121 - ; ("error_description", "Unable to authorize user.") 122 122 - ; ("state", req.state) 123 123 - ; ("iss", "https://" ^ Env.hostname) ] 124 124 - in 125 125 - let query = 126 126 - String.concat "&" 127 127 - (List.map 128 128 - (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v) 129 129 - params ) 130 130 - in 131 131 - Dream.redirect ctx.req (req.redirect_uri ^ "?" ^ query) 132 132 - | None -> 133 133 - Errors.invalid_request "request expired" ) 134 134 - | Some "allow", Some code, Some _request_uri -> ( 135 135 - let%lwt code_record = Queries.get_auth_code ctx.db code in 136 136 - match code_record with 137 137 - | None -> 138 138 - Errors.invalid_request "invalid code" 139 139 - | Some code_rec -> ( 140 140 - if code_rec.authorized_by <> None then 141 141 - Errors.invalid_request "code already authorized" 142 142 - else if code_rec.used then 143 143 - Errors.invalid_request "code already used" 144 144 - else if Util.now_ms () > code_rec.expires_at then 145 145 - Errors.invalid_request "code expired" 146 146 - else 147 147 - let%lwt () = 148 148 - Queries.activate_auth_code ctx.db code user_did 149 149 - in 150 150 - let%lwt req_record = 151 151 - Queries.get_par_request ctx.db code_rec.request_id 152 152 - in 153 153 - match req_record with 154 154 - | None -> 155 155 - Errors.internal_error ~msg:"request not found" () 156 156 - | Some rec_ -> 157 157 - let req = 158 158 - Yojson.Safe.from_string rec_.request_data 159 159 - |> par_request_of_yojson |> Result.get_ok 160 160 - in 161 161 - let params = 162 162 - [ ("code", code) 163 163 - ; ("state", req.state) 164 164 - ; ("iss", "https://" ^ Env.hostname) ] 165 165 - in 166 166 - let query = 167 167 - String.concat "&" 168 168 - (List.map 169 169 - (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v) 170 170 - params ) 171 171 - in 172 172 - let separator = 173 173 - match req.response_mode with 174 174 - | Some "fragment" -> 175 175 - "#" 176 176 - | _ -> 177 177 - "?" 178 178 - in 179 179 - Dream.redirect ctx.req 180 180 - (req.redirect_uri ^ separator ^ query) ) ) 181 181 - | _ -> 182 182 - Errors.invalid_request "invalid request" ) 183 183 - | _ -> 184 184 - Errors.invalid_request "invalid request" ) )

-41

pegasus/lib/api/oauth_/par.ml

··· 1 1 - open Oauth 2 2 - open Oauth.Types 3 3 - 4 4 - let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content) 5 5 - 6 6 - let post_handler = 7 7 - Xrpc.handler ~auth:DPoP (fun ctx -> 8 8 - let proof = Auth.get_dpop_proof_exn ctx.auth in 9 9 - let%lwt req = Xrpc.parse_body ctx.req par_request_of_yojson in 10 10 - let%lwt client = 11 11 - try%lwt Client.fetch_client_metadata req.client_id 12 12 - with e -> 13 13 - Errors.log_exn ~req:ctx.req e ; 14 14 - Errors.invalid_request "failed to fetch client metadata" 15 15 - in 16 16 - if req.response_type <> "code" then 17 17 - Errors.invalid_request "only response_type=code supported" 18 18 - else if req.code_challenge_method <> "S256" then 19 19 - Errors.invalid_request "only code_challenge_method=S256 supported" 20 20 - else if not (List.mem req.redirect_uri client.redirect_uris) then 21 21 - Errors.invalid_request "invalid redirect_uri" 22 22 - else 23 23 - let request_id = 24 24 - "req-" 25 25 - ^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 26 26 - in 27 27 - let request_uri = Constants.request_uri_prefix ^ request_id in 28 28 - let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in 29 29 - let request : oauth_request = 30 30 - { request_id 31 31 - ; client_id= req.client_id 32 32 - ; request_data= Yojson.Safe.to_string (par_request_to_yojson req) 33 33 - ; dpop_jkt= Some proof.jkt 34 34 - ; expires_at 35 35 - ; created_at= Util.now_ms () } 36 36 - in 37 37 - let%lwt () = Queries.insert_par_request ctx.db request in 38 38 - Dream.json ~status:`Created 39 39 - @@ Yojson.Safe.to_string 40 40 - @@ `Assoc 41 41 - [("request_uri", `String request_uri); ("expires_in", `Int 300)] )

-179

pegasus/lib/api/oauth_/token.ml

··· 1 1 - open Oauth 2 2 - 3 3 - let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content) 4 4 - 5 5 - let post_handler = 6 6 - Xrpc.handler ~auth:DPoP (fun ctx -> 7 7 - let%lwt req = Xrpc.parse_body ctx.req Types.token_request_of_yojson in 8 8 - let proof = Auth.get_dpop_proof_exn ctx.auth in 9 9 - match req.grant_type with 10 10 - | "authorization_code" -> ( 11 11 - match req.code with 12 12 - | None -> 13 13 - Errors.invalid_request "code required" 14 14 - | Some code -> ( 15 15 - let%lwt code_record = Queries.consume_auth_code ctx.db code in 16 16 - match code_record with 17 17 - | None -> 18 18 - Errors.invalid_request "invalid code" 19 19 - | Some code_rec -> ( 20 20 - if Util.now_ms () > code_rec.expires_at then 21 21 - Errors.invalid_request "code expired" 22 22 - else 23 23 - match code_rec.authorized_by with 24 24 - | None -> 25 25 - Errors.invalid_request "code not authorized" 26 26 - | Some did -> ( 27 27 - let%lwt par_req = 28 28 - Queries.get_par_request ctx.db code_rec.request_id 29 29 - in 30 30 - match par_req with 31 31 - | None -> 32 32 - Errors.internal_error ~msg:"request not found" () 33 33 - | Some par_record -> 34 34 - let orig_req = 35 35 - Yojson.Safe.from_string par_record.request_data 36 36 - |> Types.par_request_of_yojson |> Result.get_ok 37 37 - in 38 38 - ( match req.redirect_uri with 39 39 - | None -> 40 40 - Errors.invalid_request "redirect_uri required" 41 41 - | Some uri when uri <> orig_req.redirect_uri -> 42 42 - Errors.invalid_request "redirect_uri mismatch" 43 43 - | _ -> 44 44 - () ) ; 45 45 - ( match req.code_verifier with 46 46 - | None -> 47 47 - Errors.invalid_request "code_verifier required" 48 48 - | Some verifier -> 49 49 - let computed = 50 50 - Digestif.SHA256.digest_string verifier 51 51 - |> Digestif.SHA256.to_raw_string 52 52 - |> Base64.( 53 53 - encode_exn ~pad:false 54 54 - ~alphabet:uri_safe_alphabet ) 55 55 - in 56 56 - if orig_req.code_challenge <> computed then 57 57 - Errors.invalid_request "invalid code_verifier" 58 58 - ) ; 59 59 - ( match par_record.dpop_jkt with 60 60 - | Some stored when stored <> proof.jkt -> 61 61 - Errors.invalid_request "DPoP key mismatch" 62 62 - | _ -> 63 63 - () ) ; 64 64 - let token_id = 65 65 - "tok-" 66 66 - ^ Uuidm.to_string 67 67 - (Uuidm.v4_gen 68 68 - (Random.State.make_self_init ()) 69 69 - () ) 70 70 - in 71 71 - let refresh_token = 72 72 - "ref-" 73 73 - ^ Uuidm.to_string 74 74 - (Uuidm.v4_gen 75 75 - (Random.State.make_self_init ()) 76 76 - () ) 77 77 - in 78 78 - let now_sec = int_of_float (Unix.gettimeofday ()) in 79 79 - let expires_in = 80 80 - Constants.access_token_expiry_ms / 1000 81 81 - in 82 82 - let exp_sec = now_sec + expires_in in 83 83 - let expires_at = exp_sec * 1000 in 84 84 - let claims = 85 85 - `Assoc 86 86 - [ ("jti", `String token_id) 87 87 - ; ("sub", `String did) 88 88 - ; ("iat", `Int now_sec) 89 89 - ; ("exp", `Int exp_sec) 90 90 - ; ("scope", `String orig_req.scope) 91 91 - ; ("aud", `String ("https://" ^ Env.hostname)) 92 92 - ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ] 93 93 - in 94 94 - let access_token = 95 95 - Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key 96 96 - in 97 97 - let%lwt () = 98 98 - Queries.insert_oauth_token ctx.db 99 99 - { refresh_token 100 100 - ; client_id= req.client_id 101 101 - ; did 102 102 - ; dpop_jkt= proof.jkt 103 103 - ; scope= orig_req.scope 104 104 - ; expires_at } 105 105 - in 106 106 - let nonce = Dpop.next_nonce () in 107 107 - Dream.json 108 108 - ~headers: 109 109 - [ ("DPoP-Nonce", nonce) 110 110 - ; ("Access-Control-Expose-Headers", "DPoP-Nonce") 111 111 - ; ("Cache-Control", "no-store") ] 112 112 - @@ Yojson.Safe.to_string 113 113 - @@ `Assoc 114 114 - [ ("access_token", `String access_token) 115 115 - ; ("token_type", `String "DPoP") 116 116 - ; ("refresh_token", `String refresh_token) 117 117 - ; ("expires_in", `Int expires_in) 118 118 - ; ("scope", `String orig_req.scope) 119 119 - ; ("sub", `String did) ] ) ) ) ) 120 120 - | "refresh_token" -> ( 121 121 - match req.refresh_token with 122 122 - | None -> 123 123 - Errors.invalid_request "refresh_token required" 124 124 - | Some refresh_token -> ( 125 125 - let%lwt token_record = 126 126 - Queries.get_oauth_token_by_refresh ctx.db refresh_token 127 127 - in 128 128 - match token_record with 129 129 - | None -> 130 130 - Errors.invalid_request "invalid refresh token" 131 131 - | Some session -> 132 132 - if session.client_id <> req.client_id then 133 133 - Errors.invalid_request "client_id mismatch" 134 134 - else if session.dpop_jkt <> proof.jkt then 135 135 - Errors.invalid_request "DPoP key mismatch" 136 136 - else 137 137 - let new_token_id = 138 138 - "tok-" 139 139 - ^ Uuidm.to_string 140 140 - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 141 141 - in 142 142 - let new_refresh = 143 143 - "ref-" 144 144 - ^ Uuidm.to_string 145 145 - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 146 146 - in 147 147 - let now_sec = int_of_float (Unix.gettimeofday ()) in 148 148 - let expires_in = Constants.access_token_expiry_ms / 1000 in 149 149 - let exp_sec = now_sec + expires_in in 150 150 - let new_expires_at = exp_sec * 1000 in 151 151 - let claims = 152 152 - `Assoc 153 153 - [ ("jti", `String new_token_id) 154 154 - ; ("sub", `String session.did) 155 155 - ; ("iat", `Int now_sec) 156 156 - ; ("exp", `Int exp_sec) 157 157 - ; ("scope", `String session.scope) 158 158 - ; ("aud", `String ("https://" ^ Env.hostname)) 159 159 - ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ] 160 160 - in 161 161 - let new_access_token = 162 162 - Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key 163 163 - in 164 164 - let%lwt () = 165 165 - Queries.update_oauth_token ctx.db 166 166 - ~old_refresh_token:refresh_token 167 167 - ~new_refresh_token:new_refresh ~expires_at:new_expires_at 168 168 - in 169 169 - Dream.json ~headers:[("Cache-Control", "no-store")] 170 170 - @@ Yojson.Safe.to_string 171 171 - @@ `Assoc 172 172 - [ ("access_token", `String new_access_token) 173 173 - ; ("token_type", `String "DPoP") 174 174 - ; ("refresh_token", `String new_refresh) 175 175 - ; ("expires_in", `Int expires_in) 176 176 - ; ("scope", `String session.scope) 177 177 - ; ("sub", `String session.did) ] ) ) 178 178 - | _ -> 179 179 - Errors.invalid_request ("unsupported grant_type: " ^ req.grant_type) )

+11 -11

pegasus/lib/api/repo/createAccount.ml

··· 57 57 let%lwt did = 58 58 match input.did with 59 59 | Some did -> ( 60 60 - match%lwt Data_store.get_actor_by_identifier did ctx.db with 61 61 - | Some _ -> 62 62 - Errors.invalid_request "an account with that did already exists" 63 63 - | None -> 64 64 - Lwt.return did ) 60 60 + match%lwt Data_store.get_actor_by_identifier did ctx.db with 61 61 + | Some _ -> 62 62 + Errors.invalid_request "an account with that did already exists" 63 63 + | None -> 64 64 + Lwt.return did ) 65 65 | None -> ( 66 66 let sk_did = Kleidos.K256.pubkey_to_did_key signing_pubkey in 67 67 let rotation_did_keys = ··· 79 79 let%lwt _ = 80 80 match input.invite_code with 81 81 | Some code -> ( 82 82 - match%lwt Data_store.use_invite ~code ctx.db with 83 83 - | Some _ -> 84 84 - Lwt.return () 85 85 - | None -> 86 86 - failwith "failed to use invite code" ) 82 82 + match%lwt Data_store.use_invite ~code ctx.db with 83 83 + | Some _ -> 84 84 + Lwt.return () 85 85 + | None -> 86 86 + failwith "failed to use invite code" ) 87 87 | None -> 88 88 Lwt.return () 89 89 in ··· 115 115 let%lwt _ = 116 116 Sequencer.sequence_sync ctx.db ~did ~rev:commit.rev ~blocks () 117 117 in 118 118 - let access_jwt, refresh_jwt = Jwt.generate_jwt did in 118 118 + let access_jwt, refresh_jwt = Auth.generate_jwt did in 119 119 Dream.json @@ Yojson.Safe.to_string 120 120 @@ response_to_yojson {access_jwt; refresh_jwt; did; handle= input.handle} )

+2 -2

pegasus/lib/api/server/createSession.ml

··· 17 17 [@@deriving yojson {strict= false}] 18 18 19 19 let handler = 20 20 - Xrpc.handler (fun {req; auth; db; _} -> 20 20 + Xrpc.handler (fun {req; db; auth} -> 21 21 let%lwt {identifier; password; _} = 22 22 Xrpc.parse_body req request_of_yojson 23 23 in ··· 26 26 Lwt_result.catch @@ fun () -> Data_store.try_login ~id ~password db 27 27 with 28 28 | Ok (Some actor) when Auth.verify_auth auth actor.did -> 29 29 - let access_jwt, refresh_jwt = Jwt.generate_jwt actor.did in 29 29 + let access_jwt, refresh_jwt = Auth.generate_jwt actor.did in 30 30 let active, status = 31 31 match actor.deactivated_at with 32 32 | None ->

+3 -4

pegasus/lib/api/server/getServiceAuth.ml

··· 1 1 type response = {token: string} [@@deriving yojson {strict= false}] 2 2 3 3 let handler = 4 4 - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> 4 4 + Xrpc.handler ~auth:Authorization (fun {req; auth; db} -> 5 5 let did = Auth.get_authed_did_exn auth in 6 6 let aud, lxm = 7 7 match (Dream.query req "aud", Dream.query req "lxm") with ··· 10 10 | _ -> 11 11 Errors.invalid_request "missing aud or lxm" 12 12 in 13 13 - let%lwt signing_multikey = 13 13 + let%lwt signing_key = 14 14 match%lwt Data_store.get_actor_by_identifier did db with 15 15 | Some {signing_key; _} -> 16 16 Lwt.return signing_key 17 17 | None -> 18 18 Errors.internal_error ~msg:"actor not found" () 19 19 in 20 20 - let signing_key = Kleidos.parse_multikey_str signing_multikey in 21 21 - let token = Jwt.generate_service_jwt ~did ~aud ~lxm ~signing_key in 20 20 + let token = Auth.generate_service_jwt ~did ~aud ~lxm ~signing_key in 22 21 Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {token} )

+1 -1

pegasus/lib/api/server/refreshSession.ml

··· 18 18 in 19 19 let%lwt () = Data_store.revoke_token ~did ~jti db in 20 20 let%lwt {handle; did; active; status; _} = Auth.get_session_info did db in 21 21 - let access_jwt, refresh_jwt = Jwt.generate_jwt did in 21 21 + let access_jwt, refresh_jwt = Auth.generate_jwt did in 22 22 Dream.json @@ Yojson.Safe.to_string 23 23 @@ response_to_yojson 24 24 {access_jwt; refresh_jwt; handle; did; active; status} )

+2 -57

pegasus/lib/api/well_known.ml

··· 1 1 - open struct 2 2 - let make_url pth = 3 3 - Uri.(make ~scheme:"https" ~host:Env.hostname ~path:pth () |> to_string) 4 4 - 5 5 - let pds_url = `String (make_url "") 6 6 - end 7 7 - 8 1 let did_json = 9 2 Xrpc.handler (fun _ -> 10 3 Dream.json @@ Yojson.Safe.to_string ··· 15 8 , `Assoc 16 9 [ ("id", `String "#atproto_pds") 17 10 ; ("type", `String "AtprotoPersonalDataServer") 18 18 - ; ("serviceEndpoint", pds_url) ] ) ] ) 19 19 - 20 20 - let oauth_protected_resource = 21 21 - Xrpc.handler (fun _ -> 22 22 - Dream.json @@ Yojson.Safe.to_string 23 23 - @@ `Assoc 24 24 - [ ("authorization_servers", `List [pds_url]) 25 25 - ; ("bearer_methods_supported", `List [`String "header"]) 26 26 - ; ("resource", pds_url) 27 27 - ; ("resource_documentation", `String "https://atproto.com") 28 28 - ; ("scopes_supported", `List []) ] ) 29 29 - 30 30 - let oauth_authorization_server = 31 31 - Xrpc.handler (fun _ -> 32 32 - Dream.json @@ Yojson.Safe.to_string 33 33 - @@ `Assoc 34 34 - [ ("issuer", pds_url) 35 35 - ; ("authorization_endpoint", `String (make_url "/oauth/authorize")) 36 36 - ; ("token_endpoint", `String (make_url "/oauth/token")) 37 37 - ; ( "pushed_authorization_request_endpoint" 38 38 - , `String (make_url "/oauth/par") ) 39 39 - ; ("require_pushed_authorization_requests", `Bool true) 40 40 - ; ( "scopes_supported" 41 41 - , `List 42 42 - [ `String "atproto" 43 43 - ; `String "transition:email" 44 44 - ; `String "transition:generic" 45 45 - ; `String "transition:chat.bsky" ] ) 46 46 - ; ("subject_types_supported", `List [`String "public"]) 47 47 - ; ("response_types_supported", `List [`String "code"]) 48 48 - ; ( "response_modes_supported" 49 49 - , `List [`String "query"; `String "fragment"] ) 50 50 - ; ( "grant_types_supported" 51 51 - , `List [`String "authorization_code"; `String "refresh_token"] ) 52 52 - ; ("code_challenge_methods_supported", `List [`String "S256"]) 53 53 - ; ("ui_locales_supported", `List [`String "en-US"]) 54 54 - ; ( "display_values_supported" 55 55 - , `List [`String "page"; `String "popup"; `String "touch"] ) 56 56 - ; ("authorization_response_iss_parameter_supported", `Bool true) 57 57 - ; ( "request_object_signing_alg_values_supported" 58 58 - , `List [`String "ES256"; `String "ES256K"] ) 59 59 - ; ("request_object_encryption_alg_values_supported", `List []) 60 60 - ; ("request_object_encryption_enc_values_supported", `List []) 61 61 - ; ( "token_endpoint_auth_methods_supported" 62 62 - , `List [`String "none"; `String "private_key_jwt"] ) 63 63 - ; ( "token_endpoint_auth_signing_alg_values_supported" 64 64 - , `List [`String "ES256"; `String "ES256K"] ) 65 65 - ; ( "dpop_signing_alg_values_supported" 66 66 - , `List [`String "ES256"; `String "ES256K"] ) 67 67 - ; ("client_id_metadata_document_supported", `Bool true) ] ) 11 11 + ; ("serviceEndpoint", `String ("https://" ^ Env.hostname)) ] ) 12 12 + ] )

+131 -160

pegasus/lib/auth.ml

··· 1 1 type t = (module Rapper_helper.CONNECTION) 2 2 3 3 + type symmetric_jwt = 4 4 + {scope: string; aud: string; sub: string; iat: int; exp: int; jti: string} 5 5 + 3 6 type session_info = 4 7 { handle: string 5 8 ; did: string ··· 15 18 | Admin 16 19 | Access of {did: string} 17 20 | Refresh of {did: string; jti: string} 18 18 - | OAuth of {did: string; proof: Oauth.Dpop.proof} 19 19 - | DPoP of {proof: Oauth.Dpop.proof} 21 21 + 22 22 + let generate_jwt did = 23 23 + let now_s = int_of_float (Unix.gettimeofday ()) in 24 24 + let access_exp = now_s + (60 * 60 * 3) in 25 25 + let refresh_exp = now_s + (60 * 60 * 24 * 7) in 26 26 + let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in 27 27 + let access = 28 28 + match 29 29 + Jwto.encode Jwto.HS256 Env.jwt_secret 30 30 + [ ("scope", "com.atproto.access") 31 31 + ; ("aud", Env.did) 32 32 + ; ("sub", did) 33 33 + ; ("iat", Int.to_string now_s) 34 34 + ; ("exp", Int.to_string access_exp) 35 35 + ; ("jti", jti) ] 36 36 + with 37 37 + | Ok token -> 38 38 + token 39 39 + | Error err -> 40 40 + failwith err 41 41 + in 42 42 + let refresh = 43 43 + match 44 44 + Jwto.encode Jwto.HS256 Env.jwt_secret 45 45 + [ ("scope", "com.atproto.refresh") 46 46 + ; ("aud", Env.did) 47 47 + ; ("sub", did) 48 48 + ; ("iat", Int.to_string now_s) 49 49 + ; ("exp", Int.to_string refresh_exp) 50 50 + ; ("jti", jti) ] 51 51 + with 52 52 + | Ok token -> 53 53 + token 54 54 + | Error err -> 55 55 + failwith err 56 56 + in 57 57 + (access, refresh) 58 58 + 59 59 + let generate_service_jwt ~did ~aud ~lxm ~signing_key = 60 60 + let now_s = int_of_float (Unix.gettimeofday ()) in 61 61 + let exp = now_s + (60 * 5) in 62 62 + match 63 63 + Jwto.encode Jwto.HS256 signing_key 64 64 + [("iss", did); ("aud", aud); ("lxm", lxm); ("exp", Int.to_string exp)] 65 65 + with 66 66 + | Ok token -> 67 67 + token 68 68 + | Error err -> 69 69 + failwith err 20 70 21 71 let verify_bearer_jwt t token expected_scope = 22 22 - match Jwt.verify_jwt token Env.jwt_key with 72 72 + match Jwto.decode_and_verify Env.jwt_secret token with 23 73 | Error err -> 24 74 Lwt.return_error err 25 25 - | Ok (_, payload) -> ( 26 26 - try 75 75 + | Ok jwt -> 76 76 + let payload = Jwto.get_payload jwt in 27 77 let now_s = int_of_float (Unix.gettimeofday ()) in 28 28 - let jwt = Jwt.symmetric_jwt_of_yojson payload |> Result.get_ok in 29 29 - if jwt.aud <> Env.did then Lwt.return_error "invalid aud" 30 30 - else if jwt.sub = "" then Lwt.return_error "missing sub" 31 31 - else if now_s < jwt.iat then Lwt.return_error "token issued in the future" 32 32 - else if now_s > jwt.exp then Lwt.return_error "expired token" 33 33 - else if jwt.scope <> expected_scope then Lwt.return_error "invalid scope" 34 34 - else if jwt.jti = "" then Lwt.return_error "missing jti" 78 78 + let scope = List.assoc_opt "scope" payload |> Option.value ~default:"" in 79 79 + let aud = List.assoc_opt "aud" payload |> Option.value ~default:"" in 80 80 + let sub = List.assoc_opt "sub" payload |> Option.value ~default:"" in 81 81 + let iat = 82 82 + List.assoc_opt "iat" payload 83 83 + |> Option.map int_of_string 84 84 + |> Option.value ~default:max_int 85 85 + in 86 86 + let exp = 87 87 + List.assoc_opt "exp" payload 88 88 + |> Option.map int_of_string |> Option.value ~default:0 89 89 + in 90 90 + let jti = List.assoc_opt "jti" payload |> Option.value ~default:"" in 91 91 + if aud <> Env.did then Lwt.return_error "invalid aud" 92 92 + else if sub = "" then Lwt.return_error "missing sub" 93 93 + else if now_s < iat then Lwt.return_error "token issued in the future" 94 94 + else if now_s > exp then Lwt.return_error "expired token" 95 95 + else if scope <> expected_scope then Lwt.return_error "invalid scope" 96 96 + else if jti = "" then Lwt.return_error "missing jti" 35 97 else 36 36 - let%lwt revoked_at = 37 37 - Data_store.is_token_revoked t ~did:jwt.sub ~jti:jwt.jti 38 38 - in 98 98 + let%lwt revoked_at = Data_store.is_token_revoked t ~did:sub ~jti in 39 99 if revoked_at <> None then Lwt.return_error "token revoked" 40 40 - else Lwt.return_ok jwt 41 41 - with _ -> Lwt.return_error "invalid token format" ) 100 100 + else Lwt.return_ok {scope; aud; sub; iat; exp; jti} 42 101 43 102 let verify_auth ?(refresh = false) credentials did = 44 103 match credentials with 45 104 | Admin -> 46 105 true 47 47 - | (Access {did= creds} | OAuth {did= creds; _}) when creds = did -> 106 106 + | Access {did= creds} when creds = did -> 48 107 true 49 108 | Refresh {did= creds; _} when creds = did && refresh -> 50 109 true ··· 52 111 false 53 112 54 113 let get_authed_did_exn = function 55 55 - | Access {did} | OAuth {did; _} -> 114 114 + | Access {did} -> 56 115 did 57 116 | Refresh {did; _} -> 58 117 did 59 118 | _ -> 60 60 - Errors.auth_required "invalid authorization header" 61 61 - 62 62 - let get_dpop_proof_exn = function 63 63 - | OAuth {proof; _} | DPoP {proof} -> 64 64 - proof 65 65 - | _ -> 66 66 - Errors.invalid_request "invalid DPoP header" 119 119 + Errors.auth_required "Invalid authorization header" 67 120 68 121 let get_session_info identifier db = 69 122 let%lwt actor = ··· 92 145 module Verifiers = struct 93 146 open struct 94 147 let parse_header req expected_type = 95 95 - match Dream.header req "Authorization" with 148 148 + match Dream.header req "authorization" with 96 149 | Some header -> ( 97 150 match String.split_on_char ' ' header with 98 151 | [typ; token] ··· 103 156 Error "invalid authorization header" ) 104 157 | None -> 105 158 Error "missing authorization header" 106 106 - end 107 159 108 108 - let parse_basic req = 109 109 - match parse_header req "Basic" with 110 110 - | Ok token -> ( 111 111 - match Base64.decode token with 112 112 - | Ok decoded -> ( 113 113 - match Str.bounded_split (Str.regexp_string ":") decoded 2 with 114 114 - | [username; password] -> 115 115 - Ok (username, password) 116 116 - | _ -> 160 160 + let parse_basic req = 161 161 + match parse_header req "Basic" with 162 162 + | Ok token -> ( 163 163 + match Base64.decode token with 164 164 + | Ok decoded -> ( 165 165 + match Str.bounded_split (Str.regexp_string ":") decoded 2 with 166 166 + | [username; password] -> 167 167 + Ok (username, password) 168 168 + | _ -> 169 169 + Error "invalid basic authorization header" ) 170 170 + | Error _ -> 117 171 Error "invalid basic authorization header" ) 118 172 | Error _ -> 119 119 - Error "invalid basic authorization header" ) 120 120 - | Error _ -> 121 121 - Error "invalid basic authorization header" 173 173 + Error "invalid basic authorization header" 122 174 123 123 - let parse_bearer req = parse_header req "Bearer" 124 124 - 125 125 - let parse_dpop req = parse_header req "DPoP" 175 175 + let parse_bearer req = parse_header req "Bearer" 176 176 + end 126 177 127 178 type ctx = {req: Dream.request; db: Data_store.t} 128 179 ··· 132 183 fun {req; _} -> 133 184 match Dream.header req "authorization" with 134 185 | Some _ -> 135 135 - Lwt.return_error @@ Errors.auth_required "invalid authorization header" 186 186 + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 136 187 | None -> 137 188 Lwt.return_ok Unauthenticated 138 189 ··· 144 195 | "admin", p when p = Env.admin_password -> 145 196 Lwt.return_ok Admin 146 197 | _ -> 147 147 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 198 198 + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 148 199 | Error _ -> 149 149 - Lwt.return_error @@ Errors.auth_required "invalid authorization header" 200 200 + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 150 201 151 151 - let bearer : verifier = 202 202 + let access : verifier = 152 203 fun {req; db} -> 153 204 match parse_bearer req with 154 205 | Ok jwt -> ( 155 155 - match%lwt verify_bearer_jwt db jwt "com.atproto.access" with 156 156 - | Ok {sub= did; _} -> ( 157 157 - match%lwt Data_store.get_actor_by_identifier did db with 158 158 - | Some {deactivated_at= None; _} -> 159 159 - Lwt.return_ok (Access {did}) 160 160 - | Some {deactivated_at= Some _; _} -> 161 161 - Lwt.return_error 162 162 - @@ Errors.auth_required ~name:"AccountDeactivated" 163 163 - "account is deactivated" 164 164 - | None -> 165 165 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 166 166 - | Error _ -> 167 167 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 206 206 + match%lwt verify_bearer_jwt db jwt "com.atproto.access" with 207 207 + | Ok {sub= did; _} -> ( 208 208 + match%lwt Data_store.get_actor_by_identifier did db with 209 209 + | Some {deactivated_at= None; _} -> 210 210 + Lwt.return_ok (Access {did}) 211 211 + | Some {deactivated_at= Some _; _} -> 212 212 + Lwt.return_error 213 213 + @@ Errors.auth_required ~name:"AccountDeactivated" 214 214 + "Account is deactivated" 215 215 + | None -> 216 216 + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 217 217 + | Error _ -> 218 218 + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 168 219 | Error _ -> 169 169 - Lwt.return_error @@ Errors.auth_required "invalid authorization header" 170 170 - 171 171 - let dpop : verifier = 172 172 - fun {req; _} -> 173 173 - let dpop_header = Dream.header req "DPoP" in 174 174 - match 175 175 - Oauth.Dpop.verify_dpop_proof 176 176 - ~mthd:(Dream.method_to_string @@ Dream.method_ req) 177 177 - ~url:(Dream.target req) ~dpop_header () 178 178 - with 179 179 - | Error "use_dpop_nonce" -> 180 180 - Lwt.return_error @@ Errors.use_dpop_nonce () 181 181 - | Error e -> 182 182 - Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e) 183 183 - | Ok proof -> 184 184 - Lwt.return_ok (DPoP {proof}) 185 185 - 186 186 - let oauth : verifier = 187 187 - fun {req; db} -> 188 188 - match parse_dpop req with 189 189 - | Error e -> 190 190 - Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e) 191 191 - | Ok token -> ( 192 192 - match%lwt dpop {req; db} with 193 193 - | Error e -> 194 194 - Lwt.return_error e 195 195 - | Ok (DPoP {proof}) -> ( 196 196 - match Jwt.verify_jwt token Env.jwt_key with 197 197 - | Error e -> 198 198 - Lwt.return_error @@ Errors.auth_required e 199 199 - | Ok (_header, claims) -> ( 200 200 - let open Yojson.Safe.Util in 201 201 - try 202 202 - let did = claims |> member "sub" |> to_string in 203 203 - let exp = claims |> member "exp" |> to_int in 204 204 - let jkt_claim = 205 205 - claims |> member "cnf" |> member "jkt" |> to_string 206 206 - in 207 207 - let now = int_of_float (Unix.gettimeofday ()) in 208 208 - if jkt_claim <> proof.jkt then 209 209 - Lwt.return_error @@ Errors.auth_required "dpop key mismatch" 210 210 - else if exp < now then 211 211 - Lwt.return_error @@ Errors.auth_required "token expired" 212 212 - else 213 213 - let%lwt session = 214 214 - try%lwt 215 215 - let%lwt sess = get_session_info did db in 216 216 - Lwt.return_ok sess 217 217 - with _ -> 218 218 - Lwt.return_error 219 219 - @@ Errors.auth_required "invalid credentials" 220 220 - in 221 221 - match session with 222 222 - | Ok {active= Some true; _} -> 223 223 - Lwt.return_ok (OAuth {did; proof}) 224 224 - | Ok _ -> 225 225 - Lwt.return_error 226 226 - @@ Errors.auth_required ~name:"AccountDeactivated" 227 227 - "account is deactivated" 228 228 - | Error _ -> 229 229 - Lwt.return_error 230 230 - @@ Errors.auth_required "invalid credentials" 231 231 - with _ -> 232 232 - Lwt.return_error @@ Errors.auth_required "malformed JWT claims" ) 233 233 - ) 234 234 - | Ok _ -> 235 235 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 220 220 + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 236 221 237 222 let refresh : verifier = 238 223 fun {req; db} -> 239 224 match parse_bearer req with 240 225 | Ok jwt -> ( 241 241 - match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with 242 242 - | Ok {sub= did; jti; _} -> ( 243 243 - match%lwt Data_store.get_actor_by_identifier did db with 244 244 - | Some {deactivated_at= None; _} -> 245 245 - Lwt.return_ok (Refresh {did; jti}) 246 246 - | Some {deactivated_at= Some _; _} -> 247 247 - Lwt.return_error 248 248 - @@ Errors.auth_required ~name:"AccountDeactivated" 249 249 - "account is deactivated" 250 250 - | None -> 251 251 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 252 252 - | Error "" | Error _ -> 253 253 - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 226 226 + match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with 227 227 + | Ok {sub= did; jti; _} -> ( 228 228 + match%lwt Data_store.get_actor_by_identifier did db with 229 229 + | Some {deactivated_at= None; _} -> 230 230 + Lwt.return_ok (Refresh {did; jti}) 231 231 + | Some {deactivated_at= Some _; _} -> 232 232 + Lwt.return_error 233 233 + @@ Errors.auth_required ~name:"AccountDeactivated" 234 234 + "Account is deactivated" 235 235 + | None -> 236 236 + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 237 237 + | Error "" | Error _ -> 238 238 + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 254 239 | Error _ -> 255 255 - Lwt.return_error @@ Errors.auth_required "invalid authorization header" 240 240 + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 256 241 257 242 let authorization : verifier = 258 243 fun ctx -> ··· 263 248 | Some ("Basic" :: _) -> 264 249 admin ctx 265 250 | Some ("Bearer" :: _) -> 266 266 - bearer ctx 267 267 - | Some ("DPoP" :: _) -> 268 268 - oauth ctx 251 251 + access ctx 269 252 | _ -> 270 253 Lwt.return_error 271 254 @@ Errors.auth_required ~name:"InvalidToken" 272 272 - "unexpected authorization type" 255 255 + "Unexpected authorization type" 273 256 274 257 let any : verifier = 275 258 fun ctx -> try authorization ctx with _ -> unauthenticated ctx 276 259 277 277 - type t = 278 278 - | Unauthenticated 279 279 - | Admin 280 280 - | Bearer 281 281 - | DPoP 282 282 - | OAuth 283 283 - | Refresh 284 284 - | Authorization 285 285 - | Any 260 260 + type t = Unauthenticated | Admin | Access | Refresh | Authorization | Any 286 261 287 262 let of_t = function 288 263 | Unauthenticated -> 289 264 unauthenticated 290 265 | Admin -> 291 266 admin 292 292 - | Bearer -> 293 293 - bearer 294 294 - | DPoP -> 295 295 - dpop 296 296 - | OAuth -> 297 297 - oauth 267 267 + | Access -> 268 268 + access 298 269 | Refresh -> 299 270 refresh 300 271 | Authorization ->

+23 -115

pegasus/lib/data_store.ml

··· 36 36 created_at INTEGER NOT NULL, 37 37 deactivated_at INTEGER 38 38 ) 39 39 - |sql}] 39 39 + |sql}] 40 40 () conn 41 41 in 42 42 let$! () = ··· 52 52 [%rapper 53 53 execute 54 54 {sql| CREATE TABLE IF NOT EXISTS invite_codes ( 55 55 - code TEXT PRIMARY KEY, 56 56 - did TEXT NOT NULL, 57 57 - remaining INTEGER NOT NULL 58 58 - ) 59 59 - |sql}] 55 55 + code TEXT PRIMARY KEY, 56 56 + did TEXT NOT NULL, 57 57 + remaining INTEGER NOT NULL 58 58 + ) 59 59 + |sql}] 60 60 () conn 61 61 in 62 62 let$! () = 63 63 [%rapper 64 64 execute 65 65 {sql| CREATE TABLE IF NOT EXISTS firehose ( 66 66 - seq INTEGER PRIMARY KEY, 67 67 - time INTEGER NOT NULL, 68 68 - t TEXT NOT NULL, 69 69 - data BLOB NOT NULL 70 70 - ) 71 71 - |sql}] 72 72 - () conn 73 73 - in 74 74 - let$! () = 75 75 - [%rapper 76 76 - execute 77 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 78 - {sql| CREATE TABLE IF NOT EXISTS revoked_tokens ( 79 79 - did TEXT NOT NULL, 80 80 - jti TEXT NOT NULL, 81 81 - revoked_at INTEGER NOT NULL, 82 82 - PRIMARY KEY (did, jti) 83 83 - ) 84 84 - |sql}] 85 85 - () conn 86 86 - in 87 87 - let$! () = 88 88 - [%rapper 89 89 - execute 90 90 - {sql| CREATE TABLE IF NOT EXISTS oauth_requests ( 91 91 - request_id TEXT PRIMARY KEY, 92 92 - client_id TEXT NOT NULL, 93 93 - request_data TEXT NOT NULL, 94 94 - dpop_jkt TEXT, 95 95 - expires_at INTEGER NOT NULL, 96 96 - created_at INTEGER NOT NULL 97 97 - ) 98 98 - |sql}] 99 99 - () conn 100 100 - in 101 101 - let$! () = 102 102 - [%rapper 103 103 - execute 104 104 - {sql| CREATE TABLE IF NOT EXISTS oauth_codes ( 105 105 - code TEXT PRIMARY KEY, 106 106 - request_id TEXT NOT NULL REFERENCES oauth_requests(request_id) ON DELETE CASCADE, 107 107 - authorized_by TEXT, 108 108 - authorized_at INTEGER, 109 109 - expires_at INTEGER NOT NULL, 110 110 - used BOOLEAN DEFAULT FALSE 111 111 - ) 112 112 - |sql}] 113 113 - () conn 114 114 - in 115 115 - let$! () = 116 116 - [%rapper 117 117 - execute 118 118 - {sql| CREATE TABLE IF NOT EXISTS oauth_tokens ( 119 119 - refresh_token TEXT UNIQUE NOT NULL, 120 120 - client_id TEXT NOT NULL, 121 121 - did TEXT NOT NULL, 122 122 - dpop_jkt TEXT, 123 123 - scope TEXT NOT NULL, 124 124 - expires_at INTEGER NOT NULL 125 125 - ) 126 126 - |sql}] 127 127 - () conn 128 128 - in 129 129 - let$! () = 130 130 - [%rapper 131 131 - execute 132 132 - {sql| CREATE INDEX IF NOT EXISTS oauth_requests_expires_idx ON oauth_requests(expires_at); 133 133 - CREATE INDEX IF NOT EXISTS oauth_codes_expires_idx ON oauth_codes(expires_at); 134 134 - CREATE INDEX IF NOT EXISTS oauth_tokens_refresh_idx ON oauth_tokens(refresh_token); 135 135 - |sql}] 136 136 - () conn 137 137 - in 138 138 - let$! () = 139 139 - [%rapper 140 140 - execute 141 141 - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests 142 142 - AFTER INSERT ON oauth_requests 143 143 - BEGIN 144 144 - DELETE FROM oauth_requests WHERE expires_at < unixepoch() * 1000; 145 145 - END 146 146 - |sql} 147 147 - syntax_off] 148 148 - () conn 149 149 - in 150 150 - let$! () = 151 151 - [%rapper 152 152 - execute 153 153 - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes 154 154 - AFTER INSERT ON oauth_codes 155 155 - BEGIN 156 156 - DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000 OR used = 1; 157 157 - END 158 158 - |sql} 159 159 - syntax_off] 160 160 - () conn 161 161 - in 162 162 - let$! () = 163 163 - [%rapper 164 164 - execute 165 165 - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens 166 166 - AFTER INSERT ON oauth_tokens 167 167 - BEGIN 168 168 - DELETE FROM oauth_tokens WHERE expires_at < unixepoch() * 1000; 169 169 - END 170 170 - |sql} 171 171 - syntax_off] 66 66 + seq INTEGER PRIMARY KEY, 67 67 + time INTEGER NOT NULL, 68 68 + t TEXT NOT NULL, 69 69 + data BLOB NOT NULL 70 70 + ) 71 71 + |sql}] 172 72 () conn 173 73 in 174 174 - Lwt.return_ok () 74 74 + [%rapper 75 75 + execute 76 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 77 + {sql| CREATE TABLE IF NOT EXISTS revoked_tokens ( 78 78 + did TEXT NOT NULL, 79 79 + jti TEXT NOT NULL, 80 80 + revoked_at INTEGER NOT NULL, 81 81 + PRIMARY KEY (did, jti) 82 82 + ) 83 83 + |sql}] 84 84 + () conn 175 85 176 86 let create_actor = 177 87 [%rapper ··· 311 221 type t = Util.caqti_pool 312 222 313 223 let connect ?create ?write () : t Lwt.t = 314 314 - if create = Some true then 315 315 - Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ; 316 224 Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location 317 225 318 226 let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables

+2 -3

pegasus/lib/dune

··· 9 9 cohttp-lwt-unix 10 10 dns-client.unix 11 11 dream 12 12 - html_of_jsx 13 12 ipld 13 13 + jwto 14 14 kleidos 15 15 lwt 16 16 lwt.unix ··· 19 19 safepass 20 20 str 21 21 timedesc 22 22 - uri 23 22 uuidm 24 23 yojson 25 24 lwt_ppx 26 25 ppx_deriving_yojson.runtime 27 26 ppx_rapper_lwt) 28 27 (preprocess 29 29 - (pps html_of_jsx.ppx lwt_ppx ppx_deriving_yojson ppx_rapper))) 28 28 + (pps lwt_ppx ppx_deriving_yojson ppx_rapper))) 30 29 31 30 (include_subdirs qualified)

+6 -26

pegasus/lib/env.ml

··· 1 1 - let getenv name = 2 2 - try Sys.getenv name 3 3 - with Not_found -> failwith ("Missing environment variable " ^ name) 4 4 - 5 1 let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR" 6 2 7 7 - let hostname = getenv "PDS_HOSTNAME" 3 3 + let hostname = Sys.getenv "PDS_HOSTNAME" 8 4 9 5 let did = 10 6 Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID" 11 7 12 12 - let invite_required = getenv "INVITE_CODE_REQUIRED" = "true" 13 13 - 14 14 - let rotation_key = getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str 8 8 + let invite_required = Sys.getenv "INVITE_CODE_REQUIRED" = "true" 15 9 16 16 - let jwt_key = getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str 10 10 + let rotation_key = 11 11 + Sys.getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str 17 12 18 18 - let admin_password = getenv "ADMIN_PASSWORD" 13 13 + let admin_password = Sys.getenv "ADMIN_PASSWORD" 19 14 20 20 - let dpop_nonce_secret = 21 21 - match Sys.getenv_opt "DPOP_NONCE_SECRET" with 22 22 - | Some sec -> 23 23 - let secret = 24 24 - Base64.(decode_exn ~alphabet:uri_safe_alphabet ~pad:false) sec 25 25 - |> Bytes.of_string 26 26 - in 27 27 - if Bytes.length secret = 32 then secret 28 28 - else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64uri" 29 29 - | None -> 30 30 - let secret = Mirage_crypto_rng_unix.getrandom 32 in 31 31 - Dream.warning (fun log -> 32 32 - log "DPOP_NONCE_SECRET not set; using DPOP_NONCE_SECRET=%s" 33 33 - ( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret 34 34 - |> Result.get_ok ) ) ; 35 35 - Bytes.of_string secret 15 15 + let jwt_secret = Sys.getenv "JWT_SECRET"

-6

pegasus/lib/errors.ml

··· 4 4 5 5 exception AuthError of (string * string) 6 6 7 7 - exception UseDpopNonceError 8 8 - 9 7 let is_xrpc_error = function 10 8 | InvalidRequestError _ | InternalServerError _ | AuthError _ -> 11 9 true ··· 21 19 22 20 let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg)) 23 21 24 24 - let use_dpop_nonce () = raise UseDpopNonceError 25 25 - 26 22 let exn_to_response exn = 27 23 let format_response error msg status = 28 24 Dream.json ~status @@ Yojson.Safe.to_string ··· 35 31 format_response error message `Internal_Server_Error 36 32 | AuthError (error, message) -> 37 33 format_response error message `Unauthorized 38 38 - | UseDpopNonceError -> 39 39 - Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|} 40 34 | _ -> 41 35 format_response "InternalServerError" "Internal server error" 42 36 `Internal_Server_Error

+4 -3

pegasus/lib/id_resolver.ml

··· 1 1 open Cohttp_lwt 2 2 + open Cohttp_lwt_unix 2 3 3 4 let did_regex = 4 5 Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|} ··· 11 12 let uri = 12 13 Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did") 13 14 in 14 14 - let%lwt {status; _}, body = Util.http_get uri in 15 15 + let%lwt {status; _}, body = Client.get uri in 15 16 match status with 16 17 | `OK -> 17 18 let%lwt did = Body.to_string body in ··· 163 164 ~path:(Uri.pct_encode did) () 164 165 in 165 166 let%lwt {status; _}, body = 166 166 - Util.http_get uri 167 167 + Client.get uri 167 168 ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) 168 169 in 169 170 match status with ··· 185 186 ~path:"/.well-known/did.json" () 186 187 in 187 188 let%lwt {status; _}, body = 188 188 - Util.http_get uri 189 189 + Client.get uri 189 190 ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) 190 191 in 191 192 match status with

-122

pegasus/lib/jwt.ml

··· 1 1 - module Defaults = struct 2 2 - let service_token_exp = 60 * 5 (* 5 minutes *) 3 3 - 4 4 - let access_token_exp = 60 * 60 * 3 (* 3 hours *) 5 5 - 6 6 - let refresh_token_exp = 60 * 60 * 24 * 7 (* 7 days *) 7 7 - end 8 8 - 9 9 - type service_jwt = {iss: string; aud: string; lxm: string; exp: int} 10 10 - [@@deriving yojson] 11 11 - 12 12 - type symmetric_jwt = 13 13 - {scope: string; aud: string; sub: string; iat: int; exp: int; jti: string} 14 14 - [@@deriving yojson] 15 15 - 16 16 - let b64_encode str = 17 17 - Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet str 18 18 - 19 19 - let b64_decode str = 20 20 - match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with 21 21 - | Ok s -> 22 22 - s 23 23 - | Error (`Msg e) -> 24 24 - failwith e 25 25 - 26 26 - let extract_signature_components signature = 27 27 - if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature" 28 28 - else 29 29 - let r = Bytes.sub signature 0 32 in 30 30 - let s = Bytes.sub signature 32 32 in 31 31 - (r, s) 32 32 - 33 33 - let sign_jwt payload ?(typ = "JWT") signing_key = 34 34 - let _, (module Curve : Kleidos.CURVE) = signing_key in 35 35 - let alg = 36 36 - match Curve.name with 37 37 - | "K256" -> 38 38 - "ES256K" 39 39 - | "P256" -> 40 40 - "ES256" 41 41 - | _ -> 42 42 - failwith "invalid curve" 43 43 - in 44 44 - let crv = 45 45 - match Curve.name with 46 46 - | "K256" -> 47 47 - "secp256k1" 48 48 - | "P256" -> 49 49 - "P-256" 50 50 - | _ -> 51 51 - failwith "invalid curve" 52 52 - in 53 53 - let header_json = 54 54 - `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String typ)] 55 55 - in 56 56 - let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in 57 57 - let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in 58 58 - let signing_input = encoded_header ^ "." ^ encoded_payload in 59 59 - let signature = 60 60 - Kleidos.sign ~privkey:signing_key ~msg:(Bytes.of_string signing_input) 61 61 - in 62 62 - let encoded_signature = b64_encode (Bytes.to_string signature) in 63 63 - signing_input ^ "." ^ encoded_signature 64 64 - 65 65 - let decode_jwt jwt = 66 66 - match String.split_on_char '.' jwt with 67 67 - | [header_b64; payload_b64; _] -> ( 68 68 - try 69 69 - let header = Yojson.Safe.from_string (b64_decode header_b64) in 70 70 - let payload = Yojson.Safe.from_string (b64_decode payload_b64) in 71 71 - Ok (header, payload) 72 72 - with _ -> Error "invalid jwt" ) 73 73 - | _ -> 74 74 - Error "invalid jwt format" 75 75 - 76 76 - let verify_jwt jwt pubkey = 77 77 - match String.split_on_char '.' jwt with 78 78 - | [header_b64; payload_b64; signature_b64] -> 79 79 - let signature = Bytes.of_string (b64_decode signature_b64) in 80 80 - let signing_input = header_b64 ^ "." ^ payload_b64 in 81 81 - let verified = 82 82 - Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature 83 83 - in 84 84 - if verified then decode_jwt jwt 85 85 - else Error "jwt signature verification failed" 86 86 - | _ -> 87 87 - Error "invalid jwt format" 88 88 - 89 89 - let generate_jwt did = 90 90 - let now_s = int_of_float (Unix.gettimeofday ()) in 91 91 - let access_exp = now_s + Defaults.access_token_exp in 92 92 - let refresh_exp = now_s + Defaults.refresh_token_exp in 93 93 - let jti = 94 94 - Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string 95 95 - in 96 96 - let access_payload = 97 97 - symmetric_jwt_to_yojson 98 98 - { scope= "com.atproto.access" 99 99 - ; aud= Env.did 100 100 - ; sub= did 101 101 - ; iat= now_s 102 102 - ; exp= access_exp 103 103 - ; jti } 104 104 - in 105 105 - let refresh_payload = 106 106 - symmetric_jwt_to_yojson 107 107 - { scope= "com.atproto.refresh" 108 108 - ; aud= Env.did 109 109 - ; sub= did 110 110 - ; iat= now_s 111 111 - ; exp= refresh_exp 112 112 - ; jti } 113 113 - in 114 114 - let access = sign_jwt access_payload Env.jwt_key in 115 115 - let refresh = sign_jwt refresh_payload Env.jwt_key in 116 116 - (access, refresh) 117 117 - 118 118 - let generate_service_jwt ~did ~aud ~lxm ~signing_key = 119 119 - let now_s = int_of_float (Unix.gettimeofday ()) in 120 120 - let exp = now_s + Defaults.service_token_exp in 121 121 - let payload = service_jwt_to_yojson {iss= did; aud; lxm; exp} in 122 122 - sign_jwt payload signing_key

-45

pegasus/lib/oauth/client.ml

··· 1 1 - open Types 2 2 - 3 3 - let fetch_client_metadata client_id : client_metadata Lwt.t = 4 4 - let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in 5 5 - if status <> `OK then 6 6 - let%lwt () = Cohttp_lwt.Body.drain_body res in 7 7 - failwith 8 8 - (Printf.sprintf "client metadata not found; http %d" 9 9 - (Cohttp.Code.code_of_status status) ) 10 10 - else 11 11 - let%lwt body = Cohttp_lwt.Body.to_string res in 12 12 - let json = Yojson.Safe.from_string body in 13 13 - let metadata = 14 14 - match client_metadata_of_yojson json with 15 15 - | Ok metadata -> 16 16 - metadata 17 17 - | Error err -> 18 18 - failwith err 19 19 - in 20 20 - if metadata.client_id <> client_id then failwith "client_id mismatch" 21 21 - else 22 22 - let scopes = String.split_on_char ' ' metadata.scope in 23 23 - if not (List.mem "atproto" scopes) then 24 24 - failwith "scope must include 'atproto'" 25 25 - else 26 26 - List.iter 27 27 - (function 28 28 - | "authorization_code" | "refresh_token" -> 29 29 - () 30 30 - | grant -> 31 31 - failwith ("invalid grant type: " ^ grant) ) 32 32 - metadata.grant_types ; 33 33 - List.iter 34 34 - (fun uri -> 35 35 - let u = Uri.of_string uri in 36 36 - let host = Uri.host u in 37 37 - match Uri.scheme u with 38 38 - | Some "https" when host <> Some "localhost" -> 39 39 - () 40 40 - | Some "http" when host = Some "127.0.0.1" || host = Some "[::1]" -> 41 41 - () 42 42 - | _ -> 43 43 - failwith ("invalid redirect_uri: " ^ uri) ) 44 44 - metadata.redirect_uris ; 45 45 - Lwt.return metadata

-15

pegasus/lib/oauth/constants.ml

··· 1 1 - let max_dpop_age_s = 60 2 2 - 3 3 - let dpop_rotation_interval_ms = 60_000L 4 4 - 5 5 - let jti_ttl_s = 3600 6 6 - 7 7 - let jti_cache_size = 10_000 8 8 - 9 9 - let par_request_ttl_ms = 300_000 10 10 - 11 11 - let code_expiry_ms = 300_000 12 12 - 13 13 - let access_token_expiry_ms = 60 * 60 * 1000 14 14 - 15 15 - let request_uri_prefix = "urn:ietf:params:oauth:request_uri:"

-204

pegasus/lib/oauth/dpop.ml

··· 1 1 - type nonce_state = 2 2 - { secret: bytes 3 3 - ; mutable counter: int64 4 4 - ; mutable prev: string 5 5 - ; mutable curr: string 6 6 - ; mutable next: string 7 7 - ; rotation_interval_ms: int64 } 8 8 - 9 9 - type ec_jwk = {crv: string; kty: string; x: string; y: string} 10 10 - [@@deriving yojson] 11 11 - 12 12 - type proof = {jti: string; jkt: string; htm: string; htu: string} 13 13 - [@@deriving yojson] 14 14 - 15 15 - let jti_cache : (string, int) Hashtbl.t = 16 16 - Hashtbl.create Constants.jti_cache_size 17 17 - 18 18 - let cleanup_jti_cache () = 19 19 - let now = int_of_float (Unix.gettimeofday ()) in 20 20 - Hashtbl.filter_map_inplace 21 21 - (fun _ expires_at -> if expires_at > now then Some expires_at else None) 22 22 - jti_cache 23 23 - 24 24 - let compute_nonce secret counter = 25 25 - let data = Bytes.create 8 in 26 26 - Bytes.set_int64_be data 0 counter ; 27 27 - Digestif.SHA256.( 28 28 - hmac_bytes ~key:(Bytes.to_string secret) data 29 29 - |> to_raw_string |> Jwt.b64_encode ) 30 30 - 31 31 - let create_nonce_state secret = 32 32 - let counter = 33 33 - Int64.div 34 34 - (Int64.of_float (Unix.gettimeofday () *. 1000.)) 35 35 - Constants.dpop_rotation_interval_ms 36 36 - in 37 37 - { secret 38 38 - ; counter 39 39 - ; prev= compute_nonce secret (Int64.pred counter) 40 40 - ; curr= compute_nonce secret counter 41 41 - ; next= compute_nonce secret (Int64.succ counter) 42 42 - ; rotation_interval_ms= Constants.dpop_rotation_interval_ms } 43 43 - 44 44 - let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret) 45 45 - 46 46 - let next_nonce () = 47 47 - let now_counter = 48 48 - Int64.div 49 49 - (Int64.of_float (Unix.gettimeofday () *. 1000.)) 50 50 - !nonce_state.rotation_interval_ms 51 51 - in 52 52 - if now_counter <> !nonce_state.counter then ( 53 53 - !nonce_state.prev <- !nonce_state.curr ; 54 54 - !nonce_state.curr <- !nonce_state.next ; 55 55 - !nonce_state.next <- 56 56 - compute_nonce !nonce_state.secret (Int64.succ now_counter) ; 57 57 - !nonce_state.counter <- now_counter ) ; 58 58 - !nonce_state.next 59 59 - 60 60 - let verify_nonce nonce = 61 61 - let valid = 62 62 - nonce = !nonce_state.prev || nonce = !nonce_state.curr 63 63 - || nonce = !nonce_state.next 64 64 - in 65 65 - ignore next_nonce ; valid 66 66 - 67 67 - let add_jti jti = 68 68 - let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in 69 69 - if Hashtbl.mem jti_cache jti then false (* replay *) 70 70 - else ( 71 71 - Hashtbl.add jti_cache jti expires_at ; 72 72 - (* clean up every once in a while *) 73 73 - if Hashtbl.length jti_cache mod 100 = 0 then cleanup_jti_cache () ; 74 74 - true ) 75 75 - 76 76 - let normalize_url url = 77 77 - let uri = Uri.of_string url in 78 78 - Uri.make ~scheme:"https" 79 79 - ~host:(Uri.host uri |> Option.value ~default:Env.hostname) 80 80 - ~path:(Uri.path uri) () 81 81 - |> Uri.to_string 82 82 - 83 83 - let compute_jwk_thumbprint jwk = 84 84 - let {crv; kty; x; y} = jwk in 85 85 - let tp = 86 86 - (* keys must be in lexicographic order *) 87 87 - Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y 88 88 - in 89 89 - Digestif.SHA256.(digest_string tp |> to_raw_string |> Jwt.b64_encode) 90 90 - 91 91 - let verify_signature jwt jwk = 92 92 - let parts = String.split_on_char '.' jwt in 93 93 - match parts with 94 94 - | [header_b64; payload_b64; sig_b64] -> 95 95 - let signing_input = header_b64 ^ "." ^ payload_b64 in 96 96 - let msg = Bytes.of_string signing_input in 97 97 - let {x; y; crv; _} = jwk in 98 98 - let x = x |> Jwt.b64_decode |> Bytes.of_string in 99 99 - let y = y |> Jwt.b64_decode |> Bytes.of_string in 100 100 - let pubkey = Bytes.cat (Bytes.of_string "\x04") (Bytes.cat x y) in 101 101 - let pubkey = 102 102 - ( pubkey 103 103 - , match crv with 104 104 - | "secp256k1" -> 105 105 - (module Kleidos.K256 : Kleidos.CURVE) 106 106 - | "P-256" -> 107 107 - (module Kleidos.P256 : Kleidos.CURVE) 108 108 - | _ -> 109 109 - failwith "unsupported algorithm" ) 110 110 - in 111 111 - let sig_bytes = Jwt.b64_decode sig_b64 |> Bytes.of_string in 112 112 - let r = Bytes.sub sig_bytes 0 32 in 113 113 - let s = Bytes.sub sig_bytes 32 32 in 114 114 - let signature = Bytes.cat r s in 115 115 - Kleidos.verify ~pubkey ~msg ~signature 116 116 - | _ -> 117 117 - false 118 118 - 119 119 - let verify_dpop_proof ~mthd ~url ~dpop_header ?access_token () = 120 120 - match dpop_header with 121 121 - | None -> 122 122 - Error "missing dpop header" 123 123 - | Some jwt -> ( 124 124 - let open Yojson.Safe.Util in 125 125 - match String.split_on_char '.' jwt with 126 126 - | [header_b64; payload_b64; _] -> ( 127 127 - let header = Yojson.Safe.from_string (Jwt.b64_decode header_b64) in 128 128 - let payload = Yojson.Safe.from_string (Jwt.b64_decode payload_b64) in 129 129 - let typ = header |> member "typ" |> to_string in 130 130 - if typ <> "dpop+jwt" then Error "invalid typ in dpop proof" 131 131 - else 132 132 - let alg = header |> member "alg" |> to_string in 133 133 - if alg <> "ES256" && alg <> "ES256K" then 134 134 - Error "only es256 and es256k supported for dpop" 135 135 - else 136 136 - let jwk = 137 137 - header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok 138 138 - in 139 139 - if 140 140 - not 141 141 - ( match (alg, jwk.crv) with 142 142 - | "ES256", "P-256" -> 143 143 - true 144 144 - | "ES256K", "secp256k1" -> 145 145 - true 146 146 - | _ -> 147 147 - false ) 148 148 - then 149 149 - Error 150 150 - (Printf.sprintf "algorithm %s doesn't match curve %s" alg 151 151 - jwk.crv ) 152 152 - else 153 153 - let jti = payload |> member "jti" |> to_string in 154 154 - let htm = payload |> member "htm" |> to_string in 155 155 - let htu = payload |> member "htu" |> to_string in 156 156 - let iat = payload |> member "iat" |> to_int in 157 157 - let nonce_claim = 158 158 - payload |> member "nonce" |> to_string_option 159 159 - in 160 160 - match nonce_claim with 161 161 - (* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *) 162 162 - | None -> 163 163 - Error "use_dpop_nonce" 164 164 - | Some n when not (verify_nonce n) -> 165 165 - Error "use_dpop_nonce" 166 166 - | Some _ -> ( 167 167 - if htm <> mthd then Error "htm mismatch" 168 168 - else if 169 169 - not (String.equal (normalize_url htu) (normalize_url url)) 170 170 - then Error "htu mismatch" 171 171 - else 172 172 - let now = int_of_float (Unix.gettimeofday ()) in 173 173 - if now - iat > Constants.max_dpop_age_s then 174 174 - Error "dpop proof too old" 175 175 - else if iat - now > 5 then Error "dpop proof in future" 176 176 - else if not (add_jti jti) then 177 177 - Error "dpop proof replay detected" 178 178 - else if not (verify_signature jwt jwk) then 179 179 - Error "invalid dpop signature" 180 180 - else 181 181 - let jkt = compute_jwk_thumbprint jwk in 182 182 - (* verify ath if access token is provided *) 183 183 - match access_token with 184 184 - | Some token -> 185 185 - let ath_claim = 186 186 - payload |> member "ath" |> to_string_option 187 187 - in 188 188 - let expected_ath = 189 189 - Digestif.SHA256.( 190 190 - digest_string token |> to_raw_string 191 191 - |> Jwt.b64_encode ) 192 192 - in 193 193 - if Some expected_ath <> ath_claim then 194 194 - Error "ath mismatch" 195 195 - else Ok {jti; jkt; htm; htu} 196 196 - | None -> 197 197 - let ath_claim = 198 198 - payload |> member "ath" |> to_string_option 199 199 - in 200 200 - if ath_claim <> None then 201 201 - Error "ath claim not allowed without access token" 202 202 - else Ok {jti; jkt; htm; htu} ) ) 203 203 - | _ -> 204 204 - Error "invalid dpop jwt" )

-138

pegasus/lib/oauth/queries.ml

··· 1 1 - [@@@warning "-missing-record-field-pattern"] 2 2 - 3 3 - open Types 4 4 - 5 5 - let insert_par_request conn req = 6 6 - Util.use_pool conn 7 7 - @@ [%rapper 8 8 - execute 9 9 - {sql| 10 10 - INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at) 11 11 - VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string?{dpop_jkt}, %int{expires_at}, %int{created_at}) 12 12 - |sql} 13 13 - record_in] 14 14 - req 15 15 - 16 16 - let get_par_request conn request_id = 17 17 - Util.use_pool conn 18 18 - @@ [%rapper 19 19 - get_opt 20 20 - {sql| 21 21 - SELECT @string{request_id}, @string{client_id}, @string{request_data}, 22 22 - @string?{dpop_jkt}, @int{expires_at}, @int{created_at} 23 23 - FROM oauth_requests 24 24 - WHERE request_id = %string{request_id} 25 25 - AND expires_at > %int{now} 26 26 - |sql} 27 27 - record_out] 28 28 - ~request_id ~now:(Util.now_ms ()) 29 29 - 30 30 - let insert_auth_code conn code = 31 31 - Util.use_pool conn 32 32 - @@ [%rapper 33 33 - execute 34 34 - {sql| 35 35 - INSERT INTO oauth_codes (code, request_id, authorized_by, authorized_at, expires_at, used) 36 36 - VALUES (%string{code}, %string{request_id}, %string?{authorized_by}, %int?{authorized_at}, %int{expires_at}, 0) 37 37 - |sql} 38 38 - record_in] 39 39 - code 40 40 - 41 41 - let get_auth_code conn code = 42 42 - Util.use_pool conn 43 43 - @@ [%rapper 44 44 - get_opt 45 45 - {sql| 46 46 - SELECT @string{code}, @string{request_id}, @string?{authorized_by}, 47 47 - @int?{authorized_at}, @int{expires_at}, @bool{used} 48 48 - FROM oauth_codes 49 49 - WHERE code = %string{code} 50 50 - |sql} 51 51 - record_out] 52 52 - ~code 53 53 - 54 54 - let activate_auth_code conn code did = 55 55 - let authorized_at = Util.now_ms () in 56 56 - Util.use_pool conn 57 57 - @@ [%rapper 58 58 - execute 59 59 - {sql| 60 60 - UPDATE oauth_codes 61 61 - SET authorized_by = %string{did}, 62 62 - authorized_at = %int{authorized_at} 63 63 - WHERE code = %string{code} 64 64 - |sql}] 65 65 - ~did ~authorized_at ~code 66 66 - 67 67 - let consume_auth_code conn code = 68 68 - Util.use_pool conn 69 69 - @@ [%rapper 70 70 - get_opt 71 71 - {sql| 72 72 - UPDATE oauth_codes 73 73 - SET used = 1 74 74 - WHERE code = %string{code} AND used = 0 75 75 - RETURNING @string{code}, @string{request_id}, @string?{authorized_by}, 76 76 - @int?{authorized_at}, @int{expires_at}, @bool{used} 77 77 - |sql} 78 78 - record_out] 79 79 - ~code 80 80 - 81 81 - let insert_oauth_token conn token = 82 82 - Util.use_pool conn 83 83 - @@ [%rapper 84 84 - execute 85 85 - {sql| 86 86 - INSERT INTO oauth_tokens (refresh_token, client_id, did, dpop_jkt, scope, expires_at) 87 87 - VALUES (%string{refresh_token}, %string{client_id}, %string{did}, %string{dpop_jkt}, %string{scope}, %int{expires_at}) 88 88 - |sql} 89 89 - record_in] 90 90 - token 91 91 - 92 92 - let get_oauth_token_by_refresh conn refresh_token = 93 93 - Util.use_pool conn 94 94 - @@ [%rapper 95 95 - get_opt 96 96 - {sql| 97 97 - SELECT @string{refresh_token}, @string{client_id}, @string{did}, 98 98 - @string{dpop_jkt}, @string{scope}, @int{expires_at} 99 99 - FROM oauth_tokens 100 100 - WHERE refresh_token = %string{refresh_token} 101 101 - |sql} 102 102 - record_out] 103 103 - ~refresh_token 104 104 - 105 105 - let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at = 106 106 - Util.use_pool conn 107 107 - @@ [%rapper 108 108 - execute 109 109 - {sql| 110 110 - UPDATE oauth_tokens 111 111 - SET refresh_token = %string{new_refresh_token}, 112 112 - expires_at = %int{expires_at} 113 113 - WHERE refresh_token = %string{old_refresh_token} 114 114 - |sql}] 115 115 - ~new_refresh_token ~expires_at ~old_refresh_token 116 116 - 117 117 - let delete_oauth_token_by_refresh conn refresh_token = 118 118 - Util.use_pool conn 119 119 - @@ [%rapper 120 120 - execute 121 121 - {sql| 122 122 - DELETE FROM oauth_tokens WHERE refresh_token = %string{refresh_token} 123 123 - |sql}] 124 124 - ~refresh_token 125 125 - 126 126 - let get_oauth_tokens_by_did conn did = 127 127 - Util.use_pool conn 128 128 - @@ [%rapper 129 129 - get_many 130 130 - {sql| 131 131 - SELECT @string{refresh_token}, @string{client_id}, @string{did}, 132 132 - @string{dpop_jkt}, @string{scope}, @int{expires_at} 133 133 - FROM oauth_tokens 134 134 - WHERE did = %string{did} 135 135 - ORDER BY expires_at ASC 136 136 - |sql} 137 137 - record_out] 138 138 - ~did

-71

pegasus/lib/oauth/types.ml

··· 1 1 - type par_request = 2 2 - { client_id: string 3 3 - ; response_type: string 4 4 - ; response_mode: string option [@default None] 5 5 - ; redirect_uri: string 6 6 - ; scope: string 7 7 - ; state: string 8 8 - ; code_challenge: string 9 9 - ; code_challenge_method: string 10 10 - ; login_hint: string option [@default None] 11 11 - ; dpop_jkt: string option [@default None] 12 12 - ; client_assertion_type: string option [@default None] 13 13 - ; client_assertion: string option [@default None] } 14 14 - [@@deriving yojson {strict= false}] 15 15 - 16 16 - type token_request = 17 17 - { grant_type: string 18 18 - ; code: string option [@default None] 19 19 - ; redirect_uri: string option [@default None] 20 20 - ; code_verifier: string option [@default None] 21 21 - ; refresh_token: string option [@default None] 22 22 - ; client_id: string 23 23 - ; client_assertion_type: string option [@default None] 24 24 - ; client_assertion: string option [@default None] } 25 25 - [@@deriving yojson {strict= false}] 26 26 - 27 27 - type client_metadata = 28 28 - { client_id: string 29 29 - ; client_name: string option [@default None] 30 30 - ; client_uri: string 31 31 - ; redirect_uris: string list 32 32 - ; grant_types: string list 33 33 - ; response_types: string list 34 34 - ; scope: string 35 35 - ; token_endpoint_auth_method: string 36 36 - ; token_endpoint_auth_signing_alg: string option [@default None] 37 37 - ; application_type: string 38 38 - ; dpop_bound_access_tokens: bool 39 39 - ; jwks_uri: string option [@default None] 40 40 - ; jwks: Yojson.Safe.t option [@default None] } 41 41 - [@@deriving yojson {strict= false}] 42 42 - 43 43 - type dpop_proof = {jti: string; jkt: string; htm: string; htu: string} 44 44 - [@@deriving yojson {strict= false}] 45 45 - 46 46 - type oauth_request = 47 47 - { request_id: string 48 48 - ; client_id: string 49 49 - ; request_data: string 50 50 - ; dpop_jkt: string option [@default None] 51 51 - ; expires_at: int 52 52 - ; created_at: int } 53 53 - [@@deriving yojson {strict= false}] 54 54 - 55 55 - type oauth_code = 56 56 - { code: string 57 57 - ; request_id: string 58 58 - ; authorized_by: string option [@default None] 59 59 - ; authorized_at: int option [@default None] 60 60 - ; expires_at: int 61 61 - ; used: bool } 62 62 - [@@deriving yojson {strict= false}] 63 63 - 64 64 - type oauth_token = 65 65 - { refresh_token: string 66 66 - ; client_id: string 67 67 - ; did: string 68 68 - ; dpop_jkt: string 69 69 - ; scope: string 70 70 - ; expires_at: int } 71 71 - [@@deriving yojson {strict= false}]

+1 -1

pegasus/lib/plc.ml

··· 302 302 did 303 303 in 304 304 let headers = Http.Header.init_with "Accept" "application/json" in 305 305 - let%lwt res, body = Util.http_get ~headers uri in 305 305 + let%lwt res, body = Client.get ~headers uri in 306 306 match res.status with 307 307 | `OK -> 308 308 let%lwt body = Body.to_string body in

+11 -11

pegasus/lib/repository.ml

··· 180 180 let%lwt map = get_map t in 181 181 String_map.bindings map 182 182 |> List.filter (fun (path, _) -> 183 183 - String.starts_with ~prefix:(path ^ "/") collection ) 183 183 + String.starts_with ~prefix:(path ^ "/") collection ) 184 184 |> Lwt_list.fold_left_s 185 185 (fun acc (path, cid) -> 186 186 match%lwt User_store.get_record t.db path with ··· 320 320 let%lwt () = 321 321 match old_cid with 322 322 | Some _ -> ( 323 323 - match%lwt User_store.get_record t.db path with 324 324 - | Some record -> 325 325 - let refs = 326 326 - Util.find_blob_refs record.value 327 327 - |> List.map (fun (r : Mist.Blob_ref.t) -> r.ref) 328 328 - in 329 329 - let%lwt () = User_store.clear_blob_refs t.db path refs in 330 330 - Lwt.return_unit 331 331 - | None -> 332 332 - Lwt.return_unit ) 323 323 + match%lwt User_store.get_record t.db path with 324 324 + | Some record -> 325 325 + let refs = 326 326 + Util.find_blob_refs record.value 327 327 + |> List.map (fun (r : Mist.Blob_ref.t) -> r.ref) 328 328 + in 329 329 + let%lwt () = User_store.clear_blob_refs t.db path refs in 330 330 + Lwt.return_unit 331 331 + | None -> 332 332 + Lwt.return_unit ) 333 333 | None -> 334 334 Lwt.return_unit 335 335 in

+28 -28

pegasus/lib/sequencer.ml

··· 330 330 let blobs = 331 331 j |> member "blobs" |> to_list 332 332 |> List.filter_map (fun x -> 333 333 - match Cid.of_yojson x with Ok c -> Some c | _ -> None ) 333 333 + match Cid.of_yojson x with Ok c -> Some c | _ -> None ) 334 334 in 335 335 let prev_data = 336 336 match j |> member "prevData" with ··· 342 342 let ops = 343 343 j |> member "ops" |> to_list 344 344 |> List.map (fun opj -> 345 345 - let action = 346 346 - match opj |> member "action" |> to_string with 347 347 - | "create" -> 348 348 - `Create 349 349 - | "update" -> 350 350 - `Update 351 351 - | "delete" -> 352 352 - `Delete 353 353 - | _ -> 354 354 - `Create 355 355 - in 356 356 - let path = opj |> member "path" |> to_string in 357 357 - let cid = 358 358 - match opj |> member "cid" with 359 359 - | `Null -> 360 360 - None 361 361 - | v -> ( 362 362 - match Cid.of_yojson v with Ok c -> Some c | _ -> None ) 363 363 - in 364 364 - let prev = 365 365 - match opj |> member "prev" with 366 366 - | `Null -> 367 367 - None 368 368 - | v -> ( 369 369 - match Cid.of_yojson v with Ok c -> Some c | _ -> None ) 370 370 - in 371 371 - {action; path; cid; prev} ) 345 345 + let action = 346 346 + match opj |> member "action" |> to_string with 347 347 + | "create" -> 348 348 + `Create 349 349 + | "update" -> 350 350 + `Update 351 351 + | "delete" -> 352 352 + `Delete 353 353 + | _ -> 354 354 + `Create 355 355 + in 356 356 + let path = opj |> member "path" |> to_string in 357 357 + let cid = 358 358 + match opj |> member "cid" with 359 359 + | `Null -> 360 360 + None 361 361 + | v -> ( 362 362 + match Cid.of_yojson v with Ok c -> Some c | _ -> None ) 363 363 + in 364 364 + let prev = 365 365 + match opj |> member "prev" with 366 366 + | `Null -> 367 367 + None 368 368 + | v -> ( 369 369 + match Cid.of_yojson v with Ok c -> Some c | _ -> None ) 370 370 + in 371 371 + {action; path; cid; prev} ) 372 372 in 373 373 Ok 374 374 { rebase

-33

pegasus/lib/templates/components/button.mlx

··· 1 1 - let base_classes = 2 2 - "py-1 px-4 text-lg rounded-lg w-full flex items-center justify-center \ 3 3 - transition delay-50 duration-300 focus-visible:outline-none disabled:text-mist-80" 4 4 - 5 5 - type kind = Primary | Secondary | Tertiary | Danger 6 6 - 7 7 - let classes = function 8 8 - | Primary -> 9 9 - base_classes 10 10 - ^ " bg-white font-serif text-mana-200 shadow-whisper \ 11 11 - hover:shadow-shimmer hover:bg-mist-20 focus-visible:shadow-shimmer \ 12 12 - focus-visible:bg-mist-20 active:shadow-glow disabled:bg-mana-40" 13 13 - | Secondary -> 14 14 - base_classes 15 15 - ^ " bg-feather font-serif underline text-mana-100 hover:no-underline \ 16 16 - focus-visible:shadow-whisper active:shadow-whisper disabled:no-underline \ 17 17 - disabled:bg-mana-40" 18 18 - | Tertiary -> 19 19 - base_classes 20 20 - ^ " font-sans underline text-mana-100 hover:no-underline \ 21 21 - focus-visible:text-mana-200 active:text-mana-200" 22 22 - | Danger -> 23 23 - base_classes 24 24 - ^ " bg-white font-serif text-phoenix-100 shadow-bleed hover:bg-mist-20 \ 25 25 - hover:text-phoenix-40 focus:bg-mist-20 focus:text-phoenix-40 \ 26 26 - focus-visible:outline-none active:bg-phoenix-40 active:text-mist-20 \ 27 27 - disabled:bg-mana-40" 28 28 - 29 29 - let make ?id ?name ?(kind = Primary) ?(type_ = "button") ?onclick ?value 30 30 - ?(class_ = "") ~children () = 31 31 - <button ?id ?name type_ ?onclick ?value class_=(classes kind ^ " " ^ class_)> 32 32 - children 33 33 - </button>

-56

pegasus/lib/templates/components/input.mlx

··· 1 1 - open JSX 2 2 - 3 3 - (* putting this inline messes with ocamlformat-mlx *) 4 4 - let req_marker = " *" 5 5 - 6 6 - let make ?id ~name ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false) 7 7 - ?value ?placeholder ?(required = false) ?(disabled = false) ?trailing () = 8 8 - let id = Option.value id ~default:name in 9 9 - let placeholder = if label <> None && sr_only then label else placeholder in 10 10 - let input = 11 11 - <input 12 12 - id 13 13 - type_ 14 14 - name 15 15 - ?placeholder 16 16 - required 17 17 - disabled 18 18 - ?value 19 19 - class_="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \ 20 20 - placeholder:font-medium focus-visible:outline-none" 21 21 - /> 22 22 - in 23 23 - <div> 24 24 - ( match label with 25 25 - | Some label -> 26 26 - <div 27 27 - class_=( "flex justify-between text-sm" 28 28 - ^ if sr_only then " sr-only" else "" )> 29 29 - <label for_=id class_="text-mist-100"> 30 30 - ( if required then 31 31 - list 32 32 - [ string label 33 33 - ; <span class_="text-phoenix-100">(string req_marker)</span> 34 34 - ] 35 35 - else string label ) 36 36 - </label> 37 37 - ( if required then null 38 38 - else <span class_="text-mist-80">"optional"</span> ) 39 39 - </div> 40 40 - | None -> 41 41 - null ) 42 42 - ( if type_ = "hidden" then input 43 43 - else 44 44 - <div 45 45 - class_=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \ 46 46 - outline-mana-40 disabled:outline-mana-40/20 \ 47 47 - disabled:bg-mana-40/20 focus-within:outline-2 \ 48 48 - focus-within:outline-mana-100" ^ class_ )> 49 49 - input 50 50 - ( match trailing with 51 51 - | Some trailing -> 52 52 - <div class_="shrink-0 text-mist-100 select-none">trailing</div> 53 53 - | None -> 54 54 - null ) 55 55 - </div> ) 56 56 - </div>

-11

pegasus/lib/templates/icons/circle_alert.mlx

··· 1 1 - let make ?class_ () = 2 2 - <svg 3 3 - ?class_ 4 4 - viewBox="0 0 24 24" 5 5 - fill="none" 6 6 - stroke="currentColor" 7 7 - strokeLinecap="round" 8 8 - strokeLinejoin="round" 9 9 - strokeWidth="2"> 10 10 - <circle cx="12" cy="12" r="10" /> <path d="M12 8v4M12 16h.01" /> 11 11 - </svg>

-16

pegasus/lib/templates/layout.mlx

··· 1 1 - open JSX 2 2 - 3 3 - let make ?(title = "Pegasus") ~children () = 4 4 - <html lang="en"> 5 5 - <head> 6 6 - <meta charset="utf-8" /> 7 7 - <meta name="viewport" content="width=device-width, initial-scale=1" /> 8 8 - <link rel="stylesheet" href="/public/index.css" /> 9 9 - <title>(string title)</title> 10 10 - </head> 11 11 - <body 12 12 - class_="bg-feather-100 font-sans font-normal text-base tracking-normal \ 13 13 - flex items-center justify-center min-h-screen"> 14 14 - children 15 15 - </body> 16 16 - </html>

-35

pegasus/lib/templates/login.mlx

··· 1 1 - open JSX 2 2 - open Components 3 3 - 4 4 - let make ~redirect_url ?error ~csrf_token () = 5 5 - <Layout title="Login"> 6 6 - <main class_="w-full h-auto max-w-xs px-4 sm:px-0"> 7 7 - <h1 class_="text-2xl font-serif text-mana-200 mb-2">"sign in"</h1> 8 8 - <span class_="w-full text-balance text-mist-100"> 9 9 - "Enter your handle, email address, or DID, and your password." 10 10 - </span> 11 11 - <form method_="post" class_="w-full flex flex-col mt-4 mb-2 gap-y-2"> 12 12 - <input type_="hidden" name="dream.csrf" value=csrf_token /> 13 13 - <Input sr_only=true name="identifier" type_="text" label="identifier" /> 14 14 - <Input sr_only=true name="password" type_="password" label="password" /> 15 15 - <input type_="hidden" name="redirect_url" value=redirect_url /> 16 16 - ( match error with 17 17 - | Some error -> 18 18 - <span class_="inline-flex items-center text-phoenix-100 text-sm"> 19 19 - <Icons.Circle_alert class_="w-4 h-4 mr-2" /> (string error) 20 20 - </span> 21 21 - | None -> 22 22 - null ) 23 23 - <Button type_="submit" class_="mt-2">"sign in"</Button> 24 24 - </form> 25 25 - <span class_="text-sm text-mist-100"> 26 26 - "Or " 27 27 - <a 28 28 - href="/account/signup" 29 29 - class_="text-mana-100 underline hover:text-mana-200"> 30 30 - "create an account" 31 31 - </a> 32 32 - "." 33 33 - </span> 34 34 - </main> 35 35 - </Layout>

-64

pegasus/lib/templates/oauth_authorize.mlx

··· 1 1 - open JSX 2 2 - open Components 3 3 - 4 4 - let cimd_suffix_len = String.length "/oauth-client-metadata.json" 5 5 - 6 6 - let make ~(metadata : Oauth.Types.client_metadata) ~handle ~scopes ~code 7 7 - ~request_uri ~csrf_token () = 8 8 - let client_id = Uri.of_string metadata.client_id in 9 9 - let raw_host = Uri.host client_id |> Option.get in 10 10 - let path = Uri.path client_id in 11 11 - let path = String.sub path 0 (String.length path - cimd_suffix_len) in 12 12 - let hostname = raw_host ^ path in 13 13 - let rendered_name = 14 14 - match metadata.client_name with 15 15 - | Some client_name -> 16 16 - <span class_="text-mana-100 font-serif"> 17 17 - (string client_name) 18 18 - <span class_="font-sans">(string (" (" ^ hostname ^ ")"))</span> 19 19 - </span> 20 20 - | None when String.length path = 0 -> 21 21 - <span class_="text-mana-100 font-serif">(string hostname)</span> 22 22 - | None -> 23 23 - <span class_="text-mana-100 font-serif"> 24 24 - (string raw_host) <span class_="text-mana-40">(string path)</span> 25 25 - </span> 26 26 - in 27 27 - let rendered_handle = 28 28 - <span class_="text-mana-100 font-serif">"@" (string handle)</span> 29 29 - in 30 30 - <Layout title="Login"> 31 31 - <main class_="w-full h-auto max-w-lg px-4 sm:px-0"> 32 32 - <h1 class_="text-2xl font-serif text-mana-200 mb-2"> 33 33 - (string ("authorizing " ^ hostname)) 34 34 - </h1> 35 35 - <p class_="w-full text-mist-100"> 36 36 - "You’re signing into " 37 37 - rendered_name 38 38 - " as " 39 39 - rendered_handle 40 40 - " and granting it the following permissions:" 41 41 - </p> 42 42 - <ul class_="w-full text-mist-100 list-disc ml-8 mt-2 space-y-1"> 43 43 - (list @@ List.map (fun scope -> <li>(string scope)</li>) scopes) 44 44 - </ul> 45 45 - <form 46 46 - method_="post" 47 47 - class_="w-full flex flex-row items-center justify-between mt-6"> 48 48 - <input type_="hidden" name="dream.csrf" value=csrf_token /> 49 49 - <input type_="hidden" name="code" value=code /> 50 50 - <input type_="hidden" name="request_uri" value=request_uri /> 51 51 - <Button kind=Secondary type_="submit" name="action" value="deny" class_="grow basis-1/3 min-w-0"> 52 52 - "cancel" 53 53 - </Button> 54 54 - <Button 55 55 - kind=Primary 56 56 - type_="submit" 57 57 - name="action" 58 58 - value="allow" 59 59 - class_="grow basis-2/3 min-w-0 max-w-2xs"> 60 60 - "authorize" 61 61 - </Button> 62 62 - </form> 63 63 - </main> 64 64 - </Layout>

+2 -2

pegasus/lib/user_store.ml

··· 386 386 let get_record t path : record option Lwt.t = 387 387 Util.use_pool t.db @@ Queries.get_record ~path 388 388 >|= Option.map (fun (cid, data, since) -> 389 389 - {path; cid; value= Lex.of_cbor data; since} ) 389 389 + {path; cid; value= Lex.of_cbor data; since} ) 390 390 391 391 let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection : 392 392 record list Lwt.t = ··· 395 395 in 396 396 Util.use_pool t.db @@ fn ~collection ~limit ~cursor 397 397 >|= List.map (fun (path, cid, data, since) -> 398 398 - {path; cid; value= Lex.of_cbor data; since} ) 398 398 + {path; cid; value= Lex.of_cbor data; since} ) 399 399 400 400 let put_record t record path : (Cid.t * bytes) Lwt.t = 401 401 let cid, data = Lex.to_cbor_block record in

+19 -59

pegasus/lib/util.ml

··· 287 287 let is_none = function None -> true | _ -> false 288 288 289 289 let validate_handle handle = 290 290 - let front = 291 291 - String.sub handle 0 (String.length handle - (String.length Env.hostname + 1)) 292 292 - in 293 293 - if String.contains front '.' then 294 294 - Error 295 295 - (Errors.InvalidRequestError 296 296 - ("InvalidHandle", "invalid characters in handle") ) 290 290 + if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then 291 291 + Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix")) 297 292 else 298 298 - match String.length front with 299 299 - | l when l < 3 -> 300 300 - Error (Errors.InvalidRequestError ("InvalidHandle", "handle too short")) 301 301 - | l when l > 18 -> 302 302 - Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long")) 303 303 - | _ -> 304 304 - Ok () 293 293 + let front = 294 294 + String.sub handle 0 295 295 + (String.length handle - (String.length Env.hostname + 1)) 296 296 + in 297 297 + if String.contains front '.' then 298 298 + Error 299 299 + (Errors.InvalidRequestError 300 300 + ("InvalidHandle", "invalid characters in handle") ) 301 301 + else 302 302 + match String.length front with 303 303 + | l when l < 3 -> 304 304 + Error 305 305 + (Errors.InvalidRequestError ("InvalidHandle", "handle too short")) 306 306 + | l when l > 18 -> 307 307 + Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long")) 308 308 + | _ -> 309 309 + Ok () 305 310 306 311 let mkfile_p path ~perm = 307 312 Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ; ··· 319 324 valid ) 320 325 did_keys 321 326 <> None 322 322 - 323 323 - let rec http_get ?(max_redirects = 5) ?headers uri = 324 324 - let%lwt ans = Cohttp_lwt_unix.Client.get ?headers uri in 325 325 - follow_redirect ~max_redirects uri ans 326 326 - 327 327 - and follow_redirect ~max_redirects request_uri (response, body) = 328 328 - let status = Http.Response.status response in 329 329 - (* the unconsumed body would otherwise leak memory *) 330 330 - let%lwt () = 331 331 - if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit 332 332 - in 333 333 - match status with 334 334 - | `OK -> 335 335 - Lwt.return (response, body) 336 336 - | `Permanent_redirect | `Moved_permanently -> 337 337 - handle_redirect ~permanent:true ~max_redirects request_uri response 338 338 - | `Found | `Temporary_redirect -> 339 339 - handle_redirect ~permanent:false ~max_redirects request_uri response 340 340 - | `Not_found | `Gone -> 341 341 - failwith "not found" 342 342 - | status -> 343 343 - Printf.ksprintf failwith "unhandled status: %s" 344 344 - (Cohttp.Code.string_of_status status) 345 345 - 346 346 - and handle_redirect ~permanent ~max_redirects request_uri response = 347 347 - if max_redirects <= 0 then failwith "too many redirects" 348 348 - else 349 349 - let headers = Http.Response.headers response in 350 350 - let location = Http.Header.get headers "location" in 351 351 - match location with 352 352 - | None -> 353 353 - failwith "redirection without Location header" 354 354 - | Some url -> 355 355 - let uri = Uri.of_string url in 356 356 - let%lwt () = 357 357 - if permanent then 358 358 - Logs_lwt.warn (fun m -> 359 359 - m "Permanent redirection from %s to %s" 360 360 - (Uri.to_string request_uri) 361 361 - url ) 362 362 - else Lwt.return_unit 363 363 - in 364 364 - http_get uri ~max_redirects:(max_redirects - 1) 365 365 - 366 366 - let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v]))

+17 -36

pegasus/lib/xrpc.ml

··· 10 10 let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) = 11 11 let open Errors in 12 12 let auth = Auth.Verifiers.of_t auth in 13 13 - try%lwt 14 14 - match%lwt auth init with 15 15 - | Ok creds -> ( 13 13 + match%lwt auth init with 14 14 + | Ok creds -> ( 16 15 try%lwt hdlr {req= init.req; db= init.db; auth= creds} 17 16 with e -> 18 18 - if not (is_xrpc_error e) then log_exn ~req:init.req e ; 17 17 + ( match is_xrpc_error e with 18 18 + | true -> 19 19 + () 20 20 + | false -> 21 21 + log_exn ~req:init.req e ) ; 19 22 exn_to_response e ) 20 20 - | Error e -> 21 21 - exn_to_response e 22 22 - with e -> 23 23 - if not (is_xrpc_error e) then log_exn ~req:init.req e ; 24 24 - exn_to_response e 23 23 + | Error e -> 24 24 + exn_to_response e 25 25 26 26 let parse_query (req : Dream.request) 27 27 (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a = ··· 29 29 let queries = Dream.all_queries req in 30 30 let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in 31 31 query_json |> of_yojson |> Result.get_ok 32 32 - with _ -> Errors.invalid_request "invalid query string" 32 32 + with _ -> Errors.invalid_request "Invalid query string" 33 33 34 34 let parse_body (req : Dream.request) 35 35 (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t = 36 36 try%lwt 37 37 let%lwt body = Dream.body req in 38 38 body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return 39 39 - with _ -> Errors.invalid_request "invalid request body" 39 39 + with e -> 40 40 + Errors.log_exn e ; 41 41 + Errors.invalid_request "Invalid request body" 40 42 41 43 let service_proxy (ctx : context) (proxy_header : string) = 42 44 let did = Auth.get_authed_did_exn ctx.auth in ··· 67 69 | None -> 68 70 Errors.invalid_request "failed to resolve destination service" 69 71 in 70 70 - let%lwt signing_multikey = 72 72 + let%lwt signing_key = 71 73 match%lwt Data_store.get_actor_by_identifier did ctx.db with 72 74 | Some {signing_key; _} -> 73 75 Lwt.return signing_key 74 76 | None -> 75 77 Errors.internal_error ~msg:"user not found" () 76 78 in 77 77 - let signing_key = Kleidos.parse_multikey_str signing_multikey in 78 79 let jwt = 79 79 - Jwt.generate_service_jwt ~did ~aud:service_did ~lxm:nsid ~signing_key 80 80 + Auth.generate_service_jwt ~did ~aud:service_did ~lxm:nsid ~signing_key 80 81 in 81 82 let uri = 82 83 host ^ "/" ^ String.concat "/" @@ (Dream.path [@warning "-3"]) ctx.req ··· 85 86 let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in 86 87 match Dream.method_ ctx.req with 87 88 | `GET -> ( 88 88 - let%lwt res, body = Util.http_get uri ~headers in 89 89 + let%lwt res, body = Client.get uri ~headers in 89 90 match res.status with 90 91 | `OK -> 91 92 let%lwt body = Body.to_string body in ··· 119 120 let service_proxy_middleware db inner_handler req = 120 121 match Dream.header req "atproto-proxy" with 121 122 | Some header -> 122 122 - handler ~auth:Authorization (fun ctx -> service_proxy ctx header) {req; db} 123 123 + handler ~auth:Access (fun ctx -> service_proxy ctx header) {req; db} 123 124 | None -> 124 125 inner_handler req 125 126 126 126 - let dpop_middleware inner_handler req = 127 127 - let%lwt res = inner_handler req in 128 128 - match Dream.header req "DPoP" with 129 129 - | Some _ -> 130 130 - Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ; 131 131 - Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ; 132 132 - Lwt.return res 133 133 - | None -> 134 134 - Lwt.return res 135 135 - 136 136 - let cors_middleware inner_handler req = 137 137 - let%lwt res = inner_handler req in 138 138 - Dream.add_header res "Access-Control-Allow-Origin" "*" ; 139 139 - Dream.add_header res "Access-Control-Allow-Methods" 140 140 - "GET, POST, PUT, DELETE, OPTIONS" ; 141 141 - Dream.add_header res "Access-Control-Allow-Headers" 142 142 - "Content-Type, Authorization, DPoP" ; 143 143 - Dream.add_header res "Access-Control-Max-Age" "86400" ; 144 144 - Lwt.return res 145 145 - 146 127 let resolve_repo_did ctx repo = 147 128 if String.starts_with ~prefix:"did:" repo then Lwt.return repo 148 129 else

public/fonts/Fragment.woff

This is a binary file and will not be displayed.

public/fonts/Fragment.woff2

This is a binary file and will not be displayed.

-48

public/main.css

··· 1 1 - @import "tailwindcss" source("../pegasus/lib/templates"); 2 2 - 3 3 - @font-face { 4 4 - font-family: "Fragment"; 5 5 - src: 6 6 - url("fonts/Fragment.woff2") format("woff2"), 7 7 - url("fonts/Fragment.woff") format("woff"); 8 8 - font-weight: normal; 9 9 - font-style: normal; 10 10 - font-display: swap; 11 11 - } 12 12 - 13 13 - @font-face { 14 14 - font-family: "Geist"; 15 15 - src: url("https://fonts.gstatic.com/s/geist/v4/gyByhwUxId8gMEwcGFWNOITd.woff2") 16 16 - format("woff2"); 17 17 - font-weight: 300 400; 18 18 - font-style: normal; 19 19 - font-display: swap; 20 20 - } 21 21 - 22 22 - @theme { 23 23 - --font-serif: Fragment, Georgia, "Times New Roman", Times, serif; 24 24 - --font-sans: Geist, Helvetica, -apple-system, system-ui, sans-serif; 25 25 - --font-weight-normal: 300; 26 26 - --font-weight-medium: 400; 27 27 - 28 28 - --tracking-normal: 0.01em; 29 29 - 30 30 - --color-*: initial; 31 31 - --color-white: #fff; 32 32 - --color-feather-100: #c8cfd2; 33 33 - --color-phoenix-40: #e499a6; 34 34 - --color-phoenix-100: #db4c64; 35 35 - --color-mana-40: #9b9eaa; 36 36 - --color-mana-100: #6558a1; 37 37 - --color-mana-200: #312b4d; 38 38 - --color-mist-20: #ecedf8; 39 39 - --color-mist-40: #dee1e3; 40 40 - --color-mist-60: #a4a9ac; 41 41 - --color-mist-80: #737579; 42 42 - --color-mist-100: #4f4f53; 43 43 - 44 44 - --shadow-whisper: inset 0 0 1em #97baff8c; 45 45 - --shadow-shimmer: inset 0 0 1em #79a7ed99; 46 46 - --shadow-glow: inset 0 0 2em #2d37ba73; 47 47 - --shadow-bleed: inset 0 0 2em #db4c6466; 48 48 - }

-27

tailwindcss.opam

··· 1 1 - # This file is generated by dune, edit dune-project instead 2 2 - opam-version: "2.0" 3 3 - maintainer: ["futurGH"] 4 4 - authors: ["futurGH"] 5 5 - license: "MPL-2.0" 6 6 - homepage: "https://github.com/futurGH/pegasus" 7 7 - bug-reports: "https://github.com/futurGH/pegasus/issues" 8 8 - depends: [ 9 9 - "dune" {>= "3.20"} 10 10 - "odoc" {with-doc} 11 11 - ] 12 12 - build: [ 13 13 - ["dune" "subst"] {dev} 14 14 - [ 15 15 - "dune" 16 16 - "build" 17 17 - "-p" 18 18 - name 19 19 - "-j" 20 20 - jobs 21 21 - "@install" 22 22 - "@runtest" {with-test} 23 23 - "@doc" {with-doc} 24 24 - ] 25 25 - ] 26 26 - dev-repo: "git+https://github.com/futurGH/pegasus.git" 27 27 - x-maintenance-intent: ["(latest)"]

-88

tools/tailwindcss/dune

··· 1 1 - (rule 2 2 - (target tailwindcss-linux-x64) 3 3 - (action 4 4 - (progn 5 5 - (with-stdout-to 6 6 - %{target} 7 7 - (bash 8 8 - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) 9 9 - (run chmod +x %{target})))) 10 10 - 11 11 - (rule 12 12 - (target tailwindcss-linux-arm64) 13 13 - (action 14 14 - (progn 15 15 - (with-stdout-to 16 16 - %{target} 17 17 - (bash 18 18 - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) 19 19 - (run chmod +x %{target})))) 20 20 - 21 21 - (rule 22 22 - (target tailwindcss-macos-x64) 23 23 - (action 24 24 - (progn 25 25 - (with-stdout-to 26 26 - %{target} 27 27 - (bash 28 28 - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) 29 29 - (run chmod +x %{target})))) 30 30 - 31 31 - (rule 32 32 - (target tailwindcss-macos-arm64) 33 33 - (action 34 34 - (progn 35 35 - (with-stdout-to 36 36 - %{target} 37 37 - (bash 38 38 - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) 39 39 - (run chmod +x %{target})))) 40 40 - 41 41 - (rule 42 42 - (enabled_if 43 43 - (and 44 44 - (= %{architecture} amd64) 45 45 - (= %{system} linux))) 46 46 - (target tailwindcss) 47 47 - (deps tailwindcss-linux-x64) 48 48 - (action 49 49 - (copy %{deps} tailwindcss))) 50 50 - 51 51 - (rule 52 52 - (enabled_if 53 53 - (and 54 54 - (= %{architecture} arm64) 55 55 - (= %{system} linux))) 56 56 - (target tailwindcss) 57 57 - (deps tailwindcss-linux-arm64) 58 58 - (action 59 59 - (copy %{deps} tailwindcss))) 60 60 - 61 61 - (rule 62 62 - (enabled_if 63 63 - (and 64 64 - (= %{architecture} amd64) 65 65 - (= %{system} macosx))) 66 66 - (target tailwindcss) 67 67 - (deps tailwindcss-macos-x64) 68 68 - (action 69 69 - (copy %{deps} tailwindcss))) 70 70 - 71 71 - (rule 72 72 - (enabled_if 73 73 - (and 74 74 - (= %{architecture} arm64) 75 75 - (= %{system} macosx))) 76 76 - (target tailwindcss) 77 77 - (deps tailwindcss-macos-arm64) 78 78 - (action 79 79 - (copy %{deps} tailwindcss))) 80 80 - 81 81 - (alias 82 82 - (name default) 83 83 - (deps tailwindcss)) 84 84 - 85 85 - (install 86 86 - (section bin) 87 87 - (package tailwindcss) 88 88 - (files tailwindcss))