gdiazlo.tngl.sh
+1
-1
atproto-api.opam
+1
-1
atproto-api.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "High-level API client for AT Protocol"
5
5
description:
6
6
"User-friendly API client for AT Protocol with session management, posting, and social actions"
+1
-1
atproto-crypto.opam
+1
-1
atproto-crypto.opam
+1
-1
atproto-effects.opam
+1
-1
atproto-effects.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "Effects-based I/O abstraction for AT Protocol"
5
5
description:
6
6
"Unified effect types for HTTP, DNS, WebSocket, time, and random operations. Allows libraries to be runtime-agnostic."
+1
-1
atproto-identity.opam
+1
-1
atproto-identity.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "DID and Handle resolution for AT Protocol"
5
5
description:
6
6
"DID and Handle resolution including did:plc, did:web, and DNS/HTTPS handle resolution"
+1
-1
atproto-ipld.opam
+1
-1
atproto-ipld.opam
+1
-1
atproto-json.opam
+1
-1
atproto-json.opam
+1
-1
atproto-lexicon.opam
+1
-1
atproto-lexicon.opam
+1
-1
atproto-mst.opam
+1
-1
atproto-mst.opam
+1
-1
atproto-multibase.opam
+1
-1
atproto-multibase.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "Base encoding utilities for AT Protocol"
5
5
description:
6
6
"Multibase encoding/decoding including base32-sortable for TIDs and base58btc for did:key"
+1
-1
atproto-repo.opam
+1
-1
atproto-repo.opam
+1
-1
atproto-sync.opam
+1
-1
atproto-sync.opam
+1
-1
atproto-syntax.opam
+1
-1
atproto-syntax.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "Syntax validation for AT Protocol identifiers"
5
5
description:
6
6
"Parser-based validation for handles, DIDs, NSIDs, TIDs, AT-URIs, and other AT Protocol syntax"
+1
-1
atproto-xrpc.opam
+1
-1
atproto-xrpc.opam
+1
-1
atproto.opam
+1
-1
atproto.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
version: "0.1.1"
3
+
version: "0.1.2"
4
4
synopsis: "AT Protocol implementation in OCaml"
5
5
description:
6
6
"Complete AT Protocol implementation including syntax validation, cryptography, IPLD, and identity resolution"
-2
bin/dune
-2
bin/dune
+1
-1
dune-project
+1
-1
dune-project
+62
-77
examples/bsky_bot/bsky_bot.ml
+62
-77
examples/bsky_bot/bsky_bot.ml
···
5
5
module Richtext = Atproto_api.Richtext
6
6
module Client = Atproto_xrpc.Client
7
7
8
-
(** {1 HTTP Client with cohttp-eio} *)
9
-
10
-
let http_request ~sw ~client (req : Client.request) : Client.response =
11
-
let headers = Cohttp.Header.of_list req.headers in
12
-
let body =
13
-
match req.body with
14
-
| Some b -> Cohttp_eio.Body.of_string b
15
-
| None -> Cohttp_eio.Body.of_string ""
8
+
let http_request ~hcs_client (req : Client.request) : Client.response =
9
+
let url = Uri.to_string req.uri in
10
+
let result =
11
+
match req.meth with
12
+
| `GET -> Hcs.Client.request hcs_client url
13
+
| `POST ->
14
+
let body = Option.value ~default:"" req.body in
15
+
Hcs.Client.request_post hcs_client url ~body
16
16
in
17
-
let meth = match req.meth with `GET -> `GET | `POST -> `POST in
18
-
try
19
-
let resp, resp_body =
20
-
Cohttp_eio.Client.call ~sw client meth req.uri ~headers ~body
21
-
in
22
-
let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
23
-
let headers = Cohttp.Response.headers resp |> Cohttp.Header.to_list in
24
-
let body =
25
-
Eio.Buf_read.(of_flow ~max_size:(10 * 1024 * 1024) resp_body |> take_all)
26
-
in
27
-
{ Client.status; headers; body }
28
-
with e -> { Client.status = 0; headers = []; body = Printexc.to_string e }
29
-
30
-
(** {1 Effect Handler} *)
17
+
match result with
18
+
| Ok resp ->
19
+
{ Client.status = resp.status; headers = resp.headers; body = resp.body }
20
+
| Error e ->
21
+
let msg =
22
+
match e with
23
+
| Hcs.Client.Connection_failed s -> "Connection failed: " ^ s
24
+
| Hcs.Client.Tls_error s -> "TLS error: " ^ s
25
+
| Hcs.Client.Protocol_error s -> "Protocol error: " ^ s
26
+
| Hcs.Client.Timeout -> "Timeout"
27
+
| Hcs.Client.Invalid_response s -> "Invalid response: " ^ s
28
+
| Hcs.Client.Too_many_redirects -> "Too many redirects"
29
+
in
30
+
{ Client.status = 0; headers = []; body = msg }
31
31
32
-
let run_with_eio ~sw ~client f =
32
+
let run_with_hcs ~hcs_client f =
33
33
Effect.Deep.try_with f ()
34
34
{
35
35
effc =
···
38
38
| Client.Http_request req ->
39
39
Some
40
40
(fun (k : (a, _) Effect.Deep.continuation) ->
41
-
Effect.Deep.continue k (http_request ~sw ~client req))
41
+
Effect.Deep.continue k (http_request ~hcs_client req))
42
42
| _ -> None);
43
43
}
44
44
45
-
(** {1 Commands} *)
46
-
47
-
let login ~sw ~client ~pds ~identifier ~password =
48
-
run_with_eio ~sw ~client (fun () ->
45
+
let login ~hcs_client ~pds ~identifier ~password =
46
+
run_with_hcs ~hcs_client (fun () ->
49
47
let agent = Agent.create_from_url ~url:pds in
50
48
match Agent.login agent ~identifier ~password with
51
49
| Error e ->
···
56
54
(Option.value ~default:"?" (Agent.handle agent));
57
55
Some agent)
58
56
59
-
let post ~sw ~client agent text =
60
-
run_with_eio ~sw ~client (fun () ->
57
+
let post ~hcs_client agent text =
58
+
run_with_hcs ~hcs_client (fun () ->
61
59
let rt = Richtext.detect_facets text in
62
60
match Agent.create_post_richtext agent ~richtext:rt () with
63
61
| Error e ->
···
67
65
Printf.printf "Posted: %s\n" r.uri;
68
66
0)
69
67
70
-
let timeline ~sw ~client agent limit =
71
-
run_with_eio ~sw ~client (fun () ->
68
+
let timeline ~hcs_client agent limit =
69
+
run_with_hcs ~hcs_client (fun () ->
72
70
match Agent.get_timeline agent ~limit () with
73
71
| Error e ->
74
72
Printf.printf "Timeline failed: %s\n" (Agent.error_to_string e);
···
81
79
feed.items;
82
80
0)
83
81
84
-
let profile ~sw ~client agent actor =
85
-
run_with_eio ~sw ~client (fun () ->
82
+
let profile ~hcs_client agent actor =
83
+
run_with_hcs ~hcs_client (fun () ->
86
84
match Agent.get_profile agent ~actor with
87
85
| Error e ->
88
86
Printf.printf "Profile failed: %s\n" (Agent.error_to_string e);
···
95
93
p.followers_count p.follows_count p.posts_count;
96
94
0)
97
95
98
-
let follow ~sw ~client agent did =
99
-
run_with_eio ~sw ~client (fun () ->
96
+
let follow ~hcs_client agent did =
97
+
run_with_hcs ~hcs_client (fun () ->
100
98
match Agent.follow agent ~did with
101
99
| Error e ->
102
100
Printf.printf "Follow failed: %s\n" (Agent.error_to_string e);
···
105
103
Printf.printf "Followed: %s\n" r.uri;
106
104
0)
107
105
108
-
(** {1 CLI} *)
109
-
110
106
type cmd =
111
107
| Post of string
112
108
| Timeline of int
···
141
137
Mirage_crypto_rng_unix.use_default ();
142
138
Eio_main.run @@ fun env ->
143
139
Eio.Switch.run @@ fun sw ->
144
-
let https_config =
145
-
match
146
-
Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) ()
147
-
with
148
-
| Ok c -> c
149
-
| Error (`Msg m) -> failwith m
140
+
let config = Hcs.Client.default_config |> Hcs.Client.with_insecure_tls in
141
+
let hcs_client =
142
+
Hcs.Client.create ~sw ~net:(Eio.Stdenv.net env)
143
+
~clock:(Eio.Stdenv.clock env) ~config ()
150
144
in
151
-
let https uri socket =
152
-
let tls_host =
153
-
match Uri.host uri with
154
-
| Some h -> (
155
-
match Domain_name.of_string h with
156
-
| Error _ -> Option.None
157
-
| Ok dn -> Domain_name.host dn |> Result.to_option)
158
-
| Option.None -> Option.None
159
-
in
160
-
Tls_eio.client_of_flow https_config ?host:tls_host socket
161
-
in
162
-
let client = Cohttp_eio.Client.make ~https:(Some https) env#net in
163
145
let pds, identifier, password, cmd =
164
146
Climate.Command.run ~program_name:(Climate.Program_name.Literal "bsky_bot")
165
147
(Climate.Command.singleton ~doc:"Bluesky bot - post, timeline, follow" cli)
166
148
in
167
-
match cmd with
168
-
| None ->
169
-
Printf.printf
170
-
"Usage: bsky_bot --user USER --password PASS [--post \
171
-
TEXT|--timeline|--profile ACTOR|--follow DID]\n";
172
-
exit 0
173
-
| _ -> (
174
-
match (identifier, password) with
175
-
| Some id, Some pw -> (
176
-
match login ~sw ~client ~pds ~identifier:id ~password:pw with
177
-
| None -> exit 1
178
-
| Some agent ->
179
-
exit
180
-
(match cmd with
181
-
| Post t -> post ~sw ~client agent t
182
-
| Timeline n -> timeline ~sw ~client agent n
183
-
| Profile a -> profile ~sw ~client agent a
184
-
| Follow d -> follow ~sw ~client agent d
149
+
let result =
150
+
match cmd with
151
+
| None ->
152
+
Printf.printf
153
+
"Usage: bsky_bot --user USER --password PASS [--post \
154
+
TEXT|--timeline|--profile ACTOR|--follow DID]\n";
155
+
0
156
+
| _ -> (
157
+
match (identifier, password) with
158
+
| Some id, Some pw -> (
159
+
match login ~hcs_client ~pds ~identifier:id ~password:pw with
160
+
| None -> 1
161
+
| Some agent -> (
162
+
match cmd with
163
+
| Post t -> post ~hcs_client agent t
164
+
| Timeline n -> timeline ~hcs_client agent n
165
+
| Profile a -> profile ~hcs_client agent a
166
+
| Follow d -> follow ~hcs_client agent d
185
167
| None -> 0))
186
-
| _ ->
187
-
Printf.printf "Error: --user and --password required\n";
188
-
exit 1)
168
+
| _ ->
169
+
Printf.printf "Error: --user and --password required\n";
170
+
1)
171
+
in
172
+
Hcs.Client.close hcs_client;
173
+
exit result
+1
-4
examples/bsky_bot/dune
+1
-4
examples/bsky_bot/dune
+2
-7
examples/feed_generator/dune
+2
-7
examples/feed_generator/dune
···
1
1
(executable
2
2
(name feed_generator)
3
-
(public_name feed_generator)
4
-
(package atproto)
5
3
(libraries
6
4
atproto-sync
7
5
atproto-ipld
···
9
7
uri
10
8
eio
11
9
eio_main
12
-
tls-eio
13
-
ca-certs-nss
14
-
mirage-crypto-rng.unix
15
-
base64
16
-
cstruct))
10
+
hcs
11
+
mirage-crypto-rng.unix))
+35
-243
examples/feed_generator/feed_generator.ml
+35
-243
examples/feed_generator/feed_generator.ml
···
178
178
| Firehose.Tombstone _ -> List.mem Tombstones filters
179
179
| Firehose.Info _ | Firehose.StreamError _ -> true)
180
180
181
-
(** {1 Keyword Filtering} *)
182
-
183
181
let contains_keyword keyword text =
184
182
let kw = String.lowercase_ascii keyword in
185
183
let txt = String.lowercase_ascii text in
···
216
214
&& text_matches_keyword kw blocks op)
217
215
evt.ops
218
216
| _ -> false)
219
-
220
-
(** {1 Feed Skeleton} *)
221
217
222
218
let max_feed_size = 1000
223
219
let feed_posts : string Queue.t = Queue.create ()
···
264
260
Printf.printf " ]\n}\n"
265
261
end
266
262
267
-
(** {1 WebSocket Client} *)
268
-
269
-
module Ws = struct
270
-
type conn = {
271
-
socket : Tls_eio.t;
272
-
buf : bytes;
273
-
mutable buf_len : int;
274
-
frag_buf : Buffer.t;
275
-
mutable frag_opcode : int;
276
-
}
277
-
278
-
let ws_nonce () =
279
-
let b = Bytes.create 16 in
280
-
for i = 0 to 15 do
281
-
Bytes.set b i (Char.chr (Random.int 256))
282
-
done;
283
-
Base64.encode_exn (Bytes.to_string b)
284
-
285
-
let parse_frame_header buf off len =
286
-
if len < 2 then None
287
-
else
288
-
let b0, b1 =
289
-
(Char.code (Bytes.get buf off), Char.code (Bytes.get buf (off + 1)))
290
-
in
291
-
let fin, opcode = (b0 land 0x80 <> 0, b0 land 0x0f) in
292
-
let masked, plen = (b1 land 0x80 <> 0, b1 land 0x7f) in
293
-
let hlen, plen =
294
-
if plen = 126 then
295
-
if len < 4 then (0, -1)
296
-
else
297
-
( 4,
298
-
(Char.code (Bytes.get buf (off + 2)) lsl 8)
299
-
lor Char.code (Bytes.get buf (off + 3)) )
300
-
else if plen = 127 then
301
-
if len < 10 then (0, -1)
302
-
else
303
-
( 10,
304
-
(Char.code (Bytes.get buf (off + 6)) lsl 24)
305
-
lor (Char.code (Bytes.get buf (off + 7)) lsl 16)
306
-
lor (Char.code (Bytes.get buf (off + 8)) lsl 8)
307
-
lor Char.code (Bytes.get buf (off + 9)) )
308
-
else (2, plen)
309
-
in
310
-
if plen < 0 then None
311
-
else
312
-
let mlen = if masked then 4 else 0 in
313
-
if len < hlen + mlen then None
314
-
else
315
-
Some
316
-
( fin,
317
-
opcode,
318
-
plen,
319
-
(if masked then Some (Bytes.sub buf (off + hlen) 4) else None),
320
-
hlen + mlen )
321
-
322
-
let make_frame opcode payload =
323
-
let plen = String.length payload in
324
-
let mask = Bytes.init 4 (fun _ -> Char.chr (Random.int 256)) in
325
-
let hdr =
326
-
if plen < 126 then (
327
-
let h = Bytes.create 6 in
328
-
Bytes.set h 0 (Char.chr (0x80 lor opcode));
329
-
Bytes.set h 1 (Char.chr (0x80 lor plen));
330
-
Bytes.blit mask 0 h 2 4;
331
-
Bytes.to_string h)
332
-
else if plen < 65536 then (
333
-
let h = Bytes.create 8 in
334
-
Bytes.set h 0 (Char.chr (0x80 lor opcode));
335
-
Bytes.set h 1 (Char.chr (0x80 lor 126));
336
-
Bytes.set h 2 (Char.chr ((plen lsr 8) land 0xff));
337
-
Bytes.set h 3 (Char.chr (plen land 0xff));
338
-
Bytes.blit mask 0 h 4 4;
339
-
Bytes.to_string h)
340
-
else
341
-
let h = Bytes.create 14 in
342
-
Bytes.set h 0 (Char.chr (0x80 lor opcode));
343
-
Bytes.set h 1 (Char.chr (0x80 lor 127));
344
-
for i = 2 to 5 do
345
-
Bytes.set h i '\000'
346
-
done;
347
-
Bytes.set h 6 (Char.chr ((plen lsr 24) land 0xff));
348
-
Bytes.set h 7 (Char.chr ((plen lsr 16) land 0xff));
349
-
Bytes.set h 8 (Char.chr ((plen lsr 8) land 0xff));
350
-
Bytes.set h 9 (Char.chr (plen land 0xff));
351
-
Bytes.blit mask 0 h 10 4;
352
-
Bytes.to_string h
353
-
in
354
-
let masked =
355
-
Bytes.mapi
356
-
(fun i c ->
357
-
Char.chr (Char.code c lxor Char.code (Bytes.get mask (i mod 4))))
358
-
(Bytes.of_string payload)
359
-
in
360
-
hdr ^ Bytes.to_string masked
361
-
362
-
let connect ~net ~sw uri =
363
-
let host = Uri.host uri |> Option.value ~default:"localhost" in
364
-
let port = Uri.port uri |> Option.value ~default:443 in
365
-
let auth =
366
-
match Ca_certs_nss.authenticator () with
367
-
| Ok a -> a
368
-
| Error (`Msg m) -> failwith m
369
-
in
370
-
let tls_config =
371
-
match
372
-
Tls.Config.client ~authenticator:auth ~alpn_protocols:[ "http/1.1" ] ()
373
-
with
374
-
| Ok c -> c
375
-
| Error (`Msg m) -> failwith m
376
-
in
377
-
let hostname =
378
-
match Domain_name.of_string host with
379
-
| Error _ -> None
380
-
| Ok dn -> (
381
-
match Domain_name.host dn with Ok h -> Some h | Error _ -> None)
382
-
in
383
-
let addr =
384
-
match
385
-
Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port)
386
-
with
387
-
| [] -> failwith ("DNS failed: " ^ host)
388
-
| a :: _ -> a
389
-
in
390
-
let socket = Eio.Net.connect ~sw net addr in
391
-
let tls_socket = Tls_eio.client_of_flow tls_config ?host:hostname socket in
392
-
let nonce = ws_nonce () in
393
-
Eio.Flow.copy_string
394
-
(Printf.sprintf
395
-
"GET %s HTTP/1.1\r\n\
396
-
Host: %s\r\n\
397
-
Upgrade: websocket\r\n\
398
-
Connection: Upgrade\r\n\
399
-
Sec-WebSocket-Key: %s\r\n\
400
-
Sec-WebSocket-Version: 13\r\n\
401
-
\r\n"
402
-
(Uri.path_and_query uri) host nonce)
403
-
tls_socket;
404
-
let resp_buf = Cstruct.create 4096 in
405
-
let n = Eio.Flow.single_read tls_socket resp_buf in
406
-
let resp = Cstruct.to_string (Cstruct.sub resp_buf 0 n) in
407
-
if not (String.length resp >= 12 && String.sub resp 0 12 = "HTTP/1.1 101")
408
-
then
409
-
failwith
410
-
("WebSocket upgrade failed: "
411
-
^ String.sub resp 0 (min 50 (String.length resp)));
412
-
{
413
-
socket = tls_socket;
414
-
buf = Bytes.create 1048576;
415
-
buf_len = 0;
416
-
frag_buf = Buffer.create 65536;
417
-
frag_opcode = 0;
418
-
}
419
-
420
-
let read_more conn =
421
-
let cs = Cstruct.create 65536 in
422
-
let n = Eio.Flow.single_read conn.socket cs in
423
-
Cstruct.blit_to_bytes cs 0 conn.buf conn.buf_len n;
424
-
conn.buf_len <- conn.buf_len + n
425
-
426
-
let recv conn =
427
-
let rec read_frame () =
428
-
if conn.buf_len < 2 then (
429
-
read_more conn;
430
-
read_frame ())
431
-
else
432
-
match parse_frame_header conn.buf 0 conn.buf_len with
433
-
| None ->
434
-
read_more conn;
435
-
read_frame ()
436
-
| Some (fin, opcode, plen, mask, hlen) -> (
437
-
let total = hlen + plen in
438
-
while conn.buf_len < total do
439
-
read_more conn
440
-
done;
441
-
let payload = Bytes.sub conn.buf hlen plen in
442
-
(match mask with
443
-
| Some k ->
444
-
for i = 0 to plen - 1 do
445
-
Bytes.set payload i
446
-
(Char.chr
447
-
(Char.code (Bytes.get payload i)
448
-
lxor Char.code (Bytes.get k (i mod 4))))
449
-
done
450
-
| None -> ());
451
-
let rem = conn.buf_len - total in
452
-
if rem > 0 then Bytes.blit conn.buf total conn.buf 0 rem;
453
-
conn.buf_len <- rem;
454
-
match opcode with
455
-
| 0x0 ->
456
-
Buffer.add_bytes conn.frag_buf payload;
457
-
if fin then (
458
-
let data = Buffer.contents conn.frag_buf in
459
-
Buffer.clear conn.frag_buf;
460
-
if conn.frag_opcode = 0x2 then Ok data else read_frame ())
461
-
else read_frame ()
462
-
| 0x1 ->
463
-
if not fin then (
464
-
Buffer.clear conn.frag_buf;
465
-
Buffer.add_bytes conn.frag_buf payload;
466
-
conn.frag_opcode <- 0x1);
467
-
read_frame ()
468
-
| 0x2 ->
469
-
if fin then Ok (Bytes.to_string payload)
470
-
else (
471
-
Buffer.clear conn.frag_buf;
472
-
Buffer.add_bytes conn.frag_buf payload;
473
-
conn.frag_opcode <- 0x2;
474
-
read_frame ())
475
-
| 0x8 -> Error "Connection closed"
476
-
| 0x9 ->
477
-
Eio.Flow.copy_string
478
-
(make_frame 0xA (Bytes.to_string payload))
479
-
conn.socket;
480
-
read_frame ()
481
-
| _ -> read_frame ())
482
-
in
483
-
try read_frame () with exn -> Error (Printexc.to_string exn)
484
-
485
-
let close _conn = ()
486
-
end
487
-
488
-
let with_websocket ~net ~sw f =
263
+
let with_websocket ~sw ~net f =
489
264
let open Effect.Deep in
490
265
try_with f ()
491
266
{
···
495
270
| Firehose.Ws_connect uri ->
496
271
Some
497
272
(fun (k : (a, _) continuation) ->
498
-
try
499
-
continue k
500
-
(Ok
501
-
(Obj.magic (Ws.connect ~net ~sw uri)
502
-
: Firehose.websocket))
503
-
with exn -> continue k (Error (Printexc.to_string exn)))
273
+
let url = Uri.to_string uri in
274
+
match Hcs.Websocket.connect ~sw ~net url with
275
+
| Ok ws -> continue k (Ok (Obj.magic ws : Firehose.websocket))
276
+
| Error e ->
277
+
let msg =
278
+
match e with
279
+
| Hcs.Websocket.Connection_closed -> "Connection closed"
280
+
| Hcs.Websocket.Protocol_error s ->
281
+
"Protocol error: " ^ s
282
+
| Hcs.Websocket.Io_error s -> "IO error: " ^ s
283
+
| Hcs.Websocket.Payload_too_large n ->
284
+
"Payload too large: " ^ string_of_int n
285
+
in
286
+
continue k (Error msg))
504
287
| Firehose.Ws_recv ws ->
505
-
Some (fun k -> continue k (Ws.recv (Obj.magic ws : Ws.conn)))
288
+
Some
289
+
(fun k ->
290
+
let hcs_ws = (Obj.magic ws : Hcs.Websocket.t) in
291
+
match Hcs.Websocket.recv hcs_ws with
292
+
| Ok frame ->
293
+
if frame.opcode = Hcs.Websocket.Opcode.Binary then
294
+
continue k (Ok frame.content)
295
+
else if frame.opcode = Hcs.Websocket.Opcode.Close then
296
+
continue k (Error "Connection closed")
297
+
else continue k (Ok frame.content)
298
+
| Error Hcs.Websocket.Connection_closed ->
299
+
continue k (Error "Connection closed")
300
+
| Error (Hcs.Websocket.Protocol_error s) ->
301
+
continue k (Error ("Protocol error: " ^ s))
302
+
| Error (Hcs.Websocket.Io_error s) ->
303
+
continue k (Error ("IO error: " ^ s))
304
+
| Error (Hcs.Websocket.Payload_too_large n) ->
305
+
continue k
306
+
(Error ("Payload too large: " ^ string_of_int n)))
506
307
| Firehose.Ws_close ws ->
507
308
Some
508
309
(fun k ->
509
-
Ws.close (Obj.magic ws);
310
+
Hcs.Websocket.close (Obj.magic ws);
510
311
continue k ())
511
312
| _ -> None);
512
313
}
513
314
514
-
(** {1 Configuration} *)
515
-
516
315
type config = {
517
316
cursor : int64 option;
518
317
limit : int option;
···
563
362
Climate.Command.singleton
564
363
~doc:"AT Protocol firehose client and feed generator" config_parser
565
364
566
-
(** {1 Stats} *)
567
-
568
365
type stats = {
569
366
mutable total : int;
570
367
mutable matched : int;
···
582
379
let stats = { total = 0; matched = 0; last_seq = 0L; start = 0. }
583
380
let interrupted = ref false
584
381
585
-
(** {1 Main} *)
586
-
587
382
let run ~net ~sw config =
588
383
let uri =
589
384
Uri.of_string "wss://bsky.network/xrpc/com.atproto.sync.subscribeRepos"
···
601
396
(match Firehose.event_seq event with
602
397
| Some s -> stats.last_seq <- s
603
398
| None -> ());
604
-
(* Collect posts for skeleton if enabled *)
605
399
(if config.skeleton then
606
400
match event with
607
401
| Firehose.Commit evt -> collect_post_uris evt config.keyword
608
402
| _ -> ());
609
-
(* Check filters *)
610
403
let type_match = event_matches config.filters event in
611
404
let keyword_match = event_matches_keyword config.keyword event in
612
405
if type_match && keyword_match then begin
···
642
435
Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> interrupted := true));
643
436
stats.start <- Unix.gettimeofday ();
644
437
Mirage_crypto_rng_unix.use_default ();
645
-
Random.self_init ();
646
438
(try
647
439
Eio_main.run @@ fun env ->
648
440
Eio.Switch.run @@ fun sw -> run ~net:(Eio.Stdenv.net env) ~sw config
+1
-4
examples/identity_tool/dune
+1
-4
examples/identity_tool/dune
+36
-49
examples/identity_tool/identity_tool.ml
+36
-49
examples/identity_tool/identity_tool.ml
···
5
5
open Atproto_syntax
6
6
open Atproto_identity
7
7
8
-
(** {1 HTTP Client with cohttp-eio} *)
8
+
let http_get ~hcs_client uri =
9
+
let url = Uri.to_string uri in
10
+
match Hcs.Client.request hcs_client url with
11
+
| Ok resp -> Did_resolver.{ status = resp.status; body = resp.body }
12
+
| Error e ->
13
+
let msg =
14
+
match e with
15
+
| Hcs.Client.Connection_failed s -> "Connection failed: " ^ s
16
+
| Hcs.Client.Tls_error s -> "TLS error: " ^ s
17
+
| Hcs.Client.Protocol_error s -> "Protocol error: " ^ s
18
+
| Hcs.Client.Timeout -> "Timeout"
19
+
| Hcs.Client.Invalid_response s -> "Invalid response: " ^ s
20
+
| Hcs.Client.Too_many_redirects -> "Too many redirects"
21
+
in
22
+
Did_resolver.{ status = 0; body = msg }
9
23
10
-
let http_get ~sw ~client uri =
11
-
try
12
-
let resp, resp_body = Cohttp_eio.Client.call ~sw client `GET uri in
13
-
let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
14
-
let body =
15
-
Eio.Buf_read.(of_flow ~max_size:(10 * 1024 * 1024) resp_body |> take_all)
16
-
in
17
-
Did_resolver.{ status; body }
18
-
with e -> Did_resolver.{ status = 0; body = Printexc.to_string e }
19
-
20
-
(** {1 Effect Handler} *)
21
-
22
-
let run_with_eio ~sw ~client f =
24
+
let run_with_hcs ~hcs_client f =
23
25
Effect.Deep.try_with f ()
24
26
{
25
27
effc =
···
28
30
| Did_resolver.Http_get uri ->
29
31
Some
30
32
(fun (k : (a, _) Effect.Deep.continuation) ->
31
-
Effect.Deep.continue k (http_get ~sw ~client uri))
33
+
Effect.Deep.continue k (http_get ~hcs_client uri))
32
34
| Handle_resolver.Http_get uri ->
33
35
Some
34
36
(fun k ->
35
-
let r = http_get ~sw ~client uri in
37
+
let r = http_get ~hcs_client uri in
36
38
Effect.Deep.continue k
37
39
Handle_resolver.{ status = r.status; body = r.body })
38
40
| Handle_resolver.Dns_txt _ ->
···
41
43
| _ -> None);
42
44
}
43
45
44
-
(** {1 Commands} *)
45
-
46
-
let resolve_handle ~sw ~client h =
46
+
let resolve_handle ~hcs_client h =
47
47
match Handle.of_string h with
48
48
| Error _ ->
49
49
Printf.printf "Error: Invalid handle\n";
50
50
1
51
51
| Ok handle ->
52
-
run_with_eio ~sw ~client (fun () ->
52
+
run_with_hcs ~hcs_client (fun () ->
53
53
match Handle_resolver.resolve handle with
54
54
| Error e ->
55
55
Printf.printf "Error: %s\n" (Handle_resolver.error_to_string e);
···
59
59
(Did.to_string did);
60
60
0)
61
61
62
-
let resolve_did ~sw ~client d =
62
+
let resolve_did ~hcs_client d =
63
63
match Did.of_string d with
64
64
| Error _ ->
65
65
Printf.printf "Error: Invalid DID\n";
66
66
1
67
67
| Ok did ->
68
-
run_with_eio ~sw ~client (fun () ->
68
+
run_with_hcs ~hcs_client (fun () ->
69
69
match Did_resolver.resolve_did did with
70
70
| Error e ->
71
71
Printf.printf "Error: %s\n" (Did_resolver.error_to_string e);
···
87
87
doc.service;
88
88
0)
89
89
90
-
let verify ~sw ~client id =
90
+
let verify ~hcs_client id =
91
91
let is_did = String.length id > 4 && String.sub id 0 4 = "did:" in
92
-
run_with_eio ~sw ~client (fun () ->
92
+
run_with_hcs ~hcs_client (fun () ->
93
93
let result =
94
94
if is_did then
95
95
match Did.of_string id with
···
116
116
v.pds_endpoint;
117
117
0)
118
118
119
-
(** {1 CLI} *)
120
-
121
119
type mode = Resolve_handle | Resolve_did | Verify
122
120
123
121
let cli =
···
136
134
Mirage_crypto_rng_unix.use_default ();
137
135
Eio_main.run @@ fun env ->
138
136
Eio.Switch.run @@ fun sw ->
139
-
let https_config =
140
-
match
141
-
Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) ()
142
-
with
143
-
| Ok c -> c
144
-
| Error (`Msg m) -> failwith m
145
-
in
146
-
let https uri socket =
147
-
let tls_host =
148
-
match Uri.host uri with
149
-
| Some h -> (
150
-
match Domain_name.of_string h with
151
-
| Error _ -> None
152
-
| Ok dn -> Domain_name.host dn |> Result.to_option)
153
-
| None -> None
154
-
in
155
-
Tls_eio.client_of_flow https_config ?host:tls_host socket
137
+
let config = Hcs.Client.default_config |> Hcs.Client.with_insecure_tls in
138
+
let hcs_client =
139
+
Hcs.Client.create ~sw ~net:(Eio.Stdenv.net env)
140
+
~clock:(Eio.Stdenv.clock env) ~config ()
156
141
in
157
-
let client = Cohttp_eio.Client.make ~https:(Some https) env#net in
158
142
let mode, id =
159
143
Climate.Command.run
160
144
~program_name:(Climate.Program_name.Literal "identity_tool")
161
145
(Climate.Command.singleton ~doc:"AT Protocol identity lookup tool" cli)
162
146
in
163
-
exit
164
-
(match mode with
165
-
| Resolve_handle -> resolve_handle ~sw ~client id
166
-
| Resolve_did -> resolve_did ~sw ~client id
167
-
| Verify -> verify ~sw ~client id)
147
+
let result =
148
+
match mode with
149
+
| Resolve_handle -> resolve_handle ~hcs_client id
150
+
| Resolve_did -> resolve_did ~hcs_client id
151
+
| Verify -> verify ~hcs_client id
152
+
in
153
+
Hcs.Client.close hcs_client;
154
+
exit result
+1
-5
examples/repo_inspector/dune
+1
-5
examples/repo_inspector/dune
···
1
1
(executable
2
2
(name repo_inspector)
3
-
(public_name repo_inspector)
4
-
(package atproto)
5
3
(libraries
6
4
atproto-repo
7
5
atproto-mst
···
11
9
atproto-crypto
12
10
climate
13
11
eio_main
14
-
cohttp-eio
15
-
tls-eio
16
-
ca-certs-nss
12
+
hcs
17
13
base64
18
14
mirage-crypto-rng.unix
19
15
uri))
+35
-57
examples/repo_inspector/repo_inspector.ml
+35
-57
examples/repo_inspector/repo_inspector.ml
···
18
18
module Did = Atproto_syntax.Did
19
19
module Did_resolver = Atproto_identity.Did_resolver
20
20
21
-
(** {1 HTTP Client with cohttp-eio} *)
22
-
23
-
let http_get ~sw ~client uri =
24
-
try
25
-
let resp, resp_body = Cohttp_eio.Client.call ~sw client `GET uri in
26
-
let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
27
-
let body =
28
-
Eio.Buf_read.(of_flow ~max_size:(100 * 1024 * 1024) resp_body |> take_all)
29
-
in
30
-
(status, body)
31
-
with e -> (0, Printexc.to_string e)
32
-
33
-
(** {1 DID Resolution Effect Handler} *)
21
+
let http_get ~hcs_client uri =
22
+
let url = Uri.to_string uri in
23
+
match Hcs.Client.request hcs_client url with
24
+
| Ok resp -> (resp.status, resp.body)
25
+
| Error e ->
26
+
let msg =
27
+
match e with
28
+
| Hcs.Client.Connection_failed s -> "Connection failed: " ^ s
29
+
| Hcs.Client.Tls_error s -> "TLS error: " ^ s
30
+
| Hcs.Client.Protocol_error s -> "Protocol error: " ^ s
31
+
| Hcs.Client.Timeout -> "Timeout"
32
+
| Hcs.Client.Invalid_response s -> "Invalid response: " ^ s
33
+
| Hcs.Client.Too_many_redirects -> "Too many redirects"
34
+
in
35
+
(0, msg)
34
36
35
-
let run_with_resolver ~sw ~client f =
37
+
let run_with_resolver ~hcs_client f =
36
38
Effect.Deep.try_with f ()
37
39
{
38
40
effc =
···
41
43
| Did_resolver.Http_get uri ->
42
44
Some
43
45
(fun (k : (a, _) Effect.Deep.continuation) ->
44
-
let status, body = http_get ~sw ~client uri in
46
+
let status, body = http_get ~hcs_client uri in
45
47
Effect.Deep.continue k Did_resolver.{ status; body })
46
48
| _ -> None);
47
49
}
48
50
49
-
(** {1 PDS Resolution} *)
50
-
51
-
let resolve_pds ~sw ~client did_str =
51
+
let resolve_pds ~hcs_client did_str =
52
52
match Did.of_string did_str with
53
53
| Error _ -> Error "Invalid DID format"
54
54
| Ok did ->
55
-
run_with_resolver ~sw ~client (fun () ->
55
+
run_with_resolver ~hcs_client (fun () ->
56
56
match Did_resolver.resolve_did did with
57
57
| Error e -> Error (Did_resolver.error_to_string e)
58
58
| Ok doc -> (
59
-
(* Find AtprotoPersonalDataServer service *)
60
59
match
61
60
List.find_opt
62
61
(fun (s : Did_resolver.service) ->
···
66
65
| Some s -> Ok s.service_endpoint
67
66
| None -> Error "No PDS service found in DID document"))
68
67
69
-
(** {1 Repository Fetching} *)
70
-
71
-
let fetch_repo ~sw ~client ~pds_url did =
68
+
let fetch_repo ~hcs_client ~pds_url did =
72
69
let uri =
73
70
Uri.of_string (pds_url ^ "/xrpc/com.atproto.sync.getRepo")
74
71
|> Fun.flip Uri.add_query_param ("did", [ did ])
75
72
in
76
73
Printf.printf "Fetching %s...\n%!" (Uri.to_string uri);
77
-
let status, body = http_get ~sw ~client uri in
74
+
let status, body = http_get ~hcs_client uri in
78
75
if status = 200 then Ok body
79
76
else
80
77
Error
81
78
(Printf.sprintf "HTTP %d: %s" status
82
79
(String.sub body 0 (min 200 (String.length body))))
83
80
84
-
(** {1 Repository Analysis} *)
85
-
86
81
let truncate n s =
87
82
if String.length s <= n then s else String.sub s 0 (n - 3) ^ "..."
88
83
···
110
105
(fun r -> Printf.printf " - %s\n" (Cid.to_string r))
111
106
header.roots;
112
107
Printf.printf "Blocks: %d\n\n" (List.length blocks);
113
-
(* Build blockstore *)
114
108
let store = Blockstore.create () in
115
109
List.iter
116
110
(fun (b : Car.block) -> Blockstore.put store b.cid b.data)
117
111
blocks;
118
-
(* Find commit *)
119
112
let commit_cid = List.hd header.roots in
120
113
let commit_data = Blockstore.get store commit_cid in
121
114
match commit_data with
···
181
174
(fun (key, cid) ->
182
175
if !shown < limit then begin
183
176
Printf.printf "%s\n CID: %s\n" key (Cid.to_string cid);
184
-
(* Try to get and show content preview *)
185
177
(match Blockstore.get store cid with
186
178
| Some data -> (
187
179
match Dag_cbor.decode data with
···
207
199
else "(none)"
208
200
in
209
201
Printf.printf "Signature: %s\n" sig_b64;
210
-
(* Get signing key from DID - would need identity resolution *)
211
202
Printf.printf
212
203
"Status: Signature present but key resolution not implemented\n";
213
204
Printf.printf " (would need to resolve DID document to verify)\n"
214
205
215
-
(** {1 CLI} *)
216
-
217
206
type mode = Summary | Collections | Records of string option | Verify
218
207
219
208
let cli =
···
239
228
Mirage_crypto_rng_unix.use_default ();
240
229
Eio_main.run @@ fun env ->
241
230
Eio.Switch.run @@ fun sw ->
242
-
let auth =
243
-
match Ca_certs_nss.authenticator () with
244
-
| Ok a -> a
245
-
| Error (`Msg m) -> failwith m
231
+
let config =
232
+
Hcs.Client.default_config |> Hcs.Client.with_max_response_body 104857600L
246
233
in
247
-
let https_config =
248
-
match Tls.Config.client ~authenticator:auth () with
249
-
| Ok c -> c
250
-
| Error (`Msg m) -> failwith m
251
-
in
252
-
let https uri socket =
253
-
let tls_host =
254
-
match Uri.host uri with
255
-
| Some h -> (
256
-
match Domain_name.of_string h with
257
-
| Error _ -> None
258
-
| Ok dn -> Domain_name.host dn |> Result.to_option)
259
-
| None -> None
260
-
in
261
-
Tls_eio.client_of_flow https_config ?host:tls_host socket
234
+
let hcs_client =
235
+
Hcs.Client.create ~sw ~net:(Eio.Stdenv.net env)
236
+
~clock:(Eio.Stdenv.clock env) ~config ()
262
237
in
263
-
let client = Cohttp_eio.Client.make ~https:(Some https) env#net in
264
238
let did, pds_opt, mode, limit =
265
239
Climate.Command.run
266
240
~program_name:(Climate.Program_name.Literal "repo_inspector")
267
241
(Climate.Command.singleton ~doc:"AT Protocol repository inspector" cli)
268
242
in
269
243
Printf.printf "Repository Inspector\n====================\n\n";
270
-
(* Resolve PDS if not provided *)
271
244
let pds_url =
272
245
match pds_opt with
273
246
| Some url -> url
274
247
| None -> (
275
248
Printf.printf "Resolving PDS for %s...\n%!" did;
276
-
match resolve_pds ~sw ~client did with
249
+
match resolve_pds ~hcs_client did with
277
250
| Ok url ->
278
251
Printf.printf "PDS: %s\n\n%!" url;
279
252
url
280
253
| Error e ->
281
254
Printf.printf "Error resolving PDS: %s\n" e;
255
+
Hcs.Client.close hcs_client;
282
256
exit 1)
283
257
in
284
-
match fetch_repo ~sw ~client ~pds_url did with
258
+
(match fetch_repo ~hcs_client ~pds_url did with
285
259
| Error e ->
286
260
Printf.printf "Error: %s\n" e;
261
+
Hcs.Client.close hcs_client;
287
262
exit 1
288
263
| Ok car_data -> (
289
264
match analyze_repo car_data with
290
-
| None -> exit 1
265
+
| None ->
266
+
Hcs.Client.close hcs_client;
267
+
exit 1
291
268
| Some (store, commit) -> (
292
269
show_commit commit;
293
270
match mode with
294
271
| Summary -> show_collections store commit
295
272
| Collections -> show_collections store commit
296
273
| Records coll -> show_records ~limit ~collection:coll store commit
297
-
| Verify -> verify_commit store commit))
274
+
| Verify -> verify_commit store commit)));
275
+
Hcs.Client.close hcs_client