objective categorical abstract machine language personal data server
move dpoop state out of ctx
+69
-63
+4
-5
pegasus/lib/api/oauth_/par.ml
+4
-5
pegasus/lib/api/oauth_/par.ml
···
9
9
; login_hint: string option }
10
10
[@@deriving yojson]
11
11
12
-
let handler =
12
+
let handler ~nonce_state =
13
13
Xrpc.handler (fun ctx ->
14
14
let%lwt proof =
15
-
Oauth.Dpop.verify_dpop_proof ctx.dpop ~mthd:"POST" ~url:"/oauth/par"
15
+
Oauth.Dpop.verify_dpop_proof ~nonce_state ~mthd:"POST" ~url:"/oauth/par"
16
16
~dpop_header:(Dream.header ctx.req "DPoP")
17
17
()
18
18
in
19
19
match proof with
20
20
| Error "use_dpop_nonce" ->
21
-
let nonce = Oauth.Dpop.next_nonce ctx.dpop.nonce_state in
21
+
let nonce = Oauth.Dpop.next_nonce nonce_state in
22
22
Dream.json ~status:`Bad_Request ~headers:[("DPoP-Nonce", nonce)]
23
23
@@ Yojson.Safe.to_string
24
24
@@ `Assoc [("error", `String "use_dpop_nonce")]
···
55
55
conn )
56
56
in
57
57
Dream.json ~status:`Created
58
-
~headers:
59
-
[("DPoP-Nonce", Oauth.Dpop.next_nonce ctx.dpop.nonce_state)]
58
+
~headers:[("DPoP-Nonce", Oauth.Dpop.next_nonce nonce_state)]
60
59
@@ Yojson.Safe.to_string
61
60
@@ `Assoc
62
61
[("request_uri", `String request_uri); ("expires_in", `Int 300)] )
+2
pegasus/lib/auth.ml
+2
pegasus/lib/auth.ml
···
16
16
| Access of {did: string}
17
17
| Refresh of {did: string; jti: string}
18
18
19
+
let dpop_nonce_state = ref (Oauth.Dpop.create_nonce_state Env.dpop_nonce_secret)
20
+
19
21
let verify_bearer_jwt t token expected_scope =
20
22
match Jwt.verify_jwt token Env.jwt_key with
21
23
| Error err ->
+23
-15
pegasus/lib/oauth/client.ml
+23
-15
pegasus/lib/oauth/client.ml
···
18
18
in
19
19
if status <> `OK then
20
20
let%lwt () = Cohttp_lwt.Body.drain_body res in
21
-
Errors.invalid_request "client metadata not found"
21
+
failwith
22
+
(Printf.sprintf "client metadata not found; http %d"
23
+
(Cohttp.Code.code_of_status status) )
22
24
else
23
25
let%lwt body = Cohttp_lwt.Body.to_string res in
24
26
let json = Yojson.Safe.from_string body in
···
40
42
; dpop_bound_access_tokens=
41
43
json |> member "dpop_bound_access_tokens" |> to_bool
42
44
; jwks_uri= json |> member "jwks_uri" |> to_string_option
43
-
; jwks= json |> member "jwks" |> to_option Fun.id }
45
+
; jwks= json |> member "jwks" |> to_option (fun j -> j) }
44
46
in
45
-
if metadata.client_id <> client_id then
46
-
Errors.invalid_request "client_id mismatch"
47
+
if metadata.client_id <> client_id then failwith "client_id mismatch"
47
48
else
48
49
let scopes = String.split_on_char ' ' metadata.scope in
49
50
if not (List.mem "atproto" scopes) then
50
-
Errors.invalid_request "scope must include 'atproto'"
51
+
failwith "scope must include 'atproto'"
51
52
else
52
53
List.iter
53
-
(fun uri ->
54
-
let u = Uri.of_string uri in
55
-
match Uri.scheme u with
56
-
| Some "https" ->
57
-
()
58
-
| Some "http"
59
-
when Uri.host u = Some "127.0.0.1" || Uri.host u = Some "[::1]" ->
54
+
(function
55
+
| "authorization_code" | "refresh_token" ->
60
56
()
61
-
| _ ->
62
-
Errors.invalid_request ("invalid redirect_uri: " ^ uri) )
63
-
metadata.redirect_uris ;
57
+
| grant ->
58
+
failwith ("invalid grant type: " ^ grant) )
59
+
metadata.grant_types ;
60
+
List.iter
61
+
(fun uri ->
62
+
let u = Uri.of_string uri in
63
+
let host = Uri.host u in
64
+
match Uri.scheme u with
65
+
| Some "https" when host <> Some "localhost" ->
66
+
()
67
+
| Some "http" when host = Some "127.0.0.1" || host = Some "[::1]" ->
68
+
()
69
+
| _ ->
70
+
failwith ("invalid redirect_uri: " ^ uri) )
71
+
metadata.redirect_uris ;
64
72
Lwt.return metadata
+38
-32
pegasus/lib/oauth/dpop.ml
+38
-32
pegasus/lib/oauth/dpop.ml
···
8
8
9
9
type proof = {jti: string; jkt: string; htm: string; htu: string}
10
10
11
-
type context = {nonce_state: nonce_state; jti_cache: (string, int) Hashtbl.t}
11
+
let max_age_s = 60
12
+
13
+
let rotation_interval_ms = 60_000L
14
+
15
+
let jti_ttl_s = 3600
16
+
17
+
let jti_cache_size = 10_000
18
+
19
+
let jti_cache : (string, int) Hashtbl.t = Hashtbl.create jti_cache_size
20
+
21
+
let cleanup_jti_cache () =
22
+
let now = int_of_float (Unix.gettimeofday ()) in
23
+
Hashtbl.filter_map_inplace
24
+
(fun _ expires_at -> if expires_at > now then Some expires_at else None)
25
+
jti_cache
26
+
27
+
let compute_nonce secret counter =
28
+
let data = Bytes.create 8 in
29
+
Bytes.set_int64_be data 0 counter ;
30
+
Digestif.SHA256.(
31
+
hmac_bytes ~key:(Bytes.to_string secret) data
32
+
|> to_raw_string
33
+
|> Base64.encode_exn ~pad:false )
12
34
13
-
let create_nonce_state ?(rotation_interval_ms = 60_000L) secret =
35
+
let create_nonce_state secret =
14
36
let counter =
15
37
Int64.div
16
38
(Int64.of_float (Unix.gettimeofday () *. 1000.))
17
39
rotation_interval_ms
18
40
in
19
-
let compute_nonce cnt =
20
-
let data = Bytes.create 8 in
21
-
Bytes.set_int64_be data 0 cnt ;
22
-
Digestif.SHA256.(
23
-
hmac_bytes ~key:(Bytes.to_string secret) data
24
-
|> to_raw_string
25
-
|> Base64.encode_exn ~pad:false )
26
-
in
27
41
{ secret
28
42
; counter
29
-
; prev= compute_nonce (Int64.pred counter)
30
-
; curr= compute_nonce counter
31
-
; next= compute_nonce (Int64.succ counter)
43
+
; prev= compute_nonce secret (Int64.pred counter)
44
+
; curr= compute_nonce secret counter
45
+
; next= compute_nonce secret (Int64.succ counter)
32
46
; rotation_interval_ms }
33
47
34
48
let next_nonce state =
···
40
54
if now_counter <> state.counter then (
41
55
state.prev <- state.curr ;
42
56
state.curr <- state.next ;
43
-
let data = Bytes.create 8 in
44
-
Bytes.set_int64_be data 0 (Int64.succ now_counter) ;
45
-
state.next <-
46
-
Digestif.SHA256.(
47
-
hmac_bytes ~key:(Bytes.to_string state.secret) data
48
-
|> to_raw_string
49
-
|> Base64.encode_exn ~pad:false ) ;
57
+
state.next <- compute_nonce state.secret (Int64.succ now_counter) ;
50
58
state.counter <- now_counter ) ;
51
59
state.next
52
60
···
66
74
digest_string tp |> to_raw_string |> Base64.encode_exn ~pad:false )
67
75
68
76
let normalize_url url =
69
-
(* Remove query params and fragment, normalize to https://host/path *)
70
77
let uri = Uri.of_string url in
71
78
Uri.make ~scheme:"https"
72
79
~host:(Uri.host uri |> Option.get)
···
83
90
Digestif.SHA256.(digest_string signing_input |> to_raw_string)
84
91
|> Bytes.of_string
85
92
in
86
-
let x = jwk |> member "x" |> to_string |> Base64.decode_exn in
87
-
let y = jwk |> member "y" |> to_string |> Base64.decode_exn in
93
+
let x = jwk |> member "x" |> to_string |> Base64.decode_exn ~pad:false in
94
+
let y = jwk |> member "y" |> to_string |> Base64.decode_exn ~pad:false in
95
+
let pubkey =
96
+
Bytes.cat (Bytes.of_string "\x04") (Bytes.of_string (x ^ y))
97
+
in
88
98
let pubkey =
89
-
( Bytes.of_string (x ^ y)
99
+
( pubkey
90
100
, match alg with
91
101
| "ES256K" ->
92
102
(module Kleidos.K256 : Kleidos.CURVE)
···
103
113
| _ ->
104
114
false
105
115
106
-
let verify_dpop_proof {nonce_state; jti_cache} ~mthd ~url ~dpop_header
107
-
?access_token () =
116
+
let verify_dpop_proof ~nonce_state ~mthd ~url ~dpop_header ?access_token () =
108
117
match dpop_header with
109
118
| None ->
110
119
Lwt.return_error "missing dpop header"
···
142
151
then Lwt.return_error "htu mismatch"
143
152
else
144
153
let now = int_of_float (Unix.gettimeofday ()) in
145
-
if now - iat > 60 then Lwt.return_error "dpop proof too old"
154
+
if now - iat > max_age_s then
155
+
Lwt.return_error "dpop proof too old"
146
156
else if Hashtbl.mem jti_cache jti then
147
157
Lwt.return_error "dpop proof replay detected"
148
158
else (
149
-
Hashtbl.add jti_cache jti (now + 3600) ;
159
+
Hashtbl.add jti_cache jti (now + jti_ttl_s) ;
150
160
if not (verify_signature jwt jwk alg) then
151
161
Lwt.return_error "invalid dpop signature"
152
162
else
···
175
185
else Lwt.return_ok {jti; jkt; htm; htu} ) )
176
186
| _ ->
177
187
Lwt.return_error "invalid dpop jwt" )
178
-
179
-
let create_context ?rotation_interval_ms secret =
180
-
{ nonce_state= create_nonce_state secret ?rotation_interval_ms
181
-
; jti_cache= Hashtbl.create 1000 }
+2
-11
pegasus/lib/xrpc.ml
+2
-11
pegasus/lib/xrpc.ml
···
3
3
4
4
type init = Auth.Verifiers.ctx
5
5
6
-
type context =
7
-
{ req: Dream.request
8
-
; db: Data_store.t
9
-
; auth: Auth.credentials
10
-
; dpop: Oauth.Dpop.context }
6
+
type context = {req: Dream.request; db: Data_store.t; auth: Auth.credentials}
11
7
12
8
type handler = context -> Dream.response Lwt.t
13
9
···
16
12
let auth = Auth.Verifiers.of_t auth in
17
13
match%lwt auth init with
18
14
| Ok creds -> (
19
-
try%lwt
20
-
hdlr
21
-
{ req= init.req
22
-
; db= init.db
23
-
; auth= creds
24
-
; dpop= Oauth.Dpop.create_context Env.dpop_nonce_secret }
15
+
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
25
16
with e ->
26
17
( match is_xrpc_error e with
27
18
| true ->