objective categorical abstract machine language personal data server
abstract out queries/types/constants
+235
-77
+10
-12
pegasus/lib/api/oauth_/par.ml
+10
-12
pegasus/lib/api/oauth_/par.ml
···
40
40
let request_uri =
41
41
"urn:ietf:params:oauth:request_uri:" ^ request_id
42
42
in
43
-
let expires_at = Util.now_ms () + (5 * 60 * 1000) in
43
+
let expires_at =
44
+
Util.now_ms () + Oauth.Constants.par_request_ttl_ms
45
+
in
44
46
let%lwt () =
45
-
Util.use_pool ctx.db (fun conn ->
46
-
[%rapper
47
-
execute
48
-
{sql| INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at)
49
-
VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string{dpop_jkt}, %int{expires_at}, %int{created_at})
50
-
|sql}]
51
-
~request_id ~client_id:req.client_id
52
-
~request_data:
53
-
(Yojson.Safe.to_string (request_to_yojson req))
54
-
~dpop_jkt:proof.jkt ~expires_at ~created_at:(Util.now_ms ())
55
-
conn )
47
+
Oauth.Queries.insert_par_request ctx.db
48
+
{ request_id
49
+
; client_id= req.client_id
50
+
; request_data= Yojson.Safe.to_string (request_to_yojson req)
51
+
; dpop_jkt= Some proof.jkt
52
+
; expires_at
53
+
; created_at= Util.now_ms () }
56
54
in
57
55
Dream.json ~status:`Created
58
56
~headers:[("DPoP-Nonce", Oauth.Dpop.next_nonce nonce_state)]
+1
-1
pegasus/lib/data_store.ml
+1
-1
pegasus/lib/data_store.ml
···
157
157
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes
158
158
AFTER INSERT ON oauth_codes
159
159
BEGIN
160
-
DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000;
160
+
DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000 OR used = 1;
161
161
END
162
162
|sql}
163
163
syntax_off]
+3
-34
pegasus/lib/oauth/client.ml
+3
-34
pegasus/lib/oauth/client.ml
···
1
-
type metadata =
2
-
{ client_id: string
3
-
; client_name: string option
4
-
; client_uri: string
5
-
; redirect_uris: string list
6
-
; grant_types: string list
7
-
; response_types: string list
8
-
; scope: string
9
-
; token_endpoint_auth_method: string
10
-
; application_type: string
11
-
; dpop_bound_access_tokens: bool
12
-
; jwks_uri: string option
13
-
; jwks: Yojson.Safe.t option }
1
+
open Types
14
2
15
-
let fetch_client_metadata client_id =
3
+
let fetch_client_metadata client_id : client_metadata Lwt.t =
16
4
let%lwt {status; _}, res =
17
5
Cohttp_lwt_unix.Client.get (Uri.of_string client_id)
18
6
in
···
24
12
else
25
13
let%lwt body = Cohttp_lwt.Body.to_string res in
26
14
let json = Yojson.Safe.from_string body in
27
-
let open Yojson.Safe.Util in
28
-
let metadata =
29
-
{ client_id= json |> member "client_id" |> to_string
30
-
; client_name= json |> member "client_name" |> to_string_option
31
-
; client_uri= json |> member "client_uri" |> to_string
32
-
; redirect_uris=
33
-
json |> member "redirect_uris" |> to_list |> List.map to_string
34
-
; grant_types=
35
-
json |> member "grant_types" |> to_list |> List.map to_string
36
-
; response_types=
37
-
json |> member "response_types" |> to_list |> List.map to_string
38
-
; scope= json |> member "scope" |> to_string
39
-
; token_endpoint_auth_method=
40
-
json |> member "token_endpoint_auth_method" |> to_string
41
-
; application_type= json |> member "application_type" |> to_string
42
-
; dpop_bound_access_tokens=
43
-
json |> member "dpop_bound_access_tokens" |> to_bool
44
-
; jwks_uri= json |> member "jwks_uri" |> to_string_option
45
-
; jwks= json |> member "jwks" |> to_option (fun j -> j) }
46
-
in
15
+
let metadata = client_metadata_of_yojson json |> Result.get_ok in
47
16
if metadata.client_id <> client_id then failwith "client_id mismatch"
48
17
else
49
18
let scopes = String.split_on_char ' ' metadata.scope in
+9
pegasus/lib/oauth/constants.ml
+9
pegasus/lib/oauth/constants.ml
+20
-30
pegasus/lib/oauth/dpop.ml
+20
-30
pegasus/lib/oauth/dpop.ml
···
6
6
; mutable next: string
7
7
; rotation_interval_ms: int64 }
8
8
9
+
type ec_jwk = {crv: string; kty: string; x: string; y: string}
10
+
[@@deriving yojson]
11
+
9
12
type proof = {jti: string; jkt: string; htm: string; htu: string}
13
+
[@@deriving yojson]
10
14
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
15
+
let jti_cache : (string, int) Hashtbl.t =
16
+
Hashtbl.create Constants.jti_cache_size
20
17
21
18
let cleanup_jti_cache () =
22
19
let now = int_of_float (Unix.gettimeofday ()) in
···
35
32
let counter =
36
33
Int64.div
37
34
(Int64.of_float (Unix.gettimeofday () *. 1000.))
38
-
rotation_interval_ms
35
+
Constants.dpop_rotation_interval_ms
39
36
in
40
37
{ secret
41
38
; counter
42
39
; prev= compute_nonce secret (Int64.pred counter)
43
40
; curr= compute_nonce secret counter
44
41
; next= compute_nonce secret (Int64.succ counter)
45
-
; rotation_interval_ms }
42
+
; rotation_interval_ms= Constants.dpop_rotation_interval_ms }
46
43
47
44
let next_nonce state =
48
45
let now_counter =
···
63
60
valid
64
61
65
62
let add_jti jti =
66
-
let expires_at = int_of_float (Unix.gettimeofday ()) + jti_ttl_s in
63
+
let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in
67
64
if Hashtbl.mem jti_cache jti then false (* replay *)
68
65
else (
69
66
Hashtbl.add jti_cache jti expires_at ;
···
79
76
|> Uri.to_string
80
77
81
78
let compute_jwk_thumbprint jwk =
82
-
let open Yojson.Safe.Util in
83
-
let crv = jwk |> member "crv" |> to_string in
84
-
let kty = jwk |> member "kty" |> to_string in
85
-
let x = jwk |> member "x" |> to_string in
86
-
let y = jwk |> member "y" |> to_string in
79
+
let {crv; kty; x; y} = jwk in
87
80
let tp =
88
81
(* keys must be in lexicographic order *)
89
82
Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y
···
91
84
Digestif.SHA256.(digest_string tp |> to_raw_string |> Jwt.b64_encode)
92
85
93
86
let verify_signature jwt jwk =
94
-
let open Yojson.Safe.Util in
95
87
let parts = String.split_on_char '.' jwt in
96
88
match parts with
97
89
| [header_b64; payload_b64; sig_b64] ->
98
90
let signing_input = header_b64 ^ "." ^ payload_b64 in
99
91
let msg = Bytes.of_string signing_input in
100
-
let x =
101
-
jwk |> member "x" |> to_string |> Jwt.b64_decode |> Bytes.of_string
102
-
in
103
-
let y =
104
-
jwk |> member "y" |> to_string |> Jwt.b64_decode |> Bytes.of_string
105
-
in
106
-
let crv = jwk |> member "crv" |> to_string in
92
+
let {x; y; crv; _} = jwk in
93
+
let x = x |> Jwt.b64_decode |> Bytes.of_string in
94
+
let y = y |> Jwt.b64_decode |> Bytes.of_string in
107
95
let pubkey = Bytes.cat (Bytes.of_string "\x04") (Bytes.cat x y) in
108
96
let pubkey =
109
97
( pubkey
···
140
128
if alg <> "ES256" && alg <> "ES256K" then
141
129
Lwt.return_error "only es256 and es256k supported for dpop"
142
130
else
143
-
let jwk = header |> member "jwk" in
144
-
let crv = jwk |> member "crv" |> to_string in
131
+
let jwk =
132
+
header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok
133
+
in
145
134
if
146
135
not
147
-
( match (alg, crv) with
136
+
( match (alg, jwk.crv) with
148
137
| "ES256", "P-256" ->
149
138
true
150
139
| "ES256K", "secp256k1" ->
···
153
142
false )
154
143
then
155
144
Lwt.return_error
156
-
(Printf.sprintf "algorithm %s doesn't match curve %s" alg crv)
145
+
(Printf.sprintf "algorithm %s doesn't match curve %s" alg
146
+
jwk.crv )
157
147
else
158
148
let jti = payload |> member "jti" |> to_string in
159
149
let htm = payload |> member "htm" |> to_string in
···
175
165
then Lwt.return_error "htu mismatch"
176
166
else
177
167
let now = int_of_float (Unix.gettimeofday ()) in
178
-
if now - iat > max_age_s then
168
+
if now - iat > Constants.max_dpop_age_s then
179
169
Lwt.return_error "dpop proof too old"
180
170
else if iat - now > 5 then
181
171
Lwt.return_error "dpop proof in future"
+118
pegasus/lib/oauth/queries.ml
+118
pegasus/lib/oauth/queries.ml
···
1
+
[@@@warning "-missing-record-field-pattern"]
2
+
3
+
open Types
4
+
5
+
let insert_par_request conn req =
6
+
Util.use_pool conn
7
+
@@ [%rapper
8
+
execute
9
+
{sql|
10
+
INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at)
11
+
VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string?{dpop_jkt}, %int{expires_at}, %int{created_at})
12
+
|sql}
13
+
record_in]
14
+
req
15
+
16
+
let get_par_request conn request_id =
17
+
Util.use_pool conn
18
+
@@ [%rapper
19
+
get_opt
20
+
{sql|
21
+
SELECT @string{request_id}, @string{client_id}, @string{request_data},
22
+
@string?{dpop_jkt}, @int{expires_at}, @int{created_at}
23
+
FROM oauth_requests
24
+
WHERE request_id = %string{request_id}
25
+
|sql}
26
+
record_out]
27
+
~request_id
28
+
29
+
let insert_auth_code conn code =
30
+
Util.use_pool conn
31
+
@@ [%rapper
32
+
execute
33
+
{sql|
34
+
INSERT INTO oauth_codes (code, request_id, authorized_by, authorized_at, expires_at, used)
35
+
VALUES (%string{code}, %string{request_id}, %string?{authorized_by}, %int?{authorized_at}, %int{expires_at}, 0)
36
+
|sql}
37
+
record_in]
38
+
code
39
+
40
+
let consume_auth_code conn code =
41
+
Util.use_pool conn
42
+
@@ [%rapper
43
+
get_opt
44
+
{sql|
45
+
UPDATE oauth_codes
46
+
SET used = 1
47
+
WHERE code = %string{code} AND used = 0
48
+
RETURNING @string{code}, @string{request_id}, @string?{authorized_by},
49
+
@int?{authorized_at}, @int{expires_at}, @bool{used}
50
+
|sql}
51
+
record_out]
52
+
~code
53
+
54
+
let insert_oauth_token conn token =
55
+
Util.use_pool conn
56
+
@@ [%rapper
57
+
execute
58
+
{sql|
59
+
INSERT INTO oauth_tokens (token_id, refresh_token, client_id, did, dpop_jkt, scope, created_at, expires_at, last_refreshed_at)
60
+
VALUES (%string{token_id}, %string{refresh_token}, %string{client_id}, %string{did}, %string{dpop_jkt}, %string{scope}, %int{created_at}, %int{expires_at}, %int{last_refreshed_at})
61
+
|sql}
62
+
record_in]
63
+
token
64
+
65
+
let get_oauth_token_by_refresh conn refresh_token =
66
+
Util.use_pool conn
67
+
@@ [%rapper
68
+
get_opt
69
+
{sql|
70
+
SELECT @int{id}, @string{token_id}, @string{refresh_token}, @string{client_id},
71
+
@string{did}, @string{dpop_jkt}, @string{scope}, @int{created_at},
72
+
@int{expires_at}, @int{last_refreshed_at}
73
+
FROM oauth_tokens
74
+
WHERE refresh_token = %string{refresh_token}
75
+
|sql}
76
+
record_out]
77
+
~refresh_token
78
+
79
+
let update_oauth_token conn ~old_refresh_token ~new_token_id ~new_refresh_token
80
+
~expires_at =
81
+
let last_refreshed_at = Util.now_ms () in
82
+
Util.use_pool conn
83
+
@@ [%rapper
84
+
execute
85
+
{sql|
86
+
UPDATE oauth_tokens
87
+
SET token_id = %string{new_token_id},
88
+
refresh_token = %string{new_refresh_token},
89
+
expires_at = %int{expires_at},
90
+
last_refreshed_at = %int{last_refreshed_at}
91
+
WHERE refresh_token = %string{old_refresh_token}
92
+
|sql}]
93
+
~new_token_id ~new_refresh_token ~expires_at ~last_refreshed_at
94
+
~old_refresh_token
95
+
96
+
let delete_oauth_token_by_refresh conn refresh_token =
97
+
Util.use_pool conn
98
+
@@ [%rapper
99
+
execute
100
+
{sql|
101
+
DELETE FROM oauth_tokens WHERE refresh_token = %string{refresh_token}
102
+
|sql}]
103
+
~refresh_token
104
+
105
+
let get_oauth_tokens_by_did conn did =
106
+
Util.use_pool conn
107
+
@@ [%rapper
108
+
get_many
109
+
{sql|
110
+
SELECT @int{id}, @string{token_id}, @string{refresh_token}, @string{client_id},
111
+
@string{did}, @string{dpop_jkt}, @string{scope}, @int{created_at},
112
+
@int{expires_at}, @int{last_refreshed_at}
113
+
FROM oauth_tokens
114
+
WHERE did = %string{did}
115
+
ORDER BY created_at DESC
116
+
|sql}
117
+
record_out]
118
+
~did
+74
pegasus/lib/oauth/types.ml
+74
pegasus/lib/oauth/types.ml
···
1
+
type par_request =
2
+
{ client_id: string
3
+
; response_type: string
4
+
; redirect_uri: string
5
+
; scope: string
6
+
; state: string
7
+
; code_challenge: string
8
+
; code_challenge_method: string
9
+
; login_hint: string option
10
+
; dpop_jkt: string option
11
+
; client_assertion_type: string option
12
+
; client_assertion: string option }
13
+
[@@deriving yojson {strict= false}]
14
+
15
+
type token_request =
16
+
{ grant_type: string
17
+
; code: string option
18
+
; redirect_uri: string option
19
+
; code_verifier: string option
20
+
; refresh_token: string option
21
+
; client_id: string
22
+
; client_assertion_type: string option
23
+
; client_assertion: string option }
24
+
[@@deriving yojson {strict= false}]
25
+
26
+
type client_metadata =
27
+
{ client_id: string
28
+
; client_name: string option
29
+
; client_uri: string
30
+
; redirect_uris: string list
31
+
; grant_types: string list
32
+
; response_types: string list
33
+
; scope: string
34
+
; token_endpoint_auth_method: string
35
+
; token_endpoint_auth_signing_alg: string option
36
+
; application_type: string
37
+
; dpop_bound_access_tokens: bool
38
+
; jwks_uri: string option
39
+
; jwks: Yojson.Safe.t option }
40
+
[@@deriving yojson {strict= false}]
41
+
42
+
type dpop_proof = {jti: string; jkt: string; htm: string; htu: string}
43
+
[@@deriving yojson {strict= false}]
44
+
45
+
type oauth_request_record =
46
+
{ request_id: string
47
+
; client_id: string
48
+
; request_data: string
49
+
; dpop_jkt: string option
50
+
; expires_at: int
51
+
; created_at: int }
52
+
[@@deriving yojson {strict= false}]
53
+
54
+
type oauth_code_record =
55
+
{ code: string
56
+
; request_id: string
57
+
; authorized_by: string option
58
+
; authorized_at: int option
59
+
; expires_at: int
60
+
; used: bool }
61
+
[@@deriving yojson {strict= false}]
62
+
63
+
type oauth_token_record =
64
+
{ id: int
65
+
; token_id: string
66
+
; refresh_token: string
67
+
; client_id: string
68
+
; did: string
69
+
; dpop_jkt: string
70
+
; scope: string
71
+
; created_at: int
72
+
; expires_at: int
73
+
; last_refreshed_at: int }
74
+
[@@deriving yojson {strict= false}]