My aggregated monorepo of OCaml code, automaintained
Eliminate Obj.magic with type-safe equivalents
Replace unsafe Obj.magic casts with proper type-safe alternatives:
- conpool: Make protocol parameter required, add create_basic for simple
pools. The previous optional protocol with Obj.magic default was
fundamentally unsound as OCaml cannot have optional parameters that
change return types.
- publicsuffix: Add explicit id field to trie_node instead of using
Obj.magic to cast nodes to int for hashtable keys.
- yamlt: Add init_unknown_builder helper that properly handles GADT
refinement, returning () for Unknown_skip/Unknown_error cases where
builder=unit.
- jmap_brr: Use Jsont_brr.encode/decode Jsont.json instead of unsafe
casts between Jv.t and Jsont.json.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+70
-37
+4
-4
ocaml-conpool/README.md
+4
-4
ocaml-conpool/README.md
···
20
20
21
21
let run env =
22
22
Switch.run (fun sw ->
23
-
(* Create a connection pool *)
24
-
let pool = Conpool.create
23
+
(* Create a basic connection pool (no protocol state) *)
24
+
let pool = Conpool.create_basic
25
25
~sw
26
26
~net:(Eio.Stdenv.net env)
27
27
~clock:(Eio.Stdenv.clock env)
···
49
49
let tls_config = Tls.Config.client ~authenticator:(Ca_certs.authenticator ()) () in
50
50
51
51
(* Create pool with TLS *)
52
-
let pool = Conpool.create
52
+
let pool = Conpool.create_basic
53
53
~sw
54
54
~net:(Eio.Stdenv.net env)
55
55
~clock:(Eio.Stdenv.clock env)
···
76
76
()
77
77
in
78
78
79
-
let pool = Conpool.create ~sw ~net ~clock ~config ()
79
+
let pool = Conpool.create_basic ~sw ~net ~clock ~config ()
80
80
```
81
81
82
82
Monitor pool statistics:
+4
-5
ocaml-conpool/lib/conpool.ml
+4
-5
ocaml-conpool/lib/conpool.ml
···
566
566
(** {1 Public API} *)
567
567
568
568
let create ~sw ~(net : 'net Eio.Net.t) ~(clock : 'clock Eio.Time.clock)
569
-
?tls ?(config = Config.default) ?protocol () =
570
-
let protocol = match protocol with
571
-
| Some p -> p
572
-
| None -> Obj.magic default_protocol (* Safe: unit is compatible with any 'state *)
573
-
in
569
+
?tls ?(config = Config.default) ~protocol () =
574
570
575
571
Log.info (fun m ->
576
572
m "Creating connection pool (max_per_endpoint=%d)"
···
599
595
Hashtbl.clear pool.endpoints));
600
596
601
597
Pool pool
598
+
599
+
let create_basic ~sw ~net ~clock ?tls ?config () =
600
+
create ~sw ~net ~clock ?tls ?config ~protocol:default_protocol ()
602
601
603
602
let connection ~sw (Pool pool) endpoint =
604
603
Log.debug (fun m -> m "Acquiring connection to %a" Endpoint.pp endpoint);
+34
-6
ocaml-conpool/lib/conpool.mli
+34
-6
ocaml-conpool/lib/conpool.mli
···
13
13
14
14
For simple exclusive-access protocols (HTTP/1.x, Redis, etc.):
15
15
{[
16
-
let pool = Conpool.create ~sw ~net ~clock ~tls () in
16
+
let pool = Conpool.create_basic ~sw ~net ~clock ~tls () in
17
17
Eio.Switch.run (fun conn_sw ->
18
18
let conn = Conpool.connection ~sw:conn_sw pool endpoint in
19
19
(* Use conn.flow for I/O *)
···
105
105
106
106
(** {2 Pool Creation} *)
107
107
108
+
val default_protocol : unit Config.protocol_config
109
+
(** Default protocol configuration for simple exclusive-access protocols.
110
+
Use with {!create} for HTTP/1.x, Redis, and similar protocols where
111
+
each connection handles one request at a time with no extra state. *)
112
+
108
113
val create :
109
114
sw:Eio.Switch.t ->
110
115
net:'net Eio.Net.t ->
111
116
clock:'clock Eio.Time.clock ->
112
117
?tls:Tls.Config.client ->
113
118
?config:Config.t ->
114
-
?protocol:'state Config.protocol_config ->
119
+
protocol:'state Config.protocol_config ->
115
120
unit ->
116
121
'state t
117
-
(** Create a connection pool.
122
+
(** Create a connection pool with a protocol handler.
118
123
119
124
@param sw Switch for resource management
120
125
@param net Network interface for creating connections
121
126
@param clock Clock for timeouts
122
127
@param tls Optional TLS client configuration
123
128
@param config Pool configuration (uses {!Config.default} if not provided)
124
-
@param protocol Protocol handler for state management. If not provided,
125
-
creates a [unit t] pool with exclusive access mode (one user per connection).
129
+
@param protocol Protocol handler for state management
126
130
127
131
Examples:
128
132
129
133
Simple pool for HTTP/1.x (exclusive access, no state):
130
134
{[
131
-
let pool = Conpool.create ~sw ~net ~clock ~tls ()
135
+
let pool = Conpool.create ~sw ~net ~clock ~tls
136
+
~protocol:Conpool.default_protocol ()
132
137
]}
133
138
134
139
HTTP/2 pool (shared access with H2 state):
135
140
{[
136
141
let pool = Conpool.create ~sw ~net ~clock ~tls ~protocol:h2_handler ()
142
+
]} *)
143
+
144
+
val create_basic :
145
+
sw:Eio.Switch.t ->
146
+
net:'net Eio.Net.t ->
147
+
clock:'clock Eio.Time.clock ->
148
+
?tls:Tls.Config.client ->
149
+
?config:Config.t ->
150
+
unit ->
151
+
unit t
152
+
(** Create a basic connection pool with no protocol state.
153
+
154
+
This is a convenience function equivalent to:
155
+
{[
156
+
Conpool.create ~sw ~net ~clock ?tls ?config
157
+
~protocol:Conpool.default_protocol ()
158
+
]}
159
+
160
+
Use for simple exclusive-access protocols like HTTP/1.x and Redis.
161
+
162
+
Example:
163
+
{[
164
+
let pool = Conpool.create_basic ~sw ~net ~clock ~tls ()
137
165
]} *)
138
166
139
167
(** {2 Connection Acquisition} *)
+1
-1
ocaml-conpool/test/stress_test.ml
+1
-1
ocaml-conpool/test/stress_test.ml
+1
-1
ocaml-imap/PLAN.md
+1
-1
ocaml-imap/PLAN.md
···
73
73
74
74
let create ~sw ~net ~clock ~host ~port ~tls =
75
75
let endpoint = Conpool.Endpoint.make ~host ~port in
76
-
let pool = Conpool.create ~sw ~net ~clock ~tls () in
76
+
let pool = Conpool.create_basic ~sw ~net ~clock ~tls () in
77
77
{ pool; endpoint }
78
78
79
79
let with_connection t f =
+2
-4
ocaml-jmap/lib/js/jmap_brr.ml
+2
-4
ocaml-jmap/lib/js/jmap_brr.ml
···
44
44
Jsont_brr.encode Jmap.Proto.Session.jsont session
45
45
46
46
let decode_json s =
47
-
match Brr.Json.decode s with
48
-
| Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *)
49
-
| Error e -> Error e
47
+
Jsont_brr.decode Jsont.json s
50
48
51
49
let encode_json json =
52
-
Ok (Brr.Json.encode (Obj.magic json : Jv.t))
50
+
Jsont_brr.encode Jsont.json json
53
51
54
52
let pp_json ppf json =
55
53
match encode_json json with
+1
-1
ocaml-mqtte/lib/cmd/mqtte_cmd.ml
+1
-1
ocaml-mqtte/lib/cmd/mqtte_cmd.ml
···
346
346
| Error (`Msg msg) -> failwith ("Failed to create TLS config: " ^ msg)
347
347
else None
348
348
in
349
-
Conpool.create ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
349
+
Conpool.create_basic ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
350
350
351
351
let endpoint conn = Conpool.Endpoint.make ~host:conn.host ~port:conn.port
352
352
+11
-5
ocaml-publicsuffix/gen/gen_psl.ml
+11
-5
ocaml-publicsuffix/gen/gen_psl.ml
···
35
35
36
36
(** Trie node for efficient lookup *)
37
37
type trie_node = {
38
+
id : int; (* Unique identifier for this node *)
38
39
mutable rule : (rule_type * section) option;
39
40
mutable children : (string * trie_node) list;
40
41
mutable wildcard_child : trie_node option;
41
42
}
42
43
43
-
let make_node () = { rule = None; children = []; wildcard_child = None }
44
+
let node_id_counter = ref 0
45
+
46
+
let make_node () =
47
+
let id = !node_id_counter in
48
+
incr node_id_counter;
49
+
{ id; rule = None; children = []; wildcard_child = None }
44
50
45
51
(** Parse a single line from the PSL file *)
46
52
let parse_line section line =
···
221
227
let rec assign_names node =
222
228
let name = Printf.sprintf "n%d" !node_counter in
223
229
incr node_counter;
224
-
Hashtbl.add node_names (Obj.magic node : int) name;
230
+
Hashtbl.add node_names node.id name;
225
231
List.iter (fun (_, child) -> assign_names child) node.children;
226
232
Option.iter assign_names node.wildcard_child
227
233
in
···
232
238
let output_buffer = Buffer.create (1024 * 1024) in
233
239
234
240
let rec generate_node node =
235
-
let node_id = (Obj.magic node : int) in
241
+
let node_id = node.id in
236
242
if Hashtbl.mem generated node_id then
237
243
Hashtbl.find node_names node_id
238
244
else begin
···
264
270
else begin
265
271
Buffer.add_string output_buffer " children = [\n";
266
272
List.iter (fun (label, child) ->
267
-
let child_name = Hashtbl.find node_names (Obj.magic child : int) in
273
+
let child_name = Hashtbl.find node_names child.id in
268
274
Buffer.add_string output_buffer
269
275
(Printf.sprintf " (\"%s\", %s);\n" (escape_string label) child_name)
270
276
) node.children;
···
275
281
(match node.wildcard_child with
276
282
| None -> Buffer.add_string output_buffer " wildcard_child = None;\n"
277
283
| Some child ->
278
-
let child_name = Hashtbl.find node_names (Obj.magic child : int) in
284
+
let child_name = Hashtbl.find node_names child.id in
279
285
Buffer.add_string output_buffer
280
286
(Printf.sprintf " wildcard_child = Some %s;\n" child_name));
281
287
+2
-2
ocaml-requests/lib/requests.ml
+2
-2
ocaml-requests/lib/requests.ml
···
148
148
let http_pool = match http_pool with
149
149
| Some p -> p
150
150
| None ->
151
-
Conpool.create ~sw ~net ~clock ~config:pool_config ()
151
+
Conpool.create_basic ~sw ~net ~clock ~config:pool_config ()
152
152
in
153
153
154
154
(* HTTPS pool - TLS-wrapped connections *)
155
155
let https_pool = match https_pool with
156
156
| Some p -> p
157
157
| None ->
158
-
Conpool.create ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
158
+
Conpool.create_basic ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
159
159
in
160
160
161
161
(* HTTP/2 pool - shared connections with H2 state *)
+1
-1
ocaml-requests/test/test_localhost.ml
+1
-1
ocaml-requests/test/test_localhost.ml
+1
-1
ocaml-requests/test/test_simple.ml
+1
-1
ocaml-requests/test/test_simple.ml
···
43
43
Eio.Time.sleep env#clock 0.1;
44
44
45
45
traceln "Creating connection pool";
46
-
let pool = Conpool.create ~sw ~net:env#net ~clock:env#clock () in
46
+
let pool = Conpool.create_basic ~sw ~net:env#net ~clock:env#clock () in
47
47
48
48
traceln "Testing connection";
49
49
let endpoint = Conpool.Endpoint.make ~host:"127.0.0.1" ~port:9000 in
+8
-6
ocaml-yamlt/lib/yamlt.ml
+8
-6
ocaml-yamlt/lib/yamlt.ml
···
437
437
let umems = Unknown_mems umems_opt in
438
438
decode_object_cases d ~nest obj_meta map umems cases mem_miss [] dict
439
439
440
+
and init_unknown_builder : type o mems builder.
441
+
(o, mems, builder) unknown_mems -> builder =
442
+
function
443
+
| Unknown_skip -> ()
444
+
| Unknown_error -> ()
445
+
| Unknown_keep (mmap, _) -> mmap.dec_empty ()
446
+
440
447
and decode_object_basic : type o mems builder.
441
448
decoder ->
442
449
nest:int ->
···
447
454
Dict.t ->
448
455
Dict.t =
449
456
fun d ~nest obj_meta object_map umems mem_miss dict ->
450
-
let ubuilder =
451
-
ref
452
-
(match umems with
453
-
| Unknown_skip | Unknown_error -> Obj.magic ()
454
-
| Unknown_keep (mmap, _) -> mmap.dec_empty ())
455
-
in
457
+
let ubuilder = ref (init_unknown_builder umems) in
456
458
let mem_miss = ref mem_miss in
457
459
let dict = ref dict in
458
460
let rec loop () =