Implement OAuth #2

···

       
1
       
1
       
 
       
profile = ocamlformat

     

       
2
       
2
       
+
       
version = 0.27.0

     

···

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

     

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

     

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

     

       
10
       
10
       
-
       
  ; ( get

     

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

     

       
12
       
12
       
-
       
    , Api.Well_known.oauth_protected_resource )

     

       
13
       
13
       
-
       
  ; ( get

     

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

     

       
15
       
15
       
-
       
    , Api.Well_known.oauth_authorization_server )

     

       
16
       
16
       
-
       
  ; (* oauth *)

     

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

     

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

     

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

     

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

     

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

     

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

     

       
23
       
23
       
-
       
  ; (* account *)

     

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

     

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

     

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

     

       
27
       
10
       
 
       
  ; (* unauthed *)

     

       
28
       
11
       
 
       
    ( get

     

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

     
···

       
32
       
15
       
 
       
  ; ( get

     

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

     

       
34
       
17
       
 
       
    , Api.Identity.ResolveHandle.handler )

     

       
35
       
35
       
-
       
  ; (* account management *)

     

       
18
       
18
       
+
       
  ; (* account *)

     

       
36
       
19
       
 
       
    ( post

     

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

     

       
38
       
21
       
 
       
    , Api.Server.CreateInviteCode.handler )

     
···

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

     

       
83
       
66
       
 
       
    , Api.Actor.PutPreferences.handler ) ]

     

       
84
       
67
       
 
       


     

       
85
       
85
       
-
       
let static_routes =

     

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

     

       
87
       
87
       
-
       


     

       
88
       
68
       
 
       
let main =

     

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

     

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

     

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

     

       
92
       
72
       
 
       
  @@ Dream.logger

     

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

     

       
94
       
94
       
-
       
  @@ Dream.cookie_sessions

     

       
95
       
73
       
 
       
  @@ Xrpc.service_proxy_middleware db

     

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

     

       
74
       
74
       
+
       
  @@ Dream.router

     

       
97
       
75
       
 
       
  @@ List.map

     

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

     

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

     

       
100
       
78
       
 
       
       handlers

     

       
101
       
101
       
-
       
  @ static_routes

     

       
102
       
79
       
 
       


     

       
103
       
80
       
 
       
let () = Lwt_main.run main

     

···

       
1
       
1
       
-
       
(subdir

     

       
2
       
2
       
-
       
 public/

     

       
3
       
3
       
-
       
 (rule

     

       
4
       
4
       
-
       
  (target index.css)

     

       
5
       
5
       
-
       
  (deps

     

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

     

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

     

       
8
       
8
       
-
       
   (source_tree %{workspace_root}/public)

     

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

     

       
10
       
10
       
-
       
  (action

     

       
11
       
11
       
-
       
   (chdir

     

       
12
       
12
       
-
       
    %{workspace_root}

     

       
13
       
13
       
-
       
    (run

     

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

     

       
15
       
15
       
-
       
     -m

     

       
16
       
16
       
-
       
     -i

     

       
17
       
17
       
-
       
     %{input}

     

       
18
       
18
       
-
       
     -o

     

       
19
       
19
       
-
       
     %{target})))))

     

       
20
       
20
       
-
       


     

       
21
       
21
       
-
       
(copy_files public/*)

     

···

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

     

       
48
       
47
       
 
       
  (dns-client (>= 10.2.0))

     

       
49
       
48
       
 
       
  dream

     

       
50
       
50
       
-
       
  html_of_jsx

     

       
51
       
51
       
-
       
  mlx

     

       
52
       
49
       
 
       
  (re (>= 1.13.2))

     

       
53
       
50
       
 
       
  (safepass (>= 3.1))

     

       
54
       
51
       
 
       
  (timedesc (>= 3.1.0))

     

       
55
       
55
       
-
       
  (uri (>= 4.4.0))

     

       
56
       
52
       
 
       
  (uuidm (>= 0.9.10))

     

       
57
       
53
       
 
       
  (yojson (>= 3.0.0))

     

       
58
       
54
       
 
       
  (lwt_ppx (>= 5.9.1))

     

       
59
       
55
       
 
       
  (ppx_deriving_yojson (>= 3.9.1))

     

       
60
       
56
       
 
       
  ppx_rapper

     

       
61
       
57
       
 
       
  ppx_rapper_lwt

     

       
62
       
62
       
-
       
  (alcotest :with-test)

     

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

     

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

     

       
58
       
58
       
+
       
  (alcotest :with-test)))

     

       
65
       
59
       
 
       


     

       
66
       
60
       
 
       
(package

     

       
67
       
61
       
 
       
 (name mist)

     
···

       
103
       
97
       
 
       
  (hacl-star (>= 0.7.2))

     

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

     

       
105
       
99
       
 
       
  (multibase (>= 0.1.0))))

     

       
106
       
106
       
-
       


     

       
107
       
107
       
-
       
(package

     

       
108
       
108
       
-
       
    (name tailwindcss) (allow_empty))

     

       
109
       
109
       
-
       


     

       
110
       
110
       
-
       
(dialect

     

       
111
       
111
       
-
       
 (name mlx)

     

       
112
       
112
       
-
       
 (implementation

     

       
113
       
113
       
-
       
  (extension mlx)

     

       
114
       
114
       
-
       
  (merlin_reader mlx)

     

       
115
       
115
       
-
       
  (preprocess

     

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

     

···

       
220
       
220
       
 
       
let pubkey_to_did_key pubkey : string =

     

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

     

       
222
       
222
       
 
       
  Curve.pubkey_to_did_key pubkey

     

       
223
       
223
       
-
       


     

       
224
       
224
       
-
       
let privkey_to_multikey privkey : string =

     

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

     

       
226
       
226
       
-
       
  Curve.privkey_to_multikey privkey

     

···

       
498
       
498
       
 
       
          match Util.at_index index seq with

     

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

     

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

     

       
501
       
501
       
-
       
            match%lwt

     

       
502
       
502
       
-
       
              Store.get_bytes t.blockstore v

     

       
503
       
503
       
-
       
            with

     

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

     

       
504
       
502
       
 
       
              | Some leaf_bytes ->

     

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

     

       
506
       
504
       
 
       
              | None ->

     
···

       
533
       
531
       
 
       
                    | Some cid_left -> (

     

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

     

       
535
       
533
       
 
       
                        | Some b ->

     

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

     

       
534
       
534
       
+
       
                            Lwt.return

     

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

     

       
537
       
536
       
 
       
                        | None ->

     

       
538
       
537
       
 
       
                            Lwt.return Block_map.empty )

     

       
539
       
538
       
 
       
                    | None ->

     

···

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

     

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

     

       
20
       
20
       
 
       
  "dream"

     

       
21
       
21
       
-
       
  "html_of_jsx"

     

       
22
       
22
       
-
       
  "mlx"

     

       
23
       
21
       
 
       
  "re" {>= "1.13.2"}

     

       
24
       
22
       
 
       
  "safepass" {>= "3.1"}

     

       
25
       
23
       
 
       
  "timedesc" {>= "3.1.0"}

     

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

     

       
27
       
24
       
 
       
  "uuidm" {>= "0.9.10"}

     

       
28
       
25
       
 
       
  "yojson" {>= "3.0.0"}

     

       
29
       
26
       
 
       
  "lwt_ppx" {>= "5.9.1"}

     
···

       
31
       
28
       
 
       
  "ppx_rapper"

     

       
32
       
29
       
 
       
  "ppx_rapper_lwt"

     

       
33
       
30
       
 
       
  "alcotest" {with-test}

     

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

     

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

     

       
36
       
31
       
 
       
  "odoc" {with-doc}

     

       
37
       
32
       
 
       
]

     

       
38
       
33
       
 
       
build: [

     

···

       
1
       
1
       
-
       
let get_handler =

     

       
2
       
2
       
-
       
  Xrpc.handler (fun ctx ->

     

       
3
       
3
       
-
       
      let redirect_url =

     

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

     

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

     

       
6
       
6
       
-
       
          |> Uri.to_string

     

       
7
       
7
       
-
       
        else "/account"

     

       
8
       
8
       
-
       
      in

     

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

     

       
10
       
10
       
-
       
      let html =

     

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

     

       
12
       
12
       
-
       
      in

     

       
13
       
13
       
-
       
      Dream.html html )

     

       
14
       
14
       
-
       


     

       
15
       
15
       
-
       
let post_handler =

     

       
16
       
16
       
-
       
  Xrpc.handler (fun ctx ->

     

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

     

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

     

       
19
       
19
       
-
       
      | `Ok fields -> (

     

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

     

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

     

       
22
       
22
       
-
       
          let redirect_url =

     

       
23
       
23
       
-
       
            List.assoc_opt "redirect_url" fields

     

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

     

       
25
       
25
       
-
       
          in

     

       
26
       
26
       
-
       
          let%lwt actor =

     

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

     

       
28
       
28
       
-
       
          in

     

       
29
       
29
       
-
       
          match actor with

     

       
30
       
30
       
-
       
          | None ->

     

       
31
       
31
       
-
       
              let html =

     

       
32
       
32
       
-
       
                JSX.render

     

       
33
       
33
       
-
       
                  (Templates.Login.make ~redirect_url

     

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

     

       
35
       
35
       
-
       
                     ~csrf_token () )

     

       
36
       
36
       
-
       
              in

     

       
37
       
37
       
-
       
              Dream.html ~status:`Unauthorized html

     

       
38
       
38
       
-
       
          | Some {did; _} ->

     

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

     

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

     

       
41
       
41
       
-
       
              Dream.redirect ctx.req redirect_url )

     

       
42
       
42
       
-
       
      | _ ->

     

       
43
       
43
       
-
       
          let html =

     

       
44
       
44
       
-
       
            JSX.render

     

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

     

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

     

       
47
       
47
       
-
       
                 ~csrf_token () )

     

       
48
       
48
       
-
       
          in

     

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

     

···

       
1
       
1
       
-
       
let handler =

     

       
2
       
2
       
-
       
  Xrpc.handler (fun ctx ->

     

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

     

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

     

···

       
1
       
1
       
 
       
let handler =

     

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

     

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

     

       
3
       
3
       
 
       
      let did = Auth.get_authed_did_exn auth in

     

       
4
       
4
       
 
       
      let%lwt body = Dream.body req in

     

       
5
       
5
       
 
       
      let prefs =

     

···

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

     

       
2
       
2
       
 
       


     

       
3
       
3
       
 
       
let handler =

     

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

     

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

     

       
5
       
5
       
 
       
      let did = Auth.get_authed_did_exn auth in

     

       
6
       
6
       
 
       
      let%lwt body = Dream.body req in

     

       
7
       
7
       
 
       
      let handle =

     
···

       
17
       
17
       
 
       
      | Ok () -> (

     

       
18
       
18
       
 
       
          match%lwt Data_store.get_actor_by_identifier handle db with

     

       
19
       
19
       
 
       
          | Some _ ->

     

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

     

       
20
       
20
       
+
       
              Errors.invalid_request ~name:"InvalidHandle"

     

       
21
       
21
       
+
       
                "handle already in use"

     

       
21
       
22
       
 
       
          | None ->

     

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

     

       
23
       
24
       
 
       
              let%lwt _ =

     
···

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

     

       
67
       
68
       
 
       
                else Lwt.return_unit

     

       
68
       
69
       
 
       
              in

     

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

     

       
70
       
70
       
+
       
              let () =

     

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

     

       
72
       
72
       
+
       
              in

     

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

     

       
71
       
74
       
 
       
              Dream.empty `OK ) )

     

···

       
1
       
1
       
-
       
open Oauth

     

       
2
       
2
       
-
       
open Oauth.Types

     

       
3
       
3
       
-
       


     

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

     

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

     

       
6
       
6
       
-
       
  | Some did ->

     

       
7
       
7
       
-
       
      Lwt.return_some did

     

       
8
       
8
       
-
       
  | None ->

     

       
9
       
9
       
-
       
      Lwt.return_none

     

       
10
       
10
       
-
       


     

       
11
       
11
       
-
       
let get_handler =

     

       
12
       
12
       
-
       
  Xrpc.handler (fun ctx ->

     

       
13
       
13
       
-
       
      let login_redirect =

     

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

     

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

     

       
16
       
16
       
-
       
      in

     

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

     

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

     

       
19
       
19
       
-
       
      match (client_id, request_uri) with

     

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

     

       
21
       
21
       
-
       
          login_redirect

     

       
22
       
22
       
-
       
      | Some client_id, Some request_uri -> (

     

       
23
       
23
       
-
       
          let prefix = Constants.request_uri_prefix in

     

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

     

       
25
       
25
       
-
       
          else

     

       
26
       
26
       
-
       
            let request_id =

     

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

     

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

     

       
29
       
29
       
-
       
            in

     

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

     

       
31
       
31
       
-
       
            | None ->

     

       
32
       
32
       
-
       
                login_redirect

     

       
33
       
33
       
-
       
            | Some req_record -> (

     

       
34
       
34
       
-
       
                if req_record.client_id <> client_id then login_redirect

     

       
35
       
35
       
-
       
                else

     

       
36
       
36
       
-
       
                  let req =

     

       
37
       
37
       
-
       
                    Yojson.Safe.from_string req_record.request_data

     

       
38
       
38
       
-
       
                    |> par_request_of_yojson

     

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

     

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

     

       
41
       
41
       
-
       
                          () )

     

       
42
       
42
       
-
       
                    |> Result.get_ok

     

       
43
       
43
       
-
       
                  in

     

       
44
       
44
       
-
       
                  let%lwt metadata =

     

       
45
       
45
       
-
       
                    try%lwt Client.fetch_client_metadata client_id

     

       
46
       
46
       
-
       
                    with _ ->

     

       
47
       
47
       
-
       
                      Errors.internal_error

     

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

     

       
49
       
49
       
-
       
                  in

     

       
50
       
50
       
-
       
                  let code =

     

       
51
       
51
       
-
       
                    "cod-"

     

       
52
       
52
       
-
       
                    ^ Uuidm.to_string

     

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

     

       
54
       
54
       
-
       
                  in

     

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

     

       
56
       
56
       
-
       
                  let%lwt () =

     

       
57
       
57
       
-
       
                    Queries.insert_auth_code ctx.db

     

       
58
       
58
       
-
       
                      { code

     

       
59
       
59
       
-
       
                      ; request_id

     

       
60
       
60
       
-
       
                      ; authorized_by= None

     

       
61
       
61
       
-
       
                      ; authorized_at= None

     

       
62
       
62
       
-
       
                      ; expires_at

     

       
63
       
63
       
-
       
                      ; used= false }

     

       
64
       
64
       
-
       
                  in

     

       
65
       
65
       
-
       
                  match%lwt get_session_user ctx with

     

       
66
       
66
       
-
       
                  | None ->

     

       
67
       
67
       
-
       
                      login_redirect

     

       
68
       
68
       
-
       
                  | Some did -> (

     

       
69
       
69
       
-
       
                    match req.login_hint with

     

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

     

       
71
       
71
       
-
       
                        login_redirect

     

       
72
       
72
       
-
       
                    | _ ->

     

       
73
       
73
       
-
       
                        let%lwt handle =

     

       
74
       
74
       
-
       
                          match%lwt

     

       
75
       
75
       
-
       
                            Data_store.get_actor_by_identifier did ctx.db

     

       
76
       
76
       
-
       
                          with

     

       
77
       
77
       
-
       
                          | Some {handle; _} ->

     

       
78
       
78
       
-
       
                              Lwt.return handle

     

       
79
       
79
       
-
       
                          | None ->

     

       
80
       
80
       
-
       
                              Errors.internal_error

     

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

     

       
82
       
82
       
-
       
                        in

     

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

     

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

     

       
85
       
85
       
-
       
                        let html =

     

       
86
       
86
       
-
       
                          JSX.render

     

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

     

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

     

       
89
       
89
       
-
       
                        in

     

       
90
       
90
       
-
       
                        Dream.html html ) ) ) )

     

       
91
       
91
       
-
       


     

       
92
       
92
       
-
       
let post_handler =

     

       
93
       
93
       
-
       
  Xrpc.handler (fun ctx ->

     

       
94
       
94
       
-
       
      match%lwt get_session_user ctx with

     

       
95
       
95
       
-
       
      | None ->

     

       
96
       
96
       
-
       
          Errors.auth_required "missing authentication"

     

       
97
       
97
       
-
       
      | Some user_did -> (

     

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

     

       
99
       
99
       
-
       
        | `Ok fields -> (

     

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

     

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

     

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

     

       
103
       
103
       
-
       
            match (action, code, request_uri) with

     

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

     

       
105
       
105
       
-
       
                let prefix = Constants.request_uri_prefix in

     

       
106
       
106
       
-
       
                let request_id =

     

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

     

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

     

       
109
       
109
       
-
       
                in

     

       
110
       
110
       
-
       
                let%lwt req_record =

     

       
111
       
111
       
-
       
                  Queries.get_par_request ctx.db request_id

     

       
112
       
112
       
-
       
                in

     

       
113
       
113
       
-
       
                match req_record with

     

       
114
       
114
       
-
       
                | Some rec_ ->

     

       
115
       
115
       
-
       
                    let req =

     

       
116
       
116
       
-
       
                      Yojson.Safe.from_string rec_.request_data

     

       
117
       
117
       
-
       
                      |> par_request_of_yojson |> Result.get_ok

     

       
118
       
118
       
-
       
                    in

     

       
119
       
119
       
-
       
                    let params =

     

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

     

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

     

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

     

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

     

       
124
       
124
       
-
       
                    in

     

       
125
       
125
       
-
       
                    let query =

     

       
126
       
126
       
-
       
                      String.concat "&"

     

       
127
       
127
       
-
       
                        (List.map

     

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

     

       
129
       
129
       
-
       
                           params )

     

       
130
       
130
       
-
       
                    in

     

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

     

       
132
       
132
       
-
       
                | None ->

     

       
133
       
133
       
-
       
                    Errors.invalid_request "request expired" )

     

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

     

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

     

       
136
       
136
       
-
       
                match code_record with

     

       
137
       
137
       
-
       
                | None ->

     

       
138
       
138
       
-
       
                    Errors.invalid_request "invalid code"

     

       
139
       
139
       
-
       
                | Some code_rec -> (

     

       
140
       
140
       
-
       
                    if code_rec.authorized_by <> None then

     

       
141
       
141
       
-
       
                      Errors.invalid_request "code already authorized"

     

       
142
       
142
       
-
       
                    else if code_rec.used then

     

       
143
       
143
       
-
       
                      Errors.invalid_request "code already used"

     

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

     

       
145
       
145
       
-
       
                      Errors.invalid_request "code expired"

     

       
146
       
146
       
-
       
                    else

     

       
147
       
147
       
-
       
                      let%lwt () =

     

       
148
       
148
       
-
       
                        Queries.activate_auth_code ctx.db code user_did

     

       
149
       
149
       
-
       
                      in

     

       
150
       
150
       
-
       
                      let%lwt req_record =

     

       
151
       
151
       
-
       
                        Queries.get_par_request ctx.db code_rec.request_id

     

       
152
       
152
       
-
       
                      in

     

       
153
       
153
       
-
       
                      match req_record with

     

       
154
       
154
       
-
       
                      | None ->

     

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

     

       
156
       
156
       
-
       
                      | Some rec_ ->

     

       
157
       
157
       
-
       
                          let req =

     

       
158
       
158
       
-
       
                            Yojson.Safe.from_string rec_.request_data

     

       
159
       
159
       
-
       
                            |> par_request_of_yojson |> Result.get_ok

     

       
160
       
160
       
-
       
                          in

     

       
161
       
161
       
-
       
                          let params =

     

       
162
       
162
       
-
       
                            [ ("code", code)

     

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

     

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

     

       
165
       
165
       
-
       
                          in

     

       
166
       
166
       
-
       
                          let query =

     

       
167
       
167
       
-
       
                            String.concat "&"

     

       
168
       
168
       
-
       
                              (List.map

     

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

     

       
170
       
170
       
-
       
                                 params )

     

       
171
       
171
       
-
       
                          in

     

       
172
       
172
       
-
       
                          let separator =

     

       
173
       
173
       
-
       
                            match req.response_mode with

     

       
174
       
174
       
-
       
                            | Some "fragment" ->

     

       
175
       
175
       
-
       
                                "#"

     

       
176
       
176
       
-
       
                            | _ ->

     

       
177
       
177
       
-
       
                                "?"

     

       
178
       
178
       
-
       
                          in

     

       
179
       
179
       
-
       
                          Dream.redirect ctx.req

     

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

     

       
181
       
181
       
-
       
            | _ ->

     

       
182
       
182
       
-
       
                Errors.invalid_request "invalid request" )

     

       
183
       
183
       
-
       
        | _ ->

     

       
184
       
184
       
-
       
            Errors.invalid_request "invalid request" ) )

     

···

       
1
       
1
       
-
       
open Oauth

     

       
2
       
2
       
-
       
open Oauth.Types

     

       
3
       
3
       
-
       


     

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

     

       
5
       
5
       
-
       


     

       
6
       
6
       
-
       
let post_handler =

     

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

     

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

     

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

     

       
10
       
10
       
-
       
      let%lwt client =

     

       
11
       
11
       
-
       
        try%lwt Client.fetch_client_metadata req.client_id

     

       
12
       
12
       
-
       
        with e ->

     

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

     

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

     

       
15
       
15
       
-
       
      in

     

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

     

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

     

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

     

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

     

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

     

       
21
       
21
       
-
       
        Errors.invalid_request "invalid redirect_uri"

     

       
22
       
22
       
-
       
      else

     

       
23
       
23
       
-
       
        let request_id =

     

       
24
       
24
       
-
       
          "req-"

     

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

     

       
26
       
26
       
-
       
        in

     

       
27
       
27
       
-
       
        let request_uri = Constants.request_uri_prefix ^ request_id in

     

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

     

       
29
       
29
       
-
       
        let request : oauth_request =

     

       
30
       
30
       
-
       
          { request_id

     

       
31
       
31
       
-
       
          ; client_id= req.client_id

     

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

     

       
33
       
33
       
-
       
          ; dpop_jkt= Some proof.jkt

     

       
34
       
34
       
-
       
          ; expires_at

     

       
35
       
35
       
-
       
          ; created_at= Util.now_ms () }

     

       
36
       
36
       
-
       
        in

     

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

     

       
38
       
38
       
-
       
        Dream.json ~status:`Created

     

       
39
       
39
       
-
       
        @@ Yojson.Safe.to_string

     

       
40
       
40
       
-
       
        @@ `Assoc

     

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

     

···

       
1
       
1
       
-
       
open Oauth

     

       
2
       
2
       
-
       


     

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

     

       
4
       
4
       
-
       


     

       
5
       
5
       
-
       
let post_handler =

     

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

     

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

     

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

     

       
9
       
9
       
-
       
      match req.grant_type with

     

       
10
       
10
       
-
       
      | "authorization_code" -> (

     

       
11
       
11
       
-
       
        match req.code with

     

       
12
       
12
       
-
       
        | None ->

     

       
13
       
13
       
-
       
            Errors.invalid_request "code required"

     

       
14
       
14
       
-
       
        | Some code -> (

     

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

     

       
16
       
16
       
-
       
            match code_record with

     

       
17
       
17
       
-
       
            | None ->

     

       
18
       
18
       
-
       
                Errors.invalid_request "invalid code"

     

       
19
       
19
       
-
       
            | Some code_rec -> (

     

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

     

       
21
       
21
       
-
       
                  Errors.invalid_request "code expired"

     

       
22
       
22
       
-
       
                else

     

       
23
       
23
       
-
       
                  match code_rec.authorized_by with

     

       
24
       
24
       
-
       
                  | None ->

     

       
25
       
25
       
-
       
                      Errors.invalid_request "code not authorized"

     

       
26
       
26
       
-
       
                  | Some did -> (

     

       
27
       
27
       
-
       
                      let%lwt par_req =

     

       
28
       
28
       
-
       
                        Queries.get_par_request ctx.db code_rec.request_id

     

       
29
       
29
       
-
       
                      in

     

       
30
       
30
       
-
       
                      match par_req with

     

       
31
       
31
       
-
       
                      | None ->

     

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

     

       
33
       
33
       
-
       
                      | Some par_record ->

     

       
34
       
34
       
-
       
                          let orig_req =

     

       
35
       
35
       
-
       
                            Yojson.Safe.from_string par_record.request_data

     

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

     

       
37
       
37
       
-
       
                          in

     

       
38
       
38
       
-
       
                          ( match req.redirect_uri with

     

       
39
       
39
       
-
       
                          | None ->

     

       
40
       
40
       
-
       
                              Errors.invalid_request "redirect_uri required"

     

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

     

       
42
       
42
       
-
       
                              Errors.invalid_request "redirect_uri mismatch"

     

       
43
       
43
       
-
       
                          | _ ->

     

       
44
       
44
       
-
       
                              () ) ;

     

       
45
       
45
       
-
       
                          ( match req.code_verifier with

     

       
46
       
46
       
-
       
                          | None ->

     

       
47
       
47
       
-
       
                              Errors.invalid_request "code_verifier required"

     

       
48
       
48
       
-
       
                          | Some verifier ->

     

       
49
       
49
       
-
       
                              let computed =

     

       
50
       
50
       
-
       
                                Digestif.SHA256.digest_string verifier

     

       
51
       
51
       
-
       
                                |> Digestif.SHA256.to_raw_string

     

       
52
       
52
       
-
       
                                |> Base64.(

     

       
53
       
53
       
-
       
                                     encode_exn ~pad:false

     

       
54
       
54
       
-
       
                                       ~alphabet:uri_safe_alphabet )

     

       
55
       
55
       
-
       
                              in

     

       
56
       
56
       
-
       
                              if orig_req.code_challenge <> computed then

     

       
57
       
57
       
-
       
                                Errors.invalid_request "invalid code_verifier"

     

       
58
       
58
       
-
       
                          ) ;

     

       
59
       
59
       
-
       
                          ( match par_record.dpop_jkt with

     

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

     

       
61
       
61
       
-
       
                              Errors.invalid_request "DPoP key mismatch"

     

       
62
       
62
       
-
       
                          | _ ->

     

       
63
       
63
       
-
       
                              () ) ;

     

       
64
       
64
       
-
       
                          let token_id =

     

       
65
       
65
       
-
       
                            "tok-"

     

       
66
       
66
       
-
       
                            ^ Uuidm.to_string

     

       
67
       
67
       
-
       
                                (Uuidm.v4_gen

     

       
68
       
68
       
-
       
                                   (Random.State.make_self_init ())

     

       
69
       
69
       
-
       
                                   () )

     

       
70
       
70
       
-
       
                          in

     

       
71
       
71
       
-
       
                          let refresh_token =

     

       
72
       
72
       
-
       
                            "ref-"

     

       
73
       
73
       
-
       
                            ^ Uuidm.to_string

     

       
74
       
74
       
-
       
                                (Uuidm.v4_gen

     

       
75
       
75
       
-
       
                                   (Random.State.make_self_init ())

     

       
76
       
76
       
-
       
                                   () )

     

       
77
       
77
       
-
       
                          in

     

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

     

       
79
       
79
       
-
       
                          let expires_in =

     

       
80
       
80
       
-
       
                            Constants.access_token_expiry_ms / 1000

     

       
81
       
81
       
-
       
                          in

     

       
82
       
82
       
-
       
                          let exp_sec = now_sec + expires_in in

     

       
83
       
83
       
-
       
                          let expires_at = exp_sec * 1000 in

     

       
84
       
84
       
-
       
                          let claims =

     

       
85
       
85
       
-
       
                            `Assoc

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       
93
       
93
       
-
       
                          in

     

       
94
       
94
       
-
       
                          let access_token =

     

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

     

       
96
       
96
       
-
       
                          in

     

       
97
       
97
       
-
       
                          let%lwt () =

     

       
98
       
98
       
-
       
                            Queries.insert_oauth_token ctx.db

     

       
99
       
99
       
-
       
                              { refresh_token

     

       
100
       
100
       
-
       
                              ; client_id= req.client_id

     

       
101
       
101
       
-
       
                              ; did

     

       
102
       
102
       
-
       
                              ; dpop_jkt= proof.jkt

     

       
103
       
103
       
-
       
                              ; scope= orig_req.scope

     

       
104
       
104
       
-
       
                              ; expires_at }

     

       
105
       
105
       
-
       
                          in

     

       
106
       
106
       
-
       
                          let nonce = Dpop.next_nonce () in

     

       
107
       
107
       
-
       
                          Dream.json

     

       
108
       
108
       
-
       
                            ~headers:

     

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

     

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

     

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

     

       
112
       
112
       
-
       
                          @@ Yojson.Safe.to_string

     

       
113
       
113
       
-
       
                          @@ `Assoc

     

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

     

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

     

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

     

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

     

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

     

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

     

       
120
       
120
       
-
       
      | "refresh_token" -> (

     

       
121
       
121
       
-
       
        match req.refresh_token with

     

       
122
       
122
       
-
       
        | None ->

     

       
123
       
123
       
-
       
            Errors.invalid_request "refresh_token required"

     

       
124
       
124
       
-
       
        | Some refresh_token -> (

     

       
125
       
125
       
-
       
            let%lwt token_record =

     

       
126
       
126
       
-
       
              Queries.get_oauth_token_by_refresh ctx.db refresh_token

     

       
127
       
127
       
-
       
            in

     

       
128
       
128
       
-
       
            match token_record with

     

       
129
       
129
       
-
       
            | None ->

     

       
130
       
130
       
-
       
                Errors.invalid_request "invalid refresh token"

     

       
131
       
131
       
-
       
            | Some session ->

     

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

     

       
133
       
133
       
-
       
                  Errors.invalid_request "client_id mismatch"

     

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

     

       
135
       
135
       
-
       
                  Errors.invalid_request "DPoP key mismatch"

     

       
136
       
136
       
-
       
                else

     

       
137
       
137
       
-
       
                  let new_token_id =

     

       
138
       
138
       
-
       
                    "tok-"

     

       
139
       
139
       
-
       
                    ^ Uuidm.to_string

     

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

     

       
141
       
141
       
-
       
                  in

     

       
142
       
142
       
-
       
                  let new_refresh =

     

       
143
       
143
       
-
       
                    "ref-"

     

       
144
       
144
       
-
       
                    ^ Uuidm.to_string

     

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

     

       
146
       
146
       
-
       
                  in

     

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

     

       
148
       
148
       
-
       
                  let expires_in = Constants.access_token_expiry_ms / 1000 in

     

       
149
       
149
       
-
       
                  let exp_sec = now_sec + expires_in in

     

       
150
       
150
       
-
       
                  let new_expires_at = exp_sec * 1000 in

     

       
151
       
151
       
-
       
                  let claims =

     

       
152
       
152
       
-
       
                    `Assoc

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       
160
       
160
       
-
       
                  in

     

       
161
       
161
       
-
       
                  let new_access_token =

     

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

     

       
163
       
163
       
-
       
                  in

     

       
164
       
164
       
-
       
                  let%lwt () =

     

       
165
       
165
       
-
       
                    Queries.update_oauth_token ctx.db

     

       
166
       
166
       
-
       
                      ~old_refresh_token:refresh_token

     

       
167
       
167
       
-
       
                      ~new_refresh_token:new_refresh ~expires_at:new_expires_at

     

       
168
       
168
       
-
       
                  in

     

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

     

       
170
       
170
       
-
       
                  @@ Yojson.Safe.to_string

     

       
171
       
171
       
-
       
                  @@ `Assoc

     

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

     

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

     

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

     

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

     

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

     

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

     

       
178
       
178
       
-
       
      | _ ->

     

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

     

···

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

     

       
18
       
18
       
 
       


     

       
19
       
19
       
 
       
let handler =

     

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

     

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

     

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

     

       
22
       
22
       
 
       
        Xrpc.parse_body req request_of_yojson

     

       
23
       
23
       
 
       
      in

     

···

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

     

       
2
       
2
       
 
       


     

       
3
       
3
       
 
       
let handler =

     

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

     

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

     

       
5
       
5
       
 
       
      let did = Auth.get_authed_did_exn auth in

     

       
6
       
6
       
 
       
      let aud, lxm =

     

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

     

···

       
1
       
1
       
-
       
open struct

     

       
2
       
2
       
-
       
  let make_url pth =

     

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

     

       
4
       
4
       
-
       


     

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

     

       
6
       
6
       
-
       
end

     

       
7
       
7
       
-
       


     

       
8
       
1
       
 
       
let did_json =

     

       
9
       
2
       
 
       
  Xrpc.handler (fun _ ->

     

       
10
       
3
       
 
       
      Dream.json @@ Yojson.Safe.to_string

     
···

       
15
       
8
       
 
       
             , `Assoc

     

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

     

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

     

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

     

       
19
       
19
       
-
       


     

       
20
       
20
       
-
       
let oauth_protected_resource =

     

       
21
       
21
       
-
       
  Xrpc.handler (fun _ ->

     

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

     

       
23
       
23
       
-
       
      @@ `Assoc

     

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

     

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

     

       
26
       
26
       
-
       
           ; ("resource", pds_url)

     

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

     

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

     

       
29
       
29
       
-
       


     

       
30
       
30
       
-
       
let oauth_authorization_server =

     

       
31
       
31
       
-
       
  Xrpc.handler (fun _ ->

     

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

     

       
33
       
33
       
-
       
      @@ `Assoc

     

       
34
       
34
       
-
       
           [ ("issuer", pds_url)

     

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

     

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

     

       
37
       
37
       
-
       
           ; ( "pushed_authorization_request_endpoint"

     

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

     

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

     

       
40
       
40
       
-
       
           ; ( "scopes_supported"

     

       
41
       
41
       
-
       
             , `List

     

       
42
       
42
       
-
       
                 [ `String "atproto"

     

       
43
       
43
       
-
       
                 ; `String "transition:email"

     

       
44
       
44
       
-
       
                 ; `String "transition:generic"

     

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

     

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

     

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

     

       
48
       
48
       
-
       
           ; ( "response_modes_supported"

     

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

     

       
50
       
50
       
-
       
           ; ( "grant_types_supported"

     

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

     

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

     

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

     

       
54
       
54
       
-
       
           ; ( "display_values_supported"

     

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

     

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

     

       
57
       
57
       
-
       
           ; ( "request_object_signing_alg_values_supported"

     

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

     

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

     

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

     

       
61
       
61
       
-
       
           ; ( "token_endpoint_auth_methods_supported"

     

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

     

       
63
       
63
       
-
       
           ; ( "token_endpoint_auth_signing_alg_values_supported"

     

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

     

       
65
       
65
       
-
       
           ; ( "dpop_signing_alg_values_supported"

     

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

     

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

     

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

     

       
12
       
12
       
+
       
           ] )

     

···

       
15
       
15
       
 
       
  | Admin

     

       
16
       
16
       
 
       
  | Access of {did: string}

     

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

     

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

     

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

     

       
20
       
18
       
 
       


     

       
21
       
19
       
 
       
let verify_bearer_jwt t token expected_scope =

     

       
22
       
20
       
 
       
  match Jwt.verify_jwt token Env.jwt_key with

     
···

       
44
       
42
       
 
       
  match credentials with

     

       
45
       
43
       
 
       
  | Admin ->

     

       
46
       
44
       
 
       
      true

     

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

     

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

     

       
48
       
46
       
 
       
      true

     

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

     

       
50
       
48
       
 
       
      true

     
···

       
52
       
50
       
 
       
      false

     

       
53
       
51
       
 
       


     

       
54
       
52
       
 
       
let get_authed_did_exn = function

     

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

     

       
53
       
53
       
+
       
  | Access {did} ->

     

       
56
       
54
       
 
       
      did

     

       
57
       
55
       
 
       
  | Refresh {did; _} ->

     

       
58
       
56
       
 
       
      did

     

       
59
       
57
       
 
       
  | _ ->

     

       
60
       
60
       
-
       
      Errors.auth_required "invalid authorization header"

     

       
61
       
61
       
-
       


     

       
62
       
62
       
-
       
let get_dpop_proof_exn = function

     

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

     

       
64
       
64
       
-
       
      proof

     

       
65
       
65
       
-
       
  | _ ->

     

       
66
       
66
       
-
       
      Errors.invalid_request "invalid DPoP header"

     

       
58
       
58
       
+
       
      Errors.auth_required "Invalid authorization header"

     

       
67
       
59
       
 
       


     

       
68
       
60
       
 
       
let get_session_info identifier db =

     

       
69
       
61
       
 
       
  let%lwt actor =

     
···

       
92
       
84
       
 
       
module Verifiers = struct

     

       
93
       
85
       
 
       
  open struct

     

       
94
       
86
       
 
       
    let parse_header req expected_type =

     

       
95
       
95
       
-
       
      match Dream.header req "Authorization" with

     

       
87
       
87
       
+
       
      match Dream.header req "authorization" with

     

       
96
       
88
       
 
       
      | Some header -> (

     

       
97
       
89
       
 
       
        match String.split_on_char ' ' header with

     

       
98
       
90
       
 
       
        | [typ; token]

     
···

       
103
       
95
       
 
       
            Error "invalid authorization header" )

     

       
104
       
96
       
 
       
      | None ->

     

       
105
       
97
       
 
       
          Error "missing authorization header"

     

       
106
       
106
       
-
       
  end

     

       
107
       
98
       
 
       


     

       
108
       
99
       
 
       
    let parse_basic req =

     

       
109
       
100
       
 
       
      match parse_header req "Basic" with

     
···

       
121
       
112
       
 
       
          Error "invalid basic authorization header"

     

       
122
       
113
       
 
       


     

       
123
       
114
       
 
       
    let parse_bearer req = parse_header req "Bearer"

     

       
124
       
124
       
-
       


     

       
125
       
125
       
-
       
  let parse_dpop req = parse_header req "DPoP"

     

       
115
       
115
       
+
       
  end

     

       
126
       
116
       
 
       


     

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

     

       
128
       
118
       
 
       


     
···

       
132
       
122
       
 
       
   fun {req; _} ->

     

       
133
       
123
       
 
       
    match Dream.header req "authorization" with

     

       
134
       
124
       
 
       
    | Some _ ->

     

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

     

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

     

       
136
       
126
       
 
       
    | None ->

     

       
137
       
127
       
 
       
        Lwt.return_ok Unauthenticated

     

       
138
       
128
       
 
       


     
···

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

     

       
145
       
135
       
 
       
          Lwt.return_ok Admin

     

       
146
       
136
       
 
       
      | _ ->

     

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

     

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

     

       
148
       
138
       
 
       
    | Error _ ->

     

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

     

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

     

       
150
       
140
       
 
       


     

       
151
       
151
       
-
       
  let bearer : verifier =

     

       
141
       
141
       
+
       
  let access : verifier =

     

       
152
       
142
       
 
       
   fun {req; db} ->

     

       
153
       
143
       
 
       
    match parse_bearer req with

     

       
154
       
144
       
 
       
    | Ok jwt -> (

     
···

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

     

       
161
       
151
       
 
       
                Lwt.return_error

     

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

     

       
163
       
163
       
-
       
                 "account is deactivated"

     

       
153
       
153
       
+
       
                     "Account is deactivated"

     

       
164
       
154
       
 
       
            | None ->

     

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

     

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

     

       
166
       
156
       
 
       
        | Error _ ->

     

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

     

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

     

       
168
       
158
       
 
       
    | Error _ ->

     

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

     

       
170
       
170
       
-
       


     

       
171
       
171
       
-
       
  let dpop : verifier =

     

       
172
       
172
       
-
       
   fun {req; _} ->

     

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

     

       
174
       
174
       
-
       
    match

     

       
175
       
175
       
-
       
      Oauth.Dpop.verify_dpop_proof

     

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

     

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

     

       
178
       
178
       
-
       
    with

     

       
179
       
179
       
-
       
    | Error "use_dpop_nonce" ->

     

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

     

       
181
       
181
       
-
       
    | Error e ->

     

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

     

       
183
       
183
       
-
       
    | Ok proof ->

     

       
184
       
184
       
-
       
        Lwt.return_ok (DPoP {proof})

     

       
185
       
185
       
-
       


     

       
186
       
186
       
-
       
  let oauth : verifier =

     

       
187
       
187
       
-
       
   fun {req; db} ->

     

       
188
       
188
       
-
       
    match parse_dpop req with

     

       
189
       
189
       
-
       
    | Error e ->

     

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

     

       
191
       
191
       
-
       
    | Ok token -> (

     

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

     

       
193
       
193
       
-
       
      | Error e ->

     

       
194
       
194
       
-
       
          Lwt.return_error e

     

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

     

       
196
       
196
       
-
       
        match Jwt.verify_jwt token Env.jwt_key with

     

       
197
       
197
       
-
       
        | Error e ->

     

       
198
       
198
       
-
       
            Lwt.return_error @@ Errors.auth_required e

     

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

     

       
200
       
200
       
-
       
            let open Yojson.Safe.Util in

     

       
201
       
201
       
-
       
            try

     

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

     

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

     

       
204
       
204
       
-
       
              let jkt_claim =

     

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

     

       
206
       
206
       
-
       
              in

     

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

     

       
208
       
208
       
-
       
              if jkt_claim <> proof.jkt then

     

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

     

       
210
       
210
       
-
       
              else if exp < now then

     

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

     

       
212
       
212
       
-
       
              else

     

       
213
       
213
       
-
       
                let%lwt session =

     

       
214
       
214
       
-
       
                  try%lwt

     

       
215
       
215
       
-
       
                    let%lwt sess = get_session_info did db in

     

       
216
       
216
       
-
       
                    Lwt.return_ok sess

     

       
217
       
217
       
-
       
                  with _ ->

     

       
218
       
218
       
-
       
                    Lwt.return_error

     

       
219
       
219
       
-
       
                    @@ Errors.auth_required "invalid credentials"

     

       
220
       
220
       
-
       
                in

     

       
221
       
221
       
-
       
                match session with

     

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

     

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

     

       
224
       
224
       
-
       
                | Ok _ ->

     

       
225
       
225
       
-
       
                    Lwt.return_error

     

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

     

       
227
       
227
       
-
       
                         "account is deactivated"

     

       
228
       
228
       
-
       
                | Error _ ->

     

       
229
       
229
       
-
       
                    Lwt.return_error

     

       
230
       
230
       
-
       
                    @@ Errors.auth_required "invalid credentials"

     

       
231
       
231
       
-
       
            with _ ->

     

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

     

       
233
       
233
       
-
       
        )

     

       
234
       
234
       
-
       
      | Ok _ ->

     

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

     

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

     

       
236
       
160
       
 
       


     

       
237
       
161
       
 
       
  let refresh : verifier =

     

       
238
       
162
       
 
       
   fun {req; db} ->

     
···

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

     

       
247
       
171
       
 
       
                Lwt.return_error

     

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

     

       
249
       
249
       
-
       
                 "account is deactivated"

     

       
173
       
173
       
+
       
                     "Account is deactivated"

     

       
250
       
174
       
 
       
            | None ->

     

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

     

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

     

       
252
       
176
       
 
       
        | Error "" | Error _ ->

     

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

     

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

     

       
254
       
178
       
 
       
    | Error _ ->

     

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

     

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

     

       
256
       
180
       
 
       


     

       
257
       
181
       
 
       
  let authorization : verifier =

     

       
258
       
182
       
 
       
   fun ctx ->

     
···

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

     

       
264
       
188
       
 
       
        admin ctx

     

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

     

       
266
       
266
       
-
       
        bearer ctx

     

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

     

       
268
       
268
       
-
       
        oauth ctx

     

       
190
       
190
       
+
       
        access ctx

     

       
269
       
191
       
 
       
    | _ ->

     

       
270
       
192
       
 
       
        Lwt.return_error

     

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

     

       
272
       
272
       
-
       
             "unexpected authorization type"

     

       
194
       
194
       
+
       
             "Unexpected authorization type"

     

       
273
       
195
       
 
       


     

       
274
       
196
       
 
       
  let any : verifier =

     

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

     

       
276
       
198
       
 
       


     

       
277
       
277
       
-
       
  type t =

     

       
278
       
278
       
-
       
    | Unauthenticated

     

       
279
       
279
       
-
       
    | Admin

     

       
280
       
280
       
-
       
    | Bearer

     

       
281
       
281
       
-
       
    | DPoP

     

       
282
       
282
       
-
       
    | OAuth

     

       
283
       
283
       
-
       
    | Refresh

     

       
284
       
284
       
-
       
    | Authorization

     

       
285
       
285
       
-
       
    | Any

     

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

     

       
286
       
200
       
 
       


     

       
287
       
201
       
 
       
  let of_t = function

     

       
288
       
202
       
 
       
    | Unauthenticated ->

     

       
289
       
203
       
 
       
        unauthenticated

     

       
290
       
204
       
 
       
    | Admin ->

     

       
291
       
205
       
 
       
        admin

     

       
292
       
292
       
-
       
    | Bearer ->

     

       
293
       
293
       
-
       
        bearer

     

       
294
       
294
       
-
       
    | DPoP ->

     

       
295
       
295
       
-
       
        dpop

     

       
296
       
296
       
-
       
    | OAuth ->

     

       
297
       
297
       
-
       
        oauth

     

       
206
       
206
       
+
       
    | Access ->

     

       
207
       
207
       
+
       
        access

     

       
298
       
208
       
 
       
    | Refresh ->

     

       
299
       
209
       
 
       
        refresh

     

       
300
       
210
       
 
       
    | Authorization ->

     

···

       
71
       
71
       
 
       
        |sql}]

     

       
72
       
72
       
 
       
        () conn

     

       
73
       
73
       
 
       
    in

     

       
74
       
74
       
-
       
    let$! () =

     

       
75
       
74
       
 
       
    [%rapper

     

       
76
       
75
       
 
       
      execute

     

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

     
···

       
83
       
82
       
 
       
          )

     

       
84
       
83
       
 
       
       |sql}]

     

       
85
       
84
       
 
       
      () conn

     

       
86
       
86
       
-
       
    in

     

       
87
       
87
       
-
       
    let$! () =

     

       
88
       
88
       
-
       
      [%rapper

     

       
89
       
89
       
-
       
        execute

     

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

     

       
91
       
91
       
-
       
		        request_id TEXT PRIMARY KEY,

     

       
92
       
92
       
-
       
		        client_id TEXT NOT NULL,

     

       
93
       
93
       
-
       
		        request_data TEXT NOT NULL,

     

       
94
       
94
       
-
       
		        dpop_jkt TEXT,

     

       
95
       
95
       
-
       
		        expires_at INTEGER NOT NULL,

     

       
96
       
96
       
-
       
		        created_at INTEGER NOT NULL

     

       
97
       
97
       
-
       
		      )

     

       
98
       
98
       
-
       
		  |sql}]

     

       
99
       
99
       
-
       
        () conn

     

       
100
       
100
       
-
       
    in

     

       
101
       
101
       
-
       
    let$! () =

     

       
102
       
102
       
-
       
      [%rapper

     

       
103
       
103
       
-
       
        execute

     

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

     

       
105
       
105
       
-
       
                code TEXT PRIMARY KEY,

     

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

     

       
107
       
107
       
-
       
                authorized_by TEXT,

     

       
108
       
108
       
-
       
                authorized_at INTEGER,

     

       
109
       
109
       
-
       
                expires_at INTEGER NOT NULL,

     

       
110
       
110
       
-
       
                used BOOLEAN DEFAULT FALSE

     

       
111
       
111
       
-
       
              )

     

       
112
       
112
       
-
       
          |sql}]

     

       
113
       
113
       
-
       
        () conn

     

       
114
       
114
       
-
       
    in

     

       
115
       
115
       
-
       
    let$! () =

     

       
116
       
116
       
-
       
      [%rapper

     

       
117
       
117
       
-
       
        execute

     

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

     

       
119
       
119
       
-
       
            	refresh_token TEXT UNIQUE NOT NULL,

     

       
120
       
120
       
-
       
            	client_id TEXT NOT NULL,

     

       
121
       
121
       
-
       
            	did TEXT NOT NULL,

     

       
122
       
122
       
-
       
            	dpop_jkt TEXT,

     

       
123
       
123
       
-
       
            	scope TEXT NOT NULL,

     

       
124
       
124
       
-
       
            	expires_at INTEGER NOT NULL

     

       
125
       
125
       
-
       
              )

     

       
126
       
126
       
-
       
          |sql}]

     

       
127
       
127
       
-
       
        () conn

     

       
128
       
128
       
-
       
    in

     

       
129
       
129
       
-
       
    let$! () =

     

       
130
       
130
       
-
       
      [%rapper

     

       
131
       
131
       
-
       
        execute

     

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

     

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

     

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

     

       
135
       
135
       
-
       
          |sql}]

     

       
136
       
136
       
-
       
        () conn

     

       
137
       
137
       
-
       
    in

     

       
138
       
138
       
-
       
    let$! () =

     

       
139
       
139
       
-
       
      [%rapper

     

       
140
       
140
       
-
       
        execute

     

       
141
       
141
       
-
       
          {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests

     

       
142
       
142
       
-
       
                AFTER INSERT ON oauth_requests

     

       
143
       
143
       
-
       
                BEGIN

     

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

     

       
145
       
145
       
-
       
                END

     

       
146
       
146
       
-
       
          |sql}

     

       
147
       
147
       
-
       
          syntax_off]

     

       
148
       
148
       
-
       
        () conn

     

       
149
       
149
       
-
       
    in

     

       
150
       
150
       
-
       
    let$! () =

     

       
151
       
151
       
-
       
      [%rapper

     

       
152
       
152
       
-
       
        execute

     

       
153
       
153
       
-
       
          {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes

     

       
154
       
154
       
-
       
                AFTER INSERT ON oauth_codes

     

       
155
       
155
       
-
       
                BEGIN

     

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

     

       
157
       
157
       
-
       
                END

     

       
158
       
158
       
-
       
          |sql}

     

       
159
       
159
       
-
       
          syntax_off]

     

       
160
       
160
       
-
       
        () conn

     

       
161
       
161
       
-
       
    in

     

       
162
       
162
       
-
       
    let$! () =

     

       
163
       
163
       
-
       
      [%rapper

     

       
164
       
164
       
-
       
        execute

     

       
165
       
165
       
-
       
          {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens

     

       
166
       
166
       
-
       
                AFTER INSERT ON oauth_tokens

     

       
167
       
167
       
-
       
                BEGIN

     

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

     

       
169
       
169
       
-
       
                END

     

       
170
       
170
       
-
       
          |sql}

     

       
171
       
171
       
-
       
          syntax_off]

     

       
172
       
172
       
-
       
        () conn

     

       
173
       
173
       
-
       
    in

     

       
174
       
174
       
-
       
    Lwt.return_ok ()

     

       
175
       
85
       
 
       


     

       
176
       
86
       
 
       
  let create_actor =

     

       
177
       
87
       
 
       
    [%rapper

     
···

       
311
       
221
       
 
       
type t = Util.caqti_pool

     

       
312
       
222
       
 
       


     

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

     

       
314
       
314
       
-
       
  if create = Some true then

     

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

     

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

     

       
317
       
225
       
 
       


     

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

     

···

       
9
       
9
       
 
       
  cohttp-lwt-unix

     

       
10
       
10
       
 
       
  dns-client.unix

     

       
11
       
11
       
 
       
  dream

     

       
12
       
12
       
-
       
  html_of_jsx

     

       
13
       
12
       
 
       
  ipld

     

       
14
       
13
       
 
       
  kleidos

     

       
15
       
14
       
 
       
  lwt

     
···

       
19
       
18
       
 
       
  safepass

     

       
20
       
19
       
 
       
  str

     

       
21
       
20
       
 
       
  timedesc

     

       
22
       
22
       
-
       
  uri

     

       
23
       
21
       
 
       
  uuidm

     

       
24
       
22
       
 
       
  yojson

     

       
25
       
23
       
 
       
  lwt_ppx

     

       
26
       
24
       
 
       
  ppx_deriving_yojson.runtime

     

       
27
       
25
       
 
       
  ppx_rapper_lwt)

     

       
28
       
26
       
 
       
 (preprocess

     

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

     

       
27
       
27
       
+
       
  (pps lwt_ppx ppx_deriving_yojson ppx_rapper)))

     

       
30
       
28
       
 
       


     

       
31
       
29
       
 
       
(include_subdirs qualified)