-1

.ocamlformat

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

+25 -2

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) 10 27 ; (* unauthed *) 11 28 ( get 12 29 , "/xrpc/com.atproto.server.describeServer" ··· 15 32 ; ( get 16 33 , "/xrpc/com.atproto.identity.resolveHandle" 17 34 , Api.Identity.ResolveHandle.handler ) 18 18 - ; (* account *) 35 35 + ; (* account management *) 19 36 ( post 20 37 , "/xrpc/com.atproto.server.createInviteCode" 21 38 , Api.Server.CreateInviteCode.handler ) ··· 65 82 , "/xrpc/com.atproto.actor.putPreferences" 66 83 , Api.Actor.PutPreferences.handler ) ] 67 84 85 85 + let static_routes = 86 86 + [Dream.get "/public/**" (Dream.static "_build/default/public")] 87 87 + 68 88 let main = 69 89 let%lwt db = Data_store.connect ~create:true () in 70 90 let%lwt () = Data_store.init db in 71 91 Dream.serve ~interface:"0.0.0.0" ~port:8008 72 92 @@ Dream.logger 93 93 + @@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey) 94 94 + @@ Dream.cookie_sessions 73 95 @@ Xrpc.service_proxy_middleware db 74 74 - @@ Dream.router 96 96 + @@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router 75 97 @@ List.map 76 98 (fun (fn, path, handler) -> 77 99 fn path (fun req -> handler ({req; db} : Xrpc.init)) ) 78 100 handlers 101 101 + @ static_routes 79 102 80 103 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/*)

+18 -1

dune-project

··· 30 30 (url "git+https://github.com/roddyyaga/ppx_rapper.git") 31 31 (package (name ppx_rapper_lwt))) 32 32 33 33 + 33 34 (package 34 35 (name pegasus) 35 36 (synopsis "An atproto Personal Data Server implementation") ··· 46 47 (cohttp-lwt-unix (>= 6.1.1)) 47 48 (dns-client (>= 10.2.0)) 48 49 dream 50 50 + html_of_jsx 51 51 + mlx 49 52 (re (>= 1.13.2)) 50 53 (safepass (>= 3.1)) 51 54 (timedesc (>= 3.1.0)) 55 55 + (uri (>= 4.4.0)) 52 56 (uuidm (>= 0.9.10)) 53 57 (yojson (>= 3.0.0)) 54 58 (lwt_ppx (>= 5.9.1)) 55 59 (ppx_deriving_yojson (>= 3.9.1)) 56 60 ppx_rapper 57 61 ppx_rapper_lwt 58 58 - (alcotest :with-test))) 62 62 + (alcotest :with-test) 63 63 + (ocamlformat-mlx :with-dev-setup) 64 64 + (ocamlmerlin-mlx :with-dev-setup))) 59 65 60 66 (package 61 67 (name mist) ··· 97 103 (hacl-star (>= 0.7.2)) 98 104 (mirage-crypto-ec (>= 2.0.1)) 99 105 (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 =

+4

kleidos/kleidos.ml

··· 220 220 let pubkey_to_did_key pubkey : string = 221 221 let pubkey, (module Curve : CURVE) = pubkey in 222 222 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

+34 -33

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 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 ) 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 ) 506 508 | _ -> ( 507 509 let prev = 508 510 if index - 1 >= 0 then Util.at_index (index - 1) seq else None ··· 529 531 let%lwt bm = 530 532 match left_leaf with 531 533 | Some cid_left -> ( 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 ) 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 ) 538 539 | None -> 539 540 Lwt.return Block_map.empty 540 541 in 541 542 let%lwt bm = 542 543 match right_leaf with 543 544 | Some cid_right -> ( 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 ) 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 ) 549 550 | None -> 550 551 Lwt.return bm 551 552 in ··· 571 572 | Some (Tree c) -> 572 573 proof_for_left_sibling t c key 573 574 | Some (Leaf (_, v_left, _)) -> ( 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 ) 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 ) 579 580 | _ -> 580 581 Lwt.return Block_map.empty 581 582 in ··· 612 613 | Some (Tree c) -> 613 614 proof_for_right_sibling t c key 614 615 | Some (Leaf (_, v_right, _)) -> ( 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 ) 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 ) 620 621 | _ -> 621 622 Lwt.return Block_map.empty ) 622 623 | 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"

+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 23 "re" {>= "1.13.2"} 22 24 "safepass" {>= "3.1"} 23 25 "timedesc" {>= "3.1.0"} 26 26 + "uri" {>= "4.4.0"} 24 27 "uuidm" {>= "0.9.10"} 25 28 "yojson" {>= "3.0.0"} 26 29 "lwt_ppx" {>= "5.9.1"} ··· 28 31 "ppx_rapper" 29 32 "ppx_rapper_lwt" 30 33 "alcotest" {with-test} 34 34 + "ocamlformat-mlx" {with-dev-setup} 35 35 + "ocamlmerlin-mlx" {with-dev-setup} 31 36 "odoc" {with-doc} 32 37 ] 33 38 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; db; auth} -> 2 2 + Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> 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" () ) )

+55 -58

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" 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 ) ) 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 ) )

+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) )

+10 -10

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

+1 -1

pegasus/lib/api/server/createSession.ml

··· 17 17 [@@deriving yojson {strict= false}] 18 18 19 19 let handler = 20 20 - Xrpc.handler (fun {req; db; auth} -> 20 20 + Xrpc.handler (fun {req; auth; db; _} -> 21 21 let%lwt {identifier; password; _} = 22 22 Xrpc.parse_body req request_of_yojson 23 23 in

+1 -1

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

+57 -2

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 + 1 8 let did_json = 2 9 Xrpc.handler (fun _ -> 3 10 Dream.json @@ Yojson.Safe.to_string ··· 8 15 , `Assoc 9 16 [ ("id", `String "#atproto_pds") 10 17 ; ("type", `String "AtprotoPersonalDataServer") 11 11 - ; ("serviceEndpoint", `String ("https://" ^ Env.hostname)) ] ) 12 12 - ] ) 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) ] )

+145 -55

pegasus/lib/auth.ml

··· 15 15 | Admin 16 16 | Access of {did: string} 17 17 | Refresh of {did: string; jti: string} 18 18 + | OAuth of {did: string; proof: Oauth.Dpop.proof} 19 19 + | DPoP of {proof: Oauth.Dpop.proof} 18 20 19 21 let verify_bearer_jwt t token expected_scope = 20 22 match Jwt.verify_jwt token Env.jwt_key with ··· 42 44 match credentials with 43 45 | Admin -> 44 46 true 45 45 - | Access {did= creds} when creds = did -> 47 47 + | (Access {did= creds} | OAuth {did= creds; _}) when creds = did -> 46 48 true 47 49 | Refresh {did= creds; _} when creds = did && refresh -> 48 50 true ··· 50 52 false 51 53 52 54 let get_authed_did_exn = function 53 53 - | Access {did} -> 55 55 + | Access {did} | OAuth {did; _} -> 54 56 did 55 57 | Refresh {did; _} -> 56 58 did 57 59 | _ -> 58 58 - Errors.auth_required "Invalid authorization header" 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" 59 67 60 68 let get_session_info identifier db = 61 69 let%lwt actor = ··· 84 92 module Verifiers = struct 85 93 open struct 86 94 let parse_header req expected_type = 87 87 - match Dream.header req "authorization" with 95 95 + match Dream.header req "Authorization" with 88 96 | Some header -> ( 89 97 match String.split_on_char ' ' header with 90 98 | [typ; token] ··· 95 103 Error "invalid authorization header" ) 96 104 | None -> 97 105 Error "missing authorization header" 106 106 + end 98 107 99 99 - let parse_basic req = 100 100 - match parse_header req "Basic" with 101 101 - | Ok token -> ( 102 102 - match Base64.decode token with 103 103 - | Ok decoded -> ( 104 104 - match Str.bounded_split (Str.regexp_string ":") decoded 2 with 105 105 - | [username; password] -> 106 106 - Ok (username, password) 107 107 - | _ -> 108 108 - Error "invalid basic authorization header" ) 109 109 - | Error _ -> 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 + | _ -> 110 117 Error "invalid basic authorization header" ) 111 118 | Error _ -> 112 112 - Error "invalid basic authorization header" 119 119 + Error "invalid basic authorization header" ) 120 120 + | Error _ -> 121 121 + Error "invalid basic authorization header" 113 122 114 114 - let parse_bearer req = parse_header req "Bearer" 115 115 - end 123 123 + let parse_bearer req = parse_header req "Bearer" 124 124 + 125 125 + let parse_dpop req = parse_header req "DPoP" 116 126 117 127 type ctx = {req: Dream.request; db: Data_store.t} 118 128 ··· 122 132 fun {req; _} -> 123 133 match Dream.header req "authorization" with 124 134 | Some _ -> 125 125 - Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 135 135 + Lwt.return_error @@ Errors.auth_required "invalid authorization header" 126 136 | None -> 127 137 Lwt.return_ok Unauthenticated 128 138 ··· 134 144 | "admin", p when p = Env.admin_password -> 135 145 Lwt.return_ok Admin 136 146 | _ -> 137 137 - Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 147 147 + Lwt.return_error @@ Errors.auth_required "invalid credentials" ) 138 148 | Error _ -> 139 139 - Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 149 149 + Lwt.return_error @@ Errors.auth_required "invalid authorization header" 140 150 141 141 - let access : verifier = 151 151 + let bearer : verifier = 142 152 fun {req; db} -> 143 153 match parse_bearer req with 144 154 | Ok jwt -> ( 145 145 - match%lwt verify_bearer_jwt db jwt "com.atproto.access" with 146 146 - | Ok {sub= did; _} -> ( 147 147 - match%lwt Data_store.get_actor_by_identifier did db with 148 148 - | Some {deactivated_at= None; _} -> 149 149 - Lwt.return_ok (Access {did}) 150 150 - | Some {deactivated_at= Some _; _} -> 151 151 - Lwt.return_error 152 152 - @@ Errors.auth_required ~name:"AccountDeactivated" 153 153 - "Account is deactivated" 154 154 - | None -> 155 155 - Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 156 156 - | Error _ -> 157 157 - Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 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" ) 158 168 | Error _ -> 159 159 - Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 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" ) 160 236 161 237 let refresh : verifier = 162 238 fun {req; db} -> 163 239 match parse_bearer req with 164 240 | Ok jwt -> ( 165 165 - match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with 166 166 - | Ok {sub= did; jti; _} -> ( 167 167 - match%lwt Data_store.get_actor_by_identifier did db with 168 168 - | Some {deactivated_at= None; _} -> 169 169 - Lwt.return_ok (Refresh {did; jti}) 170 170 - | Some {deactivated_at= Some _; _} -> 171 171 - Lwt.return_error 172 172 - @@ Errors.auth_required ~name:"AccountDeactivated" 173 173 - "Account is deactivated" 174 174 - | None -> 175 175 - Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 176 176 - | Error "" | Error _ -> 177 177 - Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) 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" ) 178 254 | Error _ -> 179 179 - Lwt.return_error @@ Errors.auth_required "Invalid authorization header" 255 255 + Lwt.return_error @@ Errors.auth_required "invalid authorization header" 180 256 181 257 let authorization : verifier = 182 258 fun ctx -> ··· 187 263 | Some ("Basic" :: _) -> 188 264 admin ctx 189 265 | Some ("Bearer" :: _) -> 190 190 - access ctx 266 266 + bearer ctx 267 267 + | Some ("DPoP" :: _) -> 268 268 + oauth ctx 191 269 | _ -> 192 270 Lwt.return_error 193 271 @@ Errors.auth_required ~name:"InvalidToken" 194 194 - "Unexpected authorization type" 272 272 + "unexpected authorization type" 195 273 196 274 let any : verifier = 197 275 fun ctx -> try authorization ctx with _ -> unauthenticated ctx 198 276 199 199 - type t = Unauthenticated | Admin | Access | Refresh | Authorization | Any 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 200 286 201 287 let of_t = function 202 288 | Unauthenticated -> 203 289 unauthenticated 204 290 | Admin -> 205 291 admin 206 206 - | Access -> 207 207 - access 292 292 + | Bearer -> 293 293 + bearer 294 294 + | DPoP -> 295 295 + dpop 296 296 + | OAuth -> 297 297 + oauth 208 298 | Refresh -> 209 299 refresh 210 300 | Authorization ->

+115 -23

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}] 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 - [%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 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] 172 172 + () conn 173 173 + in 174 174 + Lwt.return_ok () 85 175 86 176 let create_actor = 87 177 [%rapper ··· 221 311 type t = Util.caqti_pool 222 312 223 313 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 ; 224 316 Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location 225 317 226 318 let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables

+3 -1

pegasus/lib/dune

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

+26 -6

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 + 1 5 let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR" 2 6 3 3 - let hostname = Sys.getenv "PDS_HOSTNAME" 7 7 + let hostname = getenv "PDS_HOSTNAME" 4 8 5 9 let did = 6 10 Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID" 7 11 8 8 - let invite_required = Sys.getenv "INVITE_CODE_REQUIRED" = "true" 12 12 + let invite_required = getenv "INVITE_CODE_REQUIRED" = "true" 9 13 10 10 - let rotation_key = 11 11 - Sys.getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str 14 14 + let rotation_key = getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str 12 15 13 13 - let jwt_key = Sys.getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str 16 16 + let jwt_key = getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str 14 17 15 15 - let admin_password = Sys.getenv "ADMIN_PASSWORD" 18 18 + let admin_password = getenv "ADMIN_PASSWORD" 19 19 + 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

+6

pegasus/lib/errors.ml

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

+3 -4

pegasus/lib/id_resolver.ml

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

+20 -26

pegasus/lib/jwt.ml

··· 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 - Ok s 22 22 + s 23 23 | Error (`Msg e) -> 24 24 - Error 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" ··· 30 30 let s = Bytes.sub signature 32 32 in 31 31 (r, s) 32 32 33 33 - let sign_jwt payload signing_key = 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 ··· 51 51 failwith "invalid curve" 52 52 in 53 53 let header_json = 54 54 - `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String "JWT")] 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 ··· 65 65 let decode_jwt jwt = 66 66 match String.split_on_char '.' jwt with 67 67 | [header_b64; payload_b64; _] -> ( 68 68 - match (b64_decode header_b64, b64_decode payload_b64) with 69 69 - | Ok header_str, Ok payload_str -> ( 70 70 - try 71 71 - let header = Yojson.Safe.from_string header_str in 72 72 - let payload = Yojson.Safe.from_string payload_str in 73 73 - Ok (header, payload) 74 74 - with _ -> Error "invalid json in jwt" ) 75 75 - | Error e, _ | _, Error e -> 76 76 - Error e ) 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" ) 77 73 | _ -> 78 74 Error "invalid jwt format" 79 75 80 76 let verify_jwt jwt pubkey = 81 77 match String.split_on_char '.' jwt with 82 82 - | [header_b64; payload_b64; signature_b64] -> ( 83 83 - match b64_decode signature_b64 with 84 84 - | Error e -> 85 85 - Error e 86 86 - | Ok signature_str -> 87 87 - let signature = Bytes.of_string signature_str in 88 88 - let signing_input = header_b64 ^ "." ^ payload_b64 in 89 89 - let verified = 90 90 - Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature 91 91 - in 92 92 - if verified then decode_jwt jwt 93 93 - else Error "jwt signature verification failed" ) 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" 94 86 | _ -> 95 87 Error "invalid jwt format" 96 88 ··· 98 90 let now_s = int_of_float (Unix.gettimeofday ()) in 99 91 let access_exp = now_s + Defaults.access_token_exp in 100 92 let refresh_exp = now_s + Defaults.refresh_token_exp in 101 101 - let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in 93 93 + let jti = 94 94 + Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string 95 95 + in 102 96 let access_payload = 103 97 symmetric_jwt_to_yojson 104 98 { scope= "com.atproto.access"

+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 = Client.get ~headers uri in 305 305 + let%lwt res, body = Util.http_get ~headers uri in 306 306 match res.status with 307 307 | `OK -> 308 308 let%lwt body = Body.to_string body in

+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

+59 -19

pegasus/lib/util.ml

··· 287 287 let is_none = function None -> true | _ -> false 288 288 289 289 let validate_handle handle = 290 290 - if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then 291 291 - Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix")) 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") ) 292 297 else 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 () 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 () 310 305 311 306 let mkfile_p path ~perm = 312 307 Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ; ··· 324 319 valid ) 325 320 did_keys 326 321 <> 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]))

+33 -15

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 - match%lwt auth init with 14 14 - | Ok creds -> ( 13 13 + try%lwt 14 14 + match%lwt auth init with 15 15 + | Ok creds -> ( 15 16 try%lwt hdlr {req= init.req; db= init.db; auth= creds} 16 17 with 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 ) ; 18 18 + if not (is_xrpc_error e) then log_exn ~req:init.req e ; 22 19 exn_to_response e ) 23 23 - | Error e -> 24 24 - 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 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 e -> 40 40 - Errors.log_exn e ; 41 41 - Errors.invalid_request "Invalid request body" 39 39 + with _ -> Errors.invalid_request "invalid request body" 42 40 43 41 let service_proxy (ctx : context) (proxy_header : string) = 44 42 let did = Auth.get_authed_did_exn ctx.auth in ··· 87 85 let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in 88 86 match Dream.method_ ctx.req with 89 87 | `GET -> ( 90 90 - let%lwt res, body = Client.get uri ~headers in 88 88 + let%lwt res, body = Util.http_get uri ~headers in 91 89 match res.status with 92 90 | `OK -> 93 91 let%lwt body = Body.to_string body in ··· 121 119 let service_proxy_middleware db inner_handler req = 122 120 match Dream.header req "atproto-proxy" with 123 121 | Some header -> 124 124 - handler ~auth:Access (fun ctx -> service_proxy ctx header) {req; db} 122 122 + handler ~auth:Authorization (fun ctx -> service_proxy ctx header) {req; db} 125 123 | None -> 126 124 inner_handler req 125 125 + 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 127 145 128 146 let resolve_repo_did ctx repo = 129 147 if String.starts_with ~prefix:"did:" repo then Lwt.return repo

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))