From 2b59b5e4e26c730b38adabfb6e0800180fb215e1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 15:21:04 +0100 Subject: [PATCH 1/2] Simplify Conduit.repr Remove the intermediate value type which was not necessary --- src/core/conduit.ml | 132 +++++++++++++++++++------------- src/core/conduit.mli | 3 - src/core/conduit_intf.ml | 101 +++++++++++++----------- src/core/e0.ml | 4 +- src/core/e0.mli | 2 +- src/core/readme.mld | 6 +- src/lwt-ssl/conduit_lwt_ssl.mli | 7 +- src/lwt-tls/conduit_lwt_tls.mli | 7 +- src/lwt/conduit_lwt.mli | 4 +- 9 files changed, 141 insertions(+), 125 deletions(-) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index d17baa52..93a20710 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -123,15 +123,42 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : type 'edn resolver = Endpoint.t -> 'edn option io module F = struct - type _ t = - | Protocol : 'edn key * ('edn, 'flow) impl -> ('edn, 'flow) value t + type 'a impl = (module FLOW with type flow = 'a) + + type _ t = Flow : 'flow key * 'flow impl -> 'flow t end - module Ptr = E0.Make (F) + module Flw = E0.Make (F) + + type flow = Flw.t = private .. + + module type REPR = sig + type t + + type flow += T of t + end + + type 'a repr = (module REPR with type t = 'a) + + module Flow = struct + type 'a impl = 'a F.impl + + type 'a t = 'a Flw.s + + let register : type flow. flow impl -> flow t = + fun flow -> + let key = Map.Key.create "" in + Flw.inj (Flow (key, flow)) - type flow = Ptr.t = private .. + let repr : type flow. flow t -> (module REPR with type t = flow) = + fun (module Witness) -> + let module M = struct + include Witness - type ('edn, 'flow) protocol = ('edn, 'flow) value Ptr.s + type t = x + end in + (module M) + end (* XXX(dinosaure): note about performance, [Ptr.prj] can cost where * it's a lookup into the global [hashtbl] (created by [Ptr]). However, @@ -149,49 +176,47 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : *) let recv flow input = - let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = - Ptr.prj flow in - let (Value flow) = flow in + let (Value (flow, Flow (_, (module Protocol)))) = Flw.prj flow in Protocol.recv flow input >>| function | Ok _ as v -> v | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let send (flow : Ptr.t) output = - let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = - Ptr.prj flow in - let (Value flow) = flow in + let send flow output = + let (Value (flow, Flow (_, (module Protocol)))) = Flw.prj flow in Protocol.send flow output >>| function | Ok _ as v -> v | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) let close flow = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in - let (Value flow) = flow in + let (Value (flow, Flow (_, (module Protocol)))) = Flw.prj flow in Protocol.close flow >>| function | Ok _ as v -> v | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let register : type edn flow. (edn, flow) impl -> (edn, flow) protocol = - fun protocol -> - let key = Map.Key.create "" in - Ptr.inj (Protocol (key, protocol)) + module P = struct + type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value - module type REPR = sig - type t - - type flow += T of t + type _ t = + | Protocol : + 'edn key * 'flow Flow.t * ('edn, 'flow) impl + -> ('edn, 'flow) value t end - let repr : - type edn v. - (edn, v) protocol -> (module REPR with type t = (edn, v) value) = - fun (module Witness) -> - let module M = struct - include Witness + module Ptr = E0.Make (P) + + type ('edn, 'flow) protocol = { + protocol : ('edn, 'flow) P.value Ptr.s; + flow : 'flow Flow.t; + } + + let register : type edn flow. (edn, flow) impl -> (edn, flow) protocol = + fun (module M) -> + let flow = Flow.register (module M) in + let key = Map.Key.create "" in + let protocol = Ptr.inj (Protocol (key, flow, (module M))) in + { flow; protocol } - type t = x - end in - (module M) + let repr t = Flow.repr t.flow let ( <.> ) f g x = f (g x) @@ -206,8 +231,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : edn resolver -> resolvers -> resolvers = - fun (module Witness) ?priority resolve -> - let (Protocol (key, _)) = Witness.witness in + fun { protocol = (module Witness); _ } ?priority resolve -> + let (Protocol (key, _, _)) = Witness.witness in let resolve = inj <.> resolve in Map.add key (Resolver { priority; resolve; witness }) @@ -224,20 +249,20 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : fun key edn -> let rec go = function | [] -> return (Error `Not_found) - | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: r -> + | Ptr.Key (Protocol (k, (module Flow), (module Protocol))) :: r -> match Map.Key.(key == k) with | None -> go r | Some E1.Refl.Refl -> ( Protocol.connect edn >>= function - | Ok flow -> return (Ok (ctor (Value flow))) + | Ok flow -> return (Ok (Flow.T flow)) | Error _err -> go r) in go (Ptr.bindings ()) let flow_of_protocol : type edn flow. (edn, flow) protocol -> edn -> (flow, [> error ]) result io = - fun (module Witness) edn -> - let (Protocol (_, (module Protocol))) = Witness.witness in + fun { protocol = (module Witness); _ } edn -> + let (Protocol (_, _, (module Protocol))) = Witness.witness in Protocol.connect edn >>= function | Ok flow -> return (Ok flow) | Error err -> return (error_msgf "%a" Protocol.pp_error err) @@ -293,7 +318,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : go l let pack : type edn v. (edn, v) protocol -> v -> flow = - fun (module Witness) flow -> Witness.T (Value flow) + fun { flow = (module Witness); _ } flow -> Witness.T flow let resolve : type edn v. @@ -304,8 +329,10 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : fun m ?protocol domain_name -> match protocol with | None -> create m domain_name - | Some (module Witness) -> - let (Protocol (key', _)) = Witness.witness in + | Some protocol -> + let (module Protocol) = protocol.protocol in + let (module Flow) = protocol.flow in + let (Protocol (key', _, _)) = Protocol.witness in resolve m domain_name >>= fun l -> let rec go = function | [] -> return (Error `Not_found) @@ -313,40 +340,35 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : match Map.Key.(key == key') with | None -> go r | Some E1.Refl.Refl -> ( - flow_of_protocol (module Witness) edn >>= function - | Ok flow -> return (Ok (Witness.T (Value flow))) + flow_of_protocol protocol edn >>= function + | Ok flow -> return (Ok (Flow.T flow)) | Error _err -> go r) in go l let connect : type edn v. edn -> (edn, v) protocol -> (flow, [> error ]) result io = - fun edn (module Witness) -> - let (Protocol (_, (module Protocol))) = Witness.witness in + fun edn { protocol = (module Witness); _ } -> + let (Protocol (_, (module Flow), (module Protocol))) = Witness.witness in Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) - >>? fun flow -> return (Ok (Witness.T (Value flow))) + >>? fun flow -> return (Ok (Flow.T flow)) type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack let unpack : flow -> unpack = fun flow -> - let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = - Ptr.prj flow in - let (Value flow) = flow in - Flow (flow, (module Protocol)) + let (Value (flow, Flow (_, m))) = Flw.prj flow in + Flow (flow, m) let impl : type edn flow. (edn, flow) protocol -> (module PROTOCOL with type endpoint = edn and type flow = flow) = - fun (module Witness) -> - let (Protocol (_, (module Protocol))) = Witness.witness in + fun { protocol = (module Witness); _ } -> + let (Protocol (_, _, (module Protocol))) = Witness.witness in (module Protocol) let cast : type edn v. flow -> (edn, v) protocol -> v option = - fun flow witness -> - match Ptr.extract flow witness with - | Some (Value flow) -> Some flow - | None -> None + fun flow witness -> Flw.extract flow witness.flow module type SERVICE = SERVICE with type +'a io = 'a io diff --git a/src/core/conduit.mli b/src/core/conduit.mli index 45d7ebf5..b8754784 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -6,9 +6,6 @@ type resolvers val empty : resolvers (** [empty] is an empty {!resolvers} map. *) -type ('edn, 'flow) value = ('edn, 'flow) Conduit_intf.value = - | Value : 'flow -> ('edn, 'flow) value - module type S = Conduit_intf.S (** @inline *) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 078ec4fd..752b4ecd 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -112,8 +112,6 @@ end type ('a, 'b) refl = Refl : ('a, 'a) refl -type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value - module type S = sig module Endpoint : module type of Endpoint @@ -137,9 +135,9 @@ module type S = sig implementation: {[ - Conduit.connect domain_name >>? function - | Conduit_lwt_unix_tcp.T Conduit.(Value (file_descr : Lwt_unix.file_descr)) -> ... - | Conduit_lwt_unix_tls.T Conduit.(Value (fd, (tls : Tls.Engine.state))) -> ... + connect domain_name >>? function + | Conduit_lwt_unix_tcp.T (file_descr : Lwt_unix.file_descr) -> ... + | Conduit_lwt_unix_tls.T (_, (tls : Tls.Engine.state)) -> ... | _ -> ... (* use flow functions for the default case *) ]} *) @@ -214,6 +212,11 @@ module type S = sig endpoints, while [Unix.file_descr] would be used for the flow transport. {[ + module TCP : + PROTOCOL + with type endpoint = Unix.sockaddr + and type flow = Unix.file_descr = struct ... end + module Conduit_tcp : sig val t : (Unix.sockaddr, Unix.file_descr) protocol end = struct @@ -226,6 +229,11 @@ module type S = sig transparently: {[ + module TLS : + PROTOCOL + with type endpoint = Unix.sockaddr * Tls.config_client + and type flow = Unix.file_descr = struct ... end + module Conduit_tcp_tls : sig val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol end = struct @@ -267,32 +275,33 @@ module type S = sig type flow += T of t end - val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - (** As a protocol implementer, you should expose the concrete type of your - flow (to be able users to {i destruct} {!flow}). [repr] returns a module - which contains extension of {!flow} from your [protocol] such as: + type 'a repr = (module REPR with type t = 'a) + (** The type for {!REPR} values. *) + + val repr : (_, 'flow) protocol -> 'flow repr + (** [repr t] is a module which contains the concrete representation of flow + values. It can then be used to destruct {!flow} values, via + pattern-matching. For instance, For to set the underlying file-decriptor + as non-blocking, one can do: {[ - module Conduit_tcp : sig - type t = (Unix.sockaddr, Unix.file_descr) Conduit.value + module TCP : + PROTOCOL + with type endpoint = Unix.sockaddr + and type flow = Unix.file_descr = struct ... end - type Conduit.flow += T of t + module Conduit_tcp : sig + type flow += T of Unix.file_descr val t : (Unix.sockaddr, Unix.file_descr) protocol end = struct let t = register (module TCP) - include (val Conduit.repr t) + include (val repr t) end - ]} - - With this interface, users are able to {i destruct} {!flow} to your - concrete type: - {[ - Conduit.connect domain_name >>? function - | Conduit_tcp.T (Conduit.Value file_descr) -> ... - | _ -> ... + let set_nonblock (flow : flow) = + match flow with Conduit_tcp.T fd -> Unix.set_nonblock fd | _ -> () ]} *) type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack @@ -302,14 +311,12 @@ module type S = sig abstract [flow] such as: {[ - Conduit.connect edn >>= fun flow -> - let (Conduit.Flow (flow, (module Flow))) = Conduit.unpack flow in + connect edn >>= fun flow -> + let (Flow (flow, (module Flow))) = unpack flow in Flow.send flow "Hello World!" ]} *) - val impl : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + val impl : ('edn, 'flow) protocol -> ('edn, 'flow) impl (** [impl protocol] is [protocol]'s implementation. *) val cast : flow -> (_, 'flow) protocol -> 'flow option @@ -317,7 +324,7 @@ module type S = sig type described by the given [protocol]. {[ - match Conduit.is flow Conduit_tcp.t with + match cast flow Conduit_tcp.t with | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) | None -> None @@ -330,8 +337,8 @@ module type S = sig {[ let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let flow = Conduit.pack Conduit_tcp.t socket in - Conduit.send flow "Hello World!" + let flow = pack Conduit_tcp.t socket in + send flow "Hello World!" ]} *) (** {2:resolution Domain name resolvers.} *) @@ -408,12 +415,11 @@ module type S = sig |> add tcp ~priority:20 resolver_on_internet let () = - Conduit.resolve resolvers (Conduit.Endpoint.domain mirage_io) - >>? function - | TCP.T (Conduit.Value file_descr) as flow -> + resolve resolvers (Endpoint.domain mirage_io) >>? function + | TCP.T file_descr as flow -> let peer = Unix.getpeername file_descr in - ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) - | flow -> ignore @@ Conduit.send flow "Hello World!" + ignore @@ send flow ("Hello " ^ string_of_sockaddr peer) + | flow -> ignore @@ send flow "Hello World!" ]} *) val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io @@ -457,13 +463,18 @@ module type S = sig For instance: {[ - module TCP_service : SERVICE with type configuration = Unix.sockaddr - and type t = Unix.file_descr - and type flow = Unix.file_descr - - let tcp_protocol = Conduit.register (module TCP_protocol) - let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = - Conduit.Service.register (module TCP_service) tcp_protocol + module TCP_service : + SERVICE + with type configuration = Unix.sockaddr + and type t = Unix.file_descr + and type flow = Unix.file_descr = struct ... end + + let tcp_protocol = register (module TCP_protocol) + + let tcp_service : + (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.t + = + Service.register (module TCP_service) tcp_protocol ]} *) type error = [ `Msg of string ] @@ -487,16 +498,16 @@ module type S = sig {!flow}. {[ - let handler (flow : Conduit.flow) = - Conduit.send flow "Hello World!" >>= fun _ -> + let handler (flow : flow) = + send flow "Hello World!" >>= fun _ -> ... let run service cfg = - let module Service = Conduit.Service.impl service in + let module Service = Service.impl service in Service.init cfg >>? fun t -> let rec loop t = Service.accept t >>? fun flow -> - let flow = Conduit.Service.pack service flow in + let flow = Service.pack service flow in async (fun () -> handler flow) ; loop t in loop t diff --git a/src/core/e0.ml b/src/core/e0.ml index 1bdb5ecf..4e2cc6f0 100644 --- a/src/core/e0.ml +++ b/src/core/e0.ml @@ -100,7 +100,7 @@ module Make (Key : S1) = struct type v = Value : 'a * 'a Key.t -> v - type k = Key : 'a Key.t * ('a -> t) -> k + type k = Key : 'a Key.t -> k let equal : type a b. a s -> b s -> (a, b) refl option = fun a b -> @@ -127,7 +127,7 @@ module Make (Key : S1) = struct let witness = X.witness - let key = Key (witness, fun x -> T x) + let key = Key witness let value x = Value (x, witness) diff --git a/src/core/e0.mli b/src/core/e0.mli index b3dc6ddb..da41c78e 100644 --- a/src/core/e0.mli +++ b/src/core/e0.mli @@ -24,7 +24,7 @@ module Make (Key : S1) : sig type v = Value : 'a * 'a Key.t -> v - type k = Key : 'a Key.t * ('a -> t) -> k + type k = Key : 'a Key.t -> k val equal : 'a s -> 'b s -> ('a, 'b) refl option diff --git a/src/core/readme.mld b/src/core/readme.mld index 3c192d90..6e0c7362 100644 --- a/src/core/readme.mld +++ b/src/core/readme.mld @@ -170,10 +170,8 @@ The end user is then able to {i destruct} the flow to this type: {[ let hello (flow : Conduit.flow) = match flow with - | T (Value file_descr) -> - Unix.write file_descr "Hello World!" - | flow -> - Conduit.send flow "Hello World!" + | T file_descr -> Unix.write file_descr "Hello World!" + | flow -> Conduit.send flow "Hello World!" ]} Of course, we can not assert that the given [flow] is, in any case, an diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index 7fbd6c98..d91f37f3 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -97,10 +97,5 @@ module TCP : sig ?verify:verify -> (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver - type t = - ( (Lwt_unix.sockaddr, Conduit_lwt.TCP.Protocol.flow) endpoint, - Lwt_ssl.socket ) - Conduit.value - - type Conduit_lwt.flow += T of t + type Conduit_lwt.flow += T of Lwt_ssl.socket end diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 0cdde867..1e455e3f 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -40,12 +40,7 @@ module TCP : sig Protocol.flow protocol_with_tls ) protocol - type t = - ( Lwt_unix.sockaddr * Tls.Config.client, - Protocol.flow protocol_with_tls ) - Conduit.value - - type Conduit_lwt.flow += T of t + type Conduit_lwt.flow += T of Protocol.flow protocol_with_tls val service : ( configuration * Tls.Config.server, diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index cb006311..4a63e392 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -112,9 +112,7 @@ module TCP : sig val protocol : (Lwt_unix.sockaddr, Protocol.flow) protocol - type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value - - type flow += T of t + type flow += T of Protocol.flow val service : (configuration, Service.t, Protocol.flow) service From 5b03c98d7cae7123410b09c7c97ebd3f09488026 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Sun, 29 Nov 2020 16:09:16 +0100 Subject: [PATCH 2/2] Add tests about type equality and Conduit.repr --- tests/flow.ml | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/tests/flow.ml b/tests/flow.ml index 4955ee6a..985a6b18 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -247,6 +247,64 @@ let test_output_strings = (String.concat "" (List.map Bytes.to_string bufs)) "Hello World!" +(* XXX(dinosaure): ensure type equality. *) + +module Dummy_flow = struct + type input = bytes + + type output = string + + type +'a io = 'a + + type flow = Flow + + type error = | + + let pp_error : Format.formatter -> error -> unit = fun _ -> function _ -> . + + let recv Flow _ = Ok `End_of_flow + + let send Flow _ = Ok 0 + + let close Flow = Ok () +end + +module Dummy_protocol = struct + include Dummy_flow + + type endpoint = | + + let connect : endpoint -> (flow, error) result io = function _ -> . +end + +module Dummy_service = struct + include Dummy_flow + + type configuration = Configuration + + type t = T + + let init Configuration = Ok T + + let accept T = Ok Flow + + let close T = Ok () +end + +let dummy_protocol = Conduit.register (module Dummy_protocol) + +let dummy_service = + Conduit.Service.register (module Dummy_service) dummy_protocol + +let test_type_equality = + Alcotest.test_case "type equality" `Quick @@ fun () -> + let[@warning "-8"] (Ok t) = + Conduit.Service.init dummy_service Dummy_service.Configuration in + let module Repr = (val Conduit.repr dummy_protocol) in + match Conduit.Service.accept dummy_service t with + | Ok (Repr.T Dummy_flow.Flow) -> Alcotest.(check pass) "type equality" () () + | _ -> Alcotest.failf "Invalid flow value" + let tests = [ ( "flow", @@ -255,5 +313,6 @@ let tests = test_output_string; test_input_strings; test_output_strings; + test_type_equality; ] ); ]