~ syntax stuff

This commit is contained in:
swrup 2025-11-04 18:36:32 +01:00
parent 774d55ebb1
commit f4eb197093
4 changed files with 131 additions and 102 deletions

View file

@ -1,10 +1,10 @@
open Syntax
module type S = sig
val connect : Mimic.ctx -> Mimic.ctx Lwt.t
val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
end
open Lwt.Infix
let connect_scheme = Mimic.make ~name:"connect-scheme"
let connect_port = Mimic.make ~name:"connect-port"
let connect_hostname = Mimic.make ~name:"connect-hostname"
@ -31,20 +31,16 @@ struct
| `Closed as err -> pp_write_error ppf err
let write flow cs =
let open Lwt.Infix in
write flow cs >>= function
| Ok _ as v -> Lwt.return v
| Error err -> Lwt.return_error (`Write err)
write flow cs |> Lwt_result.map_error (fun err -> `Write err)
let writev flow css =
writev flow css >>= function
| Ok _ as v -> Lwt.return v
| Error err -> Lwt.return_error (`Write err)
writev flow css |> Lwt_result.map_error (fun err -> `Write err)
let connect (happy_eyeballs, hostname, port) =
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
| Error (`Msg err) -> Lwt.return_error (`Connect err)
| Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
let+ res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
match res with
| Error (`Msg err) -> Error (`Connect err)
| Ok ((_ipaddr, _port), flow) -> Ok flow
end
let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
@ -59,9 +55,10 @@ struct
Result.(
to_option (bind (Domain_name.of_string hostname) Domain_name.host))
in
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
| Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
let* res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
match res with
| Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
| Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
end
let tls_edn, _tls_protocol = Mimic.register ~name:"tls" (module TLS)
@ -154,8 +151,7 @@ let tls_config ?tls_config authenticator =
let create_connection ?tls_config:cfg ~ctx ~authenticator uri =
let tls_config = tls_config ?tls_config:cfg authenticator in
let open Lwt_result.Infix in
Lwt.return (decode_uri ~ctx uri) >>= fun (ctx, host) ->
let*? ctx, host = Lwt.return (decode_uri ~ctx uri) in
let ctx =
match Lazy.force tls_config with
| Ok (`Custom cfg) -> Mimic.add connect_tls_config cfg ctx