objective categorical abstract machine language personal data server
Better debug logging
+332
-281
+1
bin/main.ml
+1
bin/main.ml
+98
-93
pegasus/lib/api/oauth_/token.ml
+98
-93
pegasus/lib/api/oauth_/token.ml
···
30
30
match par_req with
31
31
| None ->
32
32
Errors.internal_error ~msg:"request not found" ()
33
-
| Some par_record ->
34
-
let orig_req =
35
-
Yojson.Safe.from_string par_record.request_data
36
-
|> Types.par_request_of_yojson |> Result.get_ok
37
-
in
38
-
( match req.redirect_uri with
39
-
| None ->
40
-
Errors.invalid_request "redirect_uri required"
41
-
| Some uri when uri <> orig_req.redirect_uri ->
42
-
Errors.invalid_request "redirect_uri mismatch"
43
-
| _ ->
44
-
() ) ;
45
-
( match req.code_verifier with
46
-
| None ->
47
-
Errors.invalid_request "code_verifier required"
48
-
| Some verifier ->
49
-
let computed =
50
-
Digestif.SHA256.digest_string verifier
51
-
|> Digestif.SHA256.to_raw_string
52
-
|> Base64.(
53
-
encode_exn ~pad:false
54
-
~alphabet:uri_safe_alphabet )
55
-
in
56
-
if orig_req.code_challenge <> computed then
57
-
Errors.invalid_request "invalid code_verifier"
58
-
) ;
59
-
( match par_record.dpop_jkt with
60
-
| Some stored when stored <> proof.jkt ->
61
-
Errors.invalid_request "DPoP key mismatch"
62
-
| _ ->
63
-
() ) ;
64
-
let token_id =
65
-
"tok-"
66
-
^ Uuidm.to_string
67
-
(Uuidm.v4_gen
68
-
(Random.State.make_self_init ())
69
-
() )
70
-
in
71
-
let refresh_token =
72
-
"ref-"
73
-
^ Uuidm.to_string
74
-
(Uuidm.v4_gen
75
-
(Random.State.make_self_init ())
76
-
() )
77
-
in
78
-
let now_sec = int_of_float (Unix.gettimeofday ()) in
79
-
let now_ms = Util.now_ms () in
80
-
let expires_in =
81
-
Constants.access_token_expiry_ms / 1000
82
-
in
83
-
let exp_sec = now_sec + expires_in in
84
-
let expires_at = exp_sec * 1000 in
85
-
let claims =
86
-
`Assoc
87
-
[ ("jti", `String token_id)
88
-
; ("sub", `String did)
89
-
; ("iat", `Int now_sec)
90
-
; ("exp", `Int exp_sec)
91
-
; ("scope", `String orig_req.scope)
92
-
; ("aud", `String Env.host_endpoint)
93
-
; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ]
94
-
in
95
-
let access_token =
96
-
Jwt.sign_jwt claims ~typ:"at+jwt"
97
-
~signing_key:Env.jwt_key
98
-
in
99
-
let%lwt () =
100
-
Queries.insert_oauth_token ctx.db
101
-
{ refresh_token
102
-
; client_id= req.client_id
103
-
; did
104
-
; dpop_jkt= proof.jkt
105
-
; scope= orig_req.scope
106
-
; created_at= now_ms
107
-
; last_refreshed_at= now_ms
108
-
; expires_at
109
-
; last_ip= ip
110
-
; last_user_agent= user_agent }
111
-
in
112
-
let nonce = Dpop.next_nonce () in
113
-
Dream.json
114
-
~headers:
115
-
[ ("DPoP-Nonce", nonce)
116
-
; ("Access-Control-Expose-Headers", "DPoP-Nonce")
117
-
; ("Cache-Control", "no-store") ]
118
-
@@ Yojson.Safe.to_string
119
-
@@ `Assoc
120
-
[ ("access_token", `String access_token)
121
-
; ("token_type", `String "DPoP")
122
-
; ("refresh_token", `String refresh_token)
123
-
; ("expires_in", `Int expires_in)
124
-
; ("scope", `String orig_req.scope)
125
-
; ("sub", `String did) ] ) ) ) )
33
+
| Some par_record -> (
34
+
match
35
+
Yojson.Safe.from_string par_record.request_data
36
+
|> Types.par_request_of_yojson
37
+
with
38
+
| Error _ ->
39
+
Errors.invalid_request
40
+
"stored par request formatted incorrectly"
41
+
| Ok orig_req ->
42
+
( match req.redirect_uri with
43
+
| None ->
44
+
Errors.invalid_request "redirect_uri required"
45
+
| Some uri when uri <> orig_req.redirect_uri ->
46
+
Errors.invalid_request "redirect_uri mismatch"
47
+
| _ ->
48
+
() ) ;
49
+
( match req.code_verifier with
50
+
| None ->
51
+
Errors.invalid_request "code_verifier required"
52
+
| Some verifier ->
53
+
let computed =
54
+
Digestif.SHA256.digest_string verifier
55
+
|> Digestif.SHA256.to_raw_string
56
+
|> Base64.(
57
+
encode_exn ~pad:false
58
+
~alphabet:uri_safe_alphabet )
59
+
in
60
+
if orig_req.code_challenge <> computed then
61
+
Errors.invalid_request "invalid code_verifier"
62
+
) ;
63
+
( match par_record.dpop_jkt with
64
+
| Some stored when stored <> proof.jkt ->
65
+
Errors.invalid_request "DPoP key mismatch"
66
+
| _ ->
67
+
() ) ;
68
+
let token_id =
69
+
"tok-"
70
+
^ Uuidm.to_string
71
+
(Uuidm.v4_gen
72
+
(Random.State.make_self_init ())
73
+
() )
74
+
in
75
+
let refresh_token =
76
+
"ref-"
77
+
^ Uuidm.to_string
78
+
(Uuidm.v4_gen
79
+
(Random.State.make_self_init ())
80
+
() )
81
+
in
82
+
let now_sec = int_of_float (Unix.gettimeofday ()) in
83
+
let now_ms = Util.now_ms () in
84
+
let expires_in =
85
+
Constants.access_token_expiry_ms / 1000
86
+
in
87
+
let exp_sec = now_sec + expires_in in
88
+
let expires_at = exp_sec * 1000 in
89
+
let claims =
90
+
`Assoc
91
+
[ ("jti", `String token_id)
92
+
; ("sub", `String did)
93
+
; ("iat", `Int now_sec)
94
+
; ("exp", `Int exp_sec)
95
+
; ("scope", `String orig_req.scope)
96
+
; ("aud", `String Env.host_endpoint)
97
+
; ("cnf", `Assoc [("jkt", `String proof.jkt)])
98
+
]
99
+
in
100
+
let access_token =
101
+
Jwt.sign_jwt claims ~typ:"at+jwt"
102
+
~signing_key:Env.jwt_key
103
+
in
104
+
let%lwt () =
105
+
Queries.insert_oauth_token ctx.db
106
+
{ refresh_token
107
+
; client_id= req.client_id
108
+
; did
109
+
; dpop_jkt= proof.jkt
110
+
; scope= orig_req.scope
111
+
; created_at= now_ms
112
+
; last_refreshed_at= now_ms
113
+
; expires_at
114
+
; last_ip= ip
115
+
; last_user_agent= user_agent }
116
+
in
117
+
let nonce = Dpop.next_nonce () in
118
+
Dream.json
119
+
~headers:
120
+
[ ("DPoP-Nonce", nonce)
121
+
; ("Access-Control-Expose-Headers", "DPoP-Nonce")
122
+
; ("Cache-Control", "no-store") ]
123
+
@@ Yojson.Safe.to_string
124
+
@@ `Assoc
125
+
[ ("access_token", `String access_token)
126
+
; ("token_type", `String "DPoP")
127
+
; ("refresh_token", `String refresh_token)
128
+
; ("expires_in", `Int expires_in)
129
+
; ("scope", `String orig_req.scope)
130
+
; ("sub", `String did) ] ) ) ) ) )
126
131
| "refresh_token" -> (
127
132
match req.refresh_token with
128
133
| None ->
+19
-13
pegasus/lib/auth.ml
+19
-13
pegasus/lib/auth.ml
···
25
25
| Ok (_, payload) -> (
26
26
try
27
27
let now_s = int_of_float (Unix.gettimeofday ()) in
28
-
let jwt = Jwt.symmetric_jwt_of_yojson payload |> Result.get_ok in
29
-
if jwt.aud <> Env.did then Lwt.return_error "invalid aud"
30
-
else if jwt.sub = "" then Lwt.return_error "missing sub"
31
-
else if now_s < jwt.iat then Lwt.return_error "token issued in the future"
32
-
else if now_s > jwt.exp then Lwt.return_error "expired token"
33
-
else if jwt.scope <> expected_scope then Lwt.return_error "invalid scope"
34
-
else if jwt.jti = "" then Lwt.return_error "missing jti"
35
-
else
36
-
let%lwt revoked_at =
37
-
Data_store.is_token_revoked t ~did:jwt.sub ~jti:jwt.jti
38
-
in
39
-
if revoked_at <> None then Lwt.return_error "token revoked"
40
-
else Lwt.return_ok jwt
28
+
match Jwt.symmetric_jwt_of_yojson payload with
29
+
| Error e ->
30
+
Dream.debug (fun log -> log "bearer jwt decode error: %s" e) ;
31
+
Lwt.return_error "invalid token format"
32
+
| Ok jwt ->
33
+
if jwt.aud <> Env.did then Lwt.return_error "invalid aud"
34
+
else if jwt.sub = "" then Lwt.return_error "missing sub"
35
+
else if now_s < jwt.iat then
36
+
Lwt.return_error "token issued in the future"
37
+
else if now_s > jwt.exp then Lwt.return_error "expired token"
38
+
else if jwt.scope <> expected_scope then
39
+
Lwt.return_error "invalid scope"
40
+
else if jwt.jti = "" then Lwt.return_error "missing jti"
41
+
else
42
+
let%lwt revoked_at =
43
+
Data_store.is_token_revoked t ~did:jwt.sub ~jti:jwt.jti
44
+
in
45
+
if revoked_at <> None then Lwt.return_error "token revoked"
46
+
else Lwt.return_ok jwt
41
47
with _ -> Lwt.return_error "invalid token format" )
42
48
43
49
let verify_auth ?(refresh = false) credentials did =
+13
pegasus/lib/env.ml
+13
pegasus/lib/env.ml
···
2
2
try Sys.getenv name
3
3
with Not_found -> failwith ("Missing environment variable " ^ name)
4
4
5
+
let log_level =
6
+
match Sys.getenv_opt "PDS_LOG_LEVEL" |> Option.map String.lowercase_ascii with
7
+
| Some "debug" ->
8
+
`Debug
9
+
| Some "info" ->
10
+
`Info
11
+
| Some "warn" | Some "warning" ->
12
+
`Warning
13
+
| Some "error" ->
14
+
`Error
15
+
| _ ->
16
+
`Info
17
+
5
18
let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "PDS_DATA_DIR"
6
19
7
20
let hostname = getenv "PDS_HOSTNAME"
+76
-70
pegasus/lib/oauth/dpop.ml
+76
-70
pegasus/lib/oauth/dpop.ml
···
7
7
; rotation_interval_ms: int64 }
8
8
9
9
type ec_jwk = {crv: string; kty: string; x: string; y: string}
10
-
[@@deriving yojson]
10
+
[@@deriving yojson {strict= false}]
11
11
12
12
type proof = {jti: string; jkt: string; htm: string; htu: string}
13
-
[@@deriving yojson]
13
+
[@@deriving yojson {strict= false}]
14
14
15
15
let jti_cache : (string, int) Hashtbl.t =
16
16
Hashtbl.create Constants.jti_cache_size
···
133
133
if alg <> "ES256" && alg <> "ES256K" then
134
134
Error "only es256 and es256k supported for dpop"
135
135
else
136
-
let jwk =
137
-
header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok
138
-
in
139
-
if
140
-
not
141
-
( match (alg, jwk.crv) with
142
-
| "ES256", "P-256" ->
143
-
true
144
-
| "ES256K", "secp256k1" ->
145
-
true
146
-
| _ ->
147
-
false )
148
-
then
149
-
Error
150
-
(Printf.sprintf "algorithm %s doesn't match curve %s" alg
151
-
jwk.crv )
152
-
else
153
-
let jti = payload |> member "jti" |> to_string in
154
-
let htm = payload |> member "htm" |> to_string in
155
-
let htu = payload |> member "htu" |> to_string in
156
-
let iat = payload |> member "iat" |> to_int in
157
-
let nonce_claim =
158
-
payload |> member "nonce" |> to_string_option
159
-
in
160
-
match nonce_claim with
161
-
(* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
162
-
| None ->
163
-
Error "use_dpop_nonce"
164
-
| Some n when not (verify_nonce n) ->
165
-
Error "use_dpop_nonce"
166
-
| Some _ -> (
167
-
if htm <> mthd then Error "htm mismatch"
168
-
else if
169
-
not (String.equal (normalize_url htu) (normalize_url url))
170
-
then Error "htu mismatch"
171
-
else
172
-
let now = int_of_float (Unix.gettimeofday ()) in
173
-
if now - iat > Constants.max_dpop_age_s then
174
-
Error "dpop proof too old"
175
-
else if iat - now > 5 then Error "dpop proof in future"
176
-
else if not (add_jti jti) then
177
-
Error "dpop proof replay detected"
178
-
else if
179
-
not (try verify_signature jwt jwk with _ -> false)
180
-
then Error "invalid dpop signature"
181
-
else
182
-
let jkt = compute_jwk_thumbprint jwk in
183
-
(* verify ath if access token is provided *)
184
-
match access_token with
185
-
| Some token ->
186
-
let ath_claim =
187
-
payload |> member "ath" |> to_string_option
188
-
in
189
-
let expected_ath =
190
-
Digestif.SHA256.(
191
-
digest_string token |> to_raw_string
192
-
|> Jwt.b64_encode )
193
-
in
194
-
if Some expected_ath <> ath_claim then
195
-
Error "ath mismatch"
196
-
else Ok {jti; jkt; htm; htu}
197
-
| None ->
198
-
let ath_claim =
199
-
payload |> member "ath" |> to_string_option
200
-
in
201
-
if ath_claim <> None then
202
-
Error "ath claim not allowed without access token"
203
-
else Ok {jti; jkt; htm; htu} ) )
136
+
match header |> member "jwk" |> ec_jwk_of_yojson with
137
+
| Error e ->
138
+
Dream.debug (fun log -> log "error parsing jwk: %s" e) ;
139
+
Errors.internal_error ()
140
+
| Ok jwk -> (
141
+
if
142
+
not
143
+
( match (alg, jwk.crv) with
144
+
| "ES256", "P-256" ->
145
+
true
146
+
| "ES256K", "secp256k1" ->
147
+
true
148
+
| _ ->
149
+
false )
150
+
then
151
+
Error
152
+
(Printf.sprintf "algorithm %s doesn't match curve %s" alg
153
+
jwk.crv )
154
+
else
155
+
let jti = payload |> member "jti" |> to_string in
156
+
let htm = payload |> member "htm" |> to_string in
157
+
let htu = payload |> member "htu" |> to_string in
158
+
let iat = payload |> member "iat" |> to_int in
159
+
let nonce_claim =
160
+
payload |> member "nonce" |> to_string_option
161
+
in
162
+
match nonce_claim with
163
+
(* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *)
164
+
| None ->
165
+
Error "use_dpop_nonce"
166
+
| Some n when not (verify_nonce n) ->
167
+
Error "use_dpop_nonce"
168
+
| Some _ -> (
169
+
if htm <> mthd then Error "htm mismatch"
170
+
else if
171
+
not
172
+
(String.equal (normalize_url htu)
173
+
(normalize_url url) )
174
+
then Error "htu mismatch"
175
+
else
176
+
let now = int_of_float (Unix.gettimeofday ()) in
177
+
if now - iat > Constants.max_dpop_age_s then
178
+
Error "dpop proof too old"
179
+
else if iat - now > 5 then
180
+
Error "dpop proof in future"
181
+
else if not (add_jti jti) then
182
+
Error "dpop proof replay detected"
183
+
else if
184
+
not (try verify_signature jwt jwk with _ -> false)
185
+
then Error "invalid dpop signature"
186
+
else
187
+
let jkt = compute_jwk_thumbprint jwk in
188
+
(* verify ath if access token is provided *)
189
+
match access_token with
190
+
| Some token ->
191
+
let ath_claim =
192
+
payload |> member "ath" |> to_string_option
193
+
in
194
+
let expected_ath =
195
+
Digestif.SHA256.(
196
+
digest_string token |> to_raw_string
197
+
|> Jwt.b64_encode )
198
+
in
199
+
if Some expected_ath <> ath_claim then
200
+
Error "ath mismatch"
201
+
else Ok {jti; jkt; htm; htu}
202
+
| None ->
203
+
let ath_claim =
204
+
payload |> member "ath" |> to_string_option
205
+
in
206
+
if ath_claim <> None then
207
+
Error
208
+
"ath claim not allowed without access token"
209
+
else Ok {jti; jkt; htm; htu} ) ) )
204
210
| _ ->
205
211
Error "invalid dpop jwt" )
+43
-38
pegasus/lib/repository.ml
+43
-38
pegasus/lib/repository.ml
···
38
38
let type' = member "$type" json |> to_string in
39
39
let collection = member "collection" json |> to_string in
40
40
let rkey = match member "rkey" json with `String s -> Some s | _ -> None in
41
-
let swap_record =
42
-
match member "swapRecord" json with
43
-
| `String s ->
44
-
s |> Cid.of_string |> Result.get_ok |> Option.some
41
+
try
42
+
let swap_record =
43
+
match member "swapRecord" json with
44
+
| `String s ->
45
+
s |> Cid.of_string |> Result.get_ok |> Option.some
46
+
| _ ->
47
+
None
48
+
in
49
+
match type' with
50
+
| "com.atproto.repo.applyWrites#create" ->
51
+
let value =
52
+
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
53
+
in
54
+
Ok (Create {type'; collection; rkey; value})
55
+
| "com.atproto.repo.applyWrites#update" ->
56
+
let value =
57
+
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
58
+
in
59
+
Ok
60
+
(Update {type'; collection; rkey= Option.get rkey; value; swap_record})
61
+
| "com.atproto.repo.applyWrites#delete" ->
62
+
Ok (Delete {type'; collection; rkey= Option.get rkey; swap_record})
45
63
| _ ->
46
-
None
47
-
in
48
-
match type' with
49
-
| "com.atproto.repo.applyWrites#create" ->
50
-
let value =
51
-
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
52
-
in
53
-
Ok (Create {type'; collection; rkey; value})
54
-
| "com.atproto.repo.applyWrites#update" ->
55
-
let value =
56
-
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
57
-
in
58
-
Ok (Update {type'; collection; rkey= Option.get rkey; value; swap_record})
59
-
| "com.atproto.repo.applyWrites#delete" ->
60
-
Ok (Delete {type'; collection; rkey= Option.get rkey; swap_record})
61
-
| _ ->
62
-
Error "invalid applyWrites write $type"
64
+
Error "invalid applyWrites write $type"
65
+
with Invalid_argument e -> Error ("invalid property " ^ e)
63
66
64
67
let repo_write_to_yojson = function
65
68
| Create {type'; collection; rkey; value} ->
···
101
104
let apply_writes_result_of_yojson (json : Yojson.Safe.t) =
102
105
let open Yojson.Safe.Util in
103
106
let type' = member "$type" json |> to_string in
104
-
match type' with
105
-
| "com.atproto.repo.applyWrites#createResult" ->
106
-
let uri = member "uri" json |> to_string in
107
-
let cid =
108
-
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
109
-
in
110
-
Ok (Create {type'; uri; cid})
111
-
| "com.atproto.repo.applyWrites#updateResult" ->
112
-
let uri = member "uri" json |> to_string in
113
-
let cid =
114
-
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
115
-
in
116
-
Ok (Update {type'; uri; cid})
117
-
| "com.atproto.repo.applyWrites#deleteResult" ->
118
-
Ok (Delete {type'})
119
-
| _ ->
120
-
Error "invalid applyWrites result $type"
107
+
try
108
+
match type' with
109
+
| "com.atproto.repo.applyWrites#createResult" ->
110
+
let uri = member "uri" json |> to_string in
111
+
let cid =
112
+
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
113
+
in
114
+
Ok (Create {type'; uri; cid})
115
+
| "com.atproto.repo.applyWrites#updateResult" ->
116
+
let uri = member "uri" json |> to_string in
117
+
let cid =
118
+
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
119
+
in
120
+
Ok (Update {type'; uri; cid})
121
+
| "com.atproto.repo.applyWrites#deleteResult" ->
122
+
Ok (Delete {type'})
123
+
| _ ->
124
+
Error "invalid applyWrites result $type"
125
+
with Invalid_argument e -> Error ("invalid property " ^ e)
121
126
122
127
let apply_writes_result_to_yojson = function
123
128
| Create {type'; uri; cid} ->
+12
-2
pegasus/lib/xrpc.ml
+12
-2
pegasus/lib/xrpc.ml
···
139
139
(k, try Yojson.Safe.from_string v with _ -> `String v) )
140
140
queries )
141
141
in
142
-
query_json |> of_yojson |> Result.get_ok
142
+
match query_json |> of_yojson with
143
+
| Error e ->
144
+
Dream.debug (fun log -> log "error parsing query: %s" e) ;
145
+
Errors.internal_error ()
146
+
| Ok query ->
147
+
query
143
148
with _ -> Errors.invalid_request "invalid query string"
144
149
145
150
let parse_body (req : Dream.request)
146
151
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
147
152
try%lwt
148
153
let%lwt body = Dream.body req in
149
-
body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return
154
+
match body |> Yojson.Safe.from_string |> of_yojson with
155
+
| Error e ->
156
+
Dream.debug (fun log -> log "error parsing body: %s" e) ;
157
+
Errors.internal_error ()
158
+
| Ok body ->
159
+
Lwt.return body
150
160
with _ -> Errors.invalid_request "invalid request body"
151
161
152
162
let parse_proxy_header req =