anil.recoil.org
ActivityPub in OCaml using jsont/eio/requests
Add Eio clock to HTTP signature validation (RFC 9421)
HTTP Message Signatures now use an explicit Eio clock for time validation
instead of Ptime_clock.now(), making the code testable and consistent with
Eio's capability-passing design.
Time validations now performed:
- Signatures with `expires` in the past are rejected
- Signatures with `created` in the future (beyond 60s clock skew) are rejected
- If `max_age` is specified and `created` is older, signature is rejected
API changes:
- sign/sign_with_digest now require ~clock parameter
- verify/verify_all now require ~clock parameter
- Auth.apply_signature now requires ~clock parameter
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+21
-17
lib/client/apubt.ml
+21
-17
lib/client/apubt.ml
···
84
84
let key t = t.key
85
85
end
86
86
87
-
type t = {
87
+
type t = T : {
88
88
requests : Requests.t;
89
+
clock : _ Eio.Time.clock;
89
90
signing : Signing.t option;
90
91
user_agent : string;
91
-
}
92
+
} -> t
92
93
93
94
let activitypub_accept =
94
95
"application/activity+json, application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""
···
101
102
|> Requests.Headers.add `User_agent user_agent
102
103
in
103
104
let requests = Requests.create ~sw ~default_headers ~timeout:timeout_config env in
104
-
{ requests; signing; user_agent }
105
+
let clock = Eio.Stdenv.clock env in
106
+
T { requests; clock; signing; user_agent }
105
107
106
-
let user_agent t = t.user_agent
108
+
let user_agent (T t) = t.user_agent
107
109
108
110
(* Internal: check HTTP response for errors *)
109
111
let check_response resp =
···
125
127
end
126
128
127
129
module Http = struct
128
-
let get t uri =
130
+
let get (T t) uri =
129
131
let url = Uri.to_string uri in
130
132
let resp = Requests.get t.requests url in
131
133
check_response resp;
132
134
Requests.Response.json resp
133
135
134
-
let get_typed t jsont uri =
136
+
let get_typed (T t) jsont uri =
135
137
let url = Uri.to_string uri in
136
138
let resp = Requests.get t.requests url in
137
139
check_response resp;
138
140
Requests.Response.jsonv jsont resp
139
141
140
142
(* Internal: sign a POST request if signing is configured *)
141
-
let sign_post_request t ~uri ~body ~headers =
143
+
let sign_post_request (T t) ~uri ~body ~headers =
142
144
match t.signing with
143
145
| None -> headers
144
146
| Some signing ->
145
-
(* Add Date header *)
146
-
let now = Ptime_clock.now () in
147
+
(* Add Date header using the session clock *)
148
+
let now_float = Eio.Time.now t.clock in
149
+
let now = Ptime.of_float_s now_float |> Option.get in
147
150
let date_str = Requests.Headers.http_date_of_ptime now in
148
151
let headers = Requests.Headers.set `Date date_str headers in
149
152
(* Create request context for signing *)
···
154
157
in
155
158
(* Sign with digest (adds Content-Digest header and signs) *)
156
159
match Requests.Signature.sign_with_digest
160
+
~clock:t.clock
157
161
~config:signing.config
158
162
~context:ctx
159
163
~headers
···
171
175
| Ok s -> s
172
176
| Error msg -> raise (E (Json_error msg))
173
177
174
-
let post t uri body =
178
+
let post (T t as client) uri body =
175
179
let url = Uri.to_string uri in
176
180
let body_str = encode_json_exn Jsont.json body in
177
181
let headers =
178
182
Requests.Headers.empty
179
183
|> Requests.Headers.set `Content_type "application/activity+json"
180
184
in
181
-
let headers = sign_post_request t ~uri ~body:body_str ~headers in
185
+
let headers = sign_post_request client ~uri ~body:body_str ~headers in
182
186
let resp = Requests.post t.requests ~headers ~body:(Requests.Body.of_string Requests.Mime.json body_str) url in
183
187
check_response resp
184
188
185
-
let post_typed t jsont uri value =
189
+
let post_typed (T t as client) jsont uri value =
186
190
let url = Uri.to_string uri in
187
191
let body_str = encode_json_exn jsont value in
188
192
let headers =
189
193
Requests.Headers.empty
190
194
|> Requests.Headers.set `Content_type "application/activity+json"
191
195
in
192
-
let headers = sign_post_request t ~uri ~body:body_str ~headers in
196
+
let headers = sign_post_request client ~uri ~body:body_str ~headers in
193
197
let resp = Requests.post t.requests ~headers ~body:(Requests.Body.of_string Requests.Mime.json body_str) url in
194
198
check_response resp
195
199
end
···
225
229
~links
226
230
()
227
231
228
-
let lookup t acct =
232
+
let lookup (T t) acct =
229
233
(* Parse the account string into an Acct.t *)
230
234
let acct_uri =
231
235
(* Handle both "user@domain" and "acct:user@domain" formats *)
···
243
247
| Error e -> raise (E (Webfinger_error (Webfinger.error_to_string e)))
244
248
245
249
(** Look up using webfinger library and return the raw Webfinger.Jrd.t *)
246
-
let lookup_raw t acct =
250
+
let lookup_raw (T t) acct =
247
251
let acct_uri =
248
252
let acct_str =
249
253
if String.starts_with ~prefix:"acct:" acct then acct
···
335
339
|> Jsont.Object.finish
336
340
end
337
341
338
-
let fetch t ~host =
342
+
let fetch (T t) ~host =
339
343
(* Step 1: Fetch the well-known nodeinfo discovery document *)
340
344
let well_known_url = Printf.sprintf "https://%s/.well-known/nodeinfo" host in
341
345
let headers =
···
527
531
let inbox = Actor.inbox t actor in
528
532
post t ~inbox activity
529
533
530
-
let discover_shared_inbox t ~host =
534
+
let discover_shared_inbox (T t) ~host =
531
535
(* Try to get shared inbox from instance actor endpoint *)
532
536
let instance_actor_url = Printf.sprintf "https://%s/actor" host in
533
537
try