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