objective categorical abstract machine language personal data server
dpop
+175
+175
pegasus/lib/oauth/dpop.ml
+175
pegasus/lib/oauth/dpop.ml
···
1
+
type nonce_state =
2
+
{ secret: bytes
3
+
; mutable counter: int64
4
+
; mutable prev: string
5
+
; mutable curr: string
6
+
; mutable next: string
7
+
; rotation_interval_ms: int64 }
8
+
9
+
type proof = {jti: string; jkt: string; htm: string; htu: string}
10
+
11
+
let create_nonce_state ?(rotation_interval_ms = 60_000L) secret =
12
+
let counter =
13
+
Int64.div
14
+
(Int64.of_float (Unix.gettimeofday () *. 1000.))
15
+
rotation_interval_ms
16
+
in
17
+
let compute_nonce cnt =
18
+
let data = Bytes.create 8 in
19
+
Bytes.set_int64_be data 0 cnt ;
20
+
Digestif.SHA256.(
21
+
hmac_bytes ~key:(Bytes.to_string secret) data
22
+
|> to_raw_string
23
+
|> Base64.encode_exn ~pad:false )
24
+
in
25
+
{ secret
26
+
; counter
27
+
; prev= compute_nonce (Int64.pred counter)
28
+
; curr= compute_nonce counter
29
+
; next= compute_nonce (Int64.succ counter)
30
+
; rotation_interval_ms }
31
+
32
+
let next_nonce state =
33
+
let now_counter =
34
+
Int64.div
35
+
(Int64.of_float (Unix.gettimeofday () *. 1000.))
36
+
state.rotation_interval_ms
37
+
in
38
+
if now_counter <> state.counter then (
39
+
state.prev <- state.curr ;
40
+
state.curr <- state.next ;
41
+
let data = Bytes.create 8 in
42
+
Bytes.set_int64_be data 0 (Int64.succ now_counter) ;
43
+
state.next <-
44
+
Digestif.SHA256.(
45
+
hmac_bytes ~key:(Bytes.to_string state.secret) data
46
+
|> to_raw_string
47
+
|> Base64.encode_exn ~pad:false ) ;
48
+
state.counter <- now_counter ) ;
49
+
state.next
50
+
51
+
let verify_nonce state nonce =
52
+
nonce = state.prev || nonce = state.curr || nonce = state.next
53
+
54
+
let compute_jwk_thumbprint jwk =
55
+
let open Yojson.Safe.Util in
56
+
let crv = jwk |> member "crv" |> to_string in
57
+
let kty = jwk |> member "kty" |> to_string in
58
+
let x = jwk |> member "x" |> to_string in
59
+
let y = jwk |> member "y" |> to_string in
60
+
let tp =
61
+
Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y
62
+
in
63
+
Digestif.SHA256.(
64
+
digest_string tp |> to_raw_string |> Base64.encode_exn ~pad:false )
65
+
66
+
let normalize_url url =
67
+
(* Remove query params and fragment, normalize to https://host/path *)
68
+
let uri = Uri.of_string url in
69
+
Uri.make ~scheme:"https"
70
+
~host:(Uri.host uri |> Option.get)
71
+
?port:(Uri.port uri) ~path:(Uri.path uri) ()
72
+
|> Uri.to_string
73
+
74
+
let verify_signature jwt jwk alg =
75
+
let open Yojson.Safe.Util in
76
+
let parts = String.split_on_char '.' jwt in
77
+
match parts with
78
+
| [header_b64; payload_b64; sig_b64] ->
79
+
let signing_input = header_b64 ^ "." ^ payload_b64 in
80
+
let msg =
81
+
Digestif.SHA256.(digest_string signing_input |> to_raw_string)
82
+
|> Bytes.of_string
83
+
in
84
+
let x = jwk |> member "x" |> to_string |> Base64.decode_exn in
85
+
let y = jwk |> member "y" |> to_string |> Base64.decode_exn in
86
+
let pubkey =
87
+
( Bytes.of_string (x ^ y)
88
+
, match alg with
89
+
| "ES256K" ->
90
+
(module Kleidos.K256 : Kleidos.CURVE)
91
+
| "ES256" ->
92
+
(module Kleidos.P256 : Kleidos.CURVE)
93
+
| _ ->
94
+
failwith "unsupported algorithm" )
95
+
in
96
+
let sig_bytes = Base64.decode_exn sig_b64 in
97
+
let r = String.sub sig_bytes 0 32 in
98
+
let s = String.sub sig_bytes 32 32 in
99
+
let signature = Bytes.of_string (r ^ s) in
100
+
Kleidos.verify ~pubkey ~msg ~signature
101
+
| _ ->
102
+
false
103
+
104
+
let verify_dpop_proof ~nonce_state ~jti_cache ~mthd ~url ~dpop_header
105
+
?access_token () =
106
+
match dpop_header with
107
+
| None ->
108
+
Lwt.return_error "missing dpop header"
109
+
| Some jwt -> (
110
+
let open Yojson.Safe.Util in
111
+
match String.split_on_char '.' jwt with
112
+
| [header_b64; payload_b64; _] -> (
113
+
let header = Yojson.Safe.from_string (Base64.decode_exn header_b64) in
114
+
let payload =
115
+
Yojson.Safe.from_string (Base64.decode_exn payload_b64)
116
+
in
117
+
let typ = header |> member "typ" |> to_string in
118
+
if typ <> "dpop+jwt" then Lwt.return_error "invalid typ in dpop proof"
119
+
else
120
+
let alg = header |> member "alg" |> to_string in
121
+
if alg <> "ES256" && alg <> "ES256K" then
122
+
Lwt.return_error "only es256 and es256k supported for dpop"
123
+
else
124
+
let jwk = header |> member "jwk" in
125
+
let jti = payload |> member "jti" |> to_string in
126
+
let htm = payload |> member "htm" |> to_string in
127
+
let htu = payload |> member "htu" |> to_string in
128
+
let iat = payload |> member "iat" |> to_int in
129
+
let nonce_claim = payload |> member "nonce" |> to_string_option in
130
+
match nonce_claim with
131
+
(* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
132
+
| None ->
133
+
Lwt.return_error "use_dpop_nonce"
134
+
| Some n when not (verify_nonce nonce_state n) ->
135
+
Lwt.return_error "use_dpop_nonce"
136
+
| Some _ ->
137
+
if htm <> mthd then Lwt.return_error "htm mismatch"
138
+
else if
139
+
not (String.equal (normalize_url htu) (normalize_url url))
140
+
then Lwt.return_error "htu mismatch"
141
+
else
142
+
let now = int_of_float (Unix.gettimeofday ()) in
143
+
if now - iat > 60 then Lwt.return_error "dpop proof too old"
144
+
else if Hashtbl.mem jti_cache jti then
145
+
Lwt.return_error "dpop proof replay detected"
146
+
else (
147
+
Hashtbl.add jti_cache jti (now + 3600) ;
148
+
if not (verify_signature jwt jwk alg) then
149
+
Lwt.return_error "invalid dpop signature"
150
+
else
151
+
let jkt = compute_jwk_thumbprint jwk in
152
+
(* verify ath if access token is provided *)
153
+
match access_token with
154
+
| Some token ->
155
+
let ath_claim =
156
+
payload |> member "ath" |> to_string_option
157
+
in
158
+
let expected_ath =
159
+
Digestif.SHA256.(
160
+
digest_string token |> to_raw_string
161
+
|> Base64.encode_exn ~pad:false )
162
+
in
163
+
if Some expected_ath <> ath_claim then
164
+
Lwt.return_error "ath mismatch"
165
+
else Lwt.return_ok {jti; jkt; htm; htu}
166
+
| None ->
167
+
let ath_claim =
168
+
payload |> member "ath" |> to_string_option
169
+
in
170
+
if ath_claim <> None then
171
+
Lwt.return_error
172
+
"ath claim not allowed without access token"
173
+
else Lwt.return_ok {jti; jkt; htm; htu} ) )
174
+
| _ ->
175
+
Lwt.return_error "invalid dpop jwt" )