objective categorical abstract machine language personal data server
set dpop headers in middleware
+71
-61
+3
-1
bin/main.ml
+3
-1
bin/main.ml
···
13
13
; ( get
14
14
, "/.well-known/oauth-authorization-server"
15
15
, Api.Well_known.oauth_authorization_server )
16
+
; (* oauth *)
17
+
(get, "/oauth/par", Api.Oauth_.Par.handler)
16
18
; (* unauthed *)
17
19
( get
18
20
, "/xrpc/com.atproto.server.describeServer"
···
77
79
Dream.serve ~interface:"0.0.0.0" ~port:8008
78
80
@@ Dream.logger
79
81
@@ Xrpc.service_proxy_middleware db
80
-
@@ Dream.router
82
+
@@ Xrpc.dpop_middleware @@ Dream.router
81
83
@@ List.map
82
84
(fun (fn, path, handler) ->
83
85
fn path (fun req -> handler ({req; db} : Xrpc.init)) )
+4
-6
pegasus/lib/api/oauth_/par.ml
+4
-6
pegasus/lib/api/oauth_/par.ml
···
9
9
; login_hint: string option }
10
10
[@@deriving yojson]
11
11
12
-
let handler ~nonce_state =
12
+
let handler =
13
13
Xrpc.handler (fun ctx ->
14
-
let%lwt proof =
15
-
Oauth.Dpop.verify_dpop_proof ~nonce_state
14
+
let proof =
15
+
Oauth.Dpop.verify_dpop_proof
16
16
~mthd:(Dream.method_to_string @@ Dream.method_ ctx.req)
17
17
~url:(Dream.target ctx.req)
18
18
~dpop_header:(Dream.header ctx.req "DPoP")
···
20
20
in
21
21
match proof with
22
22
| Error "use_dpop_nonce" ->
23
-
let nonce = Oauth.Dpop.next_nonce nonce_state in
24
-
Dream.json ~status:`Bad_Request ~headers:[("DPoP-Nonce", nonce)]
23
+
Dream.json ~status:`Bad_Request
25
24
@@ Yojson.Safe.to_string
26
25
@@ `Assoc [("error", `String "use_dpop_nonce")]
27
26
| Error e ->
···
60
59
; created_at= Util.now_ms () }
61
60
in
62
61
Dream.json ~status:`Created
63
-
~headers:[("DPoP-Nonce", Oauth.Dpop.next_nonce nonce_state)]
64
62
@@ Yojson.Safe.to_string
65
63
@@ `Assoc
66
64
[("request_uri", `String request_uri); ("expires_in", `Int 300)] )
+18
-21
pegasus/lib/auth.ml
+18
-21
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
-
21
19
let verify_bearer_jwt t token expected_scope =
22
20
match Jwt.verify_jwt token Env.jwt_key with
23
21
| Error err ->
···
97
95
Error "invalid authorization header" )
98
96
| None ->
99
97
Error "missing authorization header"
98
+
end
100
99
101
-
let parse_basic req =
102
-
match parse_header req "Basic" with
103
-
| Ok token -> (
104
-
match Base64.decode token with
105
-
| Ok decoded -> (
106
-
match Str.bounded_split (Str.regexp_string ":") decoded 2 with
107
-
| [username; password] ->
108
-
Ok (username, password)
109
-
| _ ->
110
-
Error "invalid basic authorization header" )
111
-
| Error _ ->
100
+
let parse_basic req =
101
+
match parse_header req "Basic" with
102
+
| Ok token -> (
103
+
match Base64.decode token with
104
+
| Ok decoded -> (
105
+
match Str.bounded_split (Str.regexp_string ":") decoded 2 with
106
+
| [username; password] ->
107
+
Ok (username, password)
108
+
| _ ->
112
109
Error "invalid basic authorization header" )
113
110
| Error _ ->
114
-
Error "invalid basic authorization header"
111
+
Error "invalid basic authorization header" )
112
+
| Error _ ->
113
+
Error "invalid basic authorization header"
115
114
116
-
let parse_bearer req = parse_header req "Bearer"
115
+
let parse_bearer req = parse_header req "Bearer"
117
116
118
-
let parse_dpop req = parse_header req "DPoP"
119
-
end
117
+
let parse_dpop req = parse_header req "DPoP"
120
118
121
119
type ctx = {req: Dream.request; db: Data_store.t}
122
120
···
169
167
Lwt.return_error @@ Errors.auth_required "missing authorization header"
170
168
| Ok token -> (
171
169
let dpop_header = Dream.header req "DPoP" in
172
-
let%lwt dpop_result =
173
-
Oauth.Dpop.verify_dpop_proof ~nonce_state:!dpop_nonce_state
170
+
match
171
+
Oauth.Dpop.verify_dpop_proof
174
172
~mthd:(Dream.method_to_string @@ Dream.method_ req)
175
173
~url:(Dream.target req) ~dpop_header ~access_token:token ()
176
-
in
177
-
match dpop_result with
174
+
with
178
175
| Error e ->
179
176
Lwt.return_error @@ Errors.auth_required ("dpop: " ^ e)
180
177
| Ok proof -> (
+36
-33
pegasus/lib/oauth/dpop.ml
+36
-33
pegasus/lib/oauth/dpop.ml
···
41
41
; next= compute_nonce secret (Int64.succ counter)
42
42
; rotation_interval_ms= Constants.dpop_rotation_interval_ms }
43
43
44
-
let next_nonce state =
44
+
let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret)
45
+
46
+
let next_nonce () =
45
47
let now_counter =
46
48
Int64.div
47
49
(Int64.of_float (Unix.gettimeofday () *. 1000.))
48
-
state.rotation_interval_ms
50
+
!nonce_state.rotation_interval_ms
49
51
in
50
-
if now_counter <> state.counter then (
51
-
state.prev <- state.curr ;
52
-
state.curr <- state.next ;
53
-
state.next <- compute_nonce state.secret (Int64.succ now_counter) ;
54
-
state.counter <- now_counter ) ;
55
-
state.next
52
+
if now_counter <> !nonce_state.counter then (
53
+
!nonce_state.prev <- !nonce_state.curr ;
54
+
!nonce_state.curr <- !nonce_state.next ;
55
+
!nonce_state.next <-
56
+
compute_nonce !nonce_state.secret (Int64.succ now_counter) ;
57
+
!nonce_state.counter <- now_counter ) ;
58
+
!nonce_state.next
56
59
57
-
let verify_nonce state nonce =
58
-
let valid = nonce = state.prev || nonce = state.curr || nonce = state.next in
59
-
next_nonce state |> ignore ;
60
-
valid
60
+
let verify_nonce nonce =
61
+
let valid =
62
+
nonce = !nonce_state.prev || nonce = !nonce_state.curr
63
+
|| nonce = !nonce_state.next
64
+
in
65
+
ignore next_nonce ; valid
61
66
62
67
let add_jti jti =
63
68
let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in
···
111
116
| _ ->
112
117
false
113
118
114
-
let verify_dpop_proof ~nonce_state ~mthd ~url ~dpop_header ?access_token () =
119
+
let verify_dpop_proof ~mthd ~url ~dpop_header ?access_token () =
115
120
match dpop_header with
116
121
| None ->
117
-
Lwt.return_error "missing dpop header"
122
+
Error "missing dpop header"
118
123
| Some jwt -> (
119
124
let open Yojson.Safe.Util in
120
125
match String.split_on_char '.' jwt with
···
122
127
let header = Yojson.Safe.from_string (Jwt.b64_decode header_b64) in
123
128
let payload = Yojson.Safe.from_string (Jwt.b64_decode payload_b64) in
124
129
let typ = header |> member "typ" |> to_string in
125
-
if typ <> "dpop+jwt" then Lwt.return_error "invalid typ in dpop proof"
130
+
if typ <> "dpop+jwt" then Error "invalid typ in dpop proof"
126
131
else
127
132
let alg = header |> member "alg" |> to_string in
128
133
if alg <> "ES256" && alg <> "ES256K" then
129
-
Lwt.return_error "only es256 and es256k supported for dpop"
134
+
Error "only es256 and es256k supported for dpop"
130
135
else
131
136
let jwk =
132
137
header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok
···
141
146
| _ ->
142
147
false )
143
148
then
144
-
Lwt.return_error
149
+
Error
145
150
(Printf.sprintf "algorithm %s doesn't match curve %s" alg
146
151
jwk.crv )
147
152
else
···
155
160
match nonce_claim with
156
161
(* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
157
162
| None ->
158
-
Lwt.return_error "use_dpop_nonce"
159
-
| Some n when not (verify_nonce nonce_state n) ->
160
-
Lwt.return_error "use_dpop_nonce"
163
+
Error "use_dpop_nonce"
164
+
| Some n when not (verify_nonce n) ->
165
+
Error "use_dpop_nonce"
161
166
| Some _ -> (
162
-
if htm <> mthd then Lwt.return_error "htm mismatch"
167
+
if htm <> mthd then Error "htm mismatch"
163
168
else if
164
169
not (String.equal (normalize_url htu) (normalize_url url))
165
-
then Lwt.return_error "htu mismatch"
170
+
then Error "htu mismatch"
166
171
else
167
172
let now = int_of_float (Unix.gettimeofday ()) in
168
173
if now - iat > Constants.max_dpop_age_s then
169
-
Lwt.return_error "dpop proof too old"
170
-
else if iat - now > 5 then
171
-
Lwt.return_error "dpop proof in future"
174
+
Error "dpop proof too old"
175
+
else if iat - now > 5 then Error "dpop proof in future"
172
176
else if not (add_jti jti) then
173
-
Lwt.return_error "dpop proof replay detected"
177
+
Error "dpop proof replay detected"
174
178
else if not (verify_signature jwt jwk) then
175
-
Lwt.return_error "invalid dpop signature"
179
+
Error "invalid dpop signature"
176
180
else
177
181
let jkt = compute_jwk_thumbprint jwk in
178
182
(* verify ath if access token is provided *)
···
187
191
|> Jwt.b64_encode )
188
192
in
189
193
if Some expected_ath <> ath_claim then
190
-
Lwt.return_error "ath mismatch"
191
-
else Lwt.return_ok {jti; jkt; htm; htu}
194
+
Error "ath mismatch"
195
+
else Ok {jti; jkt; htm; htu}
192
196
| None ->
193
197
let ath_claim =
194
198
payload |> member "ath" |> to_string_option
195
199
in
196
200
if ath_claim <> None then
197
-
Lwt.return_error
198
-
"ath claim not allowed without access token"
199
-
else Lwt.return_ok {jti; jkt; htm; htu} ) )
201
+
Error "ath claim not allowed without access token"
202
+
else Ok {jti; jkt; htm; htu} ) )
200
203
| _ ->
201
-
Lwt.return_error "invalid dpop jwt" )
204
+
Error "invalid dpop jwt" )
+10
pegasus/lib/xrpc.ml
+10
pegasus/lib/xrpc.ml
···
125
125
| None ->
126
126
inner_handler req
127
127
128
+
let dpop_middleware inner_handler req =
129
+
let%lwt res = inner_handler req in
130
+
match Auth.Verifiers.parse_dpop req with
131
+
| Ok _ ->
132
+
Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;
133
+
Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ;
134
+
Lwt.return res
135
+
| Error _ ->
136
+
Lwt.return res
137
+
128
138
let resolve_repo_did ctx repo =
129
139
if String.starts_with ~prefix:"did:" repo then Lwt.return repo
130
140
else