futur.blue
objective categorical abstract machine language personal data server
par
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+1
-1
pegasus/lib/api/identity/updateHandle.ml
+1
-1
pegasus/lib/api/identity/updateHandle.ml
···
1
1
type request = {handle: string} [@@deriving yojson]
2
2
3
3
let handler =
4
-
Xrpc.handler ~auth:Authorization (fun {req; auth; db} ->
4
+
Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->
5
5
let did = Auth.get_authed_did_exn auth in
6
6
let%lwt body = Dream.body req in
7
7
let handle =
+62
pegasus/lib/api/oauth_/par.ml
+62
pegasus/lib/api/oauth_/par.ml
···
1
+
type 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
+
[@@deriving yojson]
11
+
12
+
let handler =
13
+
Xrpc.handler (fun ctx ->
14
+
let%lwt proof =
15
+
Oauth.Dpop.verify_dpop_proof ctx.dpop ~mthd:"POST" ~url:"/oauth/par"
16
+
~dpop_header:(Dream.header ctx.req "DPoP")
17
+
()
18
+
in
19
+
match proof with
20
+
| Error "use_dpop_nonce" ->
21
+
let nonce = Oauth.Dpop.next_nonce ctx.dpop.nonce_state in
22
+
Dream.json ~status:`Bad_Request ~headers:[("DPoP-Nonce", nonce)]
23
+
@@ Yojson.Safe.to_string
24
+
@@ `Assoc [("error", `String "use_dpop_nonce")]
25
+
| Error e ->
26
+
Errors.invalid_request e
27
+
| Ok proof ->
28
+
let%lwt req = Xrpc.parse_body ctx.req request_of_yojson in
29
+
let%lwt client = Oauth.Client.fetch_client_metadata req.client_id in
30
+
if req.response_type <> "code" then
31
+
Errors.invalid_request "only response_type=code supported"
32
+
else if req.code_challenge_method <> "S256" then
33
+
Errors.invalid_request "only S256 code_challenge_method supported"
34
+
else if not (List.mem req.redirect_uri client.redirect_uris) then
35
+
Errors.invalid_request "invalid redirect_uri"
36
+
else
37
+
let request_id =
38
+
"req-" ^ (Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string)
39
+
in
40
+
let request_uri =
41
+
"urn:ietf:params:oauth:request_uri:" ^ request_id
42
+
in
43
+
let expires_at = Util.now_ms () + (5 * 60 * 1000) in
44
+
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 )
56
+
in
57
+
Dream.json ~status:`Created
58
+
~headers:[("DPoP-Nonce", Oauth.Dpop.next_nonce ctx.dpop.nonce_state)]
59
+
@@ Yojson.Safe.to_string
60
+
@@ `Assoc
61
+
[ ("request_uri", `String request_uri)
62
+
; ("expires_in", `Int 300) ])
+1
-1
pegasus/lib/api/server/createSession.ml
+1
-1
pegasus/lib/api/server/createSession.ml
+1
-1
pegasus/lib/api/server/getServiceAuth.ml
+1
-1
pegasus/lib/api/server/getServiceAuth.ml
···
1
1
type response = {token: string} [@@deriving yojson {strict= false}]
2
2
3
3
let handler =
4
-
Xrpc.handler ~auth:Authorization (fun {req; auth; db} ->
4
+
Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->
5
5
let did = Auth.get_authed_did_exn auth in
6
6
let aud, lxm =
7
7
match (Dream.query req "aud", Dream.query req "lxm") with
+117
-23
pegasus/lib/data_store.ml
+117
-23
pegasus/lib/data_store.ml
···
36
36
created_at INTEGER NOT NULL,
37
37
deactivated_at INTEGER
38
38
)
39
-
|sql}]
39
+
|sql}]
40
40
() conn
41
41
in
42
42
let$! () =
···
52
52
[%rapper
53
53
execute
54
54
{sql| CREATE TABLE IF NOT EXISTS invite_codes (
55
-
code TEXT PRIMARY KEY,
56
-
did TEXT NOT NULL,
57
-
remaining INTEGER NOT NULL
58
-
)
59
-
|sql}]
55
+
code TEXT PRIMARY KEY,
56
+
did TEXT NOT NULL,
57
+
remaining INTEGER NOT NULL
58
+
)
59
+
|sql}]
60
60
() conn
61
61
in
62
62
let$! () =
63
63
[%rapper
64
64
execute
65
65
{sql| CREATE TABLE IF NOT EXISTS firehose (
66
-
seq INTEGER PRIMARY KEY,
67
-
time INTEGER NOT NULL,
68
-
t TEXT NOT NULL,
69
-
data BLOB NOT NULL
70
-
)
71
-
|sql}]
66
+
seq INTEGER PRIMARY KEY,
67
+
time INTEGER NOT NULL,
68
+
t TEXT NOT NULL,
69
+
data BLOB NOT NULL
70
+
)
71
+
|sql}]
72
72
() conn
73
73
in
74
-
[%rapper
75
-
execute
76
-
(* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)
77
-
{sql| CREATE TABLE IF NOT EXISTS revoked_tokens (
78
-
did TEXT NOT NULL,
79
-
jti TEXT NOT NULL,
80
-
revoked_at INTEGER NOT NULL,
81
-
PRIMARY KEY (did, jti)
82
-
)
83
-
|sql}]
84
-
() conn
74
+
let$! () =
75
+
[%rapper
76
+
execute
77
+
(* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *)
78
+
{sql| CREATE TABLE IF NOT EXISTS revoked_tokens (
79
+
did TEXT NOT NULL,
80
+
jti TEXT NOT NULL,
81
+
revoked_at INTEGER NOT NULL,
82
+
PRIMARY KEY (did, jti)
83
+
)
84
+
|sql}]
85
+
() conn
86
+
in
87
+
let$! () =
88
+
[%rapper
89
+
execute
90
+
{sql| CREATE TABLE IF NOT EXISTS oauth_requests (
91
+
request_id TEXT PRIMARY KEY,
92
+
client_id TEXT NOT NULL,
93
+
request_data TEXT NOT NULL,
94
+
dpop_jkt TEXT,
95
+
expires_at INTEGER NOT NULL,
96
+
created_at INTEGER NOT NULL
97
+
)
98
+
|sql}]
99
+
() conn
100
+
in
101
+
let$! () =
102
+
[%rapper
103
+
execute
104
+
{sql| CREATE TABLE IF NOT EXISTS oauth_codes (
105
+
code TEXT PRIMARY KEY,
106
+
request_id TEXT NOT NULL REFERENCES oauth_requests(request_id),
107
+
authorized_by TEXT,
108
+
authorized_at INTEGER,
109
+
expires_at INTEGER NOT NULL,
110
+
used BOOLEAN DEFAULT FALSE
111
+
)
112
+
|sql}]
113
+
() conn
114
+
in
115
+
let$! () =
116
+
[%rapper
117
+
execute
118
+
{sql| CREATE TABLE IF NOT EXISTS oauth_tokens (
119
+
id INTEGER PRIMARY KEY,
120
+
token_id TEXT UNIQUE NOT NULL,
121
+
refresh_token TEXT UNIQUE NOT NULL,
122
+
client_id TEXT NOT NULL,
123
+
did TEXT NOT NULL,
124
+
dpop_jkt TEXT,
125
+
scope TEXT NOT NULL,
126
+
created_at INTEGER NOT NULL,
127
+
expires_at INTEGER NOT NULL,
128
+
last_refreshed_at INTEGER NOT NULL
129
+
)
130
+
|sql}]
131
+
() conn
132
+
in
133
+
let$! () =
134
+
[%rapper
135
+
execute
136
+
{sql| CREATE INDEX oauth_requests_expires_idx ON oauth_requests(expires_at);
137
+
CREATE INDEX oauth_codes_expires_idx ON oauth_codes(expires_at);
138
+
CREATE INDEX oauth_tokens_refresh_idx ON oauth_tokens(refresh_token);
139
+
|sql}]
140
+
() conn
141
+
in
142
+
let$! () =
143
+
[%rapper
144
+
execute
145
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests
146
+
AFTER INSERT ON oauth_requests
147
+
BEGIN
148
+
DELETE FROM oauth_requests WHERE expires_at < unixepoch() * 1000;
149
+
END
150
+
|sql}
151
+
syntax_off]
152
+
() conn
153
+
in
154
+
let$! () =
155
+
[%rapper
156
+
execute
157
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes
158
+
AFTER INSERT ON oauth_codes
159
+
BEGIN
160
+
DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000;
161
+
END
162
+
|sql}
163
+
syntax_off]
164
+
() conn
165
+
in
166
+
let$! () =
167
+
[%rapper
168
+
execute
169
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens
170
+
AFTER INSERT ON oauth_tokens
171
+
BEGIN
172
+
DELETE FROM oauth_tokens WHERE expires_at < unixepoch() * 1000;
173
+
END
174
+
|sql}
175
+
syntax_off]
176
+
() conn
177
+
in
178
+
Lwt.return_ok ()
85
179
86
180
let create_actor =
87
181
[%rapper
+13
pegasus/lib/env.ml
+13
pegasus/lib/env.ml
···
13
13
let jwt_key = Sys.getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str
14
14
15
15
let admin_password = Sys.getenv "ADMIN_PASSWORD"
16
+
17
+
let dpop_nonce_secret =
18
+
match Sys.getenv_opt "DPOP_NONCE_SECRET" with
19
+
| Some sec ->
20
+
let secret = Base64.decode_exn sec |> Bytes.of_string in
21
+
if Bytes.length secret = 32 then secret
22
+
else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64"
23
+
| None ->
24
+
let secret = Mirage_crypto_rng_unix.getrandom 32 in
25
+
Dream.warning (fun log ->
26
+
log "DPOP_NONCE_SECRET not set; using DPOP_NONCE_SECRET=%s"
27
+
(Base64.encode secret |> Result.get_ok) ) ;
28
+
Bytes.of_string secret
+7
-1
pegasus/lib/oauth/dpop.ml
+7
-1
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}
12
+
11
13
let create_nonce_state ?(rotation_interval_ms = 60_000L) secret =
12
14
let counter =
13
15
Int64.div
···
101
103
| _ ->
102
104
false
103
105
104
-
let verify_dpop_proof ~nonce_state ~jti_cache ~mthd ~url ~dpop_header
106
+
let verify_dpop_proof {nonce_state; jti_cache} ~mthd ~url ~dpop_header
105
107
?access_token () =
106
108
match dpop_header with
107
109
| None ->
···
173
175
else Lwt.return_ok {jti; jkt; htm; htu} ) )
174
176
| _ ->
175
177
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 }
+11
-2
pegasus/lib/xrpc.ml
+11
-2
pegasus/lib/xrpc.ml
···
3
3
4
4
type init = Auth.Verifiers.ctx
5
5
6
-
type context = {req: Dream.request; db: Data_store.t; auth: Auth.credentials}
6
+
type context =
7
+
{ req: Dream.request
8
+
; db: Data_store.t
9
+
; auth: Auth.credentials
10
+
; dpop: Oauth.Dpop.context }
7
11
8
12
type handler = context -> Dream.response Lwt.t
9
13
···
12
16
let auth = Auth.Verifiers.of_t auth in
13
17
match%lwt auth init with
14
18
| Ok creds -> (
15
-
try%lwt hdlr {req= init.req; db= init.db; auth= 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 }
16
25
with e ->
17
26
( match is_xrpc_error e with
18
27
| true ->