patch of Implement OAuth · round #1 · pull #2 · futur.blue/pegasus

.ocamlformat

···

       1
        
       profile = ocamlformat

     

       0

···

       1
        
       profile = ocamlformat

     

       2
       +
       version = 0.27.0

+2 -25

bin/main.ml

···

       7
        
         ; (get, "/robots.txt", Api.Robots.handler)

     

       8
        
         ; (get, "/xrpc/_health", Api.Health.handler)

     

       9
        
         ; (get, "/.well-known/did.json", Api.Well_known.did_json)

     

       10
       -
         ; ( get

     

       11
       -
           , "/.well-known/oauth-protected-resource"

     

       12
       -
           , Api.Well_known.oauth_protected_resource )

     

       13
       -
         ; ( get

     

       14
       -
           , "/.well-known/oauth-authorization-server"

     

       15
       -
           , Api.Well_known.oauth_authorization_server )

     

       16
       -
         ; (* oauth *)

     

       17
       -
           (options, "/oauth/par", Api.Oauth_.Par.options_handler)

     

       18
       -
         ; (post, "/oauth/par", Api.Oauth_.Par.post_handler)

     

       19
       -
         ; (get, "/oauth/authorize", Api.Oauth_.Authorize.get_handler)

     

       20
       -
         ; (post, "/oauth/authorize", Api.Oauth_.Authorize.post_handler)

     

       21
       -
         ; (options, "/oauth/token", Api.Oauth_.Token.options_handler)

     

       22
       -
         ; (post, "/oauth/token", Api.Oauth_.Token.post_handler)

     

       23
       -
         ; (* account *)

     

       24
       -
           (get, "/account/login", Api.Account_.Login.get_handler)

     

       25
       -
         ; (post, "/account/login", Api.Account_.Login.post_handler)

     

       26
       -
         ; (get, "/account/logout", Api.Account_.Logout.handler)

     

       27
        
         ; (* unauthed *)

     

       28
        
           ( get

     

       29
        
           , "/xrpc/com.atproto.server.describeServer"

     
···

       32
        
         ; ( get

     

       33
        
           , "/xrpc/com.atproto.identity.resolveHandle"

     

       34
        
           , Api.Identity.ResolveHandle.handler )

     

       35
       -
         ; (* account management *)

     

       36
        
           ( post

     

       37
        
           , "/xrpc/com.atproto.server.createInviteCode"

     

       38
        
           , Api.Server.CreateInviteCode.handler )

     
···

       82
        
           , "/xrpc/com.atproto.actor.putPreferences"

     

       83
        
           , Api.Actor.PutPreferences.handler ) ]

     

       84
        
       

     

       85
       -
       let static_routes =

     

       86
       -
         [Dream.get "/public/**" (Dream.static "_build/default/public")]

     

       87
       -
       

     

       88
        
       let main =

     

       89
        
         let%lwt db = Data_store.connect ~create:true () in

     

       90
        
         let%lwt () = Data_store.init db in

     

       91
        
         Dream.serve ~interface:"0.0.0.0" ~port:8008

     

       92
        
         @@ Dream.logger

     

       93
       -
         @@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey)

     

       94
       -
         @@ Dream.cookie_sessions

     

       95
        
         @@ Xrpc.service_proxy_middleware db

     

       96
       -
         @@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router

     

       97
        
         @@ List.map

     

       98
        
              (fun (fn, path, handler) ->

     

       99
        
                fn path (fun req -> handler ({req; db} : Xrpc.init)) )

     

       100
        
              handlers

     

       101
       -
         @ static_routes

     

       102
        
       

     

       103
        
       let () = Lwt_main.run main

···

       7
        
         ; (get, "/robots.txt", Api.Robots.handler)

     

       8
        
         ; (get, "/xrpc/_health", Api.Health.handler)

     

       9
        
         ; (get, "/.well-known/did.json", Api.Well_known.did_json)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       10
        
         ; (* unauthed *)

     

       11
        
           ( get

     

       12
        
           , "/xrpc/com.atproto.server.describeServer"

     
···

       15
        
         ; ( get

     

       16
        
           , "/xrpc/com.atproto.identity.resolveHandle"

     

       17
        
           , Api.Identity.ResolveHandle.handler )

     

       18
       +
         ; (* account *)

     

       19
        
           ( post

     

       20
        
           , "/xrpc/com.atproto.server.createInviteCode"

     

       21
        
           , Api.Server.CreateInviteCode.handler )

     
···

       65
        
           , "/xrpc/com.atproto.actor.putPreferences"

     

       66
        
           , Api.Actor.PutPreferences.handler ) ]

     

       67
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       68
        
       let main =

     

       69
        
         let%lwt db = Data_store.connect ~create:true () in

     

       70
        
         let%lwt () = Data_store.init db in

     

       71
        
         Dream.serve ~interface:"0.0.0.0" ~port:8008

     

       72
        
         @@ Dream.logger

     

       0
        
       
     

       0
        
       
     

       73
        
         @@ Xrpc.service_proxy_middleware db

     

       74
       +
         @@ Dream.router

     

       75
        
         @@ List.map

     

       76
        
              (fun (fn, path, handler) ->

     

       77
        
                fn path (fun req -> handler ({req; db} : Xrpc.init)) )

     

       78
        
              handlers

     

       0
        
       
     

       79
        
       

     

       80
        
       let () = Lwt_main.run main

-21

dune

···

       1
       -
       (subdir

     

       2
       -
        public/

     

       3
       -
        (rule

     

       4
       -
         (target index.css)

     

       5
       -
         (deps

     

       6
       -
          %{workspace_root}/tools/tailwindcss/tailwindcss

     

       7
       -
          (:input %{workspace_root}/public/main.css)

     

       8
       -
          (source_tree %{workspace_root}/public)

     

       9
       -
          (source_tree %{workspace_root}/pegasus/lib/templates))

     

       10
       -
         (action

     

       11
       -
          (chdir

     

       12
       -
           %{workspace_root}

     

       13
       -
           (run

     

       14
       -
            %{workspace_root}/tools/tailwindcss/tailwindcss

     

       15
       -
            -m

     

       16
       -
            -i

     

       17
       -
            %{input}

     

       18
       -
            -o

     

       19
       -
            %{target})))))

     

       20
       -
       

     

       21
       -
       (copy_files public/*)

+1 -18

dune-project

···

       30
        
        (url "git+https://github.com/roddyyaga/ppx_rapper.git")

     

       31
        
        (package (name ppx_rapper_lwt)))

     

       32
        
       

     

       33
       -
       

     

       34
        
       (package

     

       35
        
        (name pegasus)

     

       36
        
        (synopsis "An atproto Personal Data Server implementation")

     
···

       47
        
         (cohttp-lwt-unix (>= 6.1.1))

     

       48
        
         (dns-client (>= 10.2.0))

     

       49
        
         dream

     

       50
       -
         html_of_jsx

     

       51
       -
         mlx

     

       52
        
         (re (>= 1.13.2))

     

       53
        
         (safepass (>= 3.1))

     

       54
        
         (timedesc (>= 3.1.0))

     

       55
       -
         (uri (>= 4.4.0))

     

       56
        
         (uuidm (>= 0.9.10))

     

       57
        
         (yojson (>= 3.0.0))

     

       58
        
         (lwt_ppx (>= 5.9.1))

     

       59
        
         (ppx_deriving_yojson (>= 3.9.1))

     

       60
        
         ppx_rapper

     

       61
        
         ppx_rapper_lwt

     

       62
       -
         (alcotest :with-test)

     

       63
       -
         (ocamlformat-mlx :with-dev-setup)

     

       64
       -
         (ocamlmerlin-mlx :with-dev-setup)))

     

       65
        
       

     

       66
        
       (package

     

       67
        
        (name mist)

     
···

       103
        
         (hacl-star (>= 0.7.2))

     

       104
        
         (mirage-crypto-ec (>= 2.0.1))

     

       105
        
         (multibase (>= 0.1.0))))

     

       106
       -
       

     

       107
       -
       (package

     

       108
       -
           (name tailwindcss) (allow_empty))

     

       109
       -
       

     

       110
       -
       (dialect

     

       111
       -
        (name mlx)

     

       112
       -
        (implementation

     

       113
       -
         (extension mlx)

     

       114
       -
         (merlin_reader mlx)

     

       115
       -
         (preprocess

     

       116
       -
          (run mlx-pp %{input-file}))))

···

       30
        
        (url "git+https://github.com/roddyyaga/ppx_rapper.git")

     

       31
        
        (package (name ppx_rapper_lwt)))

     

       32
        
       

     

       0
        
       
     

       33
        
       (package

     

       34
        
        (name pegasus)

     

       35
        
        (synopsis "An atproto Personal Data Server implementation")

     
···

       46
        
         (cohttp-lwt-unix (>= 6.1.1))

     

       47
        
         (dns-client (>= 10.2.0))

     

       48
        
         dream

     

       0
        
       
     

       0
        
       
     

       49
        
         (re (>= 1.13.2))

     

       50
        
         (safepass (>= 3.1))

     

       51
        
         (timedesc (>= 3.1.0))

     

       0
        
       
     

       52
        
         (uuidm (>= 0.9.10))

     

       53
        
         (yojson (>= 3.0.0))

     

       54
        
         (lwt_ppx (>= 5.9.1))

     

       55
        
         (ppx_deriving_yojson (>= 3.9.1))

     

       56
        
         ppx_rapper

     

       57
        
         ppx_rapper_lwt

     

       58
       +
         (alcotest :with-test)))

     

       0
        
       
     

       0
        
       
     

       59
        
       

     

       60
        
       (package

     

       61
        
        (name mist)

     
···

       97
        
         (hacl-star (>= 0.7.2))

     

       98
        
         (mirage-crypto-ec (>= 2.0.1))

     

       99
        
         (multibase (>= 0.1.0))))

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+2 -2

ipld/lib/dag_cbor.ml

···

       197
        
               write_type_and_argument t 5 (Int64.of_int len) ;

     

       198
        
               ordered_map_keys m

     

       199
        
               |> List.iter (fun k ->

     

       200
       -
                   write_string t k ;

     

       201
       -
                   write_value t (String_map.find k m) )

     

       202
        
           | `Link cid ->

     

       203
        
               write_cid t cid

     

       204

···

       197
        
               write_type_and_argument t 5 (Int64.of_int len) ;

     

       198
        
               ordered_map_keys m

     

       199
        
               |> List.iter (fun k ->

     

       200
       +
                      write_string t k ;

     

       201
       +
                      write_value t (String_map.find k m) )

     

       202
        
           | `Link cid ->

     

       203
        
               write_cid t cid

     

       204

+4 -4

ipld/test/test_dag_cbor.ml

···

       3
        
       let rec stringify_map m =

     

       4
        
         String_map.bindings m

     

       5
        
         |> List.map (fun (k, v) ->

     

       6
       -
             Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) )

     

       7
        
         |> String.concat ", " |> Format.sprintf "{%s}"

     

       8
        
       

     

       9
        
       and stringify_ipld_value (value : Dag_cbor.value) =

     
···

       109
        
         Hashtbl.add cases (to_base_16 (Dag_cbor.encode `Null)) (Bytes.of_string "f6") ;

     

       110
        
         cases

     

       111
        
         |> Hashtbl.iter (fun key value ->

     

       112
       -
             Alcotest.(check bytes)

     

       113
       -
               ("encoded bytes for " ^ key)

     

       114
       -
               value (Bytes.of_string key) )

     

       115
        
       

     

       116
        
       let test_round_trip () =

     

       117
        
         let test_cid =

···

       3
        
       let rec stringify_map m =

     

       4
        
         String_map.bindings m

     

       5
        
         |> List.map (fun (k, v) ->

     

       6
       +
                Format.sprintf "\"%s\": %s" k (stringify_ipld_value v) )

     

       7
        
         |> String.concat ", " |> Format.sprintf "{%s}"

     

       8
        
       

     

       9
        
       and stringify_ipld_value (value : Dag_cbor.value) =

     
···

       109
        
         Hashtbl.add cases (to_base_16 (Dag_cbor.encode `Null)) (Bytes.of_string "f6") ;

     

       110
        
         cases

     

       111
        
         |> Hashtbl.iter (fun key value ->

     

       112
       +
                Alcotest.(check bytes)

     

       113
       +
                  ("encoded bytes for " ^ key)

     

       114
       +
                  value (Bytes.of_string key) )

     

       115
        
       

     

       116
        
       let test_round_trip () =

     

       117
        
         let test_cid =

-4

kleidos/kleidos.ml

···

       220
        
       let pubkey_to_did_key pubkey : string =

     

       221
        
         let pubkey, (module Curve : CURVE) = pubkey in

     

       222
        
         Curve.pubkey_to_did_key pubkey

     

       223
       -
       

     

       224
       -
       let privkey_to_multikey privkey : string =

     

       225
       -
         let privkey, (module Curve : CURVE) = privkey in

     

       226
       -
         Curve.privkey_to_multikey privkey

···

       220
        
       let pubkey_to_did_key pubkey : string =

     

       221
        
         let pubkey, (module Curve : CURVE) = pubkey in

     

       222
        
         Curve.pubkey_to_did_key pubkey

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+33 -34

mist/lib/mst.ml

···

       239
        
           | None, [] ->

     

       240
        
               Lwt.return 0

     

       241
        
           | Some left, [] -> (

     

       242
       -
             match%lwt retrieve_node_raw t left with

     

       243
       -
             | Some node ->

     

       244
       -
                 let%lwt height = get_node_height t node in

     

       245
       -
                 Lwt.return (height + 1)

     

       246
       -
             | None ->

     

       247
       -
                 failwith ("couldn't find node " ^ Cid.to_string left) )

     

       248
        
           | _, leaf :: _ -> (

     

       249
        
             match leaf.p with

     

       250
        
             | 0 ->

     
···

       497
        
               let%lwt blocks =

     

       498
        
                 match Util.at_index index seq with

     

       499
        
                 | Some (Leaf (k, v, _)) when k = key -> (

     

       500
       -
                   (* include the found leaf block to prove existence *)

     

       501
       -
                   match%lwt

     

       502
       -
                     Store.get_bytes t.blockstore v

     

       503
       -
                   with

     

       504
       -
                   | Some leaf_bytes ->

     

       505
       -
                       Lwt.return (Block_map.set v leaf_bytes Block_map.empty)

     

       506
       -
                   | None ->

     

       507
       -
                       Lwt.return Block_map.empty )

     

       508
        
                 | _ -> (

     

       509
        
                     let prev =

     

       510
        
                       if index - 1 >= 0 then Util.at_index (index - 1) seq else None

     
···

       531
        
                         let%lwt bm =

     

       532
        
                           match left_leaf with

     

       533
        
                           | Some cid_left -> (

     

       534
       -
                             match%lwt Store.get_bytes t.blockstore cid_left with

     

       535
       -
                             | Some b ->

     

       536
       -
                                 Lwt.return (Block_map.set cid_left b Block_map.empty)

     

       537
       -
                             | None ->

     

       538
       -
                                 Lwt.return Block_map.empty )

     

       0
        
       
     

       539
        
                           | None ->

     

       540
        
                               Lwt.return Block_map.empty

     

       541
        
                         in

     

       542
        
                         let%lwt bm =

     

       543
        
                           match right_leaf with

     

       544
        
                           | Some cid_right -> (

     

       545
       -
                             match%lwt Store.get_bytes t.blockstore cid_right with

     

       546
       -
                             | Some b ->

     

       547
       -
                                 Lwt.return (Block_map.set cid_right b bm)

     

       548
       -
                             | None ->

     

       549
       -
                                 Lwt.return bm )

     

       550
        
                           | None ->

     

       551
        
                               Lwt.return bm

     

       552
        
                         in

     
···

       572
        
                 | Some (Tree c) ->

     

       573
        
                     proof_for_left_sibling t c key

     

       574
        
                 | Some (Leaf (_, v_left, _)) -> (

     

       575
       -
                   match%lwt Store.get_bytes t.blockstore v_left with

     

       576
       -
                   | Some b ->

     

       577
       -
                       Lwt.return (Block_map.set v_left b Block_map.empty)

     

       578
       -
                   | None ->

     

       579
       -
                       Lwt.return Block_map.empty )

     

       580
        
                 | _ ->

     

       581
        
                     Lwt.return Block_map.empty

     

       582
        
               in

     
···

       613
        
                     | Some (Tree c) ->

     

       614
        
                         proof_for_right_sibling t c key

     

       615
        
                     | Some (Leaf (_, v_right, _)) -> (

     

       616
       -
                       match%lwt Store.get_bytes t.blockstore v_right with

     

       617
       -
                       | Some b ->

     

       618
       -
                           Lwt.return (Block_map.set v_right b Block_map.empty)

     

       619
       -
                       | None ->

     

       620
       -
                           Lwt.return Block_map.empty )

     

       621
        
                     | _ ->

     

       622
        
                         Lwt.return Block_map.empty )

     

       623
        
                 | None ->

···

       239
        
           | None, [] ->

     

       240
        
               Lwt.return 0

     

       241
        
           | Some left, [] -> (

     

       242
       +
               match%lwt retrieve_node_raw t left with

     

       243
       +
               | Some node ->

     

       244
       +
                   let%lwt height = get_node_height t node in

     

       245
       +
                   Lwt.return (height + 1)

     

       246
       +
               | None ->

     

       247
       +
                   failwith ("couldn't find node " ^ Cid.to_string left) )

     

       248
        
           | _, leaf :: _ -> (

     

       249
        
             match leaf.p with

     

       250
        
             | 0 ->

     
···

       497
        
               let%lwt blocks =

     

       498
        
                 match Util.at_index index seq with

     

       499
        
                 | Some (Leaf (k, v, _)) when k = key -> (

     

       500
       +
                     (* include the found leaf block to prove existence *)

     

       501
       +
                     match%lwt Store.get_bytes t.blockstore v with

     

       502
       +
                     | Some leaf_bytes ->

     

       503
       +
                         Lwt.return (Block_map.set v leaf_bytes Block_map.empty)

     

       504
       +
                     | None ->

     

       505
       +
                         Lwt.return Block_map.empty )

     

       0
        
       
     

       0
        
       
     

       506
        
                 | _ -> (

     

       507
        
                     let prev =

     

       508
        
                       if index - 1 >= 0 then Util.at_index (index - 1) seq else None

     
···

       529
        
                         let%lwt bm =

     

       530
        
                           match left_leaf with

     

       531
        
                           | Some cid_left -> (

     

       532
       +
                               match%lwt Store.get_bytes t.blockstore cid_left with

     

       533
       +
                               | Some b ->

     

       534
       +
                                   Lwt.return

     

       535
       +
                                     (Block_map.set cid_left b Block_map.empty)

     

       536
       +
                               | None ->

     

       537
       +
                                   Lwt.return Block_map.empty )

     

       538
        
                           | None ->

     

       539
        
                               Lwt.return Block_map.empty

     

       540
        
                         in

     

       541
        
                         let%lwt bm =

     

       542
        
                           match right_leaf with

     

       543
        
                           | Some cid_right -> (

     

       544
       +
                               match%lwt Store.get_bytes t.blockstore cid_right with

     

       545
       +
                               | Some b ->

     

       546
       +
                                   Lwt.return (Block_map.set cid_right b bm)

     

       547
       +
                               | None ->

     

       548
       +
                                   Lwt.return bm )

     

       549
        
                           | None ->

     

       550
        
                               Lwt.return bm

     

       551
        
                         in

     
···

       571
        
                 | Some (Tree c) ->

     

       572
        
                     proof_for_left_sibling t c key

     

       573
        
                 | Some (Leaf (_, v_left, _)) -> (

     

       574
       +
                     match%lwt Store.get_bytes t.blockstore v_left with

     

       575
       +
                     | Some b ->

     

       576
       +
                         Lwt.return (Block_map.set v_left b Block_map.empty)

     

       577
       +
                     | None ->

     

       578
       +
                         Lwt.return Block_map.empty )

     

       579
        
                 | _ ->

     

       580
        
                     Lwt.return Block_map.empty

     

       581
        
               in

     
···

       612
        
                     | Some (Tree c) ->

     

       613
        
                         proof_for_right_sibling t c key

     

       614
        
                     | Some (Leaf (_, v_right, _)) -> (

     

       615
       +
                         match%lwt Store.get_bytes t.blockstore v_right with

     

       616
       +
                         | Some b ->

     

       617
       +
                             Lwt.return (Block_map.set v_right b Block_map.empty)

     

       618
       +
                         | None ->

     

       619
       +
                             Lwt.return Block_map.empty )

     

       620
        
                     | _ ->

     

       621
        
                         Lwt.return Block_map.empty )

     

       622
        
                 | None ->

+7 -7

mist/test/test_util.ml

···

       8
        
         Hashtbl.add cases "app.bsky.feed.post/9adeb165882c" 8 ;

     

       9
        
         cases

     

       10
        
         |> Hashtbl.iter (fun key value ->

     

       11
       -
             Alcotest.(check int)

     

       12
       -
               ("leading zeros on hash " ^ key)

     

       13
       -
               value

     

       14
       -
               (leading_zeros_on_hash key) )

     

       15
        
       

     

       16
        
       let test_shared_prefix_length () =

     

       17
        
         let cases = Hashtbl.create 5 in

     
···

       22
        
         Hashtbl.add cases ("2653ae71", "0653ae71") 0 ;

     

       23
        
         cases

     

       24
        
         |> Hashtbl.iter (fun (a, b) value ->

     

       25
       -
             Alcotest.(check int)

     

       26
       -
               ("prefix length between " ^ a ^ " and " ^ b)

     

       27
       -
               value (shared_prefix_length a b) )

     

       28
        
       

     

       29
        
       let () =

     

       30
        
         Alcotest.run "util"

···

       8
        
         Hashtbl.add cases "app.bsky.feed.post/9adeb165882c" 8 ;

     

       9
        
         cases

     

       10
        
         |> Hashtbl.iter (fun key value ->

     

       11
       +
                Alcotest.(check int)

     

       12
       +
                  ("leading zeros on hash " ^ key)

     

       13
       +
                  value

     

       14
       +
                  (leading_zeros_on_hash key) )

     

       15
        
       

     

       16
        
       let test_shared_prefix_length () =

     

       17
        
         let cases = Hashtbl.create 5 in

     
···

       22
        
         Hashtbl.add cases ("2653ae71", "0653ae71") 0 ;

     

       23
        
         cases

     

       24
        
         |> Hashtbl.iter (fun (a, b) value ->

     

       25
       +
                Alcotest.(check int)

     

       26
       +
                  ("prefix length between " ^ a ^ " and " ^ b)

     

       27
       +
                  value (shared_prefix_length a b) )

     

       28
        
       

     

       29
        
       let () =

     

       30
        
         Alcotest.run "util"

-5

pegasus.opam

···

       18
        
         "cohttp-lwt-unix" {>= "6.1.1"}

     

       19
        
         "dns-client" {>= "10.2.0"}

     

       20
        
         "dream"

     

       21
       -
         "html_of_jsx"

     

       22
       -
         "mlx"

     

       23
        
         "re" {>= "1.13.2"}

     

       24
        
         "safepass" {>= "3.1"}

     

       25
        
         "timedesc" {>= "3.1.0"}

     

       26
       -
         "uri" {>= "4.4.0"}

     

       27
        
         "uuidm" {>= "0.9.10"}

     

       28
        
         "yojson" {>= "3.0.0"}

     

       29
        
         "lwt_ppx" {>= "5.9.1"}

     
···

       31
        
         "ppx_rapper"

     

       32
        
         "ppx_rapper_lwt"

     

       33
        
         "alcotest" {with-test}

     

       34
       -
         "ocamlformat-mlx" {with-dev-setup}

     

       35
       -
         "ocamlmerlin-mlx" {with-dev-setup}

     

       36
        
         "odoc" {with-doc}

     

       37
        
       ]

     

       38
        
       build: [

···

       18
        
         "cohttp-lwt-unix" {>= "6.1.1"}

     

       19
        
         "dns-client" {>= "10.2.0"}

     

       20
        
         "dream"

     

       0
        
       
     

       0
        
       
     

       21
        
         "re" {>= "1.13.2"}

     

       22
        
         "safepass" {>= "3.1"}

     

       23
        
         "timedesc" {>= "3.1.0"}

     

       0
        
       
     

       24
        
         "uuidm" {>= "0.9.10"}

     

       25
        
         "yojson" {>= "3.0.0"}

     

       26
        
         "lwt_ppx" {>= "5.9.1"}

     
···

       28
        
         "ppx_rapper"

     

       29
        
         "ppx_rapper_lwt"

     

       30
        
         "alcotest" {with-test}

     

       0
        
       
     

       0
        
       
     

       31
        
         "odoc" {with-doc}

     

       32
        
       ]

     

       33
        
       build: [

-49

pegasus/lib/api/account_/login.ml

···

       1
       -
       let get_handler =

     

       2
       -
         Xrpc.handler (fun ctx ->

     

       3
       -
             let redirect_url =

     

       4
       -
               if List.length @@ Dream.all_queries ctx.req > 0 then

     

       5
       -
                 Uri.make ~path:"/oauth/authorize" ~query:(Util.copy_query ctx.req) ()

     

       6
       -
                 |> Uri.to_string

     

       7
       -
               else "/account"

     

       8
       -
             in

     

       9
       -
             let csrf_token = Dream.csrf_token ctx.req in

     

       10
       -
             let html =

     

       11
       -
               JSX.render (Templates.Login.make ~redirect_url ~csrf_token ())

     

       12
       -
             in

     

       13
       -
             Dream.html html )

     

       14
       -
       

     

       15
       -
       let post_handler =

     

       16
       -
         Xrpc.handler (fun ctx ->

     

       17
       -
             let csrf_token = Dream.csrf_token ctx.req in

     

       18
       -
             match%lwt Dream.form ctx.req with

     

       19
       -
             | `Ok fields -> (

     

       20
       -
                 let identifier = List.assoc "identifier" fields in

     

       21
       -
                 let password = List.assoc "password" fields in

     

       22
       -
                 let redirect_url =

     

       23
       -
                   List.assoc_opt "redirect_url" fields

     

       24
       -
                   |> Option.value ~default:"/account"

     

       25
       -
                 in

     

       26
       -
                 let%lwt actor =

     

       27
       -
                   Data_store.try_login ~id:identifier ~password ctx.db

     

       28
       -
                 in

     

       29
       -
                 match actor with

     

       30
       -
                 | None ->

     

       31
       -
                     let html =

     

       32
       -
                       JSX.render

     

       33
       -
                         (Templates.Login.make ~redirect_url

     

       34
       -
                            ~error:"Invalid username or password. Please try again."

     

       35
       -
                            ~csrf_token () )

     

       36
       -
                     in

     

       37
       -
                     Dream.html ~status:`Unauthorized html

     

       38
       -
                 | Some {did; _} ->

     

       39
       -
                     let%lwt () = Dream.invalidate_session ctx.req in

     

       40
       -
                     let%lwt () = Dream.set_session_field ctx.req "did" did in

     

       41
       -
                     Dream.redirect ctx.req redirect_url )

     

       42
       -
             | _ ->

     

       43
       -
                 let html =

     

       44
       -
                   JSX.render

     

       45
       -
                     (Templates.Login.make ~redirect_url:"/account"

     

       46
       -
                        ~error:"Invalid credentials provided. Please try again."

     

       47
       -
                        ~csrf_token () )

     

       48
       -
                 in

     

       49
       -
                 Dream.html ~status:`Unauthorized html )

-4

pegasus/lib/api/account_/logout.ml

···

       1
       -
       let handler =

     

       2
       -
         Xrpc.handler (fun ctx ->

     

       3
       -
             let%lwt () = Dream.invalidate_session ctx.req in

     

       4
       -
             Dream.redirect ctx.req "/account/login" )

+1 -1

pegasus/lib/api/actor/putPreferences.ml

···

       1
        
       let handler =

     

       2
       -
         Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->

     

       3
        
             let did = Auth.get_authed_did_exn auth in

     

       4
        
             let%lwt body = Dream.body req in

     

       5
        
             let prefs =

···

       1
        
       let handler =

     

       2
       +
         Xrpc.handler ~auth:Authorization (fun {req; db; auth} ->

     

       3
        
             let did = Auth.get_authed_did_exn auth in

     

       4
        
             let%lwt body = Dream.body req in

     

       5
        
             let prefs =

+6 -6

pegasus/lib/api/identity/resolveHandle.ml

···

       14
        
                 Dream.json @@ Yojson.Safe.to_string

     

       15
        
                 @@ response_to_yojson {did= actor.did}

     

       16
        
             | None -> (

     

       17
       -
               match%lwt Id_resolver.Handle.resolve handle with

     

       18
       -
               | Ok did ->

     

       19
       -
                   Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did}

     

       20
       -
               | Error e ->

     

       21
       -
                   Errors.log_exn (Failure e) ;

     

       22
       -
                   Errors.internal_error ~msg:"could not resolve handle" () ) )

···

       14
        
                 Dream.json @@ Yojson.Safe.to_string

     

       15
        
                 @@ response_to_yojson {did= actor.did}

     

       16
        
             | None -> (

     

       17
       +
                 match%lwt Id_resolver.Handle.resolve handle with

     

       18
       +
                 | Ok did ->

     

       19
       +
                     Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {did}

     

       20
       +
                 | Error e ->

     

       21
       +
                     Errors.log_exn (Failure e) ;

     

       22
       +
                     Errors.internal_error ~msg:"could not resolve handle" () ) )

+58 -55

pegasus/lib/api/identity/updateHandle.ml

···

       1
        
       type request = {handle: string} [@@deriving yojson]

     

       2
        
       

     

       3
        
       let handler =

     

       4
       -
         Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->

     

       5
        
             let did = Auth.get_authed_did_exn auth in

     

       6
        
             let%lwt body = Dream.body req in

     

       7
        
             let handle =

     
···

       15
        
             | Error e ->

     

       16
        
                 raise e

     

       17
        
             | Ok () -> (

     

       18
       -
               match%lwt Data_store.get_actor_by_identifier handle db with

     

       19
       -
               | Some _ ->

     

       20
       -
                   Errors.invalid_request ~name:"InvalidHandle" "handle already in use"

     

       21
       -
               | None ->

     

       22
       -
                   let%lwt () = Data_store.update_actor_handle ~did ~handle db in

     

       23
       -
                   let%lwt _ =

     

       24
       -
                     if String.starts_with ~prefix:"did:plc:" did then

     

       25
       -
                       match%lwt Plc.get_audit_log did with

     

       26
       -
                       | Error e ->

     

       27
       -
                           Dream.error (fun log -> log ~request:req "%s" e) ;

     

       28
       -
                           Errors.internal_error ~msg:"failed to fetch did doc" ()

     

       29
       -
                       | Ok log -> (

     

       30
       -
                           let latest = List.rev log |> List.hd in

     

       31
       -
                           let aka =

     

       32
       -
                             match

     

       33
       -
                               List.mem ("at://" ^ handle)

     

       34
       -
                                 latest.operation.also_known_as

     

       35
       -
                             with

     

       36
       -
                             | true ->

     

       37
       -
                                 latest.operation.also_known_as

     

       38
       -
                             | false ->

     

       39
       -
                                 ("at://" ^ handle) :: latest.operation.also_known_as

     

       40
       -
                           in

     

       41
       -
                           let%lwt signing_key =

     

       42
       -
                             match%lwt Data_store.get_actor_by_identifier did db with

     

       43
       -
                             | Some {signing_key; _} ->

     

       44
       -
                                 Lwt.return @@ Kleidos.parse_multikey_str signing_key

     

       45
       -
                             | _ ->

     

       46
       -
                                 Errors.internal_error ()

     

       47
       -
                           in

     

       48
       -
                           let signed =

     

       49
       -
                             Plc.sign_operation signing_key

     

       50
       -
                               (Operation

     

       51
       -
                                  { type'= "plc_operation"

     

       52
       -
                                  ; prev= Some latest.cid

     

       53
       -
                                  ; also_known_as= aka

     

       54
       -
                                  ; rotation_keys= latest.operation.rotation_keys

     

       55
       -
                                  ; verification_methods=

     

       56
       -
                                      latest.operation.verification_methods

     

       57
       -
                                  ; services= latest.operation.services } )

     

       58
       -
                           in

     

       59
       -
                           match%lwt Plc.submit_operation did signed with

     

       60
       -
                           | Ok _ ->

     

       61
       -
                               Lwt.return_unit

     

       62
       -
                           | Error (status, msg) ->

     

       63
       -
                               Dream.error (fun log ->

     

       64
       -
                                   log ~request:req "%d %s" status msg ) ;

     

       65
       -
                               Errors.internal_error

     

       66
       -
                                 ~msg:"failed to submit plc operation" () )

     

       67
       -
                     else Lwt.return_unit

     

       68
       -
                   in

     

       69
       -
                   let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in

     

       70
       -
                   let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in

     

       71
       -
                   Dream.empty `OK ) )

     

       0
        
       
     

       0
        
       
     

       0

···

       1
        
       type request = {handle: string} [@@deriving yojson]

     

       2
        
       

     

       3
        
       let handler =

     

       4
       +
         Xrpc.handler ~auth:Authorization (fun {req; auth; db} ->

     

       5
        
             let did = Auth.get_authed_did_exn auth in

     

       6
        
             let%lwt body = Dream.body req in

     

       7
        
             let handle =

     
···

       15
        
             | Error e ->

     

       16
        
                 raise e

     

       17
        
             | Ok () -> (

     

       18
       +
                 match%lwt Data_store.get_actor_by_identifier handle db with

     

       19
       +
                 | Some _ ->

     

       20
       +
                     Errors.invalid_request ~name:"InvalidHandle"

     

       21
       +
                       "handle already in use"

     

       22
       +
                 | None ->

     

       23
       +
                     let%lwt () = Data_store.update_actor_handle ~did ~handle db in

     

       24
       +
                     let%lwt _ =

     

       25
       +
                       if String.starts_with ~prefix:"did:plc:" did then

     

       26
       +
                         match%lwt Plc.get_audit_log did with

     

       27
       +
                         | Error e ->

     

       28
       +
                             Dream.error (fun log -> log ~request:req "%s" e) ;

     

       29
       +
                             Errors.internal_error ~msg:"failed to fetch did doc" ()

     

       30
       +
                         | Ok log -> (

     

       31
       +
                             let latest = List.rev log |> List.hd in

     

       32
       +
                             let aka =

     

       33
       +
                               match

     

       34
       +
                                 List.mem ("at://" ^ handle)

     

       35
       +
                                   latest.operation.also_known_as

     

       36
       +
                               with

     

       37
       +
                               | true ->

     

       38
       +
                                   latest.operation.also_known_as

     

       39
       +
                               | false ->

     

       40
       +
                                   ("at://" ^ handle) :: latest.operation.also_known_as

     

       41
       +
                             in

     

       42
       +
                             let%lwt signing_key =

     

       43
       +
                               match%lwt Data_store.get_actor_by_identifier did db with

     

       44
       +
                               | Some {signing_key; _} ->

     

       45
       +
                                   Lwt.return @@ Kleidos.parse_multikey_str signing_key

     

       46
       +
                               | _ ->

     

       47
       +
                                   Errors.internal_error ()

     

       48
       +
                             in

     

       49
       +
                             let signed =

     

       50
       +
                               Plc.sign_operation signing_key

     

       51
       +
                                 (Operation

     

       52
       +
                                    { type'= "plc_operation"

     

       53
       +
                                    ; prev= Some latest.cid

     

       54
       +
                                    ; also_known_as= aka

     

       55
       +
                                    ; rotation_keys= latest.operation.rotation_keys

     

       56
       +
                                    ; verification_methods=

     

       57
       +
                                        latest.operation.verification_methods

     

       58
       +
                                    ; services= latest.operation.services } )

     

       59
       +
                             in

     

       60
       +
                             match%lwt Plc.submit_operation did signed with

     

       61
       +
                             | Ok _ ->

     

       62
       +
                                 Lwt.return_unit

     

       63
       +
                             | Error (status, msg) ->

     

       64
       +
                                 Dream.error (fun log ->

     

       65
       +
                                     log ~request:req "%d %s" status msg ) ;

     

       66
       +
                                 Errors.internal_error

     

       67
       +
                                   ~msg:"failed to submit plc operation" () )

     

       68
       +
                       else Lwt.return_unit

     

       69
       +
                     in

     

       70
       +
                     let () =

     

       71
       +
                       Ttl_cache.String_cache.remove Id_resolver.Did.cache did

     

       72
       +
                     in

     

       73
       +
                     let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in

     

       74
       +
                     Dream.empty `OK ) )

-184

pegasus/lib/api/oauth_/authorize.ml

···

       1
       -
       open Oauth

     

       2
       -
       open Oauth.Types

     

       3
       -
       

     

       4
       -
       let get_session_user (ctx : Xrpc.context) =

     

       5
       -
         match Dream.session_field ctx.req "did" with

     

       6
       -
         | Some did ->

     

       7
       -
             Lwt.return_some did

     

       8
       -
         | None ->

     

       9
       -
             Lwt.return_none

     

       10
       -
       

     

       11
       -
       let get_handler =

     

       12
       -
         Xrpc.handler (fun ctx ->

     

       13
       -
             let login_redirect =

     

       14
       -
               Uri.make ~path:"/account/login" ~query:(Util.copy_query ctx.req) ()

     

       15
       -
               |> Uri.to_string |> Dream.redirect ctx.req

     

       16
       -
             in

     

       17
       -
             let client_id = Dream.query ctx.req "client_id" in

     

       18
       -
             let request_uri = Dream.query ctx.req "request_uri" in

     

       19
       -
             match (client_id, request_uri) with

     

       20
       -
             | None, _ | _, None ->

     

       21
       -
                 login_redirect

     

       22
       -
             | Some client_id, Some request_uri -> (

     

       23
       -
                 let prefix = Constants.request_uri_prefix in

     

       24
       -
                 if not (String.starts_with ~prefix request_uri) then login_redirect

     

       25
       -
                 else

     

       26
       -
                   let request_id =

     

       27
       -
                     String.sub request_uri (String.length prefix)

     

       28
       -
                       (String.length request_uri - String.length prefix)

     

       29
       -
                   in

     

       30
       -
                   match%lwt Queries.get_par_request ctx.db request_id with

     

       31
       -
                   | None ->

     

       32
       -
                       login_redirect

     

       33
       -
                   | Some req_record -> (

     

       34
       -
                       if req_record.client_id <> client_id then login_redirect

     

       35
       -
                       else

     

       36
       -
                         let req =

     

       37
       -
                           Yojson.Safe.from_string req_record.request_data

     

       38
       -
                           |> par_request_of_yojson

     

       39
       -
                           |> Result.map_error (fun _ ->

     

       40
       -
                               Errors.internal_error ~msg:"failed to parse par request"

     

       41
       -
                                 () )

     

       42
       -
                           |> Result.get_ok

     

       43
       -
                         in

     

       44
       -
                         let%lwt metadata =

     

       45
       -
                           try%lwt Client.fetch_client_metadata client_id

     

       46
       -
                           with _ ->

     

       47
       -
                             Errors.internal_error

     

       48
       -
                               ~msg:"failed to fetch client metadata" ()

     

       49
       -
                         in

     

       50
       -
                         let code =

     

       51
       -
                           "cod-"

     

       52
       -
                           ^ Uuidm.to_string

     

       53
       -
                               (Uuidm.v4_gen (Random.State.make_self_init ()) ())

     

       54
       -
                         in

     

       55
       -
                         let expires_at = Util.now_ms () + Constants.code_expiry_ms in

     

       56
       -
                         let%lwt () =

     

       57
       -
                           Queries.insert_auth_code ctx.db

     

       58
       -
                             { code

     

       59
       -
                             ; request_id

     

       60
       -
                             ; authorized_by= None

     

       61
       -
                             ; authorized_at= None

     

       62
       -
                             ; expires_at

     

       63
       -
                             ; used= false }

     

       64
       -
                         in

     

       65
       -
                         match%lwt get_session_user ctx with

     

       66
       -
                         | None ->

     

       67
       -
                             login_redirect

     

       68
       -
                         | Some did -> (

     

       69
       -
                           match req.login_hint with

     

       70
       -
                           | Some hint when hint <> did ->

     

       71
       -
                               login_redirect

     

       72
       -
                           | _ ->

     

       73
       -
                               let%lwt handle =

     

       74
       -
                                 match%lwt

     

       75
       -
                                   Data_store.get_actor_by_identifier did ctx.db

     

       76
       -
                                 with

     

       77
       -
                                 | Some {handle; _} ->

     

       78
       -
                                     Lwt.return handle

     

       79
       -
                                 | None ->

     

       80
       -
                                     Errors.internal_error

     

       81
       -
                                       ~msg:"failed to resolve user" ()

     

       82
       -
                               in

     

       83
       -
                               let scopes = String.split_on_char ' ' req.scope in

     

       84
       -
                               let csrf_token = Dream.csrf_token ctx.req in

     

       85
       -
                               let html =

     

       86
       -
                                 JSX.render

     

       87
       -
                                   (Templates.Oauth_authorize.make ~metadata ~handle

     

       88
       -
                                      ~scopes ~code ~request_uri ~csrf_token () )

     

       89
       -
                               in

     

       90
       -
                               Dream.html html ) ) ) )

     

       91
       -
       

     

       92
       -
       let post_handler =

     

       93
       -
         Xrpc.handler (fun ctx ->

     

       94
       -
             match%lwt get_session_user ctx with

     

       95
       -
             | None ->

     

       96
       -
                 Errors.auth_required "missing authentication"

     

       97
       -
             | Some user_did -> (

     

       98
       -
               match%lwt Dream.form ctx.req with

     

       99
       -
               | `Ok fields -> (

     

       100
       -
                   let action = List.assoc_opt "action" fields in

     

       101
       -
                   let code = List.assoc_opt "code" fields in

     

       102
       -
                   let request_uri = List.assoc_opt "request_uri" fields in

     

       103
       -
                   match (action, code, request_uri) with

     

       104
       -
                   | Some "deny", _, Some request_uri -> (

     

       105
       -
                       let prefix = Constants.request_uri_prefix in

     

       106
       -
                       let request_id =

     

       107
       -
                         String.sub request_uri (String.length prefix)

     

       108
       -
                           (String.length request_uri - String.length prefix)

     

       109
       -
                       in

     

       110
       -
                       let%lwt req_record =

     

       111
       -
                         Queries.get_par_request ctx.db request_id

     

       112
       -
                       in

     

       113
       -
                       match req_record with

     

       114
       -
                       | Some rec_ ->

     

       115
       -
                           let req =

     

       116
       -
                             Yojson.Safe.from_string rec_.request_data

     

       117
       -
                             |> par_request_of_yojson |> Result.get_ok

     

       118
       -
                           in

     

       119
       -
                           let params =

     

       120
       -
                             [ ("error", "access_denied")

     

       121
       -
                             ; ("error_description", "Unable to authorize user.")

     

       122
       -
                             ; ("state", req.state)

     

       123
       -
                             ; ("iss", "https://" ^ Env.hostname) ]

     

       124
       -
                           in

     

       125
       -
                           let query =

     

       126
       -
                             String.concat "&"

     

       127
       -
                               (List.map

     

       128
       -
                                  (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v)

     

       129
       -
                                  params )

     

       130
       -
                           in

     

       131
       -
                           Dream.redirect ctx.req (req.redirect_uri ^ "?" ^ query)

     

       132
       -
                       | None ->

     

       133
       -
                           Errors.invalid_request "request expired" )

     

       134
       -
                   | Some "allow", Some code, Some _request_uri -> (

     

       135
       -
                       let%lwt code_record = Queries.get_auth_code ctx.db code in

     

       136
       -
                       match code_record with

     

       137
       -
                       | None ->

     

       138
       -
                           Errors.invalid_request "invalid code"

     

       139
       -
                       | Some code_rec -> (

     

       140
       -
                           if code_rec.authorized_by <> None then

     

       141
       -
                             Errors.invalid_request "code already authorized"

     

       142
       -
                           else if code_rec.used then

     

       143
       -
                             Errors.invalid_request "code already used"

     

       144
       -
                           else if Util.now_ms () > code_rec.expires_at then

     

       145
       -
                             Errors.invalid_request "code expired"

     

       146
       -
                           else

     

       147
       -
                             let%lwt () =

     

       148
       -
                               Queries.activate_auth_code ctx.db code user_did

     

       149
       -
                             in

     

       150
       -
                             let%lwt req_record =

     

       151
       -
                               Queries.get_par_request ctx.db code_rec.request_id

     

       152
       -
                             in

     

       153
       -
                             match req_record with

     

       154
       -
                             | None ->

     

       155
       -
                                 Errors.internal_error ~msg:"request not found" ()

     

       156
       -
                             | Some rec_ ->

     

       157
       -
                                 let req =

     

       158
       -
                                   Yojson.Safe.from_string rec_.request_data

     

       159
       -
                                   |> par_request_of_yojson |> Result.get_ok

     

       160
       -
                                 in

     

       161
       -
                                 let params =

     

       162
       -
                                   [ ("code", code)

     

       163
       -
                                   ; ("state", req.state)

     

       164
       -
                                   ; ("iss", "https://" ^ Env.hostname) ]

     

       165
       -
                                 in

     

       166
       -
                                 let query =

     

       167
       -
                                   String.concat "&"

     

       168
       -
                                     (List.map

     

       169
       -
                                        (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v)

     

       170
       -
                                        params )

     

       171
       -
                                 in

     

       172
       -
                                 let separator =

     

       173
       -
                                   match req.response_mode with

     

       174
       -
                                   | Some "fragment" ->

     

       175
       -
                                       "#"

     

       176
       -
                                   | _ ->

     

       177
       -
                                       "?"

     

       178
       -
                                 in

     

       179
       -
                                 Dream.redirect ctx.req

     

       180
       -
                                   (req.redirect_uri ^ separator ^ query) ) )

     

       181
       -
                   | _ ->

     

       182
       -
                       Errors.invalid_request "invalid request" )

     

       183
       -
               | _ ->

     

       184
       -
                   Errors.invalid_request "invalid request" ) )

-41

pegasus/lib/api/oauth_/par.ml

···

       1
       -
       open Oauth

     

       2
       -
       open Oauth.Types

     

       3
       -
       

     

       4
       -
       let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)

     

       5
       -
       

     

       6
       -
       let post_handler =

     

       7
       -
         Xrpc.handler ~auth:DPoP (fun ctx ->

     

       8
       -
             let proof = Auth.get_dpop_proof_exn ctx.auth in

     

       9
       -
             let%lwt req = Xrpc.parse_body ctx.req par_request_of_yojson in

     

       10
       -
             let%lwt client =

     

       11
       -
               try%lwt Client.fetch_client_metadata req.client_id

     

       12
       -
               with e ->

     

       13
       -
                 Errors.log_exn ~req:ctx.req e ;

     

       14
       -
                 Errors.invalid_request "failed to fetch client metadata"

     

       15
       -
             in

     

       16
       -
             if req.response_type <> "code" then

     

       17
       -
               Errors.invalid_request "only response_type=code supported"

     

       18
       -
             else if req.code_challenge_method <> "S256" then

     

       19
       -
               Errors.invalid_request "only code_challenge_method=S256 supported"

     

       20
       -
             else if not (List.mem req.redirect_uri client.redirect_uris) then

     

       21
       -
               Errors.invalid_request "invalid redirect_uri"

     

       22
       -
             else

     

       23
       -
               let request_id =

     

       24
       -
                 "req-"

     

       25
       -
                 ^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ())

     

       26
       -
               in

     

       27
       -
               let request_uri = Constants.request_uri_prefix ^ request_id in

     

       28
       -
               let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in

     

       29
       -
               let request : oauth_request =

     

       30
       -
                 { request_id

     

       31
       -
                 ; client_id= req.client_id

     

       32
       -
                 ; request_data= Yojson.Safe.to_string (par_request_to_yojson req)

     

       33
       -
                 ; dpop_jkt= Some proof.jkt

     

       34
       -
                 ; expires_at

     

       35
       -
                 ; created_at= Util.now_ms () }

     

       36
       -
               in

     

       37
       -
               let%lwt () = Queries.insert_par_request ctx.db request in

     

       38
       -
               Dream.json ~status:`Created

     

       39
       -
               @@ Yojson.Safe.to_string

     

       40
       -
               @@ `Assoc

     

       41
       -
                    [("request_uri", `String request_uri); ("expires_in", `Int 300)] )

-179

pegasus/lib/api/oauth_/token.ml

···

       1
       -
       open Oauth

     

       2
       -
       

     

       3
       -
       let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content)

     

       4
       -
       

     

       5
       -
       let post_handler =

     

       6
       -
         Xrpc.handler ~auth:DPoP (fun ctx ->

     

       7
       -
             let%lwt req = Xrpc.parse_body ctx.req Types.token_request_of_yojson in

     

       8
       -
             let proof = Auth.get_dpop_proof_exn ctx.auth in

     

       9
       -
             match req.grant_type with

     

       10
       -
             | "authorization_code" -> (

     

       11
       -
               match req.code with

     

       12
       -
               | None ->

     

       13
       -
                   Errors.invalid_request "code required"

     

       14
       -
               | Some code -> (

     

       15
       -
                   let%lwt code_record = Queries.consume_auth_code ctx.db code in

     

       16
       -
                   match code_record with

     

       17
       -
                   | None ->

     

       18
       -
                       Errors.invalid_request "invalid code"

     

       19
       -
                   | Some code_rec -> (

     

       20
       -
                       if Util.now_ms () > code_rec.expires_at then

     

       21
       -
                         Errors.invalid_request "code expired"

     

       22
       -
                       else

     

       23
       -
                         match code_rec.authorized_by with

     

       24
       -
                         | None ->

     

       25
       -
                             Errors.invalid_request "code not authorized"

     

       26
       -
                         | Some did -> (

     

       27
       -
                             let%lwt par_req =

     

       28
       -
                               Queries.get_par_request ctx.db code_rec.request_id

     

       29
       -
                             in

     

       30
       -
                             match par_req with

     

       31
       -
                             | None ->

     

       32
       -
                                 Errors.internal_error ~msg:"request not found" ()

     

       33
       -
                             | Some par_record ->

     

       34
       -
                                 let orig_req =

     

       35
       -
                                   Yojson.Safe.from_string par_record.request_data

     

       36
       -
                                   |> Types.par_request_of_yojson |> Result.get_ok

     

       37
       -
                                 in

     

       38
       -
                                 ( match req.redirect_uri with

     

       39
       -
                                 | None ->

     

       40
       -
                                     Errors.invalid_request "redirect_uri required"

     

       41
       -
                                 | Some uri when uri <> orig_req.redirect_uri ->

     

       42
       -
                                     Errors.invalid_request "redirect_uri mismatch"

     

       43
       -
                                 | _ ->

     

       44
       -
                                     () ) ;

     

       45
       -
                                 ( match req.code_verifier with

     

       46
       -
                                 | None ->

     

       47
       -
                                     Errors.invalid_request "code_verifier required"

     

       48
       -
                                 | Some verifier ->

     

       49
       -
                                     let computed =

     

       50
       -
                                       Digestif.SHA256.digest_string verifier

     

       51
       -
                                       |> Digestif.SHA256.to_raw_string

     

       52
       -
                                       |> Base64.(

     

       53
       -
                                            encode_exn ~pad:false

     

       54
       -
                                              ~alphabet:uri_safe_alphabet )

     

       55
       -
                                     in

     

       56
       -
                                     if orig_req.code_challenge <> computed then

     

       57
       -
                                       Errors.invalid_request "invalid code_verifier"

     

       58
       -
                                 ) ;

     

       59
       -
                                 ( match par_record.dpop_jkt with

     

       60
       -
                                 | Some stored when stored <> proof.jkt ->

     

       61
       -
                                     Errors.invalid_request "DPoP key mismatch"

     

       62
       -
                                 | _ ->

     

       63
       -
                                     () ) ;

     

       64
       -
                                 let token_id =

     

       65
       -
                                   "tok-"

     

       66
       -
                                   ^ Uuidm.to_string

     

       67
       -
                                       (Uuidm.v4_gen

     

       68
       -
                                          (Random.State.make_self_init ())

     

       69
       -
                                          () )

     

       70
       -
                                 in

     

       71
       -
                                 let refresh_token =

     

       72
       -
                                   "ref-"

     

       73
       -
                                   ^ Uuidm.to_string

     

       74
       -
                                       (Uuidm.v4_gen

     

       75
       -
                                          (Random.State.make_self_init ())

     

       76
       -
                                          () )

     

       77
       -
                                 in

     

       78
       -
                                 let now_sec = int_of_float (Unix.gettimeofday ()) in

     

       79
       -
                                 let expires_in =

     

       80
       -
                                   Constants.access_token_expiry_ms / 1000

     

       81
       -
                                 in

     

       82
       -
                                 let exp_sec = now_sec + expires_in in

     

       83
       -
                                 let expires_at = exp_sec * 1000 in

     

       84
       -
                                 let claims =

     

       85
       -
                                   `Assoc

     

       86
       -
                                     [ ("jti", `String token_id)

     

       87
       -
                                     ; ("sub", `String did)

     

       88
       -
                                     ; ("iat", `Int now_sec)

     

       89
       -
                                     ; ("exp", `Int exp_sec)

     

       90
       -
                                     ; ("scope", `String orig_req.scope)

     

       91
       -
                                     ; ("aud", `String ("https://" ^ Env.hostname))

     

       92
       -
                                     ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ]

     

       93
       -
                                 in

     

       94
       -
                                 let access_token =

     

       95
       -
                                   Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key

     

       96
       -
                                 in

     

       97
       -
                                 let%lwt () =

     

       98
       -
                                   Queries.insert_oauth_token ctx.db

     

       99
       -
                                     { refresh_token

     

       100
       -
                                     ; client_id= req.client_id

     

       101
       -
                                     ; did

     

       102
       -
                                     ; dpop_jkt= proof.jkt

     

       103
       -
                                     ; scope= orig_req.scope

     

       104
       -
                                     ; expires_at }

     

       105
       -
                                 in

     

       106
       -
                                 let nonce = Dpop.next_nonce () in

     

       107
       -
                                 Dream.json

     

       108
       -
                                   ~headers:

     

       109
       -
                                     [ ("DPoP-Nonce", nonce)

     

       110
       -
                                     ; ("Access-Control-Expose-Headers", "DPoP-Nonce")

     

       111
       -
                                     ; ("Cache-Control", "no-store") ]

     

       112
       -
                                 @@ Yojson.Safe.to_string

     

       113
       -
                                 @@ `Assoc

     

       114
       -
                                      [ ("access_token", `String access_token)

     

       115
       -
                                      ; ("token_type", `String "DPoP")

     

       116
       -
                                      ; ("refresh_token", `String refresh_token)

     

       117
       -
                                      ; ("expires_in", `Int expires_in)

     

       118
       -
                                      ; ("scope", `String orig_req.scope)

     

       119
       -
                                      ; ("sub", `String did) ] ) ) ) )

     

       120
       -
             | "refresh_token" -> (

     

       121
       -
               match req.refresh_token with

     

       122
       -
               | None ->

     

       123
       -
                   Errors.invalid_request "refresh_token required"

     

       124
       -
               | Some refresh_token -> (

     

       125
       -
                   let%lwt token_record =

     

       126
       -
                     Queries.get_oauth_token_by_refresh ctx.db refresh_token

     

       127
       -
                   in

     

       128
       -
                   match token_record with

     

       129
       -
                   | None ->

     

       130
       -
                       Errors.invalid_request "invalid refresh token"

     

       131
       -
                   | Some session ->

     

       132
       -
                       if session.client_id <> req.client_id then

     

       133
       -
                         Errors.invalid_request "client_id mismatch"

     

       134
       -
                       else if session.dpop_jkt <> proof.jkt then

     

       135
       -
                         Errors.invalid_request "DPoP key mismatch"

     

       136
       -
                       else

     

       137
       -
                         let new_token_id =

     

       138
       -
                           "tok-"

     

       139
       -
                           ^ Uuidm.to_string

     

       140
       -
                               (Uuidm.v4_gen (Random.State.make_self_init ()) ())

     

       141
       -
                         in

     

       142
       -
                         let new_refresh =

     

       143
       -
                           "ref-"

     

       144
       -
                           ^ Uuidm.to_string

     

       145
       -
                               (Uuidm.v4_gen (Random.State.make_self_init ()) ())

     

       146
       -
                         in

     

       147
       -
                         let now_sec = int_of_float (Unix.gettimeofday ()) in

     

       148
       -
                         let expires_in = Constants.access_token_expiry_ms / 1000 in

     

       149
       -
                         let exp_sec = now_sec + expires_in in

     

       150
       -
                         let new_expires_at = exp_sec * 1000 in

     

       151
       -
                         let claims =

     

       152
       -
                           `Assoc

     

       153
       -
                             [ ("jti", `String new_token_id)

     

       154
       -
                             ; ("sub", `String session.did)

     

       155
       -
                             ; ("iat", `Int now_sec)

     

       156
       -
                             ; ("exp", `Int exp_sec)

     

       157
       -
                             ; ("scope", `String session.scope)

     

       158
       -
                             ; ("aud", `String ("https://" ^ Env.hostname))

     

       159
       -
                             ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ]

     

       160
       -
                         in

     

       161
       -
                         let new_access_token =

     

       162
       -
                           Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key

     

       163
       -
                         in

     

       164
       -
                         let%lwt () =

     

       165
       -
                           Queries.update_oauth_token ctx.db

     

       166
       -
                             ~old_refresh_token:refresh_token

     

       167
       -
                             ~new_refresh_token:new_refresh ~expires_at:new_expires_at

     

       168
       -
                         in

     

       169
       -
                         Dream.json ~headers:[("Cache-Control", "no-store")]

     

       170
       -
                         @@ Yojson.Safe.to_string

     

       171
       -
                         @@ `Assoc

     

       172
       -
                              [ ("access_token", `String new_access_token)

     

       173
       -
                              ; ("token_type", `String "DPoP")

     

       174
       -
                              ; ("refresh_token", `String new_refresh)

     

       175
       -
                              ; ("expires_in", `Int expires_in)

     

       176
       -
                              ; ("scope", `String session.scope)

     

       177
       -
                              ; ("sub", `String session.did) ] ) )

     

       178
       -
             | _ ->

     

       179
       -
                 Errors.invalid_request ("unsupported grant_type: " ^ req.grant_type) )

+10 -10

pegasus/lib/api/repo/createAccount.ml

···

       57
        
             let%lwt did =

     

       58
        
               match input.did with

     

       59
        
               | Some did -> (

     

       60
       -
                 match%lwt Data_store.get_actor_by_identifier did ctx.db with

     

       61
       -
                 | Some _ ->

     

       62
       -
                     Errors.invalid_request "an account with that did already exists"

     

       63
       -
                 | None ->

     

       64
       -
                     Lwt.return did )

     

       65
        
               | None -> (

     

       66
        
                   let sk_did = Kleidos.K256.pubkey_to_did_key signing_pubkey in

     

       67
        
                   let rotation_did_keys =

     
···

       79
        
             let%lwt _ =

     

       80
        
               match input.invite_code with

     

       81
        
               | Some code -> (

     

       82
       -
                 match%lwt Data_store.use_invite ~code ctx.db with

     

       83
       -
                 | Some _ ->

     

       84
       -
                     Lwt.return ()

     

       85
       -
                 | None ->

     

       86
       -
                     failwith "failed to use invite code" )

     

       87
        
               | None ->

     

       88
        
                   Lwt.return ()

     

       89
        
             in

···

       57
        
             let%lwt did =

     

       58
        
               match input.did with

     

       59
        
               | Some did -> (

     

       60
       +
                   match%lwt Data_store.get_actor_by_identifier did ctx.db with

     

       61
       +
                   | Some _ ->

     

       62
       +
                       Errors.invalid_request "an account with that did already exists"

     

       63
       +
                   | None ->

     

       64
       +
                       Lwt.return did )

     

       65
        
               | None -> (

     

       66
        
                   let sk_did = Kleidos.K256.pubkey_to_did_key signing_pubkey in

     

       67
        
                   let rotation_did_keys =

     
···

       79
        
             let%lwt _ =

     

       80
        
               match input.invite_code with

     

       81
        
               | Some code -> (

     

       82
       +
                   match%lwt Data_store.use_invite ~code ctx.db with

     

       83
       +
                   | Some _ ->

     

       84
       +
                       Lwt.return ()

     

       85
       +
                   | None ->

     

       86
       +
                       failwith "failed to use invite code" )

     

       87
        
               | None ->

     

       88
        
                   Lwt.return ()

     

       89
        
             in

+1 -1

pegasus/lib/api/server/createSession.ml

···

       17
        
       [@@deriving yojson {strict= false}]

     

       18
        
       

     

       19
        
       let handler =

     

       20
       -
         Xrpc.handler (fun {req; auth; db; _} ->

     

       21
        
             let%lwt {identifier; password; _} =

     

       22
        
               Xrpc.parse_body req request_of_yojson

     

       23
        
             in

···

       17
        
       [@@deriving yojson {strict= false}]

     

       18
        
       

     

       19
        
       let handler =

     

       20
       +
         Xrpc.handler (fun {req; db; auth} ->

     

       21
        
             let%lwt {identifier; password; _} =

     

       22
        
               Xrpc.parse_body req request_of_yojson

     

       23
        
             in

+1 -1

pegasus/lib/api/server/getServiceAuth.ml

···

       1
        
       type response = {token: string} [@@deriving yojson {strict= false}]

     

       2
        
       

     

       3
        
       let handler =

     

       4
       -
         Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->

     

       5
        
             let did = Auth.get_authed_did_exn auth in

     

       6
        
             let aud, lxm =

     

       7
        
               match (Dream.query req "aud", Dream.query req "lxm") with

···

       1
        
       type response = {token: string} [@@deriving yojson {strict= false}]

     

       2
        
       

     

       3
        
       let handler =

     

       4
       +
         Xrpc.handler ~auth:Authorization (fun {req; auth; db} ->

     

       5
        
             let did = Auth.get_authed_did_exn auth in

     

       6
        
             let aud, lxm =

     

       7
        
               match (Dream.query req "aud", Dream.query req "lxm") with

+2 -57

pegasus/lib/api/well_known.ml

···

       1
       -
       open struct

     

       2
       -
         let make_url pth =

     

       3
       -
           Uri.(make ~scheme:"https" ~host:Env.hostname ~path:pth () |> to_string)

     

       4
       -
       

     

       5
       -
         let pds_url = `String (make_url "")

     

       6
       -
       end

     

       7
       -
       

     

       8
        
       let did_json =

     

       9
        
         Xrpc.handler (fun _ ->

     

       10
        
             Dream.json @@ Yojson.Safe.to_string

     
···

       15
        
                    , `Assoc

     

       16
        
                        [ ("id", `String "#atproto_pds")

     

       17
        
                        ; ("type", `String "AtprotoPersonalDataServer")

     

       18
       -
                        ; ("serviceEndpoint", pds_url) ] ) ] )

     

       19
       -
       

     

       20
       -
       let oauth_protected_resource =

     

       21
       -
         Xrpc.handler (fun _ ->

     

       22
       -
             Dream.json @@ Yojson.Safe.to_string

     

       23
       -
             @@ `Assoc

     

       24
       -
                  [ ("authorization_servers", `List [pds_url])

     

       25
       -
                  ; ("bearer_methods_supported", `List [`String "header"])

     

       26
       -
                  ; ("resource", pds_url)

     

       27
       -
                  ; ("resource_documentation", `String "https://atproto.com")

     

       28
       -
                  ; ("scopes_supported", `List []) ] )

     

       29
       -
       

     

       30
       -
       let oauth_authorization_server =

     

       31
       -
         Xrpc.handler (fun _ ->

     

       32
       -
             Dream.json @@ Yojson.Safe.to_string

     

       33
       -
             @@ `Assoc

     

       34
       -
                  [ ("issuer", pds_url)

     

       35
       -
                  ; ("authorization_endpoint", `String (make_url "/oauth/authorize"))

     

       36
       -
                  ; ("token_endpoint", `String (make_url "/oauth/token"))

     

       37
       -
                  ; ( "pushed_authorization_request_endpoint"

     

       38
       -
                    , `String (make_url "/oauth/par") )

     

       39
       -
                  ; ("require_pushed_authorization_requests", `Bool true)

     

       40
       -
                  ; ( "scopes_supported"

     

       41
       -
                    , `List

     

       42
       -
                        [ `String "atproto"

     

       43
       -
                        ; `String "transition:email"

     

       44
       -
                        ; `String "transition:generic"

     

       45
       -
                        ; `String "transition:chat.bsky" ] )

     

       46
       -
                  ; ("subject_types_supported", `List [`String "public"])

     

       47
       -
                  ; ("response_types_supported", `List [`String "code"])

     

       48
       -
                  ; ( "response_modes_supported"

     

       49
       -
                    , `List [`String "query"; `String "fragment"] )

     

       50
       -
                  ; ( "grant_types_supported"

     

       51
       -
                    , `List [`String "authorization_code"; `String "refresh_token"] )

     

       52
       -
                  ; ("code_challenge_methods_supported", `List [`String "S256"])

     

       53
       -
                  ; ("ui_locales_supported", `List [`String "en-US"])

     

       54
       -
                  ; ( "display_values_supported"

     

       55
       -
                    , `List [`String "page"; `String "popup"; `String "touch"] )

     

       56
       -
                  ; ("authorization_response_iss_parameter_supported", `Bool true)

     

       57
       -
                  ; ( "request_object_signing_alg_values_supported"

     

       58
       -
                    , `List [`String "ES256"; `String "ES256K"] )

     

       59
       -
                  ; ("request_object_encryption_alg_values_supported", `List [])

     

       60
       -
                  ; ("request_object_encryption_enc_values_supported", `List [])

     

       61
       -
                  ; ( "token_endpoint_auth_methods_supported"

     

       62
       -
                    , `List [`String "none"; `String "private_key_jwt"] )

     

       63
       -
                  ; ( "token_endpoint_auth_signing_alg_values_supported"

     

       64
       -
                    , `List [`String "ES256"; `String "ES256K"] )

     

       65
       -
                  ; ( "dpop_signing_alg_values_supported"

     

       66
       -
                    , `List [`String "ES256"; `String "ES256K"] )

     

       67
       -
                  ; ("client_id_metadata_document_supported", `Bool true) ] )

···

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       1
        
       let did_json =

     

       2
        
         Xrpc.handler (fun _ ->

     

       3
        
             Dream.json @@ Yojson.Safe.to_string

     
···

       8
        
                    , `Assoc

     

       9
        
                        [ ("id", `String "#atproto_pds")

     

       10
        
                        ; ("type", `String "AtprotoPersonalDataServer")

     

       11
       +
                        ; ("serviceEndpoint", `String ("https://" ^ Env.hostname)) ] )

     

       12
       +
                  ] )

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+55 -145

pegasus/lib/auth.ml

···

       15
        
         | Admin

     

       16
        
         | Access of {did: string}

     

       17
        
         | Refresh of {did: string; jti: string}

     

       18
       -
         | OAuth of {did: string; proof: Oauth.Dpop.proof}

     

       19
       -
         | DPoP of {proof: Oauth.Dpop.proof}

     

       20
        
       

     

       21
        
       let verify_bearer_jwt t token expected_scope =

     

       22
        
         match Jwt.verify_jwt token Env.jwt_key with

     
···

       44
        
         match credentials with

     

       45
        
         | Admin ->

     

       46
        
             true

     

       47
       -
         | (Access {did= creds} | OAuth {did= creds; _}) when creds = did ->

     

       48
        
             true

     

       49
        
         | Refresh {did= creds; _} when creds = did && refresh ->

     

       50
        
             true

     
···

       52
        
             false

     

       53
        
       

     

       54
        
       let get_authed_did_exn = function

     

       55
       -
         | Access {did} | OAuth {did; _} ->

     

       56
        
             did

     

       57
        
         | Refresh {did; _} ->

     

       58
        
             did

     

       59
        
         | _ ->

     

       60
       -
             Errors.auth_required "invalid authorization header"

     

       61
       -
       

     

       62
       -
       let get_dpop_proof_exn = function

     

       63
       -
         | OAuth {proof; _} | DPoP {proof} ->

     

       64
       -
             proof

     

       65
       -
         | _ ->

     

       66
       -
             Errors.invalid_request "invalid DPoP header"

     

       67
        
       

     

       68
        
       let get_session_info identifier db =

     

       69
        
         let%lwt actor =

     
···

       92
        
       module Verifiers = struct

     

       93
        
         open struct

     

       94
        
           let parse_header req expected_type =

     

       95
       -
             match Dream.header req "Authorization" with

     

       96
        
             | Some header -> (

     

       97
        
               match String.split_on_char ' ' header with

     

       98
        
               | [typ; token]

     
···

       103
        
                   Error "invalid authorization header" )

     

       104
        
             | None ->

     

       105
        
                 Error "missing authorization header"

     

       106
       -
         end

     

       107
        
       

     

       108
       -
         let parse_basic req =

     

       109
       -
           match parse_header req "Basic" with

     

       110
       -
           | Ok token -> (

     

       111
       -
             match Base64.decode token with

     

       112
       -
             | Ok decoded -> (

     

       113
       -
               match Str.bounded_split (Str.regexp_string ":") decoded 2 with

     

       114
       -
               | [username; password] ->

     

       115
       -
                   Ok (username, password)

     

       116
       -
               | _ ->

     

       0
        
       
     

       0
        
       
     

       117
        
                   Error "invalid basic authorization header" )

     

       118
        
             | Error _ ->

     

       119
       -
                 Error "invalid basic authorization header" )

     

       120
       -
           | Error _ ->

     

       121
       -
               Error "invalid basic authorization header"

     

       122
       -
       

     

       123
       -
         let parse_bearer req = parse_header req "Bearer"

     

       124
        
       

     

       125
       -
         let parse_dpop req = parse_header req "DPoP"

     

       0
        
       
     

       126
        
       

     

       127
        
         type ctx = {req: Dream.request; db: Data_store.t}

     

       128
        
       

     
···

       132
        
          fun {req; _} ->

     

       133
        
           match Dream.header req "authorization" with

     

       134
        
           | Some _ ->

     

       135
       -
               Lwt.return_error @@ Errors.auth_required "invalid authorization header"

     

       136
        
           | None ->

     

       137
        
               Lwt.return_ok Unauthenticated

     

       138
        
       

     
···

       144
        
             | "admin", p when p = Env.admin_password ->

     

       145
        
                 Lwt.return_ok Admin

     

       146
        
             | _ ->

     

       147
       -
                 Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       148
        
           | Error _ ->

     

       149
       -
               Lwt.return_error @@ Errors.auth_required "invalid authorization header"

     

       150
        
       

     

       151
       -
         let bearer : verifier =

     

       152
        
          fun {req; db} ->

     

       153
        
           match parse_bearer req with

     

       154
        
           | Ok jwt -> (

     

       155
       -
             match%lwt verify_bearer_jwt db jwt "com.atproto.access" with

     

       156
       -
             | Ok {sub= did; _} -> (

     

       157
       -
               match%lwt Data_store.get_actor_by_identifier did db with

     

       158
       -
               | Some {deactivated_at= None; _} ->

     

       159
       -
                   Lwt.return_ok (Access {did})

     

       160
       -
               | Some {deactivated_at= Some _; _} ->

     

       161
       -
                   Lwt.return_error

     

       162
       -
                   @@ Errors.auth_required ~name:"AccountDeactivated"

     

       163
       -
                        "account is deactivated"

     

       164
       -
               | None ->

     

       165
       -
                   Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       166
       -
             | Error _ ->

     

       167
       -
                 Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       168
        
           | Error _ ->

     

       169
       -
               Lwt.return_error @@ Errors.auth_required "invalid authorization header"

     

       170
       -
       

     

       171
       -
         let dpop : verifier =

     

       172
       -
          fun {req; _} ->

     

       173
       -
           let dpop_header = Dream.header req "DPoP" in

     

       174
       -
           match

     

       175
       -
             Oauth.Dpop.verify_dpop_proof

     

       176
       -
               ~mthd:(Dream.method_to_string @@ Dream.method_ req)

     

       177
       -
               ~url:(Dream.target req) ~dpop_header ()

     

       178
       -
           with

     

       179
       -
           | Error "use_dpop_nonce" ->

     

       180
       -
               Lwt.return_error @@ Errors.use_dpop_nonce ()

     

       181
       -
           | Error e ->

     

       182
       -
               Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)

     

       183
       -
           | Ok proof ->

     

       184
       -
               Lwt.return_ok (DPoP {proof})

     

       185
       -
       

     

       186
       -
         let oauth : verifier =

     

       187
       -
          fun {req; db} ->

     

       188
       -
           match parse_dpop req with

     

       189
       -
           | Error e ->

     

       190
       -
               Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)

     

       191
       -
           | Ok token -> (

     

       192
       -
             match%lwt dpop {req; db} with

     

       193
       -
             | Error e ->

     

       194
       -
                 Lwt.return_error e

     

       195
       -
             | Ok (DPoP {proof}) -> (

     

       196
       -
               match Jwt.verify_jwt token Env.jwt_key with

     

       197
       -
               | Error e ->

     

       198
       -
                   Lwt.return_error @@ Errors.auth_required e

     

       199
       -
               | Ok (_header, claims) -> (

     

       200
       -
                   let open Yojson.Safe.Util in

     

       201
       -
                   try

     

       202
       -
                     let did = claims |> member "sub" |> to_string in

     

       203
       -
                     let exp = claims |> member "exp" |> to_int in

     

       204
       -
                     let jkt_claim =

     

       205
       -
                       claims |> member "cnf" |> member "jkt" |> to_string

     

       206
       -
                     in

     

       207
       -
                     let now = int_of_float (Unix.gettimeofday ()) in

     

       208
       -
                     if jkt_claim <> proof.jkt then

     

       209
       -
                       Lwt.return_error @@ Errors.auth_required "dpop key mismatch"

     

       210
       -
                     else if exp < now then

     

       211
       -
                       Lwt.return_error @@ Errors.auth_required "token expired"

     

       212
       -
                     else

     

       213
       -
                       let%lwt session =

     

       214
       -
                         try%lwt

     

       215
       -
                           let%lwt sess = get_session_info did db in

     

       216
       -
                           Lwt.return_ok sess

     

       217
       -
                         with _ ->

     

       218
       -
                           Lwt.return_error

     

       219
       -
                           @@ Errors.auth_required "invalid credentials"

     

       220
       -
                       in

     

       221
       -
                       match session with

     

       222
       -
                       | Ok {active= Some true; _} ->

     

       223
       -
                           Lwt.return_ok (OAuth {did; proof})

     

       224
       -
                       | Ok _ ->

     

       225
       -
                           Lwt.return_error

     

       226
       -
                           @@ Errors.auth_required ~name:"AccountDeactivated"

     

       227
       -
                                "account is deactivated"

     

       228
       -
                       | Error _ ->

     

       229
       -
                           Lwt.return_error

     

       230
       -
                           @@ Errors.auth_required "invalid credentials"

     

       231
       -
                   with _ ->

     

       232
       -
                     Lwt.return_error @@ Errors.auth_required "malformed JWT claims" )

     

       233
       -
               )

     

       234
       -
             | Ok _ ->

     

       235
       -
                 Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       236
        
       

     

       237
        
         let refresh : verifier =

     

       238
        
          fun {req; db} ->

     

       239
        
           match parse_bearer req with

     

       240
        
           | Ok jwt -> (

     

       241
       -
             match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with

     

       242
       -
             | Ok {sub= did; jti; _} -> (

     

       243
       -
               match%lwt Data_store.get_actor_by_identifier did db with

     

       244
       -
               | Some {deactivated_at= None; _} ->

     

       245
       -
                   Lwt.return_ok (Refresh {did; jti})

     

       246
       -
               | Some {deactivated_at= Some _; _} ->

     

       247
       -
                   Lwt.return_error

     

       248
       -
                   @@ Errors.auth_required ~name:"AccountDeactivated"

     

       249
       -
                        "account is deactivated"

     

       250
       -
               | None ->

     

       251
       -
                   Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       252
       -
             | Error "" | Error _ ->

     

       253
       -
                 Lwt.return_error @@ Errors.auth_required "invalid credentials" )

     

       254
        
           | Error _ ->

     

       255
       -
               Lwt.return_error @@ Errors.auth_required "invalid authorization header"

     

       256
        
       

     

       257
        
         let authorization : verifier =

     

       258
        
          fun ctx ->

     
···

       263
        
           | Some ("Basic" :: _) ->

     

       264
        
               admin ctx

     

       265
        
           | Some ("Bearer" :: _) ->

     

       266
       -
               bearer ctx

     

       267
       -
           | Some ("DPoP" :: _) ->

     

       268
       -
               oauth ctx

     

       269
        
           | _ ->

     

       270
        
               Lwt.return_error

     

       271
        
               @@ Errors.auth_required ~name:"InvalidToken"

     

       272
       -
                    "unexpected authorization type"

     

       273
        
       

     

       274
        
         let any : verifier =

     

       275
        
          fun ctx -> try authorization ctx with _ -> unauthenticated ctx

     

       276
        
       

     

       277
       -
         type t =

     

       278
       -
           | Unauthenticated

     

       279
       -
           | Admin

     

       280
       -
           | Bearer

     

       281
       -
           | DPoP

     

       282
       -
           | OAuth

     

       283
       -
           | Refresh

     

       284
       -
           | Authorization

     

       285
       -
           | Any

     

       286
        
       

     

       287
        
         let of_t = function

     

       288
        
           | Unauthenticated ->

     

       289
        
               unauthenticated

     

       290
        
           | Admin ->

     

       291
        
               admin

     

       292
       -
           | Bearer ->

     

       293
       -
               bearer

     

       294
       -
           | DPoP ->

     

       295
       -
               dpop

     

       296
       -
           | OAuth ->

     

       297
       -
               oauth

     

       298
        
           | Refresh ->

     

       299
        
               refresh

     

       300
        
           | Authorization ->

···

       15
        
         | Admin

     

       16
        
         | Access of {did: string}

     

       17
        
         | Refresh of {did: string; jti: string}

     

       0
        
       
     

       0
        
       
     

       18
        
       

     

       19
        
       let verify_bearer_jwt t token expected_scope =

     

       20
        
         match Jwt.verify_jwt token Env.jwt_key with

     
···

       42
        
         match credentials with

     

       43
        
         | Admin ->

     

       44
        
             true

     

       45
       +
         | Access {did= creds} when creds = did ->

     

       46
        
             true

     

       47
        
         | Refresh {did= creds; _} when creds = did && refresh ->

     

       48
        
             true

     
···

       50
        
             false

     

       51
        
       

     

       52
        
       let get_authed_did_exn = function

     

       53
       +
         | Access {did} ->

     

       54
        
             did

     

       55
        
         | Refresh {did; _} ->

     

       56
        
             did

     

       57
        
         | _ ->

     

       58
       +
             Errors.auth_required "Invalid authorization header"

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       59
        
       

     

       60
        
       let get_session_info identifier db =

     

       61
        
         let%lwt actor =

     
···

       84
        
       module Verifiers = struct

     

       85
        
         open struct

     

       86
        
           let parse_header req expected_type =

     

       87
       +
             match Dream.header req "authorization" with

     

       88
        
             | Some header -> (

     

       89
        
               match String.split_on_char ' ' header with

     

       90
        
               | [typ; token]

     
···

       95
        
                   Error "invalid authorization header" )

     

       96
        
             | None ->

     

       97
        
                 Error "missing authorization header"

     

       0
        
       
     

       98
        
       

     

       99
       +
           let parse_basic req =

     

       100
       +
             match parse_header req "Basic" with

     

       101
       +
             | Ok token -> (

     

       102
       +
               match Base64.decode token with

     

       103
       +
               | Ok decoded -> (

     

       104
       +
                 match Str.bounded_split (Str.regexp_string ":") decoded 2 with

     

       105
       +
                 | [username; password] ->

     

       106
       +
                     Ok (username, password)

     

       107
       +
                 | _ ->

     

       108
       +
                     Error "invalid basic authorization header" )

     

       109
       +
               | Error _ ->

     

       110
        
                   Error "invalid basic authorization header" )

     

       111
        
             | Error _ ->

     

       112
       +
                 Error "invalid basic authorization header"

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       113
        
       

     

       114
       +
           let parse_bearer req = parse_header req "Bearer"

     

       115
       +
         end

     

       116
        
       

     

       117
        
         type ctx = {req: Dream.request; db: Data_store.t}

     

       118
        
       

     
···

       122
        
          fun {req; _} ->

     

       123
        
           match Dream.header req "authorization" with

     

       124
        
           | Some _ ->

     

       125
       +
               Lwt.return_error @@ Errors.auth_required "Invalid authorization header"

     

       126
        
           | None ->

     

       127
        
               Lwt.return_ok Unauthenticated

     

       128
        
       

     
···

       134
        
             | "admin", p when p = Env.admin_password ->

     

       135
        
                 Lwt.return_ok Admin

     

       136
        
             | _ ->

     

       137
       +
                 Lwt.return_error @@ Errors.auth_required "Invalid credentials" )

     

       138
        
           | Error _ ->

     

       139
       +
               Lwt.return_error @@ Errors.auth_required "Invalid authorization header"

     

       140
        
       

     

       141
       +
         let access : verifier =

     

       142
        
          fun {req; db} ->

     

       143
        
           match parse_bearer req with

     

       144
        
           | Ok jwt -> (

     

       145
       +
               match%lwt verify_bearer_jwt db jwt "com.atproto.access" with

     

       146
       +
               | Ok {sub= did; _} -> (

     

       147
       +
                   match%lwt Data_store.get_actor_by_identifier did db with

     

       148
       +
                   | Some {deactivated_at= None; _} ->

     

       149
       +
                       Lwt.return_ok (Access {did})

     

       150
       +
                   | Some {deactivated_at= Some _; _} ->

     

       151
       +
                       Lwt.return_error

     

       152
       +
                       @@ Errors.auth_required ~name:"AccountDeactivated"

     

       153
       +
                            "Account is deactivated"

     

       154
       +
                   | None ->

     

       155
       +
                       Lwt.return_error @@ Errors.auth_required "Invalid credentials" )

     

       156
       +
               | Error _ ->

     

       157
       +
                   Lwt.return_error @@ Errors.auth_required "Invalid credentials" )

     

       158
        
           | Error _ ->

     

       159
       +
               Lwt.return_error @@ Errors.auth_required "Invalid authorization header"

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       160
        
       

     

       161
        
         let refresh : verifier =

     

       162
        
          fun {req; db} ->

     

       163
        
           match parse_bearer req with

     

       164
        
           | Ok jwt -> (

     

       165
       +
               match%lwt verify_bearer_jwt db jwt "com.atproto.refresh" with

     

       166
       +
               | Ok {sub= did; jti; _} -> (

     

       167
       +
                   match%lwt Data_store.get_actor_by_identifier did db with

     

       168
       +
                   | Some {deactivated_at= None; _} ->

     

       169
       +
                       Lwt.return_ok (Refresh {did; jti})

     

       170
       +
                   | Some {deactivated_at= Some _; _} ->

     

       171
       +
                       Lwt.return_error

     

       172
       +
                       @@ Errors.auth_required ~name:"AccountDeactivated"

     

       173
       +
                            "Account is deactivated"

     

       174
       +
                   | None ->

     

       175
       +
                       Lwt.return_error @@ Errors.auth_required "Invalid credentials" )

     

       176
       +
               | Error "" | Error _ ->

     

       177
       +
                   Lwt.return_error @@ Errors.auth_required "Invalid credentials" )

     

       178
        
           | Error _ ->

     

       179
       +
               Lwt.return_error @@ Errors.auth_required "Invalid authorization header"

     

       180
        
       

     

       181
        
         let authorization : verifier =

     

       182
        
          fun ctx ->

     
···

       187
        
           | Some ("Basic" :: _) ->

     

       188
        
               admin ctx

     

       189
        
           | Some ("Bearer" :: _) ->

     

       190
       +
               access ctx

     

       0
        
       
     

       0
        
       
     

       191
        
           | _ ->

     

       192
        
               Lwt.return_error

     

       193
        
               @@ Errors.auth_required ~name:"InvalidToken"

     

       194
       +
                    "Unexpected authorization type"

     

       195
        
       

     

       196
        
         let any : verifier =

     

       197
        
          fun ctx -> try authorization ctx with _ -> unauthenticated ctx

     

       198
        
       

     

       199
       +
         type t = Unauthenticated | Admin | Access | Refresh | Authorization | Any

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       200
        
       

     

       201
        
         let of_t = function

     

       202
        
           | Unauthenticated ->

     

       203
        
               unauthenticated

     

       204
        
           | Admin ->

     

       205
        
               admin

     

       206
       +
           | Access ->

     

       207
       +
               access

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       208
        
           | Refresh ->

     

       209
        
               refresh

     

       210
        
           | Authorization ->

+23 -115

pegasus/lib/data_store.ml

···

       36
        
                       created_at INTEGER NOT NULL,

     

       37
        
                       deactivated_at INTEGER

     

       38
        
                     )

     

       39
       -
                 |sql}]

     

       40
        
               () conn

     

       41
        
           in

     

       42
        
           let$! () =

     
···

       52
        
             [%rapper

     

       53
        
               execute

     

       54
        
                 {sql| CREATE TABLE IF NOT EXISTS invite_codes (

     

       55
       -
                       code TEXT PRIMARY KEY,

     

       56
       -
                       did TEXT NOT NULL,

     

       57
       -
                       remaining INTEGER NOT NULL

     

       58
       -
                     )

     

       59
       -
                 |sql}]

     

       60
        
               () conn

     

       61
        
           in

     

       62
        
           let$! () =

     

       63
        
             [%rapper

     

       64
        
               execute

     

       65
        
                 {sql| CREATE TABLE IF NOT EXISTS firehose (

     

       66
       -
                     	seq INTEGER PRIMARY KEY,

     

       67
       -
                     	time INTEGER NOT NULL,

     

       68
       -
                     	t TEXT NOT NULL,

     

       69
       -
                     	data BLOB NOT NULL

     

       70
       -
                     )

     

       71
       -
                 |sql}]

     

       72
       -
               () conn

     

       73
       -
           in

     

       74
       -
           let$! () =

     

       75
       -
             [%rapper

     

       76
       -
               execute

     

       77
       -
                 (* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)

     

       78
       -
                 {sql| CREATE TABLE IF NOT EXISTS revoked_tokens (

     

       79
       -
                   	did TEXT NOT NULL,

     

       80
       -
                   	jti TEXT NOT NULL,

     

       81
       -
                   	revoked_at INTEGER NOT NULL,

     

       82
       -
                   	PRIMARY KEY (did, jti)

     

       83
       -
                     )

     

       84
       -
                 |sql}]

     

       85
       -
               () conn

     

       86
       -
           in

     

       87
       -
           let$! () =

     

       88
       -
             [%rapper

     

       89
       -
               execute

     

       90
       -
                 {sql| CREATE TABLE IF NOT EXISTS oauth_requests (

     

       91
       -
       		        request_id TEXT PRIMARY KEY,

     

       92
       -
       		        client_id TEXT NOT NULL,

     

       93
       -
       		        request_data TEXT NOT NULL,

     

       94
       -
       		        dpop_jkt TEXT,

     

       95
       -
       		        expires_at INTEGER NOT NULL,

     

       96
       -
       		        created_at INTEGER NOT NULL

     

       97
       -
       		      )

     

       98
       -
       		  |sql}]

     

       99
       -
               () conn

     

       100
       -
           in

     

       101
       -
           let$! () =

     

       102
       -
             [%rapper

     

       103
       -
               execute

     

       104
       -
                 {sql| CREATE TABLE IF NOT EXISTS oauth_codes (

     

       105
       -
                       code TEXT PRIMARY KEY,

     

       106
       -
                       request_id TEXT NOT NULL REFERENCES oauth_requests(request_id) ON DELETE CASCADE,

     

       107
       -
                       authorized_by TEXT,

     

       108
       -
                       authorized_at INTEGER,

     

       109
       -
                       expires_at INTEGER NOT NULL,

     

       110
       -
                       used BOOLEAN DEFAULT FALSE

     

       111
       -
                     )

     

       112
       -
                 |sql}]

     

       113
       -
               () conn

     

       114
       -
           in

     

       115
       -
           let$! () =

     

       116
       -
             [%rapper

     

       117
       -
               execute

     

       118
       -
                 {sql| CREATE TABLE IF NOT EXISTS oauth_tokens (

     

       119
       -
                   	refresh_token TEXT UNIQUE NOT NULL,

     

       120
       -
                   	client_id TEXT NOT NULL,

     

       121
       -
                   	did TEXT NOT NULL,

     

       122
       -
                   	dpop_jkt TEXT,

     

       123
       -
                   	scope TEXT NOT NULL,

     

       124
       -
                   	expires_at INTEGER NOT NULL

     

       125
       -
                     )

     

       126
       -
                 |sql}]

     

       127
       -
               () conn

     

       128
       -
           in

     

       129
       -
           let$! () =

     

       130
       -
             [%rapper

     

       131
       -
               execute

     

       132
       -
                 {sql| CREATE INDEX IF NOT EXISTS oauth_requests_expires_idx ON oauth_requests(expires_at);

     

       133
       -
                       CREATE INDEX IF NOT EXISTS oauth_codes_expires_idx ON oauth_codes(expires_at);

     

       134
       -
                       CREATE INDEX IF NOT EXISTS oauth_tokens_refresh_idx ON oauth_tokens(refresh_token);

     

       135
       -
                 |sql}]

     

       136
       -
               () conn

     

       137
       -
           in

     

       138
       -
           let$! () =

     

       139
       -
             [%rapper

     

       140
       -
               execute

     

       141
       -
                 {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests

     

       142
       -
                       AFTER INSERT ON oauth_requests

     

       143
       -
                       BEGIN

     

       144
       -
                         DELETE FROM oauth_requests WHERE expires_at < unixepoch() * 1000;

     

       145
       -
                       END

     

       146
       -
                 |sql}

     

       147
       -
                 syntax_off]

     

       148
       -
               () conn

     

       149
       -
           in

     

       150
       -
           let$! () =

     

       151
       -
             [%rapper

     

       152
       -
               execute

     

       153
       -
                 {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes

     

       154
       -
                       AFTER INSERT ON oauth_codes

     

       155
       -
                       BEGIN

     

       156
       -
                         DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000 OR used = 1;

     

       157
       -
                       END

     

       158
       -
                 |sql}

     

       159
       -
                 syntax_off]

     

       160
       -
               () conn

     

       161
       -
           in

     

       162
       -
           let$! () =

     

       163
       -
             [%rapper

     

       164
       -
               execute

     

       165
       -
                 {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens

     

       166
       -
                       AFTER INSERT ON oauth_tokens

     

       167
       -
                       BEGIN

     

       168
       -
                         DELETE FROM oauth_tokens WHERE expires_at < unixepoch() * 1000;

     

       169
       -
                       END

     

       170
       -
                 |sql}

     

       171
       -
                 syntax_off]

     

       172
        
               () conn

     

       173
        
           in

     

       174
       -
           Lwt.return_ok ()

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       175
        
       

     

       176
        
         let create_actor =

     

       177
        
           [%rapper

     
···

       311
        
       type t = Util.caqti_pool

     

       312
        
       

     

       313
        
       let connect ?create ?write () : t Lwt.t =

     

       314
       -
         if create = Some true then

     

       315
       -
           Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ;

     

       316
        
         Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location

     

       317
        
       

     

       318
        
       let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables

···

       36
        
                       created_at INTEGER NOT NULL,

     

       37
        
                       deactivated_at INTEGER

     

       38
        
                     )

     

       39
       +
               |sql}]

     

       40
        
               () conn

     

       41
        
           in

     

       42
        
           let$! () =

     
···

       52
        
             [%rapper

     

       53
        
               execute

     

       54
        
                 {sql| CREATE TABLE IF NOT EXISTS invite_codes (

     

       55
       +
                     code TEXT PRIMARY KEY,

     

       56
       +
                     did TEXT NOT NULL,

     

       57
       +
                     remaining INTEGER NOT NULL

     

       58
       +
                   )

     

       59
       +
               |sql}]

     

       60
        
               () conn

     

       61
        
           in

     

       62
        
           let$! () =

     

       63
        
             [%rapper

     

       64
        
               execute

     

       65
        
                 {sql| CREATE TABLE IF NOT EXISTS firehose (

     

       66
       +
                     seq INTEGER PRIMARY KEY,

     

       67
       +
                     time INTEGER NOT NULL,

     

       68
       +
                     t TEXT NOT NULL,

     

       69
       +
                     data BLOB NOT NULL

     

       70
       +
                   )

     

       71
       +
               |sql}]

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       72
        
               () conn

     

       73
        
           in

     

       74
       +
           [%rapper

     

       75
       +
             execute

     

       76
       +
               (* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)

     

       77
       +
               {sql| CREATE TABLE IF NOT EXISTS revoked_tokens (

     

       78
       +
                   did TEXT NOT NULL,

     

       79
       +
                   jti TEXT NOT NULL,

     

       80
       +
                   revoked_at INTEGER NOT NULL,

     

       81
       +
                   PRIMARY KEY (did, jti)

     

       82
       +
                 )

     

       83
       +
              |sql}]

     

       84
       +
             () conn

     

       85
        
       

     

       86
        
         let create_actor =

     

       87
        
           [%rapper

     
···

       221
        
       type t = Util.caqti_pool

     

       222
        
       

     

       223
        
       let connect ?create ?write () : t Lwt.t =

     

       0
        
       
     

       0
        
       
     

       224
        
         Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location

     

       225
        
       

     

       226
        
       let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables

+1 -3

pegasus/lib/dune

···

       9
        
         cohttp-lwt-unix

     

       10
        
         dns-client.unix

     

       11
        
         dream

     

       12
       -
         html_of_jsx

     

       13
        
         ipld

     

       14
        
         kleidos

     

       15
        
         lwt

     
···

       19
        
         safepass

     

       20
        
         str

     

       21
        
         timedesc

     

       22
       -
         uri

     

       23
        
         uuidm

     

       24
        
         yojson

     

       25
        
         lwt_ppx

     

       26
        
         ppx_deriving_yojson.runtime

     

       27
        
         ppx_rapper_lwt)

     

       28
        
        (preprocess

     

       29
       -
         (pps html_of_jsx.ppx lwt_ppx ppx_deriving_yojson ppx_rapper)))

     

       30
        
       

     

       31
        
       (include_subdirs qualified)

···

       9
        
         cohttp-lwt-unix

     

       10
        
         dns-client.unix

     

       11
        
         dream

     

       0
        
       
     

       12
        
         ipld

     

       13
        
         kleidos

     

       14
        
         lwt

     
···

       18
        
         safepass

     

       19
        
         str

     

       20
        
         timedesc

     

       0
        
       
     

       21
        
         uuidm

     

       22
        
         yojson

     

       23
        
         lwt_ppx

     

       24
        
         ppx_deriving_yojson.runtime

     

       25
        
         ppx_rapper_lwt)

     

       26
        
        (preprocess

     

       27
       +
         (pps lwt_ppx ppx_deriving_yojson ppx_rapper)))

     

       28
        
       

     

       29
        
       (include_subdirs qualified)

+6 -26

pegasus/lib/env.ml

···

       1
       -
       let getenv name =

     

       2
       -
         try Sys.getenv name

     

       3
       -
         with Not_found -> failwith ("Missing environment variable " ^ name)

     

       4
       -
       

     

       5
        
       let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR"

     

       6
        
       

     

       7
       -
       let hostname = getenv "PDS_HOSTNAME"

     

       8
        
       

     

       9
        
       let did =

     

       10
        
         Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID"

     

       11
        
       

     

       12
       -
       let invite_required = getenv "INVITE_CODE_REQUIRED" = "true"

     

       13
       -
       

     

       14
       -
       let rotation_key = getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str

     

       15
        
       

     

       16
       -
       let jwt_key = getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str

     

       0
        
       
     

       17
        
       

     

       18
       -
       let admin_password = getenv "ADMIN_PASSWORD"

     

       19
        
       

     

       20
       -
       let dpop_nonce_secret =

     

       21
       -
         match Sys.getenv_opt "DPOP_NONCE_SECRET" with

     

       22
       -
         | Some sec ->

     

       23
       -
             let secret =

     

       24
       -
               Base64.(decode_exn ~alphabet:uri_safe_alphabet ~pad:false) sec

     

       25
       -
               |> Bytes.of_string

     

       26
       -
             in

     

       27
       -
             if Bytes.length secret = 32 then secret

     

       28
       -
             else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64uri"

     

       29
       -
         | None ->

     

       30
       -
             let secret = Mirage_crypto_rng_unix.getrandom 32 in

     

       31
       -
             Dream.warning (fun log ->

     

       32
       -
                 log "DPOP_NONCE_SECRET not set; using DPOP_NONCE_SECRET=%s"

     

       33
       -
                   ( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret

     

       34
       -
                   |> Result.get_ok ) ) ;

     

       35
       -
             Bytes.of_string secret

···

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       1
        
       let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR"

     

       2
        
       

     

       3
       +
       let hostname = Sys.getenv "PDS_HOSTNAME"

     

       4
        
       

     

       5
        
       let did =

     

       6
        
         Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID"

     

       7
        
       

     

       8
       +
       let invite_required = Sys.getenv "INVITE_CODE_REQUIRED" = "true"

     

       0
        
       
     

       0
        
       
     

       9
        
       

     

       10
       +
       let rotation_key =

     

       11
       +
         Sys.getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str

     

       12
        
       

     

       13
       +
       let jwt_key = Sys.getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str

     

       14
        
       

     

       15
       +
       let admin_password = Sys.getenv "ADMIN_PASSWORD"

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

-6

pegasus/lib/errors.ml

···

       4
        
       

     

       5
        
       exception AuthError of (string * string)

     

       6
        
       

     

       7
       -
       exception UseDpopNonceError

     

       8
       -
       

     

       9
        
       let is_xrpc_error = function

     

       10
        
         | InvalidRequestError _ | InternalServerError _ | AuthError _ ->

     

       11
        
             true

     
···

       21
        
       

     

       22
        
       let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))

     

       23
        
       

     

       24
       -
       let use_dpop_nonce () = raise UseDpopNonceError

     

       25
       -
       

     

       26
        
       let exn_to_response exn =

     

       27
        
         let format_response error msg status =

     

       28
        
           Dream.json ~status @@ Yojson.Safe.to_string

     
···

       35
        
             format_response error message `Internal_Server_Error

     

       36
        
         | AuthError (error, message) ->

     

       37
        
             format_response error message `Unauthorized

     

       38
       -
         | UseDpopNonceError ->

     

       39
       -
             Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|}

     

       40
        
         | _ ->

     

       41
        
             format_response "InternalServerError" "Internal server error"

     

       42
        
               `Internal_Server_Error

···

       4
        
       

     

       5
        
       exception AuthError of (string * string)

     

       6
        
       

     

       0
        
       
     

       0
        
       
     

       7
        
       let is_xrpc_error = function

     

       8
        
         | InvalidRequestError _ | InternalServerError _ | AuthError _ ->

     

       9
        
             true

     
···

       19
        
       

     

       20
        
       let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))

     

       21
        
       

     

       0
        
       
     

       0
        
       
     

       22
        
       let exn_to_response exn =

     

       23
        
         let format_response error msg status =

     

       24
        
           Dream.json ~status @@ Yojson.Safe.to_string

     
···

       31
        
             format_response error message `Internal_Server_Error

     

       32
        
         | AuthError (error, message) ->

     

       33
        
             format_response error message `Unauthorized

     

       0
        
       
     

       0
        
       
     

       34
        
         | _ ->

     

       35
        
             format_response "InternalServerError" "Internal server error"

     

       36
        
               `Internal_Server_Error

+4 -3

pegasus/lib/id_resolver.ml

···

       1
        
       open Cohttp_lwt

     

       0
        
       
     

       2
        
       

     

       3
        
       let did_regex =

     

       4
        
         Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|}

     
···

       11
        
             let uri =

     

       12
        
               Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did")

     

       13
        
             in

     

       14
       -
             let%lwt {status; _}, body = Util.http_get uri in

     

       15
        
             match status with

     

       16
        
             | `OK ->

     

       17
        
                 let%lwt did = Body.to_string body in

     
···

       163
        
                   ~path:(Uri.pct_encode did) ()

     

       164
        
               in

     

       165
        
               let%lwt {status; _}, body =

     

       166
       -
                 Util.http_get uri

     

       167
        
                   ~headers:(Cohttp.Header.of_list [("Accept", "application/json")])

     

       168
        
               in

     

       169
        
               match status with

     
···

       185
        
                   ~path:"/.well-known/did.json" ()

     

       186
        
               in

     

       187
        
               let%lwt {status; _}, body =

     

       188
       -
                 Util.http_get uri

     

       189
        
                   ~headers:(Cohttp.Header.of_list [("Accept", "application/json")])

     

       190
        
               in

     

       191
        
               match status with

···

       1
        
       open Cohttp_lwt

     

       2
       +
       open Cohttp_lwt_unix

     

       3
        
       

     

       4
        
       let did_regex =

     

       5
        
         Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|}

     
···

       12
        
             let uri =

     

       13
        
               Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did")

     

       14
        
             in

     

       15
       +
             let%lwt {status; _}, body = Client.get uri in

     

       16
        
             match status with

     

       17
        
             | `OK ->

     

       18
        
                 let%lwt did = Body.to_string body in

     
···

       164
        
                   ~path:(Uri.pct_encode did) ()

     

       165
        
               in

     

       166
        
               let%lwt {status; _}, body =

     

       167
       +
                 Client.get uri

     

       168
        
                   ~headers:(Cohttp.Header.of_list [("Accept", "application/json")])

     

       169
        
               in

     

       170
        
               match status with

     
···

       186
        
                   ~path:"/.well-known/did.json" ()

     

       187
        
               in

     

       188
        
               let%lwt {status; _}, body =

     

       189
       +
                 Client.get uri

     

       190
        
                   ~headers:(Cohttp.Header.of_list [("Accept", "application/json")])

     

       191
        
               in

     

       192
        
               match status with

+26 -20

pegasus/lib/jwt.ml

···

       19
        
       let b64_decode str =

     

       20
        
         match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with

     

       21
        
         | Ok s ->

     

       22
       -
             s

     

       23
        
         | Error (`Msg e) ->

     

       24
       -
             failwith e

     

       25
        
       

     

       26
        
       let extract_signature_components signature =

     

       27
        
         if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature"

     
···

       30
        
           let s = Bytes.sub signature 32 32 in

     

       31
        
           (r, s)

     

       32
        
       

     

       33
       -
       let sign_jwt payload ?(typ = "JWT") signing_key =

     

       34
        
         let _, (module Curve : Kleidos.CURVE) = signing_key in

     

       35
        
         let alg =

     

       36
        
           match Curve.name with

     
···

       51
        
               failwith "invalid curve"

     

       52
        
         in

     

       53
        
         let header_json =

     

       54
       -
           `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String typ)]

     

       55
        
         in

     

       56
        
         let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in

     

       57
        
         let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in

     
···

       65
        
       let decode_jwt jwt =

     

       66
        
         match String.split_on_char '.' jwt with

     

       67
        
         | [header_b64; payload_b64; _] -> (

     

       68
       -
           try

     

       69
       -
             let header = Yojson.Safe.from_string (b64_decode header_b64) in

     

       70
       -
             let payload = Yojson.Safe.from_string (b64_decode payload_b64) in

     

       71
       -
             Ok (header, payload)

     

       72
       -
           with _ -> Error "invalid jwt" )

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       73
        
         | _ ->

     

       74
        
             Error "invalid jwt format"

     

       75
        
       

     

       76
        
       let verify_jwt jwt pubkey =

     

       77
        
         match String.split_on_char '.' jwt with

     

       78
       -
         | [header_b64; payload_b64; signature_b64] ->

     

       79
       -
             let signature = Bytes.of_string (b64_decode signature_b64) in

     

       80
       -
             let signing_input = header_b64 ^ "." ^ payload_b64 in

     

       81
       -
             let verified =

     

       82
       -
               Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature

     

       83
       -
             in

     

       84
       -
             if verified then decode_jwt jwt

     

       85
       -
             else Error "jwt signature verification failed"

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       86
        
         | _ ->

     

       87
        
             Error "invalid jwt format"

     

       88
        
       

     
···

       90
        
         let now_s = int_of_float (Unix.gettimeofday ()) in

     

       91
        
         let access_exp = now_s + Defaults.access_token_exp in

     

       92
        
         let refresh_exp = now_s + Defaults.refresh_token_exp in

     

       93
       -
         let jti =

     

       94
       -
           Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string

     

       95
       -
         in

     

       96
        
         let access_payload =

     

       97
        
           symmetric_jwt_to_yojson

     

       98
        
             { scope= "com.atproto.access"

···

       19
        
       let b64_decode str =

     

       20
        
         match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with

     

       21
        
         | Ok s ->

     

       22
       +
             Ok s

     

       23
        
         | Error (`Msg e) ->

     

       24
       +
             Error e

     

       25
        
       

     

       26
        
       let extract_signature_components signature =

     

       27
        
         if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature"

     
···

       30
        
           let s = Bytes.sub signature 32 32 in

     

       31
        
           (r, s)

     

       32
        
       

     

       33
       +
       let sign_jwt payload signing_key =

     

       34
        
         let _, (module Curve : Kleidos.CURVE) = signing_key in

     

       35
        
         let alg =

     

       36
        
           match Curve.name with

     
···

       51
        
               failwith "invalid curve"

     

       52
        
         in

     

       53
        
         let header_json =

     

       54
       +
           `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String "JWT")]

     

       55
        
         in

     

       56
        
         let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in

     

       57
        
         let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in

     
···

       65
        
       let decode_jwt jwt =

     

       66
        
         match String.split_on_char '.' jwt with

     

       67
        
         | [header_b64; payload_b64; _] -> (

     

       68
       +
           match (b64_decode header_b64, b64_decode payload_b64) with

     

       69
       +
           | Ok header_str, Ok payload_str -> (

     

       70
       +
             try

     

       71
       +
               let header = Yojson.Safe.from_string header_str in

     

       72
       +
               let payload = Yojson.Safe.from_string payload_str in

     

       73
       +
               Ok (header, payload)

     

       74
       +
             with _ -> Error "invalid json in jwt" )

     

       75
       +
           | Error e, _ | _, Error e ->

     

       76
       +
               Error e )

     

       77
        
         | _ ->

     

       78
        
             Error "invalid jwt format"

     

       79
        
       

     

       80
        
       let verify_jwt jwt pubkey =

     

       81
        
         match String.split_on_char '.' jwt with

     

       82
       +
         | [header_b64; payload_b64; signature_b64] -> (

     

       83
       +
           match b64_decode signature_b64 with

     

       84
       +
           | Error e ->

     

       85
       +
               Error e

     

       86
       +
           | Ok signature_str ->

     

       87
       +
               let signature = Bytes.of_string signature_str in

     

       88
       +
               let signing_input = header_b64 ^ "." ^ payload_b64 in

     

       89
       +
               let verified =

     

       90
       +
                 Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature

     

       91
       +
               in

     

       92
       +
               if verified then decode_jwt jwt

     

       93
       +
               else Error "jwt signature verification failed" )

     

       94
        
         | _ ->

     

       95
        
             Error "invalid jwt format"

     

       96
        
       

     
···

       98
        
         let now_s = int_of_float (Unix.gettimeofday ()) in

     

       99
        
         let access_exp = now_s + Defaults.access_token_exp in

     

       100
        
         let refresh_exp = now_s + Defaults.refresh_token_exp in

     

       101
       +
         let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in

     

       0
        
       
     

       0
        
       
     

       102
        
         let access_payload =

     

       103
        
           symmetric_jwt_to_yojson

     

       104
        
             { scope= "com.atproto.access"

-45

pegasus/lib/oauth/client.ml

···

       1
       -
       open Types

     

       2
       -
       

     

       3
       -
       let fetch_client_metadata client_id : client_metadata Lwt.t =

     

       4
       -
         let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in

     

       5
       -
         if status <> `OK then

     

       6
       -
           let%lwt () = Cohttp_lwt.Body.drain_body res in

     

       7
       -
           failwith

     

       8
       -
             (Printf.sprintf "client metadata not found; http %d"

     

       9
       -
                (Cohttp.Code.code_of_status status) )

     

       10
       -
         else

     

       11
       -
           let%lwt body = Cohttp_lwt.Body.to_string res in

     

       12
       -
           let json = Yojson.Safe.from_string body in

     

       13
       -
           let metadata =

     

       14
       -
             match client_metadata_of_yojson json with

     

       15
       -
             | Ok metadata ->

     

       16
       -
                 metadata

     

       17
       -
             | Error err ->

     

       18
       -
                 failwith err

     

       19
       -
           in

     

       20
       -
           if metadata.client_id <> client_id then failwith "client_id mismatch"

     

       21
       -
           else

     

       22
       -
             let scopes = String.split_on_char ' ' metadata.scope in

     

       23
       -
             if not (List.mem "atproto" scopes) then

     

       24
       -
               failwith "scope must include 'atproto'"

     

       25
       -
             else

     

       26
       -
               List.iter

     

       27
       -
                 (function

     

       28
       -
                   | "authorization_code" | "refresh_token" ->

     

       29
       -
                       ()

     

       30
       -
                   | grant ->

     

       31
       -
                       failwith ("invalid grant type: " ^ grant) )

     

       32
       -
                 metadata.grant_types ;

     

       33
       -
             List.iter

     

       34
       -
               (fun uri ->

     

       35
       -
                 let u = Uri.of_string uri in

     

       36
       -
                 let host = Uri.host u in

     

       37
       -
                 match Uri.scheme u with

     

       38
       -
                 | Some "https" when host <> Some "localhost" ->

     

       39
       -
                     ()

     

       40
       -
                 | Some "http" when host = Some "127.0.0.1" || host = Some "[::1]" ->

     

       41
       -
                     ()

     

       42
       -
                 | _ ->

     

       43
       -
                     failwith ("invalid redirect_uri: " ^ uri) )

     

       44
       -
               metadata.redirect_uris ;

     

       45
       -
             Lwt.return metadata

-15

pegasus/lib/oauth/constants.ml

···

       1
       -
       let max_dpop_age_s = 60

     

       2
       -
       

     

       3
       -
       let dpop_rotation_interval_ms = 60_000L

     

       4
       -
       

     

       5
       -
       let jti_ttl_s = 3600

     

       6
       -
       

     

       7
       -
       let jti_cache_size = 10_000

     

       8
       -
       

     

       9
       -
       let par_request_ttl_ms = 300_000

     

       10
       -
       

     

       11
       -
       let code_expiry_ms = 300_000

     

       12
       -
       

     

       13
       -
       let access_token_expiry_ms = 60 * 60 * 1000

     

       14
       -
       

     

       15
       -
       let request_uri_prefix = "urn:ietf:params:oauth:request_uri:"

-204

pegasus/lib/oauth/dpop.ml

···

       1
       -
       type nonce_state =

     

       2
       -
         { secret: bytes

     

       3
       -
         ; mutable counter: int64

     

       4
       -
         ; mutable prev: string

     

       5
       -
         ; mutable curr: string

     

       6
       -
         ; mutable next: string

     

       7
       -
         ; rotation_interval_ms: int64 }

     

       8
       -
       

     

       9
       -
       type ec_jwk = {crv: string; kty: string; x: string; y: string}

     

       10
       -
       [@@deriving yojson]

     

       11
       -
       

     

       12
       -
       type proof = {jti: string; jkt: string; htm: string; htu: string}

     

       13
       -
       [@@deriving yojson]

     

       14
       -
       

     

       15
       -
       let jti_cache : (string, int) Hashtbl.t =

     

       16
       -
         Hashtbl.create Constants.jti_cache_size

     

       17
       -
       

     

       18
       -
       let cleanup_jti_cache () =

     

       19
       -
         let now = int_of_float (Unix.gettimeofday ()) in

     

       20
       -
         Hashtbl.filter_map_inplace

     

       21
       -
           (fun _ expires_at -> if expires_at > now then Some expires_at else None)

     

       22
       -
           jti_cache

     

       23
       -
       

     

       24
       -
       let compute_nonce secret counter =

     

       25
       -
         let data = Bytes.create 8 in

     

       26
       -
         Bytes.set_int64_be data 0 counter ;

     

       27
       -
         Digestif.SHA256.(

     

       28
       -
           hmac_bytes ~key:(Bytes.to_string secret) data

     

       29
       -
           |> to_raw_string |> Jwt.b64_encode )

     

       30
       -
       

     

       31
       -
       let create_nonce_state secret =

     

       32
       -
         let counter =

     

       33
       -
           Int64.div

     

       34
       -
             (Int64.of_float (Unix.gettimeofday () *. 1000.))

     

       35
       -
             Constants.dpop_rotation_interval_ms

     

       36
       -
         in

     

       37
       -
         { secret

     

       38
       -
         ; counter

     

       39
       -
         ; prev= compute_nonce secret (Int64.pred counter)

     

       40
       -
         ; curr= compute_nonce secret counter

     

       41
       -
         ; next= compute_nonce secret (Int64.succ counter)

     

       42
       -
         ; rotation_interval_ms= Constants.dpop_rotation_interval_ms }

     

       43
       -
       

     

       44
       -
       let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret)

     

       45
       -
       

     

       46
       -
       let next_nonce () =

     

       47
       -
         let now_counter =

     

       48
       -
           Int64.div

     

       49
       -
             (Int64.of_float (Unix.gettimeofday () *. 1000.))

     

       50
       -
             !nonce_state.rotation_interval_ms

     

       51
       -
         in

     

       52
       -
         if now_counter <> !nonce_state.counter then (

     

       53
       -
           !nonce_state.prev <- !nonce_state.curr ;

     

       54
       -
           !nonce_state.curr <- !nonce_state.next ;

     

       55
       -
           !nonce_state.next <-

     

       56
       -
             compute_nonce !nonce_state.secret (Int64.succ now_counter) ;

     

       57
       -
           !nonce_state.counter <- now_counter ) ;

     

       58
       -
         !nonce_state.next

     

       59
       -
       

     

       60
       -
       let verify_nonce nonce =

     

       61
       -
         let valid =

     

       62
       -
           nonce = !nonce_state.prev || nonce = !nonce_state.curr

     

       63
       -
           || nonce = !nonce_state.next

     

       64
       -
         in

     

       65
       -
         ignore next_nonce ; valid

     

       66
       -
       

     

       67
       -
       let add_jti jti =

     

       68
       -
         let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in

     

       69
       -
         if Hashtbl.mem jti_cache jti then false (* replay *)

     

       70
       -
         else (

     

       71
       -
           Hashtbl.add jti_cache jti expires_at ;

     

       72
       -
           (* clean up every once in a while *)

     

       73
       -
           if Hashtbl.length jti_cache mod 100 = 0 then cleanup_jti_cache () ;

     

       74
       -
           true )

     

       75
       -
       

     

       76
       -
       let normalize_url url =

     

       77
       -
         let uri = Uri.of_string url in

     

       78
       -
         Uri.make ~scheme:"https"

     

       79
       -
           ~host:(Uri.host uri |> Option.value ~default:Env.hostname)

     

       80
       -
           ~path:(Uri.path uri) ()

     

       81
       -
         |> Uri.to_string

     

       82
       -
       

     

       83
       -
       let compute_jwk_thumbprint jwk =

     

       84
       -
         let {crv; kty; x; y} = jwk in

     

       85
       -
         let tp =

     

       86
       -
           (* keys must be in lexicographic order *)

     

       87
       -
           Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y

     

       88
       -
         in

     

       89
       -
         Digestif.SHA256.(digest_string tp |> to_raw_string |> Jwt.b64_encode)

     

       90
       -
       

     

       91
       -
       let verify_signature jwt jwk =

     

       92
       -
         let parts = String.split_on_char '.' jwt in

     

       93
       -
         match parts with

     

       94
       -
         | [header_b64; payload_b64; sig_b64] ->

     

       95
       -
             let signing_input = header_b64 ^ "." ^ payload_b64 in

     

       96
       -
             let msg = Bytes.of_string signing_input in

     

       97
       -
             let {x; y; crv; _} = jwk in

     

       98
       -
             let x = x |> Jwt.b64_decode |> Bytes.of_string in

     

       99
       -
             let y = y |> Jwt.b64_decode |> Bytes.of_string in

     

       100
       -
             let pubkey = Bytes.cat (Bytes.of_string "\x04") (Bytes.cat x y) in

     

       101
       -
             let pubkey =

     

       102
       -
               ( pubkey

     

       103
       -
               , match crv with

     

       104
       -
                 | "secp256k1" ->

     

       105
       -
                     (module Kleidos.K256 : Kleidos.CURVE)

     

       106
       -
                 | "P-256" ->

     

       107
       -
                     (module Kleidos.P256 : Kleidos.CURVE)

     

       108
       -
                 | _ ->

     

       109
       -
                     failwith "unsupported algorithm" )

     

       110
       -
             in

     

       111
       -
             let sig_bytes = Jwt.b64_decode sig_b64 |> Bytes.of_string in

     

       112
       -
             let r = Bytes.sub sig_bytes 0 32 in

     

       113
       -
             let s = Bytes.sub sig_bytes 32 32 in

     

       114
       -
             let signature = Bytes.cat r s in

     

       115
       -
             Kleidos.verify ~pubkey ~msg ~signature

     

       116
       -
         | _ ->

     

       117
       -
             false

     

       118
       -
       

     

       119
       -
       let verify_dpop_proof ~mthd ~url ~dpop_header ?access_token () =

     

       120
       -
         match dpop_header with

     

       121
       -
         | None ->

     

       122
       -
             Error "missing dpop header"

     

       123
       -
         | Some jwt -> (

     

       124
       -
             let open Yojson.Safe.Util in

     

       125
       -
             match String.split_on_char '.' jwt with

     

       126
       -
             | [header_b64; payload_b64; _] -> (

     

       127
       -
                 let header = Yojson.Safe.from_string (Jwt.b64_decode header_b64) in

     

       128
       -
                 let payload = Yojson.Safe.from_string (Jwt.b64_decode payload_b64) in

     

       129
       -
                 let typ = header |> member "typ" |> to_string in

     

       130
       -
                 if typ <> "dpop+jwt" then Error "invalid typ in dpop proof"

     

       131
       -
                 else

     

       132
       -
                   let alg = header |> member "alg" |> to_string in

     

       133
       -
                   if alg <> "ES256" && alg <> "ES256K" then

     

       134
       -
                     Error "only es256 and es256k supported for dpop"

     

       135
       -
                   else

     

       136
       -
                     let jwk =

     

       137
       -
                       header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok

     

       138
       -
                     in

     

       139
       -
                     if

     

       140
       -
                       not

     

       141
       -
                         ( match (alg, jwk.crv) with

     

       142
       -
                         | "ES256", "P-256" ->

     

       143
       -
                             true

     

       144
       -
                         | "ES256K", "secp256k1" ->

     

       145
       -
                             true

     

       146
       -
                         | _ ->

     

       147
       -
                             false )

     

       148
       -
                     then

     

       149
       -
                       Error

     

       150
       -
                         (Printf.sprintf "algorithm %s doesn't match curve %s" alg

     

       151
       -
                            jwk.crv )

     

       152
       -
                     else

     

       153
       -
                       let jti = payload |> member "jti" |> to_string in

     

       154
       -
                       let htm = payload |> member "htm" |> to_string in

     

       155
       -
                       let htu = payload |> member "htu" |> to_string in

     

       156
       -
                       let iat = payload |> member "iat" |> to_int in

     

       157
       -
                       let nonce_claim =

     

       158
       -
                         payload |> member "nonce" |> to_string_option

     

       159
       -
                       in

     

       160
       -
                       match nonce_claim with

     

       161
       -
                       (* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)

     

       162
       -
                       | None ->

     

       163
       -
                           Error "use_dpop_nonce"

     

       164
       -
                       | Some n when not (verify_nonce n) ->

     

       165
       -
                           Error "use_dpop_nonce"

     

       166
       -
                       | Some _ -> (

     

       167
       -
                           if htm <> mthd then Error "htm mismatch"

     

       168
       -
                           else if

     

       169
       -
                             not (String.equal (normalize_url htu) (normalize_url url))

     

       170
       -
                           then Error "htu mismatch"

     

       171
       -
                           else

     

       172
       -
                             let now = int_of_float (Unix.gettimeofday ()) in

     

       173
       -
                             if now - iat > Constants.max_dpop_age_s then

     

       174
       -
                               Error "dpop proof too old"

     

       175
       -
                             else if iat - now > 5 then Error "dpop proof in future"

     

       176
       -
                             else if not (add_jti jti) then

     

       177
       -
                               Error "dpop proof replay detected"

     

       178
       -
                             else if not (verify_signature jwt jwk) then

     

       179
       -
                               Error "invalid dpop signature"

     

       180
       -
                             else

     

       181
       -
                               let jkt = compute_jwk_thumbprint jwk in

     

       182
       -
                               (* verify ath if access token is provided *)

     

       183
       -
                               match access_token with

     

       184
       -
                               | Some token ->

     

       185
       -
                                   let ath_claim =

     

       186
       -
                                     payload |> member "ath" |> to_string_option

     

       187
       -
                                   in

     

       188
       -
                                   let expected_ath =

     

       189
       -
                                     Digestif.SHA256.(

     

       190
       -
                                       digest_string token |> to_raw_string

     

       191
       -
                                       |> Jwt.b64_encode )

     

       192
       -
                                   in

     

       193
       -
                                   if Some expected_ath <> ath_claim then

     

       194
       -
                                     Error "ath mismatch"

     

       195
       -
                                   else Ok {jti; jkt; htm; htu}

     

       196
       -
                               | None ->

     

       197
       -
                                   let ath_claim =

     

       198
       -
                                     payload |> member "ath" |> to_string_option

     

       199
       -
                                   in

     

       200
       -
                                   if ath_claim <> None then

     

       201
       -
                                     Error "ath claim not allowed without access token"

     

       202
       -
                                   else Ok {jti; jkt; htm; htu} ) )

     

       203
       -
             | _ ->

     

       204
       -
                 Error "invalid dpop jwt" )

-138

pegasus/lib/oauth/queries.ml

···

       1
       -
       [@@@warning "-missing-record-field-pattern"]

     

       2
       -
       

     

       3
       -
       open Types

     

       4
       -
       

     

       5
       -
       let insert_par_request conn req =

     

       6
       -
         Util.use_pool conn

     

       7
       -
         @@ [%rapper

     

       8
       -
              execute

     

       9
       -
                {sql|

     

       10
       -
               INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at)

     

       11
       -
               VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string?{dpop_jkt}, %int{expires_at}, %int{created_at})

     

       12
       -
             |sql}

     

       13
       -
                record_in]

     

       14
       -
              req

     

       15
       -
       

     

       16
       -
       let get_par_request conn request_id =

     

       17
       -
         Util.use_pool conn

     

       18
       -
         @@ [%rapper

     

       19
       -
              get_opt

     

       20
       -
                {sql|

     

       21
       -
               SELECT @string{request_id}, @string{client_id}, @string{request_data},

     

       22
       -
                      @string?{dpop_jkt}, @int{expires_at}, @int{created_at}

     

       23
       -
               FROM oauth_requests

     

       24
       -
               WHERE request_id = %string{request_id}

     

       25
       -
               AND expires_at > %int{now}

     

       26
       -
             |sql}

     

       27
       -
                record_out]

     

       28
       -
              ~request_id ~now:(Util.now_ms ())

     

       29
       -
       

     

       30
       -
       let insert_auth_code conn code =

     

       31
       -
         Util.use_pool conn

     

       32
       -
         @@ [%rapper

     

       33
       -
              execute

     

       34
       -
                {sql|

     

       35
       -
               INSERT INTO oauth_codes (code, request_id, authorized_by, authorized_at, expires_at, used)

     

       36
       -
               VALUES (%string{code}, %string{request_id}, %string?{authorized_by}, %int?{authorized_at}, %int{expires_at}, 0)

     

       37
       -
             |sql}

     

       38
       -
                record_in]

     

       39
       -
              code

     

       40
       -
       

     

       41
       -
       let get_auth_code conn code =

     

       42
       -
         Util.use_pool conn

     

       43
       -
         @@ [%rapper

     

       44
       -
              get_opt

     

       45
       -
                {sql|

     

       46
       -
               SELECT @string{code}, @string{request_id}, @string?{authorized_by},

     

       47
       -
                      @int?{authorized_at}, @int{expires_at}, @bool{used}

     

       48
       -
               FROM oauth_codes

     

       49
       -
               WHERE code = %string{code}

     

       50
       -
             |sql}

     

       51
       -
                record_out]

     

       52
       -
              ~code

     

       53
       -
       

     

       54
       -
       let activate_auth_code conn code did =

     

       55
       -
         let authorized_at = Util.now_ms () in

     

       56
       -
         Util.use_pool conn

     

       57
       -
         @@ [%rapper

     

       58
       -
              execute

     

       59
       -
                {sql|

     

       60
       -
               UPDATE oauth_codes

     

       61
       -
               SET authorized_by = %string{did},

     

       62
       -
                   authorized_at = %int{authorized_at}

     

       63
       -
               WHERE code = %string{code}

     

       64
       -
             |sql}]

     

       65
       -
              ~did ~authorized_at ~code

     

       66
       -
       

     

       67
       -
       let consume_auth_code conn code =

     

       68
       -
         Util.use_pool conn

     

       69
       -
         @@ [%rapper

     

       70
       -
              get_opt

     

       71
       -
                {sql|

     

       72
       -
               UPDATE oauth_codes

     

       73
       -
               SET used = 1

     

       74
       -
               WHERE code = %string{code} AND used = 0

     

       75
       -
               RETURNING @string{code}, @string{request_id}, @string?{authorized_by},

     

       76
       -
                         @int?{authorized_at}, @int{expires_at}, @bool{used}

     

       77
       -
             |sql}

     

       78
       -
                record_out]

     

       79
       -
              ~code

     

       80
       -
       

     

       81
       -
       let insert_oauth_token conn token =

     

       82
       -
         Util.use_pool conn

     

       83
       -
         @@ [%rapper

     

       84
       -
              execute

     

       85
       -
                {sql|

     

       86
       -
               INSERT INTO oauth_tokens (refresh_token, client_id, did, dpop_jkt, scope, expires_at)

     

       87
       -
               VALUES (%string{refresh_token}, %string{client_id}, %string{did}, %string{dpop_jkt}, %string{scope}, %int{expires_at})

     

       88
       -
             |sql}

     

       89
       -
                record_in]

     

       90
       -
              token

     

       91
       -
       

     

       92
       -
       let get_oauth_token_by_refresh conn refresh_token =

     

       93
       -
         Util.use_pool conn

     

       94
       -
         @@ [%rapper

     

       95
       -
              get_opt

     

       96
       -
                {sql|

     

       97
       -
               SELECT @string{refresh_token}, @string{client_id}, @string{did},

     

       98
       -
                      @string{dpop_jkt}, @string{scope}, @int{expires_at}

     

       99
       -
               FROM oauth_tokens

     

       100
       -
               WHERE refresh_token = %string{refresh_token}

     

       101
       -
             |sql}

     

       102
       -
                record_out]

     

       103
       -
              ~refresh_token

     

       104
       -
       

     

       105
       -
       let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at =

     

       106
       -
         Util.use_pool conn

     

       107
       -
         @@ [%rapper

     

       108
       -
              execute

     

       109
       -
                {sql|

     

       110
       -
               UPDATE oauth_tokens

     

       111
       -
               SET refresh_token = %string{new_refresh_token},

     

       112
       -
                   expires_at = %int{expires_at}

     

       113
       -
               WHERE refresh_token = %string{old_refresh_token}

     

       114
       -
             |sql}]

     

       115
       -
              ~new_refresh_token ~expires_at ~old_refresh_token

     

       116
       -
       

     

       117
       -
       let delete_oauth_token_by_refresh conn refresh_token =

     

       118
       -
         Util.use_pool conn

     

       119
       -
         @@ [%rapper

     

       120
       -
              execute

     

       121
       -
                {sql|

     

       122
       -
               DELETE FROM oauth_tokens WHERE refresh_token = %string{refresh_token}

     

       123
       -
             |sql}]

     

       124
       -
              ~refresh_token

     

       125
       -
       

     

       126
       -
       let get_oauth_tokens_by_did conn did =

     

       127
       -
         Util.use_pool conn

     

       128
       -
         @@ [%rapper

     

       129
       -
              get_many

     

       130
       -
                {sql|

     

       131
       -
               SELECT @string{refresh_token}, @string{client_id}, @string{did},

     

       132
       -
                       @string{dpop_jkt}, @string{scope}, @int{expires_at}

     

       133
       -
               FROM oauth_tokens

     

       134
       -
               WHERE did = %string{did}

     

       135
       -
               ORDER BY expires_at ASC

     

       136
       -
             |sql}

     

       137
       -
                record_out]

     

       138
       -
              ~did

-71

pegasus/lib/oauth/types.ml

···

       1
       -
       type par_request =

     

       2
       -
         { client_id: string

     

       3
       -
         ; response_type: string

     

       4
       -
         ; response_mode: string option [@default None]

     

       5
       -
         ; redirect_uri: string

     

       6
       -
         ; scope: string

     

       7
       -
         ; state: string

     

       8
       -
         ; code_challenge: string

     

       9
       -
         ; code_challenge_method: string

     

       10
       -
         ; login_hint: string option [@default None]

     

       11
       -
         ; dpop_jkt: string option [@default None]

     

       12
       -
         ; client_assertion_type: string option [@default None]

     

       13
       -
         ; client_assertion: string option [@default None] }

     

       14
       -
       [@@deriving yojson {strict= false}]

     

       15
       -
       

     

       16
       -
       type token_request =

     

       17
       -
         { grant_type: string

     

       18
       -
         ; code: string option [@default None]

     

       19
       -
         ; redirect_uri: string option [@default None]

     

       20
       -
         ; code_verifier: string option [@default None]

     

       21
       -
         ; refresh_token: string option [@default None]

     

       22
       -
         ; client_id: string

     

       23
       -
         ; client_assertion_type: string option [@default None]

     

       24
       -
         ; client_assertion: string option [@default None] }

     

       25
       -
       [@@deriving yojson {strict= false}]

     

       26
       -
       

     

       27
       -
       type client_metadata =

     

       28
       -
         { client_id: string

     

       29
       -
         ; client_name: string option [@default None]

     

       30
       -
         ; client_uri: string

     

       31
       -
         ; redirect_uris: string list

     

       32
       -
         ; grant_types: string list

     

       33
       -
         ; response_types: string list

     

       34
       -
         ; scope: string

     

       35
       -
         ; token_endpoint_auth_method: string

     

       36
       -
         ; token_endpoint_auth_signing_alg: string option [@default None]

     

       37
       -
         ; application_type: string

     

       38
       -
         ; dpop_bound_access_tokens: bool

     

       39
       -
         ; jwks_uri: string option [@default None]

     

       40
       -
         ; jwks: Yojson.Safe.t option [@default None] }

     

       41
       -
       [@@deriving yojson {strict= false}]

     

       42
       -
       

     

       43
       -
       type dpop_proof = {jti: string; jkt: string; htm: string; htu: string}

     

       44
       -
       [@@deriving yojson {strict= false}]

     

       45
       -
       

     

       46
       -
       type oauth_request =

     

       47
       -
         { request_id: string

     

       48
       -
         ; client_id: string

     

       49
       -
         ; request_data: string

     

       50
       -
         ; dpop_jkt: string option [@default None]

     

       51
       -
         ; expires_at: int

     

       52
       -
         ; created_at: int }

     

       53
       -
       [@@deriving yojson {strict= false}]

     

       54
       -
       

     

       55
       -
       type oauth_code =

     

       56
       -
         { code: string

     

       57
       -
         ; request_id: string

     

       58
       -
         ; authorized_by: string option [@default None]

     

       59
       -
         ; authorized_at: int option [@default None]

     

       60
       -
         ; expires_at: int

     

       61
       -
         ; used: bool }

     

       62
       -
       [@@deriving yojson {strict= false}]

     

       63
       -
       

     

       64
       -
       type oauth_token =

     

       65
       -
         { refresh_token: string

     

       66
       -
         ; client_id: string

     

       67
       -
         ; did: string

     

       68
       -
         ; dpop_jkt: string

     

       69
       -
         ; scope: string

     

       70
       -
         ; expires_at: int }

     

       71
       -
       [@@deriving yojson {strict= false}]

+1 -1

pegasus/lib/plc.ml

···

       302
        
                did

     

       303
        
         in

     

       304
        
         let headers = Http.Header.init_with "Accept" "application/json" in

     

       305
       -
         let%lwt res, body = Util.http_get ~headers uri in

     

       306
        
         match res.status with

     

       307
        
         | `OK ->

     

       308
        
             let%lwt body = Body.to_string body in

···

       302
        
                did

     

       303
        
         in

     

       304
        
         let headers = Http.Header.init_with "Accept" "application/json" in

     

       305
       +
         let%lwt res, body = Client.get ~headers uri in

     

       306
        
         match res.status with

     

       307
        
         | `OK ->

     

       308
        
             let%lwt body = Body.to_string body in

+11 -11

pegasus/lib/repository.ml

···

       180
        
         let%lwt map = get_map t in

     

       181
        
         String_map.bindings map

     

       182
        
         |> List.filter (fun (path, _) ->

     

       183
       -
             String.starts_with ~prefix:(path ^ "/") collection )

     

       184
        
         |> Lwt_list.fold_left_s

     

       185
        
              (fun acc (path, cid) ->

     

       186
        
                match%lwt User_store.get_record t.db path with

     
···

       320
        
                   let%lwt () =

     

       321
        
                     match old_cid with

     

       322
        
                     | Some _ -> (

     

       323
       -
                       match%lwt User_store.get_record t.db path with

     

       324
       -
                       | Some record ->

     

       325
       -
                           let refs =

     

       326
       -
                             Util.find_blob_refs record.value

     

       327
       -
                             |> List.map (fun (r : Mist.Blob_ref.t) -> r.ref)

     

       328
       -
                           in

     

       329
       -
                           let%lwt () = User_store.clear_blob_refs t.db path refs in

     

       330
       -
                           Lwt.return_unit

     

       331
       -
                       | None ->

     

       332
       -
                           Lwt.return_unit )

     

       333
        
                     | None ->

     

       334
        
                         Lwt.return_unit

     

       335
        
                   in

···

       180
        
         let%lwt map = get_map t in

     

       181
        
         String_map.bindings map

     

       182
        
         |> List.filter (fun (path, _) ->

     

       183
       +
                String.starts_with ~prefix:(path ^ "/") collection )

     

       184
        
         |> Lwt_list.fold_left_s

     

       185
        
              (fun acc (path, cid) ->

     

       186
        
                match%lwt User_store.get_record t.db path with

     
···

       320
        
                   let%lwt () =

     

       321
        
                     match old_cid with

     

       322
        
                     | Some _ -> (

     

       323
       +
                         match%lwt User_store.get_record t.db path with

     

       324
       +
                         | Some record ->

     

       325
       +
                             let refs =

     

       326
       +
                               Util.find_blob_refs record.value

     

       327
       +
                               |> List.map (fun (r : Mist.Blob_ref.t) -> r.ref)

     

       328
       +
                             in

     

       329
       +
                             let%lwt () = User_store.clear_blob_refs t.db path refs in

     

       330
       +
                             Lwt.return_unit

     

       331
       +
                         | None ->

     

       332
       +
                             Lwt.return_unit )

     

       333
        
                     | None ->

     

       334
        
                         Lwt.return_unit

     

       335
        
                   in

+28 -28

pegasus/lib/sequencer.ml

···

       330
        
             let blobs =

     

       331
        
               j |> member "blobs" |> to_list

     

       332
        
               |> List.filter_map (fun x ->

     

       333
       -
                   match Cid.of_yojson x with Ok c -> Some c | _ -> None )

     

       334
        
             in

     

       335
        
             let prev_data =

     

       336
        
               match j |> member "prevData" with

     
···

       342
        
             let ops =

     

       343
        
               j |> member "ops" |> to_list

     

       344
        
               |> List.map (fun opj ->

     

       345
       -
                   let action =

     

       346
       -
                     match opj |> member "action" |> to_string with

     

       347
       -
                     | "create" ->

     

       348
       -
                         `Create

     

       349
       -
                     | "update" ->

     

       350
       -
                         `Update

     

       351
       -
                     | "delete" ->

     

       352
       -
                         `Delete

     

       353
       -
                     | _ ->

     

       354
       -
                         `Create

     

       355
       -
                   in

     

       356
       -
                   let path = opj |> member "path" |> to_string in

     

       357
       -
                   let cid =

     

       358
       -
                     match opj |> member "cid" with

     

       359
       -
                     | `Null ->

     

       360
       -
                         None

     

       361
       -
                     | v -> (

     

       362
       -
                       match Cid.of_yojson v with Ok c -> Some c | _ -> None )

     

       363
       -
                   in

     

       364
       -
                   let prev =

     

       365
       -
                     match opj |> member "prev" with

     

       366
       -
                     | `Null ->

     

       367
       -
                         None

     

       368
       -
                     | v -> (

     

       369
       -
                       match Cid.of_yojson v with Ok c -> Some c | _ -> None )

     

       370
       -
                   in

     

       371
       -
                   {action; path; cid; prev} )

     

       372
        
             in

     

       373
        
             Ok

     

       374
        
               { rebase

···

       330
        
             let blobs =

     

       331
        
               j |> member "blobs" |> to_list

     

       332
        
               |> List.filter_map (fun x ->

     

       333
       +
                      match Cid.of_yojson x with Ok c -> Some c | _ -> None )

     

       334
        
             in

     

       335
        
             let prev_data =

     

       336
        
               match j |> member "prevData" with

     
···

       342
        
             let ops =

     

       343
        
               j |> member "ops" |> to_list

     

       344
        
               |> List.map (fun opj ->

     

       345
       +
                      let action =

     

       346
       +
                        match opj |> member "action" |> to_string with

     

       347
       +
                        | "create" ->

     

       348
       +
                            `Create

     

       349
       +
                        | "update" ->

     

       350
       +
                            `Update

     

       351
       +
                        | "delete" ->

     

       352
       +
                            `Delete

     

       353
       +
                        | _ ->

     

       354
       +
                            `Create

     

       355
       +
                      in

     

       356
       +
                      let path = opj |> member "path" |> to_string in

     

       357
       +
                      let cid =

     

       358
       +
                        match opj |> member "cid" with

     

       359
       +
                        | `Null ->

     

       360
       +
                            None

     

       361
       +
                        | v -> (

     

       362
       +
                          match Cid.of_yojson v with Ok c -> Some c | _ -> None )

     

       363
       +
                      in

     

       364
       +
                      let prev =

     

       365
       +
                        match opj |> member "prev" with

     

       366
       +
                        | `Null ->

     

       367
       +
                            None

     

       368
       +
                        | v -> (

     

       369
       +
                          match Cid.of_yojson v with Ok c -> Some c | _ -> None )

     

       370
       +
                      in

     

       371
       +
                      {action; path; cid; prev} )

     

       372
        
             in

     

       373
        
             Ok

     

       374
        
               { rebase

-33

pegasus/lib/templates/components/button.mlx

···

       1
       -
       let base_classes =

     

       2
       -
         "py-1 px-4 text-lg rounded-lg w-full flex items-center justify-center \

     

       3
       -
          transition delay-50 duration-300 focus-visible:outline-none disabled:text-mist-80"

     

       4
       -
       

     

       5
       -
       type kind = Primary | Secondary | Tertiary | Danger

     

       6
       -
       

     

       7
       -
       let classes = function

     

       8
       -
         | Primary ->

     

       9
       -
             base_classes

     

       10
       -
             ^ " bg-white font-serif text-mana-200 shadow-whisper \

     

       11
       -
                hover:shadow-shimmer hover:bg-mist-20 focus-visible:shadow-shimmer \

     

       12
       -
                focus-visible:bg-mist-20 active:shadow-glow disabled:bg-mana-40"

     

       13
       -
         | Secondary ->

     

       14
       -
             base_classes

     

       15
       -
             ^ " bg-feather font-serif underline text-mana-100 hover:no-underline \

     

       16
       -
                focus-visible:shadow-whisper active:shadow-whisper disabled:no-underline \

     

       17
       -
                disabled:bg-mana-40"

     

       18
       -
         | Tertiary ->

     

       19
       -
             base_classes

     

       20
       -
             ^ " font-sans underline text-mana-100 hover:no-underline \

     

       21
       -
                focus-visible:text-mana-200 active:text-mana-200"

     

       22
       -
         | Danger ->

     

       23
       -
             base_classes

     

       24
       -
             ^ " bg-white font-serif text-phoenix-100 shadow-bleed hover:bg-mist-20 \

     

       25
       -
                hover:text-phoenix-40 focus:bg-mist-20 focus:text-phoenix-40 \

     

       26
       -
                focus-visible:outline-none active:bg-phoenix-40 active:text-mist-20 \

     

       27
       -
                disabled:bg-mana-40"

     

       28
       -
       

     

       29
       -
       let make ?id ?name ?(kind = Primary) ?(type_ = "button") ?onclick ?value

     

       30
       -
           ?(class_ = "") ~children () =

     

       31
       -
         <button ?id ?name type_ ?onclick ?value class_=(classes kind ^ " " ^ class_)>

     

       32
       -
           children

     

       33
       -
         </button>

-56

pegasus/lib/templates/components/input.mlx

···

       1
       -
       open JSX

     

       2
       -
       

     

       3
       -
       (* putting this inline messes with ocamlformat-mlx *)

     

       4
       -
       let req_marker = " *"

     

       5
       -
       

     

       6
       -
       let make ?id ~name ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false)

     

       7
       -
           ?value ?placeholder ?(required = false) ?(disabled = false) ?trailing () =

     

       8
       -
         let id = Option.value id ~default:name in

     

       9
       -
         let placeholder = if label <> None && sr_only then label else placeholder in

     

       10
       -
         let input =

     

       11
       -
           <input

     

       12
       -
             id

     

       13
       -
             type_

     

       14
       -
             name

     

       15
       -
             ?placeholder

     

       16
       -
             required

     

       17
       -
             disabled

     

       18
       -
             ?value

     

       19
       -
             class_="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \

     

       20
       -
                     placeholder:font-medium focus-visible:outline-none"

     

       21
       -
           />

     

       22
       -
         in

     

       23
       -
         <div>

     

       24
       -
           ( match label with

     

       25
       -
           | Some label ->

     

       26
       -
               <div

     

       27
       -
                 class_=( "flex justify-between text-sm"

     

       28
       -
                        ^ if sr_only then " sr-only" else "" )>

     

       29
       -
                 <label for_=id class_="text-mist-100">

     

       30
       -
                   ( if required then

     

       31
       -
                       list

     

       32
       -
                         [ string label

     

       33
       -
                         ; <span class_="text-phoenix-100">(string req_marker)</span>

     

       34
       -
                         ]

     

       35
       -
                     else string label )

     

       36
       -
                 </label>

     

       37
       -
                 ( if required then null

     

       38
       -
                   else <span class_="text-mist-80">"optional"</span> )

     

       39
       -
               </div>

     

       40
       -
           | None ->

     

       41
       -
               null )

     

       42
       -
           ( if type_ = "hidden" then input

     

       43
       -
             else

     

       44
       -
               <div

     

       45
       -
                 class_=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \

     

       46
       -
                           outline-mana-40 disabled:outline-mana-40/20 \

     

       47
       -
                           disabled:bg-mana-40/20 focus-within:outline-2 \

     

       48
       -
                           focus-within:outline-mana-100" ^ class_ )>

     

       49
       -
                 input

     

       50
       -
                 ( match trailing with

     

       51
       -
                 | Some trailing ->

     

       52
       -
                     <div class_="shrink-0 text-mist-100 select-none">trailing</div>

     

       53
       -
                 | None ->

     

       54
       -
                     null )

     

       55
       -
               </div> )

     

       56
       -
         </div>

-11

pegasus/lib/templates/icons/circle_alert.mlx

···

       1
       -
       let make ?class_ () =

     

       2
       -
         <svg

     

       3
       -
           ?class_

     

       4
       -
           viewBox="0 0 24 24"

     

       5
       -
           fill="none"

     

       6
       -
           stroke="currentColor"

     

       7
       -
           strokeLinecap="round"

     

       8
       -
           strokeLinejoin="round"

     

       9
       -
           strokeWidth="2">

     

       10
       -
           <circle cx="12" cy="12" r="10" /> <path d="M12 8v4M12 16h.01" />

     

       11
       -
         </svg>

-16

pegasus/lib/templates/layout.mlx

···

       1
       -
       open JSX

     

       2
       -
       

     

       3
       -
       let make ?(title = "Pegasus") ~children () =

     

       4
       -
         <html lang="en">

     

       5
       -
           <head>

     

       6
       -
             <meta charset="utf-8" />

     

       7
       -
             <meta name="viewport" content="width=device-width, initial-scale=1" />

     

       8
       -
             <link rel="stylesheet" href="/public/index.css" />

     

       9
       -
             <title>(string title)</title>

     

       10
       -
           </head>

     

       11
       -
           <body

     

       12
       -
             class_="bg-feather-100 font-sans font-normal text-base tracking-normal \

     

       13
       -
                     flex items-center justify-center min-h-screen">

     

       14
       -
             children

     

       15
       -
           </body>

     

       16
       -
         </html>

-35

pegasus/lib/templates/login.mlx

···

       1
       -
       open JSX

     

       2
       -
       open Components

     

       3
       -
       

     

       4
       -
       let make ~redirect_url ?error ~csrf_token () =

     

       5
       -
         <Layout title="Login">

     

       6
       -
           <main class_="w-full h-auto max-w-xs px-4 sm:px-0">

     

       7
       -
             <h1 class_="text-2xl font-serif text-mana-200 mb-2">"sign in"</h1>

     

       8
       -
             <span class_="w-full text-balance text-mist-100">

     

       9
       -
               "Enter your handle, email address, or DID, and your password."

     

       10
       -
             </span>

     

       11
       -
             <form method_="post" class_="w-full flex flex-col mt-4 mb-2 gap-y-2">

     

       12
       -
               <input type_="hidden" name="dream.csrf" value=csrf_token />

     

       13
       -
               <Input sr_only=true name="identifier" type_="text" label="identifier" />

     

       14
       -
               <Input sr_only=true name="password" type_="password" label="password" />

     

       15
       -
               <input type_="hidden" name="redirect_url" value=redirect_url />

     

       16
       -
               ( match error with

     

       17
       -
               | Some error ->

     

       18
       -
                   <span class_="inline-flex items-center text-phoenix-100 text-sm">

     

       19
       -
                     <Icons.Circle_alert class_="w-4 h-4 mr-2" /> (string error)

     

       20
       -
                   </span>

     

       21
       -
               | None ->

     

       22
       -
                   null )

     

       23
       -
               <Button type_="submit" class_="mt-2">"sign in"</Button>

     

       24
       -
             </form>

     

       25
       -
             <span class_="text-sm text-mist-100">

     

       26
       -
               "Or "

     

       27
       -
               <a

     

       28
       -
                 href="/account/signup"

     

       29
       -
                 class_="text-mana-100 underline hover:text-mana-200">

     

       30
       -
                 "create an account"

     

       31
       -
               </a>

     

       32
       -
               "."

     

       33
       -
             </span>

     

       34
       -
           </main>

     

       35
       -
         </Layout>

-64

pegasus/lib/templates/oauth_authorize.mlx

···

       1
       -
       open JSX

     

       2
       -
       open Components

     

       3
       -
       

     

       4
       -
       let cimd_suffix_len = String.length "/oauth-client-metadata.json"

     

       5
       -
       

     

       6
       -
       let make ~(metadata : Oauth.Types.client_metadata) ~handle ~scopes ~code

     

       7
       -
           ~request_uri ~csrf_token () =

     

       8
       -
         let client_id = Uri.of_string metadata.client_id in

     

       9
       -
         let raw_host = Uri.host client_id |> Option.get in

     

       10
       -
         let path = Uri.path client_id in

     

       11
       -
         let path = String.sub path 0 (String.length path - cimd_suffix_len) in

     

       12
       -
         let hostname = raw_host ^ path in

     

       13
       -
         let rendered_name =

     

       14
       -
           match metadata.client_name with

     

       15
       -
           | Some client_name ->

     

       16
       -
               <span class_="text-mana-100 font-serif">

     

       17
       -
                 (string client_name)

     

       18
       -
                 <span class_="font-sans">(string (" (" ^ hostname ^ ")"))</span>

     

       19
       -
               </span>

     

       20
       -
           | None when String.length path = 0 ->

     

       21
       -
               <span class_="text-mana-100 font-serif">(string hostname)</span>

     

       22
       -
           | None ->

     

       23
       -
               <span class_="text-mana-100 font-serif">

     

       24
       -
                 (string raw_host) <span class_="text-mana-40">(string path)</span>

     

       25
       -
               </span>

     

       26
       -
         in

     

       27
       -
         let rendered_handle =

     

       28
       -
           <span class_="text-mana-100 font-serif">"@" (string handle)</span>

     

       29
       -
         in

     

       30
       -
         <Layout title="Login">

     

       31
       -
           <main class_="w-full h-auto max-w-lg px-4 sm:px-0">

     

       32
       -
             <h1 class_="text-2xl font-serif text-mana-200 mb-2">

     

       33
       -
               (string ("authorizing " ^ hostname))

     

       34
       -
             </h1>

     

       35
       -
             <p class_="w-full text-mist-100">

     

       36
       -
               "You’re signing into "

     

       37
       -
               rendered_name

     

       38
       -
               " as "

     

       39
       -
               rendered_handle

     

       40
       -
               " and granting it the following permissions:"

     

       41
       -
             </p>

     

       42
       -
             <ul class_="w-full text-mist-100 list-disc ml-8 mt-2 space-y-1">

     

       43
       -
               (list @@ List.map (fun scope -> <li>(string scope)</li>) scopes)

     

       44
       -
             </ul>

     

       45
       -
             <form

     

       46
       -
               method_="post"

     

       47
       -
               class_="w-full flex flex-row items-center justify-between mt-6">

     

       48
       -
               <input type_="hidden" name="dream.csrf" value=csrf_token />

     

       49
       -
               <input type_="hidden" name="code" value=code />

     

       50
       -
               <input type_="hidden" name="request_uri" value=request_uri />

     

       51
       -
               <Button kind=Secondary type_="submit" name="action" value="deny" class_="grow basis-1/3 min-w-0">

     

       52
       -
                 "cancel"

     

       53
       -
               </Button>

     

       54
       -
               <Button

     

       55
       -
                 kind=Primary

     

       56
       -
                 type_="submit"

     

       57
       -
                 name="action"

     

       58
       -
                 value="allow"

     

       59
       -
                 class_="grow basis-2/3 min-w-0 max-w-2xs">

     

       60
       -
                 "authorize"

     

       61
       -
               </Button>

     

       62
       -
             </form>

     

       63
       -
           </main>

     

       64
       -
         </Layout>

+2 -2

pegasus/lib/user_store.ml

···

       386
        
       let get_record t path : record option Lwt.t =

     

       387
        
         Util.use_pool t.db @@ Queries.get_record ~path

     

       388
        
         >|= Option.map (fun (cid, data, since) ->

     

       389
       -
             {path; cid; value= Lex.of_cbor data; since} )

     

       390
        
       

     

       391
        
       let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection :

     

       392
        
           record list Lwt.t =

     
···

       395
        
         in

     

       396
        
         Util.use_pool t.db @@ fn ~collection ~limit ~cursor

     

       397
        
         >|= List.map (fun (path, cid, data, since) ->

     

       398
       -
             {path; cid; value= Lex.of_cbor data; since} )

     

       399
        
       

     

       400
        
       let put_record t record path : (Cid.t * bytes) Lwt.t =

     

       401
        
         let cid, data = Lex.to_cbor_block record in

···

       386
        
       let get_record t path : record option Lwt.t =

     

       387
        
         Util.use_pool t.db @@ Queries.get_record ~path

     

       388
        
         >|= Option.map (fun (cid, data, since) ->

     

       389
       +
                 {path; cid; value= Lex.of_cbor data; since} )

     

       390
        
       

     

       391
        
       let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection :

     

       392
        
           record list Lwt.t =

     
···

       395
        
         in

     

       396
        
         Util.use_pool t.db @@ fn ~collection ~limit ~cursor

     

       397
        
         >|= List.map (fun (path, cid, data, since) ->

     

       398
       +
                 {path; cid; value= Lex.of_cbor data; since} )

     

       399
        
       

     

       400
        
       let put_record t record path : (Cid.t * bytes) Lwt.t =

     

       401
        
         let cid, data = Lex.to_cbor_block record in

+19 -59

pegasus/lib/util.ml

···

       287
        
       let is_none = function None -> true | _ -> false

     

       288
        
       

     

       289
        
       let validate_handle handle =

     

       290
       -
         let front =

     

       291
       -
           String.sub handle 0 (String.length handle - (String.length Env.hostname + 1))

     

       292
       -
         in

     

       293
       -
         if String.contains front '.' then

     

       294
       -
           Error

     

       295
       -
             (Errors.InvalidRequestError

     

       296
       -
                ("InvalidHandle", "invalid characters in handle") )

     

       297
        
         else

     

       298
       -
           match String.length front with

     

       299
       -
           | l when l < 3 ->

     

       300
       -
               Error (Errors.InvalidRequestError ("InvalidHandle", "handle too short"))

     

       301
       -
           | l when l > 18 ->

     

       302
       -
               Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long"))

     

       303
       -
           | _ ->

     

       304
       -
               Ok ()

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       305
        
       

     

       306
        
       let mkfile_p path ~perm =

     

       307
        
         Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ;

     
···

       319
        
             valid )

     

       320
        
           did_keys

     

       321
        
         <> None

     

       322
       -
       

     

       323
       -
       let rec http_get ?(max_redirects = 5) ?headers uri =

     

       324
       -
         let%lwt ans = Cohttp_lwt_unix.Client.get ?headers uri in

     

       325
       -
         follow_redirect ~max_redirects uri ans

     

       326
       -
       

     

       327
       -
       and follow_redirect ~max_redirects request_uri (response, body) =

     

       328
       -
         let status = Http.Response.status response in

     

       329
       -
         (* the unconsumed body would otherwise leak memory *)

     

       330
       -
         let%lwt () =

     

       331
       -
           if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit

     

       332
       -
         in

     

       333
       -
         match status with

     

       334
       -
         | `OK ->

     

       335
       -
             Lwt.return (response, body)

     

       336
       -
         | `Permanent_redirect | `Moved_permanently ->

     

       337
       -
             handle_redirect ~permanent:true ~max_redirects request_uri response

     

       338
       -
         | `Found | `Temporary_redirect ->

     

       339
       -
             handle_redirect ~permanent:false ~max_redirects request_uri response

     

       340
       -
         | `Not_found | `Gone ->

     

       341
       -
             failwith "not found"

     

       342
       -
         | status ->

     

       343
       -
             Printf.ksprintf failwith "unhandled status: %s"

     

       344
       -
               (Cohttp.Code.string_of_status status)

     

       345
       -
       

     

       346
       -
       and handle_redirect ~permanent ~max_redirects request_uri response =

     

       347
       -
         if max_redirects <= 0 then failwith "too many redirects"

     

       348
       -
         else

     

       349
       -
           let headers = Http.Response.headers response in

     

       350
       -
           let location = Http.Header.get headers "location" in

     

       351
       -
           match location with

     

       352
       -
           | None ->

     

       353
       -
               failwith "redirection without Location header"

     

       354
       -
           | Some url ->

     

       355
       -
               let uri = Uri.of_string url in

     

       356
       -
               let%lwt () =

     

       357
       -
                 if permanent then

     

       358
       -
                   Logs_lwt.warn (fun m ->

     

       359
       -
                       m "Permanent redirection from %s to %s"

     

       360
       -
                         (Uri.to_string request_uri)

     

       361
       -
                         url )

     

       362
       -
                 else Lwt.return_unit

     

       363
       -
               in

     

       364
       -
               http_get uri ~max_redirects:(max_redirects - 1)

     

       365
       -
       

     

       366
       -
       let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v]))

···

       287
        
       let is_none = function None -> true | _ -> false

     

       288
        
       

     

       289
        
       let validate_handle handle =

     

       290
       +
         if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then

     

       291
       +
           Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix"))

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       292
        
         else

     

       293
       +
           let front =

     

       294
       +
             String.sub handle 0

     

       295
       +
               (String.length handle - (String.length Env.hostname + 1))

     

       296
       +
           in

     

       297
       +
           if String.contains front '.' then

     

       298
       +
             Error

     

       299
       +
               (Errors.InvalidRequestError

     

       300
       +
                  ("InvalidHandle", "invalid characters in handle") )

     

       301
       +
           else

     

       302
       +
             match String.length front with

     

       303
       +
             | l when l < 3 ->

     

       304
       +
                 Error

     

       305
       +
                   (Errors.InvalidRequestError ("InvalidHandle", "handle too short"))

     

       306
       +
             | l when l > 18 ->

     

       307
       +
                 Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long"))

     

       308
       +
             | _ ->

     

       309
       +
                 Ok ()

     

       310
        
       

     

       311
        
       let mkfile_p path ~perm =

     

       312
        
         Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ;

     
···

       324
        
             valid )

     

       325
        
           did_keys

     

       326
        
         <> None

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+15 -33

pegasus/lib/xrpc.ml

···

       10
        
       let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =

     

       11
        
         let open Errors in

     

       12
        
         let auth = Auth.Verifiers.of_t auth in

     

       13
       -
         try%lwt

     

       14
       -
           match%lwt auth init with

     

       15
       -
           | Ok creds -> (

     

       16
        
             try%lwt hdlr {req= init.req; db= init.db; auth= creds}

     

       17
        
             with e ->

     

       18
       -
               if not (is_xrpc_error e) then log_exn ~req:init.req e ;

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       19
        
               exn_to_response e )

     

       20
       -
           | Error e ->

     

       21
       -
               exn_to_response e

     

       22
       -
         with e ->

     

       23
       -
           if not (is_xrpc_error e) then log_exn ~req:init.req e ;

     

       24
       -
           exn_to_response e

     

       25
        
       

     

       26
        
       let parse_query (req : Dream.request)

     

       27
        
           (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =

     
···

       29
        
           let queries = Dream.all_queries req in

     

       30
        
           let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in

     

       31
        
           query_json |> of_yojson |> Result.get_ok

     

       32
       -
         with _ -> Errors.invalid_request "invalid query string"

     

       33
        
       

     

       34
        
       let parse_body (req : Dream.request)

     

       35
        
           (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =

     

       36
        
         try%lwt

     

       37
        
           let%lwt body = Dream.body req in

     

       38
        
           body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return

     

       39
       -
         with _ -> Errors.invalid_request "invalid request body"

     

       0
        
       
     

       0
        
       
     

       40
        
       

     

       41
        
       let service_proxy (ctx : context) (proxy_header : string) =

     

       42
        
         let did = Auth.get_authed_did_exn ctx.auth in

     
···

       85
        
             let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in

     

       86
        
             match Dream.method_ ctx.req with

     

       87
        
             | `GET -> (

     

       88
       -
                 let%lwt res, body = Util.http_get uri ~headers in

     

       89
        
                 match res.status with

     

       90
        
                 | `OK ->

     

       91
        
                     let%lwt body = Body.to_string body in

     
···

       119
        
       let service_proxy_middleware db inner_handler req =

     

       120
        
         match Dream.header req "atproto-proxy" with

     

       121
        
         | Some header ->

     

       122
       -
             handler ~auth:Authorization (fun ctx -> service_proxy ctx header) {req; db}

     

       123
        
         | None ->

     

       124
        
             inner_handler req

     

       125
        
       

     

       126
       -
       let dpop_middleware inner_handler req =

     

       127
       -
         let%lwt res = inner_handler req in

     

       128
       -
         match Dream.header req "DPoP" with

     

       129
       -
         | Some _ ->

     

       130
       -
             Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;

     

       131
       -
             Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ;

     

       132
       -
             Lwt.return res

     

       133
       -
         | None ->

     

       134
       -
             Lwt.return res

     

       135
       -
       

     

       136
       -
       let cors_middleware inner_handler req =

     

       137
       -
         let%lwt res = inner_handler req in

     

       138
       -
         Dream.add_header res "Access-Control-Allow-Origin" "*" ;

     

       139
       -
         Dream.add_header res "Access-Control-Allow-Methods"

     

       140
       -
           "GET, POST, PUT, DELETE, OPTIONS" ;

     

       141
       -
         Dream.add_header res "Access-Control-Allow-Headers"

     

       142
       -
           "Content-Type, Authorization, DPoP" ;

     

       143
       -
         Dream.add_header res "Access-Control-Max-Age" "86400" ;

     

       144
       -
         Lwt.return res

     

       145
       -
       

     

       146
        
       let resolve_repo_did ctx repo =

     

       147
        
         if String.starts_with ~prefix:"did:" repo then Lwt.return repo

     

       148
        
         else

···

       10
        
       let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =

     

       11
        
         let open Errors in

     

       12
        
         let auth = Auth.Verifiers.of_t auth in

     

       13
       +
         match%lwt auth init with

     

       14
       +
         | Ok creds -> (

     

       0
        
       
     

       15
        
             try%lwt hdlr {req= init.req; db= init.db; auth= creds}

     

       16
        
             with e ->

     

       17
       +
               ( match is_xrpc_error e with

     

       18
       +
               | true ->

     

       19
       +
                   ()

     

       20
       +
               | false ->

     

       21
       +
                   log_exn ~req:init.req e ) ;

     

       22
        
               exn_to_response e )

     

       23
       +
         | Error e ->

     

       24
       +
             exn_to_response e

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       25
        
       

     

       26
        
       let parse_query (req : Dream.request)

     

       27
        
           (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =

     
···

       29
        
           let queries = Dream.all_queries req in

     

       30
        
           let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in

     

       31
        
           query_json |> of_yojson |> Result.get_ok

     

       32
       +
         with _ -> Errors.invalid_request "Invalid query string"

     

       33
        
       

     

       34
        
       let parse_body (req : Dream.request)

     

       35
        
           (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =

     

       36
        
         try%lwt

     

       37
        
           let%lwt body = Dream.body req in

     

       38
        
           body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return

     

       39
       +
         with e ->

     

       40
       +
           Errors.log_exn e ;

     

       41
       +
           Errors.invalid_request "Invalid request body"

     

       42
        
       

     

       43
        
       let service_proxy (ctx : context) (proxy_header : string) =

     

       44
        
         let did = Auth.get_authed_did_exn ctx.auth in

     
···

       87
        
             let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in

     

       88
        
             match Dream.method_ ctx.req with

     

       89
        
             | `GET -> (

     

       90
       +
                 let%lwt res, body = Client.get uri ~headers in

     

       91
        
                 match res.status with

     

       92
        
                 | `OK ->

     

       93
        
                     let%lwt body = Body.to_string body in

     
···

       121
        
       let service_proxy_middleware db inner_handler req =

     

       122
        
         match Dream.header req "atproto-proxy" with

     

       123
        
         | Some header ->

     

       124
       +
             handler ~auth:Access (fun ctx -> service_proxy ctx header) {req; db}

     

       125
        
         | None ->

     

       126
        
             inner_handler req

     

       127
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       128
        
       let resolve_repo_did ctx repo =

     

       129
        
         if String.starts_with ~prefix:"did:" repo then Lwt.return repo

     

       130
        
         else

public/fonts/Fragment.woff

This is a binary file and will not be displayed.

public/fonts/Fragment.woff2

This is a binary file and will not be displayed.

-48

public/main.css

···

       1
       -
       @import "tailwindcss" source("../pegasus/lib/templates");

     

       2
       -
       

     

       3
       -
       @font-face {

     

       4
       -
       	font-family: "Fragment";

     

       5
       -
       	src:

     

       6
       -
       		url("fonts/Fragment.woff2") format("woff2"),

     

       7
       -
       		url("fonts/Fragment.woff") format("woff");

     

       8
       -
       	font-weight: normal;

     

       9
       -
       	font-style: normal;

     

       10
       -
       	font-display: swap;

     

       11
       -
       }

     

       12
       -
       

     

       13
       -
       @font-face {

     

       14
       -
       	font-family: "Geist";

     

       15
       -
       	src: url("https://fonts.gstatic.com/s/geist/v4/gyByhwUxId8gMEwcGFWNOITd.woff2")

     

       16
       -
       		format("woff2");

     

       17
       -
       	font-weight: 300 400;

     

       18
       -
       	font-style: normal;

     

       19
       -
       	font-display: swap;

     

       20
       -
       }

     

       21
       -
       

     

       22
       -
       @theme {

     

       23
       -
       	--font-serif: Fragment, Georgia, "Times New Roman", Times, serif;

     

       24
       -
       	--font-sans: Geist, Helvetica, -apple-system, system-ui, sans-serif;

     

       25
       -
       	--font-weight-normal: 300;

     

       26
       -
       	--font-weight-medium: 400;

     

       27
       -
       

     

       28
       -
       	--tracking-normal: 0.01em;

     

       29
       -
       

     

       30
       -
       	--color-*: initial;

     

       31
       -
       	--color-white: #fff;

     

       32
       -
       	--color-feather-100: #c8cfd2;

     

       33
       -
       	--color-phoenix-40: #e499a6;

     

       34
       -
       	--color-phoenix-100: #db4c64;

     

       35
       -
       	--color-mana-40: #9b9eaa;

     

       36
       -
       	--color-mana-100: #6558a1;

     

       37
       -
       	--color-mana-200: #312b4d;

     

       38
       -
       	--color-mist-20: #ecedf8;

     

       39
       -
       	--color-mist-40: #dee1e3;

     

       40
       -
       	--color-mist-60: #a4a9ac;

     

       41
       -
       	--color-mist-80: #737579;

     

       42
       -
       	--color-mist-100: #4f4f53;

     

       43
       -
       

     

       44
       -
       	--shadow-whisper: inset 0 0 1em #97baff8c;

     

       45
       -
       	--shadow-shimmer: inset 0 0 1em #79a7ed99;

     

       46
       -
       	--shadow-glow: inset 0 0 2em #2d37ba73;

     

       47
       -
       	--shadow-bleed: inset 0 0 2em #db4c6466;

     

       48
       -
       }

-27

tailwindcss.opam

···

       1
       -
       # This file is generated by dune, edit dune-project instead

     

       2
       -
       opam-version: "2.0"

     

       3
       -
       maintainer: ["futurGH"]

     

       4
       -
       authors: ["futurGH"]

     

       5
       -
       license: "MPL-2.0"

     

       6
       -
       homepage: "https://github.com/futurGH/pegasus"

     

       7
       -
       bug-reports: "https://github.com/futurGH/pegasus/issues"

     

       8
       -
       depends: [

     

       9
       -
         "dune" {>= "3.20"}

     

       10
       -
         "odoc" {with-doc}

     

       11
       -
       ]

     

       12
       -
       build: [

     

       13
       -
         ["dune" "subst"] {dev}

     

       14
       -
         [

     

       15
       -
           "dune"

     

       16
       -
           "build"

     

       17
       -
           "-p"

     

       18
       -
           name

     

       19
       -
           "-j"

     

       20
       -
           jobs

     

       21
       -
           "@install"

     

       22
       -
           "@runtest" {with-test}

     

       23
       -
           "@doc" {with-doc}

     

       24
       -
         ]

     

       25
       -
       ]

     

       26
       -
       dev-repo: "git+https://github.com/futurGH/pegasus.git"

     

       27
       -
       x-maintenance-intent: ["(latest)"]

-88

tools/tailwindcss/dune

···

       1
       -
       (rule

     

       2
       -
        (target tailwindcss-linux-x64)

     

       3
       -
        (action

     

       4
       -
         (progn

     

       5
       -
          (with-stdout-to

     

       6
       -
           %{target}

     

       7
       -
           (bash

     

       8
       -
            "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))

     

       9
       -
          (run chmod +x %{target}))))

     

       10
       -
       

     

       11
       -
       (rule

     

       12
       -
        (target tailwindcss-linux-arm64)

     

       13
       -
        (action

     

       14
       -
         (progn

     

       15
       -
          (with-stdout-to

     

       16
       -
           %{target}

     

       17
       -
           (bash

     

       18
       -
            "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))

     

       19
       -
          (run chmod +x %{target}))))

     

       20
       -
       

     

       21
       -
       (rule

     

       22
       -
        (target tailwindcss-macos-x64)

     

       23
       -
        (action

     

       24
       -
         (progn

     

       25
       -
          (with-stdout-to

     

       26
       -
           %{target}

     

       27
       -
           (bash

     

       28
       -
            "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))

     

       29
       -
          (run chmod +x %{target}))))

     

       30
       -
       

     

       31
       -
       (rule

     

       32
       -
        (target tailwindcss-macos-arm64)

     

       33
       -
        (action

     

       34
       -
         (progn

     

       35
       -
          (with-stdout-to

     

       36
       -
           %{target}

     

       37
       -
           (bash

     

       38
       -
            "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}"))

     

       39
       -
          (run chmod +x %{target}))))

     

       40
       -
       

     

       41
       -
       (rule

     

       42
       -
        (enabled_if

     

       43
       -
         (and

     

       44
       -
          (= %{architecture} amd64)

     

       45
       -
          (= %{system} linux)))

     

       46
       -
        (target tailwindcss)

     

       47
       -
        (deps tailwindcss-linux-x64)

     

       48
       -
        (action

     

       49
       -
         (copy %{deps} tailwindcss)))

     

       50
       -
       

     

       51
       -
       (rule

     

       52
       -
        (enabled_if

     

       53
       -
         (and

     

       54
       -
          (= %{architecture} arm64)

     

       55
       -
          (= %{system} linux)))

     

       56
       -
        (target tailwindcss)

     

       57
       -
        (deps tailwindcss-linux-arm64)

     

       58
       -
        (action

     

       59
       -
         (copy %{deps} tailwindcss)))

     

       60
       -
       

     

       61
       -
       (rule

     

       62
       -
        (enabled_if

     

       63
       -
         (and

     

       64
       -
          (= %{architecture} amd64)

     

       65
       -
          (= %{system} macosx)))

     

       66
       -
        (target tailwindcss)

     

       67
       -
        (deps tailwindcss-macos-x64)

     

       68
       -
        (action

     

       69
       -
         (copy %{deps} tailwindcss)))

     

       70
       -
       

     

       71
       -
       (rule

     

       72
       -
        (enabled_if

     

       73
       -
         (and

     

       74
       -
          (= %{architecture} arm64)

     

       75
       -
          (= %{system} macosx)))

     

       76
       -
        (target tailwindcss)

     

       77
       -
        (deps tailwindcss-macos-arm64)

     

       78
       -
        (action

     

       79
       -
         (copy %{deps} tailwindcss)))

     

       80
       -
       

     

       81
       -
       (alias

     

       82
       -
        (name default)

     

       83
       -
        (deps tailwindcss))

     

       84
       -
       

     

       85
       -
       (install

     

       86
       -
        (section bin)

     

       87
       -
        (package tailwindcss)

     

       88
       -
        (files tailwindcss))