From ed9629d9e84efc94e180e7de3f0988bf4c13bc52 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 15:59:44 +0200 Subject: [PATCH 001/140] Delete Travis Continuous Integration --- .travis.yml | 20 -------------------- 1 file changed, 20 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 6288a445..00000000 --- a/.travis.yml +++ /dev/null @@ -1,20 +0,0 @@ -language: c -sudo: false -services: - - docker -install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh -script: bash ./.travis-docker.sh -env: - global: - - PINS="conduit:. conduit-mirage:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." - - TESTS=true - matrix: - - OCAML_VERSION=4.10 PACKAGE=conduit-lwt-unix DISTRO=fedora DEPOPTS="lwt_ssl tls" - - OCAML_VERSION=4.10 PACKAGE=conduit-mirage DISTRO=alpine - - OCAML_VERSION=4.09 PACKAGE=conduit-lwt-unix DISTRO=debian-testing DEPOPTS="lwt_ssl tls" - - OCAML_VERSION=4.08 PACKAGE=conduit-lwt-unix DISTRO=debian-stable DEPOPTS="lwt_ssl tls" - - OCAML_VERSION=4.07 PACKAGE=conduit-mirage DISTRO=alpine - - OCAML_VERSION=4.07 PACKAGE=conduit-lwt-unix DISTRO=debian-unstable DEPOPTS="lwt_ssl tls" - - OCAML_VERSION=4.05 PACKAGE=conduit-async DISTRO=debian-unstable DEPOPTS=async_ssl - - OCAML_VERSION=4.06 PACKAGE=conduit-async DISTRO=centos DEPOPTS=async_ssl - - OCAML_VERSION=4.06 PACKAGE=conduit-async DISTRO=ubuntu DEPOPTS=async_ssl From 00f8338422790754aa0e1750e660428845bb7f06 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:03:35 +0200 Subject: [PATCH 002/140] Update GitHub Actions script --- .github/workflows/test.yml | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c6bbd044..480b0c39 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -13,16 +13,36 @@ jobs: - uses: avsm/setup-ocaml@master with: ocaml-version: ${{ matrix.ocaml-version }} + - name: Install pkg-config + if: runner.os == 'macOS' + run: brew install pkg-config - name: Deps + if: runner.os != 'Windows' run: | opam pin add -n conduit.dev . opam pin add -n conduit-lwt.dev . opam pin add -n conduit-lwt-unix.dev . opam pin add -n conduit-async.dev . opam pin add -n conduit-mirage.dev . - opam depext -y conduit conduit-lwt conduit-lwt-unix conduit-async conduit-mirage - opam install --deps-only . + opam pin add -n conduit-tls.dev . + opam depext -y conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-async conduit-mirage + opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-async conduit-mirage + - name: Deps (Windows) + if: runner.os == 'Windows' + run: | + opam pin add -n conduit.dev . + opam pin add -n conduit-lwt.dev . + opam pin add -n conduit-lwt-unix.dev . + opam pin add -n conduit-mirage.dev . + opam pin add -n conduit-tls.dev . + opam depext -y conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-mirage + opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-mirage + - name: Build (Windows) + if: runner.os == 'Windows' + run: opam exec -- dune build -p conduit,conduit-tls,conduit-lwt,conduit-lwt-unix,conduit-mirage - name: Build + if: runner.os != 'Windows' run: opam exec -- dune build - name: Test - run: opam exec -- dune runtest + if: runner.os != 'Windows' + run: opam exec -- dune runtest --no-buffer --verbose -j 1 From 9a698a2abb8a21c41927999cf0823bdc8dc7a89a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:04:50 +0200 Subject: [PATCH 003/140] Support ocamlformat --- .ocamlformat | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000..71d5f8aa --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,8 @@ +version = 0.14.1 +break-infix = fit-or-vertical +parse-docstrings = true +indicate-multiline-delimiters=no +nested-match=align +sequence-style=separator +break-before-in=auto +if-then-else=keyword-first From 417c8a2c2332296048efee322e369db1cdb01435 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:06:29 +0200 Subject: [PATCH 004/140] Use dune 2.0 --- dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune-project b/dune-project index 238a7ee7..274b40e7 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,2 @@ -(lang dune 1.0) +(lang dune 2.0) (name conduit) From 37888a6abf3742bc834b805eee49d3e73a6f358c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:39:22 +0200 Subject: [PATCH 005/140] New implementation of conduit (core library) The core library gives only abstractions needed further. It lets the end-user to choose: - the type `input` - the type `output` - the type `+'a s` (the scheduler) Definition of them will create an internal hashtbl which prospects available protocols. The core library provides without application of functors a local map `resolvers` which is needed to start a connection (eg. `Conduit.flow`). `resolvers` represents the global process to resolve a domain-name to a `flow` used by `conduit`. More technically: - E1 is the local map `resolvers` - E0 is the hidden global hashtbl of `conduit` - Sigs contains signatures needed by `conduit` This commit adds a README.md which explains how to use `conduit`. --- lib/README.md | 173 +++++++++++ lib/conduit.ml | 505 ++++++++++++++++++++++++++++-- lib/conduit.mli | 718 +++++++++++++++++++++++++++++++++++++++---- lib/conduit_trie.ml | 106 ------- lib/conduit_trie.mli | 40 --- lib/dune | 12 +- lib/e0.ml | 78 +++++ lib/e0.mli | 34 ++ lib/e1.ml | 113 +++++++ lib/e1.mli | 55 ++++ lib/index.mld | 43 --- lib/resolver.ml | 175 ----------- lib/resolver.mli | 96 ------ lib/sigs.ml | 98 ++++++ 14 files changed, 1677 insertions(+), 569 deletions(-) create mode 100644 lib/README.md delete mode 100644 lib/conduit_trie.ml delete mode 100644 lib/conduit_trie.mli create mode 100644 lib/e0.ml create mode 100644 lib/e0.mli create mode 100644 lib/e1.ml create mode 100644 lib/e1.mli delete mode 100644 lib/index.mld delete mode 100644 lib/resolver.ml delete mode 100644 lib/resolver.mli create mode 100644 lib/sigs.ml diff --git a/lib/README.md b/lib/README.md new file mode 100644 index 00000000..e44605de --- /dev/null +++ b/lib/README.md @@ -0,0 +1,173 @@ +## Conduit - core library + +The main goal of `conduit` is to be able to use an abstract type flow as a +representation of a `socket` independently of the implementation. + +Of course, this case appears on MirageOS where the implementation depends on the +_target_. But it can be more general where, as a library, you should not depends +on a given implementation of a protocol. In such context, you are able to +implement a way to communicate with a peer without a full knowledge of the +underlying protocol used. + +By this abstraction, protocol implementer can _compose_ the protocol with an +other layer such as TLS and still be able to provide the same interface. + +`conduit` wants to provide a common way to start a server too. This feature is +less abstracted than the communication with a peer but it provides a better +interface than before. + +### Implementation and `resolvers` + +Conduit splits the knowledge of protocols into 2 elements: +- a global `Hashtbl.t` +- a local `resolvers` + +A protocol must be registered with `register_protocol`: +```ocaml +let witness = Conduit.register_protocol ~key ~protocol:(module Protocol) +``` + +A protocol must follow an interface described by `PROTOCOL`. The implementer +must create a new `key` with `Conduit.key`. + +The _witness_ can be ignored and hidden. However, it should be properly exposed +with the protocol to help the end-user to enforce `conduit` to use this specific +protocol. + +The registration fills the internal global `Hashtbl` of `conduit`. Even if this +implementation is available into `conduit`, it's not true that `conduit` will +systematically use it (it's the main difference with the old version of +`conduit`). However, the _key_ used to register your protocol must exposed, +otherwise your protocol will never be available with `conduit`. + +In fact, the registration needs a `key` which is a _witness_ of needed value to +_initialize_ a flow according your protocol implementation. For example, an +`Unix.socket` must need a `Unix.socket_domain` to be created. The type of this +value will be a part of the _witness_ `key`. + +By this way, registration of a protocol must be done like this: +```ocaml +let key = Conduit.key "my-protocol" +let witness = Conduit.register_protocol ~key ~protocol:(module Protocol) +``` + +Then, `key` must be exposed to the end-user to be able to fill `resolvers`. + +#### As the end-user wants + +So even if your protocol is well registered into `conduit`, the end-user still +is able to use or ignore it. The existence into the resolution process of +`conduit` of your protocol only exists if the end-user fill the given +`resolvers` with your `key`. + +By this way, it is on the responsibility of the end-user to properly create +needed values by the _initialization_ of the flow according your protocol +implementation. + +```ocaml +(* we assume a TCP/IP protocol imported by a library. *) +val key : Unix.inet_addr Conduit.key +val witness : Unix.file_descr Conduit.Witness.protocol + +let resolve domain_name : Unix.inet_addr option = Unix.gethostbyname domain_name +let resolvers = Conduit.register_resolver ~key resolve Conduit.empty + +let _ = + Conduit.flow resolvers domain_name >>= fun flow -> ... +``` + +In your example, others protocols can be registered such as SSH or TCP + TLS, +however, the end-user registered into the `resolvers` only the TCP protocol. +Such example shows that the end-user can restrict the resolution on few +protocols like secured protocols. + +This new way to start a connection lets the end-user to specify: +- which protocol he wants to use +- how such protocol can be created +- which resolves the domain-name + +Usually, the third point is a call to `gethostbyname` which trusts on your +`/etc/resolv.conf` but such service does not exist into a MirageOS world. So +`conduit` gives the ability to specify which service handles that. + +The second point is the most important where it lets the user to specify a +process/function to _initialize_ a communication. For example, the TLS stack +expects an _authenticator_ which verifies the given certificate by your peer - +the user is able to specify an _authenticator_ which trusts on a specifc chain +of certificates. + +The first point is to let the user to enforce a protocol. Instead to try several +of them in order to their priorities, the user can enforce to use a special one. + +### Create a new flow + +As an implementer of a protocol, the way to create a /flow/ differs for each +protocols. We said that an `Unix.socket` needs a `Unix.socket_domain` to be +created. However, it's not the case for a TLS flow which should need a +`Tls.Config.t` (or basically something more complex). + +At the end, `conduit` lets the end-user to create this kind of value used then +to properly create a `flow`. Finally `conduit` has the ability to let the +implementer to define the type of this required value. + +In your previous example it's our `resolve` function. + +The rule is easy, for N `key`, the end-user should (but it's not mandatory) +define N `resolve` functions. A registration of them into a `resolvers` element +will let `conduit` to try to initiate a _flow_ to the associated protocol - this +association is done by the registration of the protocol between the `key` and +the implementation. + +At the end, the process of the resolution is clear: +``` +[ `host ] Domain_name.t -> 'edn -> 'flow -> Conduit.flow +``` + +Where `'edn` is specified by the `key` and `'flow`, by the protocol. The +end-user must implement a function `resolver : [ host ] Domain_name.t` and the +implementer must provide a function `flow : 'edn -> 'flow`. Then, `conduit` does +the glue between them to provide a fully-abstract `Conduit.flow`. + +### How to use the `flow` + +As an abstracted value, the returned `flow` can be use by: +- `Conduit.recv` +- `Conduit.send` +- `Conduit.close` + +NOTE: semantic of them depends on the implementation used by `conduit`. + +Internally, `conduit` _extracts_ your `flow` and infer the proper implementation +associated. Then, it uses this implementation registered into our internal +global `Hashtbl.t`. + +In other words, a `flow` created by our TCP/IP implementation stack will be +associated to this implementation as long as it exists. + +### Provide something more than `PROTOCOL` + +It appears that some protocols want to expose more functions that what +`PROTOCOL` defines. By this fact, `conduit` should able to expose such +functions. With the _witness_ given by the registration of the protocol, the +end-user has the ability to extract by himself the real underlying flow. + +For example, a TCP/IP `flow` can returns some information such as the IP and +port where it is connected. With the _witness_ of the TCP/IP protocol, we are +able to extract the underlying `Unix.file_descr` (considering as is) and use +directly `Unix.*` functions. + +```ocaml +let peer = match Conduit.is flow witness with + | Some socket -> Unix.getpeername socket + | None -> failwith "It's not an Unix TCP/IP connection" +``` + +A layer such as TLS can expose such accessors too like: +```ocaml +type 'flow with_tls + +val underlying : 'flow with_tls -> 'flow +val handshake : 'flow with_tls -> bool +``` + +The end-user has several ways to extract structural `flow` from the abstracted one. diff --git a/lib/conduit.ml b/lib/conduit.ml index 0a602618..2f0d79d1 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -1,35 +1,472 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -open Sexplib.Std - -(** The resolver will return an [endp], which the Conduit - backend must interpret to make a connection. *) -type endp = [ - | `TCP of Ipaddr_sexp.t * int (** ipaddr and dst port *) - | `Unix_domain_socket of string (** unix file path *) - | `Vchan_direct of int * string (** domain id, port *) - | `Vchan_domain_socket of string * string - | `TLS of string * endp (** wrap in a TLS channel, [hostname,endp] *) - | `Unknown of string (** failed resolution *) -] [@@deriving sexp] - -module type IO = sig - type +'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val return : 'a -> 'a t +module Sigs = Sigs + +type ('a, 'b) refl = Refl : ('a, 'a) refl + +let strf = Format.asprintf + +type _ witness = .. + +type _ resolver = + | Resolver : { + priority : int; + resolve : [ `host ] Domain_name.t -> ('edn option, 's) Sigs.app; + witness : 's witness; + } + -> ('edn * 's) resolver + +module Map = + E1.Make + (struct + type _ t = string + end) + (struct + type 'a t = 'a resolver + end) + +type resolvers = Map.t + +type 'a key = 'a Map.key + +let empty = Map.empty + +module type S = sig + type input + + type output + + type +'a s + + type scheduler + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + + type ('edn, 't, 'flow) service = + (module SERVICE + with type endpoint = 'edn + and type t = 't + and type flow = 'flow) + + type ('edn, 'flow) protocol = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + + type flow + + val recv : + flow -> input -> (int Sigs.or_end_of_input, [> `Msg of string ]) result s + + val send : flow -> output -> (int, [> `Msg of string ]) result s + + val close : flow -> (unit, [> `Msg of string ]) result s + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + + type 'edn key = ('edn * scheduler) Map.key + + module Witness : sig + type 'flow protocol + + type 't service + + val equal_protocol : 'a protocol -> 'b protocol -> ('a, 'b) refl option + + val equal_service : 'a service -> 'b service -> ('a, 'b) refl option + end + + val key : string -> 'edn key + + val name_of_key : 'edn key -> string + + val register_service : + key:'edn key -> + service:('edn, 't, 'flow) service -> + protocol:'flow Witness.protocol -> + ('t * 'flow) Witness.service + + val register_protocol : + key:'edn key -> protocol:('edn, 'flow) protocol -> 'flow Witness.protocol + + val register_resolver : + key:'edn key -> ?priority:int -> 'edn resolver -> resolvers -> resolvers + + type error = [ `Msg of string | `Not_found | `Unresolved | `Invalid_key ] + + val pp_error : Format.formatter -> error -> unit + + val abstract : 'flow Witness.protocol -> 'flow -> flow + + val flow_of_endpoint : key:'edn key -> 'edn -> (flow, [> error ]) result s + + val flow_of_protocol : + key:'edn key -> + 'edn -> + protocol:'flow Witness.protocol -> + ('flow, [> error ]) result s + + val flow : + resolvers -> + ?key:'edn key -> + ?protocol:'flow Witness.protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s + + val serve : + key:'edn key -> + 'edn -> + service:('t * 'flow) Witness.service -> + ('t * 'flow Witness.protocol, [> error ]) result s + + val impl_of_service : + key:'edn key -> + ('t * 'flow) Witness.service -> + ( (module SERVICE + with type endpoint = 'edn + and type t = 't + and type flow = 'flow), + [> error ] ) + result + + val impl_of_protocol : + key:'edn key -> + 'flow Witness.protocol -> + ( (module PROTOCOL with type endpoint = 'edn and type flow = 'flow), + [> error ] ) + result + + val impl_of_flow : + 'flow Witness.protocol -> (module FLOW with type flow = 'flow) + + val is : flow -> 'flow Witness.protocol -> 'flow option +end + +module Make + (Scheduler : Sigs.SCHEDULER) + (Input : Sigs.SINGLETON) + (Output : Sigs.SINGLETON) : + S + with type input = Input.t + and type output = Output.t + and type +'a s = 'a Scheduler.t = struct + module Bijection = Sigs.Higher (Scheduler) + + let inj = Bijection.inj + + let prj = Bijection.prj + + type scheduler = Bijection.t + + type _ witness += Witness : scheduler witness + + let witness : scheduler witness = Witness + + type input = Input.t + + type output = Output.t + + type +'a s = 'a Scheduler.t + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + + type ('edn, 't, 'flow) service = + (module SERVICE + with type endpoint = 'edn + and type t = 't + and type flow = 'flow) + + type ('edn, 'flow) protocol = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + + type 'edn key = ('edn * scheduler) Map.key + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + + module B = struct + type 't t = Protocol : 'edn key * ('edn, 'flow) protocol -> 'flow t + end + + module Ptr = E0.Make (B) + + type flow = Ptr.t + + module A = struct + type 't t = + | Service : + 'edn key * ('edn, 't, 'flow) service * 'flow Ptr.s + -> ('t * 'flow) t + end + + module Svc = E0.Make (A) + + module Witness = struct + type 't service = 't Svc.s + + type 'flow protocol = 'flow Ptr.s + + let equal_protocol : + type a b. a protocol -> b protocol -> (a, b) refl option = + fun a b -> + match Ptr.equal a b with Some E0.Refl -> Some Refl | None -> None + + let equal_service : type a b. a service -> b service -> (a, b) refl option = + fun a b -> + match Svc.equal a b with Some E0.Refl -> Some Refl | None -> None + end + + let return = Scheduler.return + + let ( >>= ) x f = Scheduler.bind x f + + let ( >>| ) x f = x >>= fun x -> return (f x) + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> return (Error err) + + let recv flow input = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.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 output = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.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 + Protocol.close flow >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) + + let key name = Map.Key.create name + + let name_of_key : type edn. edn key -> string = fun key -> Map.Key.info key + + let register_service : + type edn t flow. + key:edn key -> + service:(edn, t, flow) service -> + protocol:flow Witness.protocol -> + (t * flow) Witness.service = + fun ~key ~service ~protocol -> Svc.inj (Service (key, service, protocol)) + + let register_protocol : + type edn flow. + key:edn key -> protocol:(edn, flow) protocol -> flow Witness.protocol = + fun ~key ~protocol -> Ptr.inj (Protocol (key, protocol)) + + let ( <.> ) f g x = f (g x) + + let register_resolver : + type edn. + key:edn key -> ?priority:int -> edn resolver -> resolvers -> resolvers = + fun ~key ?(priority = 0) resolve -> + let resolve = inj <.> resolve in + Map.add key (Resolver { priority; resolve; witness }) + + type error = [ `Msg of string | `Not_found | `Unresolved | `Invalid_key ] + + let pf ppf fmt = Format.fprintf ppf fmt + + let pp_error ppf = function + | `Msg err -> pf ppf "%s" err + | `Not_found -> pf ppf "Not found" + | `Unresolved -> pf ppf "Unresolved" + | `Invalid_key -> pf ppf "Invalid key" + + let flow_of_endpoint : + type edn. key:edn key -> edn -> (flow, [> error ]) result s = + fun ~key edn -> + let rec go = function + | [] -> return (Error `Not_found) + | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: r -> + match Map.Key.(key == k) with + | None -> go r + | Some E1.Refl.Refl -> ( + Protocol.flow edn >>= function + | Ok flow -> return (Ok (ctor flow)) + | Error _err -> go r) in + go (Ptr.bindings ()) + + let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt + + let flow_of_protocol : + type edn flow. + key:edn key -> + edn -> + protocol:flow Witness.protocol -> + (flow, [> error ]) result s = + fun ~key edn ~protocol:(module P) -> + let (Protocol (k', (module Protocol))) = P.witness in + match Map.Key.(key == k') with + | None -> return (Error `Invalid_key) + | Some E1.Refl.Refl -> ( + Protocol.flow edn >>= function + | Ok flow -> return (Ok flow) + | Error err -> return (error_msgf "%a" Protocol.pp_error err)) + + type endpoint = Endpoint : 'edn key * 'edn -> endpoint + + module Refl = struct + type ('a, 'b) t = Refl : ('a, 'a) t + end + + let scheduler : type s. s witness -> (s, scheduler) Refl.t option = function + | Witness -> Some Refl.Refl + | _ -> None + + let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = + fun m domain_name -> + let rec go acc = function + | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) + | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> + match scheduler witness with + | None -> go acc r + | Some Refl.Refl -> ( + resolve domain_name |> prj >>= function + | Some edn -> go (Endpoint (k, edn) :: acc) r + | None -> go acc r) in + let compare (Map.Value (_, Resolver { priority = pa; _ })) + (Map.Value (_, Resolver { priority = pb; _ })) = + (Stdlib.compare : int -> int -> int) pa pb in + go [] (List.sort compare (Map.bindings m)) + + let create : + resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = + fun m domain_name -> + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> ( + flow_of_endpoint ~key edn >>= function + | Ok flow -> return (Ok flow) + | Error _err -> go r) in + go l + + let abstract : type v. v Witness.protocol -> v -> flow = + fun (module P) flow -> P.T flow + + let flow : + type edn f. + resolvers -> + ?key:edn key -> + ?protocol:f Witness.protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s = + fun m ?key ?protocol domain_name -> + match (key, protocol) with + | None, None -> create m domain_name + | Some key, None -> ( + match Map.find key m with + | None -> return (Error `Not_found) + | Some (Resolver { resolve; witness; _ }) -> + match scheduler witness with + | None -> return (Error `Unresolved) + | Some Refl.Refl -> ( + resolve domain_name |> prj >>= function + | Some edn -> flow_of_endpoint ~key edn + | None -> return (Error `Unresolved))) + | None, Some protocol -> + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> ( + flow_of_protocol ~key edn ~protocol >>= function + | Ok flow -> + let module P = (val protocol) in + let (Protocol (_, (module Protocol))) = P.witness in + return (Ok (P.T flow)) + | Error _err -> go r) in + go l + | Some key, Some protocol -> + match Map.find key m with + | None -> return (Error `Not_found) + | Some (Resolver { resolve; witness; _ }) -> + match scheduler witness with + | None -> return (Error `Unresolved) + | Some Refl.Refl -> ( + resolve domain_name |> prj >>= function + | Some edn -> + flow_of_protocol ~key edn ~protocol >>? fun flow -> + let module P = (val protocol) in + let (Protocol (_, (module Protocol))) = P.witness in + return (Ok (P.T flow)) + | None -> return (Error `Unresolved)) + + let serve : + type edn t flow. + key:edn key -> + edn -> + service:(t * flow) Witness.service -> + (t * flow Witness.protocol, [> error ]) result s = + fun ~key edn ~service:(module S) -> + let (Service (k', (module Service), protocol)) = S.witness in + match Map.Key.(key == k') with + | None -> return (Error `Invalid_key) + | Some E1.Refl.Refl -> ( + Service.make edn >>= function + | Ok t -> return (Ok (t, protocol)) + | Error err -> return (error_msgf "%a" Service.pp_error err)) + + let impl_of_service : + type edn t flow. + key:edn key -> + (t * flow) Witness.service -> + ( (module SERVICE + with type endpoint = edn + and type t = t + and type flow = flow), + [> error ] ) + result = + fun ~key (module S) -> + let (Service (k, (module Service), _)) = S.witness in + match Map.Key.(key == k) with + | Some E1.Refl.Refl -> Ok (module Service) + | None -> Error `Invalid_key + + let impl_of_protocol : + type edn flow. + key:edn key -> + flow Witness.protocol -> + ( (module PROTOCOL with type endpoint = edn and type flow = flow), + [> error ] ) + result = + fun ~key (module P) -> + let (Protocol (k, (module Protocol))) = P.witness in + match Map.Key.(key == k) with + | Some E1.Refl.Refl -> Ok (module Protocol) + | None -> Error `Invalid_key + + let impl_of_flow : + type flow. flow Witness.protocol -> (module FLOW with type flow = flow) = + fun (module P) -> + let (Protocol (_, (module Protocol))) = P.witness in + (module Protocol) + + let is : type v. flow -> v Witness.protocol -> v option = + fun flow witness -> Ptr.extract flow witness end diff --git a/lib/conduit.mli b/lib/conduit.mli index 37456a45..5471dd13 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -1,67 +1,653 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -(** Interface for establishing reliable stream-oriented connections. - - This library abstracts the concerns of establishing connections to - peers that may be running within the same host (e.g. in another - virtual machine) or on a remote host via TCP. It consists of one - library that is responsible for {{!transport}establishing individual - connections}, and a {{!resolution}name resolver} that maps URIs - to endpoints. - - {2:transport Connection Establishment} - - Connections are created by identifying remote nodes using an - {{!endp}endp} value. To ensure portability, the {!endp} values - are translated into concrete connections by separate modules that - target [Lwt_unix], [Async] and [Mirage]. This lets those backends - use the appropriate local technique for creating the connection - (such as using OpenSSL on Unix, or a pure OCaml TLS+TCP - implementation on Mirage, or some other combination). - - The modules dealing with connection establishment are: - {!modules: Conduit_lwt_unix Conduit_async Conduit_mirage} - - {2:resolution Name Resolution} - - This deals with resolving URIs into a list of {!endp} addresses that can - then be connected to by the {{!transport}connection establishment} modules. - - All of the name resolvers conform to the {!RESOLVER} module type. - The OS-specific implementations of this interface are: - {!modules: Resolver_lwt Resolver_lwt_unix Resolver_mirage} - *) - -(** End points that can potentially be connected to. - These are typically returned by a call to a {{!resolution}resolver}. *) -type endp = [ - | `TCP of Ipaddr.t * int (** IP address and destination port *) - | `Unix_domain_socket of string (** Unix domain file path *) - | `Vchan_direct of int * string (** domain id, port *) - | `Vchan_domain_socket of string * string (** Vchan Xen domain socket *) - | `TLS of string * endp (** Wrap in a TLS channel, [hostname,endp] *) - | `Unknown of string (** Failed resolution *) -] [@@deriving sexp] - -(** Module type for cooperative threading that can be satisfied by - Lwt or Async *) -module type IO = sig - type +'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val return : 'a -> 'a t +module Sigs = Sigs + +type ('a, 'b) refl = Refl : ('a, 'a) refl + +(** [Conduit] is a little library which wants to give to the developer the + easiest way to compose protocols and only one way to make a {i Flow}. + Several words are used in this sentence and we need a clear definition of + them to fully understand the purpose of [Conduit]. + + {3 A Protocol.} + + A communication protocol is a system of rules that allows entities to + transmit information. In the case of [Conduit], this kind of information + must not be arbitrary. The protocol should only solve communication problems + such as {i routing}. + + When we talk about a protocol, it's only about a standard which is able to + transmit a {i payload}. Interpretation of the {i payload} is not done by the + {i protocol} but by the user of this library. + + For example, the Transmission Control Protocol (TCP) {b is} a protocol + according to [Conduit] because it is able to transmit {i payload} without + interpreting it. A counter example is the Simple Mail Transfer Protocol + (SMTP) which gives an interpretation of the {i payload} (such as [EHLO] + which is different to [QUIT]). + + This difference is important to unlock the ability to compose {i protocols}. + An other protocol according to [Conduit] is Transport Layer Security (TLS) - + which wants to solve privacy and data integrity. [Conduit] is able to + compose protocols together like [TCP ∘ TLS] to make a new protocol. From + this composition, the user is able to implement Secure Simple Mail Transfer + Protocol (SSMTP) or HyperText Transfer Protocol Secure (HTTPS) - both use + TCP and TLS. + + {3 A Flow.} + + To be able to do this composition, the protocol must respect an interface: + the [FLOW] interface. It defines an abstract type [t] and functions like + [recv] or [send]. These functions give to us the {i payload}. Rules to solve + communication problems are already processed internally. + + In other terms, from a given [FLOW], the user should not handle {i routing}, + privacy or data integrity (or some others problems). The user should only be + able to process the {i payload}. + + Finally, representation of a TCP protocol is a [FLOW]. VCHAN protocol or + User Datagram Protocol (UDP) can be represented by a [FLOW]. However, TLS is + not a flow but a layer on top of another protocol. Composition with it + should look like: + + {[ val with_tls : (module FLOW) -> (module FLOW) ]} + + From a given [FLOW], we {i wrap} it with TLS and return a new [FLOW]. Such a + composition exists also for WireGuard or Noise layers. [Conduit] wants to + solve this composition by a strict OCaml interface of the [FLOW]. + + {3 Resolution.} + + [Conduit] wants to solve one last problem, resolution of an {i endpoint}. + The goal is to make a [FLOW] from an {i endpoint} given by the developer. + + Definition of an endpoint can not fully exist where it depends on the + returned [FLOW]. For example, if we give to you a TCP flow, {i endpoint} + should be an IP and a {i port} where the given [FLOW] is {b already} + connected. + + However, we agree that the most general (by convention) description of the + {i endpoint} is the domain-name. By knowing this, we let the developer to + construct an {i endpoint} from a [\[ `host \] Domain_name.t]. + + At the end, [Conduit] should be able to construct an {i endpoint} from a + [\[ `host \] Domain_name.t]. Then, it tries to find a [SERVICE] according to + the given {i endpoint} and initializes a [FLOW]. + + The most abstract definition provided by [Conduit] is: + + {[ val flow : resolvers -> [ `host ] Domain_name.t -> flow ]} + + Where [resolvers] is a set of {i heterogeneous} constructors of {i + endpoints} given by the developer. The returned value [flow] is an + abstraction of an {b already} initialized communication protocol. From it, + the developer can {i extract} [send] and [recv] functions (as described into + {!A Protocol}). + + {3 Conclusion.} + + [Conduit] is a {i framework} which wants to give a few definitions to {b + restrict} developers of protocols to an interface [FLOW] and, by this way, + provide them with a set of tools to compose with others protocols and give + only one way to resolve an {i endpoint} (whatever its definition). + + [Conduit] does not make magic and all described processes previously are + explicit - composition, resolution, extraction. This last aspect wants to + solve a well-known problem of [Conduit] where nobody can fully understand + this framework. + + You can start to read the rest of the documentation. *) + +type 'a key + +type resolvers +(** Type of a set of resolvers. + + This type is outside any implementation of [Conduit] to let others libraries + to depend only on the package [conduit]. Of course, at one point (specially + when they want to use [Conduit]), they must do a choice about which + implementation of [Conduit] they want - [Conduit_lwt] or [Conduit_unix]. *) + +val empty : resolvers + +module type S = sig + type input + (** The type of the {i input}. A flow is able to {i send} a {i payload}. The + type of the {i payload} is [input]. *) + + type output + (** The type of the {i output}. A flow is able to {i receive} a {i payload}. + The type of the {i payload} is [output]. *) + + (** {3 Input & Output.} + + Type of input can differ to type of output to have the ability to define + capabilities on them such as the {i read} capability or the {i write} + capability. A {i caml} example looks like: + + {[ + type input = bytes + + type output = string + ]} *) + + type +'a s + (** The type of {i scheduler}. [Conduit] is able to call some {i syscall} + which can be wrap in a {i monad} such as LWT or ASYNC. The core [Conduit] + library is abstracted over that. *) + + (** {3 Scheduling.} + + [Conduit] does not do the choice about LWT or ASYNC (or UNIX). However, it + should be able to call any {i syscall} (like [Unix.connect]) which can be + {i wrap} into a {i monad}. By this way, the core library is not + specialized to a specific {i backend}. + + However, this specialization is done as soon as we can. So, + [Conduit_unix], [Conduit_mirage] or [Conduit_caml] are different and can + not be used together into a same place. *) + + type scheduler + + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + + type ('edn, 't, 'flow) service = + (module SERVICE + with type endpoint = 'edn + and type t = 't + and type flow = 'flow) + + type ('edn, 'flow) protocol = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + + type flow + (** A [flow] is an abstract value which contains your flow. As an abstracted + value, we can use it with few functions such as {!send}, {!recv} or + {!close}. If you are not aware about underlying implementation used, it + should be enough for you to only use it as is. + + {[ + type input = bytes + + type output = string + + type +'a s = 'a + + let process (Flow (flow, (module Flow))) = + let buf = Bytes.create 0x1000 in + match Conduit.recv flow buf 0 0x1000 with + | Ok (`Data len) -> + let str = Bytes.sub_string buf 0 len in + ignore (Conduit.send flow str 0 len) + | _ -> failwith "Flow.recv" + ]} + + The given flow can be more complex than a simple TCP flow for example. It + can be wrapped into a TLS layer. However the goal is to be able to + implement a protocol without such complexity. *) + + (** {3 Usual operations on the {!flow}.} + + Even if semantics of them is quite spontaneous ({!recv} can receive + something, {!send} can send something, {!close} closes the given [flow]), + the evil is into details. So they are only wrappers of associated {!recv}, + {!send} and {!close} functions of the underlying implementation of the + given [flow]. + + By that, precise behaviours of them depend on the associated + implementation. *) + + val recv : + flow -> input -> (int Sigs.or_end_of_input, [> `Msg of string ]) result s + + val send : flow -> output -> (int, [> `Msg of string ]) result s + + val close : flow -> (unit, [> `Msg of string ]) result s + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + (** A [resolver] is an abstract function which resolves a given + [\[ `host \] Domain_name.t] to an {i endpoint}. At least, it can be + implemented as a DNS resolver such as: + + {[ + type +'a s = 'a + + let http_resolver : Unix.sockaddr resolver = + fun domain_name -> + match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) + else None + | _ -> None + ]} + + Definition of {i endpoint} is free as long as a protocol can + initialize/connect a {!FLOW.flow} from it. In our example, a [Unix] TCP + service should exist with [Unix.connect]. *) + + type nonrec 'edn key = ('edn * scheduler) key + (** To be able to {i plug} a {!resolver} to a {!service} or a {!protocol}, a + value ['edn key] exists. It represents, at the resolution step, + {!protocol} into an user-defined {!Map.t}. + + Any construction of a {!service} or a {!protocol} give to us a ['edn key] + like a [Unix.sockaddr key] for example. The user has the ability to + construct then a restrained way to resolve a [\[ `host \] Domain_name.t]: + a set of {i heterogeneous} constructors of {i endpoint}. + + Each constructor of {i endpoint} is bound with a ['edn key]. If one of + them is able to resolve the given domain-name, by the ['edn key], + [Conduit] is able to invoke the right {!protocol} to process the + initialization. + + {[ + val tcp_protocol : (Unix.sockaddr, Unix.file_descr) protocol + + val tcp_endpoint : Unix.sockaddr key + + val http_resolver : Unix.sockaddr resolver (* on [*:80] *) + + val debug_http_resolver : Unix.sockaddr resolver (* on [*:8080] *) + + let map = + Map.empty + |> register_resolver ~key:tcp_endpoint ~priority:10 http_resolver + |> register_resolver ~key:tcp_endpoint ~priority:20 + debug_http_resolver + ]} *) + + module Witness : sig + type 'flow protocol + + type 't service + + val equal_protocol : 'a protocol -> 'b protocol -> ('a, 'b) refl option + + val equal_service : 'a service -> 'b service -> ('a, 'b) refl option + end + + val key : string -> 'edn key + (** [key name] creates a new key. The returned value can be bound to a + {!service} with {!register_service} or a {!protocol} with + {!register_protocol}. + + The goal of the returned value is to plug a {!resolver} without any + knowledge of the the {!protocol}. + + {[ + type input = bytes + + type output = string + + type +'a s = 'a + + module Conduit_tcp : sig + val key : Unix.sockaddr key + end = struct + let key : Unix.sockaddr key = key "sockaddr" + + let protocol = register_protocol ~key ~protocol:(module TCP) + end + + let resolvers = + Map.empty + |> register_resolver ~key:Conduit_tcp.key http_resolver + |> register_resolver ~key:Conduit_tcp_tls.key https_resolver + + let mirage_io = Domain_name.(host_exn <.> of_string_exn) "mirage.io" + + let () = + match flow resolves mirage_io with + | Ok (flow, (module Flow)) -> ignore (Flow.send flow "Hello World!") + | Error err -> failwithf "%a" pp_error err + ]} + + More precisely a {!key} is associated with the given {!scheduler} of + [Conduit]. By this way, it's not possible to mis-use a key from an ASYNC + scheduler with [Conduit_lwt.flow] for example. *) + + val name_of_key : 'edn key -> string + + (** {3 Registration.} *) + + val register_service : + key:'edn key -> + service:('edn, 't, 'flow) service -> + protocol:'flow Witness.protocol -> + ('t * 'flow) Witness.service + (** [register_service ~key ~service ~protocol] registers implementation of a + {i service} which is able to make a {i flow} (an established transmission + between the service and an entity) according to the given definition + [protocol]. It binds [service] with [key] to be able to correctly + initialize the given service. + + A {!service} is not use with the resolution process because we assert that + the initialization of any service should be fully know. [key] unlocks only + the ability to let the user to define his type of {i endpoint}/{i + configuration} - at this stage, and only about {!service}, goal of [key] + differs from {!register_protocol}. + + {[ + module TCP_service : S with type configuration = Unix.sockaddr + and type t = Unix.file_descr + and type flow = TCP.t (* = Unix.file_descr *) + + let key : Unix.sockaddr = key "sockaddr" + let service : (Unix.file_descr * TCP.t) Witness.service = + register_service ~key ~service:(module TCP_service) ~protocol:TCP.protocol + ]} *) + + val register_protocol : + key:'edn key -> protocol:('edn, 'flow) protocol -> 'flow Witness.protocol + (** [register_protocol ~key ~protocol] registers implementation of a {i + protocol} and binds it with [key] - any resolver bound into a {!Map.t} + with this [key] will call (at least) [connect] given by [protocol]. + + [protocol] is an OCaml module which respects the interface {!F} (a + specialization of {!FLOW} according {!input}, {!output} and {!s}). + + The returned value is a {i light} representation of the given [protocol] + which can be use by the user for some others processes like the + composition. + + {[ + module TCP : F with type endpoint = Unix.sockaddr + and type t = Unix.file_descr + + let key : Unix.sockaddr key = key "sockaddr" + let protocol : Unix.file_descr Witness.protocol = + register_protocol ~key ~protocol:(module TCP) + ]} *) + + val register_resolver : + key:'edn key -> ?priority:int -> 'edn resolver -> resolvers -> resolvers + (** [register_resolver ~key ?priority resolver m] adds a new [resolver] into + [m]. [resolver] is bound to [key]. From a set of [key] which represent the + way to initialize a {!protocol}, we can bind a [resolver] into [m]. + + When the [resolver] is able to resolve the given domain-name, it will try + to initialize the transmission over the protocol bound to the shared + [key]. We try resolvers to a specific order (lower to higher). + + {[ + val resolver_on_my_private_network : Unix.sockaddr resolver + + val resolver_on_internet : Unix.sockaddr resolver + + let m = + Map.empty + |> register_resolver ~key:tcp_endpoint ~priority:10 + resolver_on_my_private_network + |> register_resolver ~key:tcp_endpoint ~priority:20 + resolver_on_internet + ]} *) + + type error = [ `Msg of string | `Not_found | `Invalid_key | `Unresolved ] + + val pp_error : Format.formatter -> error -> unit + + val abstract : 'flow Witness.protocol -> 'flow -> flow + (** [abstract protocol flow] constructs an abstracted value {!flow} from a + representation of the implementation of the protocol ([protocol]) and an + already initialized [flow]. *) + + val flow_of_endpoint : key:'edn key -> 'edn -> (flow, [> error ]) result s + (** [flow_of_endpoint ~key edn] creates a new abstracted flow from the given + endpoint ['edn]. Protocol used to initialize the transmission is (already) + registered with {!register_protocol} and [key]. + + User can register more than one protocol with the given [key]. In this + case, all of these protocols are extracted and they try to initialize the + transmission. The first which initializes the transmission is taken to + return the {!flow}. The order of protocols is undefined. + + {[ + let sockaddr : Unix.sockaddr = Conduit.key "sockaddr" + let tcp : Unix.file_descr Witness.protocol + let udp : Unix.file_descr Witness.protocol + + let mirage_io : Unix.sockaddr = match Unix.gethostbyname "mirage.io" with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Unix.ADDR_INET (h_addr_list.(0), 4242) + else failwith "Impossible to resolver mirage.io" + + let () = match flow_of_endpoint ~key:sockaddr mirage_io with + | Ok flow -> + ignore (Conduit.send flow "Hello World!") + | Error err -> failwithf "%a" pp_error err + ]} *) + + val flow_of_protocol : + key:'edn key -> + 'edn -> + protocol:'flow Witness.protocol -> + ('flow, [> error ]) result s + (** [flow_of_protocol ~key edn ~protocol] creates a new concrete ['flow] from + the given endpoint ['edn]. Protocol used to initialize the transmission is + (and only is) [protocol]. + + {[ + let sockaddr : Unix.sockaddr = Conduit.key "sockaddr" + let tcp : Unix.file_descr Witness.protocol + + let mirage_io : Unix.sockaddr = match Unix.gethostbyname "mirage.io" with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Unix.ADDR_INET (h_addr_list.(0), 4242) + else failwith "Impossible to resolver mirage.io" + + let () = match flow_of_protocol ~key:sockaddr ~protocol:tcp mirage_io with + | Ok fd -> + ignore (Unix.write fd "Hello World!" 0 12) + | Error err -> failwithf "%a" pp_error err + ]} *) + + (** {3 [Conduit] as a client.} *) + + val flow : + resolvers -> + ?key:'edn key -> + ?protocol:'flow Witness.protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s + (** [flow resolvers domain_name] tries to create a new abstracted according to + [resolvers]. Each resolver tries to resolve the given domain-name (they + are ordered by the given priority). Then, from a {i heterogeneous} set of + {i endpoints}, we try to initialize/establish a transmission. The first + which initializes the connection is taken to return the {!flow}. + + User can enforce to use a specific [key] and, by this way, a specific + resolver instead to call all of them (available into [resolvers]). + + User can enforce to use a specific [protocol], and by this way, enforce to + use a specific [key] (which is bound by [protocol]). + + {[ + let mirage_io = Domain_name.(host_exn <.> of_string_exn) "mirage.io" + + val resolver_on_my_private_network : Unix.sockaddr resolver + + val resolver_on_internet : Unix.sockaddr resolver + + val resolver_with_tls : Tls.Config.client -> Unix.sockaddr resolver + + let resolvers = + Map.empty + |> register_resolver ~key:tls_endpoint ~priority:0 + (resolver_with_tls tls_config) + |> register_resolver ~key:tcp_endpoint ~priority:10 + resolver_on_my_private_network + |> register_resolver ~key:tcp_endpoint ~priority:20 + resolver_on_internet + + let () = + match flow resolvers mirage_io with + | Ok (flow, (module Flow)) -> ignore (Flow.send flow "Hello World!") + | Error err -> failwithf "%a" pp_error err + ]} *) + + (** {3 [Conduit] as a server.} *) + + val serve : + key:'edn key -> + 'edn -> + service:('t * 'flow) Witness.service -> + ('t * 'flow Witness.protocol, [> error ]) result s + (** [serve ~key edn ~service] creates a new {i master} server with which {i + protocol} it can deliver according a configuration ['edn]. [serve] is more + restrictive than {!flow} when we assert that the initialization of a + service should be fully know. + + The initialization of the service returns a concrete type ['t] which + represents the service. It returns which protocol is used to transmit + information with entities. + + {[ + val sockaddr : Unix.sockaddr key + val tcp_service : (Unix.file_descr * TCP.t) Witness.service + + let () = + impl_of_service ~key:sockaddr tcp_service |> get_ok |> fun (module Server) -> + match serve ~key:sockaddr Unix.(ADDR_INET (inet_addr_any, 8080)) tcp_service with + | Ok (master, protocol) -> + let module Flow = impl_of_flow protocol in + let rec go () = match Server.accept t with + | Ok flow -> + ignore (Flow.send flow "Hello World") ; + Flow.close flow ; + go () + | Error err -> failwithf "%a" Server.pp_error err in + go () + ]} *) + + val impl_of_service : + key:'edn key -> + ('t * 'flow) Witness.service -> + ( (module SERVICE + with type endpoint = 'edn + and type t = 't + and type flow = 'flow), + [> error ] ) + result + (** [impl_of_service ~key svc] returns the full-defined implementation of a + service from a [key] and a witness of it [svc]. [key] and [svc] must be + associated with {!register_service}. Otherwise, we return an error. *) + + val impl_of_protocol : + key:'edn key -> + 'flow Witness.protocol -> + ( (module PROTOCOL with type endpoint = 'edn and type flow = 'flow), + [> error ] ) + result + (** [impl_of_protocol ~key protocol] returns the full-defined implementation + of a protocol from a [key] and a witness of it [protocol]. [key] and + [protocol] must be associated with {!register_protocol}. Otherwise, we + return an error. *) + + val impl_of_flow : + 'flow Witness.protocol -> (module FLOW with type flow = 'flow) + (** [impl_of_flow protocol] returns a not-full-defined implementation of a + protocol. Despite {!impl_of_protocol}, the returned implementation does + not allow to {i create} a new flow from it. It does the usual computation + {!recv}, {!send} and {!close}. *) + + val is : flow -> 'flow Witness.protocol -> 'flow option + (** [is flow protocol] tries to prove that the given flow {b comes from} + [protocol]. By this fact, you are able to directly use it with your + implementation. For example, TLS implementation comes with few accessors + such as [underlying] to fallback to the {i underlying} protocol used with + TLS. + + To be able to use this function, you must prove that [flow] comes from, at + least, the TLS protocol implementation: + + {[ + type socket = { ip : Ipaddr.V4.t; port : int; socket : Unix.socket } + + type tls + + val tcp_protocol : socket Conduit.Witness.protocol + + val tls_protocol : tls Conduit.Witness.protocol + + val underlying : tls -> Conduit.flow + + val dst : TCP.flow -> Ipaddr.V4.t * int + + let abstract_dst : flow -> (Ippaddr.V4.t * int) option = + fun flow -> + let dst_of_tcp flow = + match Conduit.is flow tcp_protocol with + | Some { ip; port; _ } -> Some (ip, port) + | None -> None in + match Conduit.is flow tls_protocol with + | Some with_tls -> dst_of_tcp (underlying with_tls) + | None -> None + ]}*) end + +(** {3 Composition.} + + [Conduit] does not do something magic as we said into the introduction. + Composition of protocols must be done by {i protocol} developer. [Conduit] + gives interfaces which can be help this composition - but {i the glue} + needed must be implemented. + + Considering TLS as a layer which can compose with an other protocol, the + implementation looks like: + + {[ + type input + type output + type +'a s + + type 'flow with_tls = + { flow : 'flow + ; tls : Tls.Engine.state } + + module With_tls + (Flow : Sigs.F with type input = input + and type output = output + and type +'a s = 'a s) + = struct + type flow = Flow.flow with_tls + type endpoint = Flow.endpoint * Tls.Config.client + + ... + end + + let with_tls + : type edn flow. + key:edn key + -> flow Witness.protocol + -> (edn * Tls.Config.client) key * flow with_tls Witness.protocol + = fun ~key protocol -> + match impl_of_protocol ~key protocol with + | Ok (module Flow) -> + let module M = With_tls(Flow) in + let k = key "with_tls" in + let p = register_protocol ~key:k ~protocol:(module M) in + k, p + | Error err -> failwithf "%a" pp_error err + ]} *) + +module Make + (Scheduler : Sigs.SCHEDULER) + (Input : Sigs.SINGLETON) + (Output : Sigs.SINGLETON) : + S + with type input = Input.t + and type output = Output.t + and type +'a s = 'a Scheduler.t diff --git a/lib/conduit_trie.ml b/lib/conduit_trie.ml deleted file mode 100644 index 969eb9ec..00000000 --- a/lib/conduit_trie.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* - * Copyright (c) 2007-2014 Dave Scott - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Sexplib.Std - -type 'a t = - | Node of string * 'a option * 'a t list [@@deriving sexp] - -(* Invariant: the only node with an empty string is the root *) -let empty = Node("", None, []) - -let is_prefix a b = - String.length b >= (String.length a) - && String.sub b 0 (String.length a) = a - -let common_prefix a b = - let j = ref 0 in (* length of common prefix *) - let skip = ref false in - for i = 0 to min (String.length a) (String.length b) - 1 do - if not !skip - then if a.[i] = b.[i] then incr j else skip := true - done; - String.sub a 0 !j - -let sub b a = - let length = String.length b - (String.length a) in - String.sub b (String.length b - length) length - -let string = function - | Node(s, _, _) -> s - -(* Relying on the invariant that only the root node has an empty string, it is - safe to examine the first characters of the child strings. Moreover since - common prefixes are always represented as shared nodes, there can be at most - one child with the same initial character as the key we're looking up. *) -let choose remaining ns = - match List.partition (fun x -> (string x).[0] = remaining.[0]) ns with - | [ n ], rest -> Some(n, rest) - | [], _ -> None - | _ :: _, _ -> assert false - -let rec insert k v = function - (* k could be equal to s *) - | Node(s, None, ns) when k = s -> Node(s, Some v, ns) - (* k could be a prefix of s *) - | Node(s, v', ns) when is_prefix k s -> - assert(sub s k <> ""); - Node(k, Some v, [ Node(sub s k, v', ns) ]) - (* s could be a prefix of k *) - | Node(s, v', ns) when is_prefix s k -> - let remaining = sub k s in - assert(remaining <> ""); - begin match choose remaining ns with - | Some (n, rest) -> Node(s, v', insert remaining v n :: rest) - | None -> Node(s, v', Node(remaining, Some v, []) :: ns) - end - (* s and k could share a non-empty common prefix *) - | Node(s, v', ns) -> - let p = common_prefix s k in - let s' = sub s p and k' = sub k p in - assert (s' <> ""); - assert (k' <> ""); - Node(p, None, [ Node(s', v', ns); Node(k', Some v, []) ]) - -let rec fold_over_path f str acc = function - | Node(p, v, _) when p = str -> f acc v - | Node(p, v, ns) when is_prefix p str -> - let remaining = sub str p in - begin match choose remaining ns with - | Some(n, _) -> fold_over_path f remaining (f acc v) n - | None -> f acc v - end - | _ -> acc - -let longest_prefix str t = - fold_over_path - (fun acc b -> if b = None then acc else b) - str None t - -let fold f acc t = - let rec inner p acc = - function - | Node (p', v, ns) -> - let pp = p ^ p' in - let acc = - match v with - | Some v -> f pp v acc - | None -> acc - in - List.fold_left (fun acc n -> inner pp acc n) acc ns in - inner "" acc t diff --git a/lib/conduit_trie.mli b/lib/conduit_trie.mli deleted file mode 100644 index 66e777cc..00000000 --- a/lib/conduit_trie.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* - * Copyright (c) 2007-2014 Dave Scott - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Radix tree that can do longest-prefix searches on string keys *) - -(** Radix tree that maps [string] keys to ['a] values *) -type 'a t [@@deriving sexp] - -(** An empty tree *) -val empty : 'a t - -(** [insert key value tree] returns a new tree with the - mapping [key] to [value] *) -val insert : string -> 'a -> 'a t -> 'a t - -(** [longest_prefix key tree] finds the key [k] which shares - the longest prefix with [key] and returns the associated - value. *) -val longest_prefix : string -> 'a t -> 'a option - -(** [fold f initial t] folds [f] over all bindings in [t] *) -val fold : (string -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b - -(** [is_prefix a b] returns true if [a] is a prefix of [b] *) -val is_prefix: string -> string -> bool diff --git a/lib/dune b/lib/dune index 556194f8..994bc5be 100644 --- a/lib/dune +++ b/lib/dune @@ -1,10 +1,4 @@ (library - (name conduit) - (public_name conduit) - (wrapped false) - (preprocess (pps ppx_sexp_conv)) - (modules conduit conduit_trie resolver) - (libraries sexplib ipaddr ipaddr-sexp uri astring)) - -(documentation - (package conduit)) + (name conduit) + (public_name conduit) + (libraries stdlib-shims domain-name)) diff --git a/lib/e0.ml b/lib/e0.ml new file mode 100644 index 00000000..a974be10 --- /dev/null +++ b/lib/e0.ml @@ -0,0 +1,78 @@ +(* (c) Frédéric Bour *) + +type ('a, 'b) refl = Refl : ('a, 'a) refl + +module Make (Key : Sigs.FUNCTOR) = struct + type t = .. + + type _ id = .. + + module type S = sig + type x + + type t += T of x + + type _ id += Id : x id + + val witness : x Key.t + end + + type 'a s = (module S with type x = 'a) + + type v = Value : 'a * 'a Key.t -> v + + type k = Key : 'a Key.t * ('a -> t) -> k + + let equal : type a b. a s -> b s -> (a, b) refl option = + fun a b -> + let module A = (val a : S with type x = a) in + let module B = (val b : S with type x = b) in + match A.Id with B.Id -> Some Refl | _ -> None + + let handlers = Hashtbl.create 16 + + let witnesses = Hashtbl.create 16 + + module Injection (X : sig + type t + + val witness : t Key.t + end) : S with type x = X.t = struct + type x = X.t + + type t += T of x + + type _ id += Id : x id + + let witness = X.witness + + let () = + let[@warning "-3"] uid = + Stdlib.Obj.extension_id [%extension_constructor T] in + Hashtbl.add handlers uid (function + | T x -> Value (x, witness) + | _ -> raise Not_found) ; + Hashtbl.add witnesses uid (Key (witness, fun x -> T x)) + end + + let inj (type a) (k : a Key.t) : a s = + (module Injection (struct + type t = a + + let witness = k + end)) + + let prj (t : t) = + let rec go = function + | [] -> assert false (* totality *) + | f :: r -> try f t with Not_found -> go r in + go + (Hashtbl.find_all handlers + Stdlib.Obj.((extension_id (extension_constructor t) [@warning "-3"]))) + + let extract (t : t) (type a) ((module S) : a s) : a option = + match t with S.T x -> Some x | _ -> None + + let bindings : unit -> k list = + fun () -> Hashtbl.fold (fun _ v a -> v :: a) witnesses [] +end diff --git a/lib/e0.mli b/lib/e0.mli new file mode 100644 index 00000000..13ac4b24 --- /dev/null +++ b/lib/e0.mli @@ -0,0 +1,34 @@ +type ('a, 'b) refl = Refl : ('a, 'a) refl + +module Make (Key : Sigs.FUNCTOR) : sig + (* XXX(dinosaure): only on [>= 4.06.0] *) + type t = private .. + + type _ id = private .. + + module type S = sig + type x + + type t += T of x + + type _ id += Id : x id + + val witness : x Key.t + end + + type 'a s = (module S with type x = 'a) + + type v = Value : 'a * 'a Key.t -> v + + type k = Key : 'a Key.t * ('a -> t) -> k + + val equal : 'a s -> 'b s -> ('a, 'b) refl option + + val inj : 'a Key.t -> 'a s + + val prj : t -> v + + val extract : t -> 'a s -> 'a option + + val bindings : unit -> k list +end diff --git a/lib/e1.ml b/lib/e1.ml new file mode 100644 index 00000000..5a4268ba --- /dev/null +++ b/lib/e1.ml @@ -0,0 +1,113 @@ +(* (c) Daniel Bünzli *) + +module Refl = struct + type ('a, 'b) t = Refl : ('a, 'a) t +end + +module Type = struct + type 'a t = .. +end + +module type TYPE = sig + type t + + type _ Type.t += T : t Type.t +end + +type 'a t = (module TYPE with type t = 'a) + +let tid () (type x) = + let module X = struct + type t = x + + type _ Type.t += T : t Type.t + end in + (module X : TYPE with type t = x) + +let eq : type a b. a t -> b t -> (a, b) Refl.t option = + fun a b -> + let module A = (val a : TYPE with type t = a) in + let module B = (val b : TYPE with type t = b) in + match A.T with B.T -> Some Refl.Refl | _ -> None + +type identifier = int + +let identifier_equal a b = (compare : int -> int -> int) a b = 0 + +let identifier_compare a b = (compare : int -> int -> int) a b + +module Make (K : Sigs.FUNCTOR) (V : Sigs.FUNCTOR) = struct + module Key = struct + type 'a info = 'a K.t + + type 'a key = { uid : identifier; tid : 'a t; info : 'a K.t } + + let uid = + let x = ref (-1) in + fun () -> + incr x ; + !x + + let create info = + let uid = uid () in + let tid = tid () in + { uid; tid; info } + + let info { info; _ } = info + + let identifier { uid; _ } = uid + + type t = K : 'a key -> t + + let hide k = K k + + let equal (K a) (K b) = (compare : int -> int -> int) a.uid b.uid = 0 + + let compare (K a) (K b) = (compare : int -> int -> int) a.uid b.uid + + let ( == ) : type a b. a key -> b key -> (a, b) Refl.t option = + fun a b -> eq a.tid b.tid + end + + type 'a key = 'a Key.key + + module Map = Map.Make (Key) + + type binding = B : 'a key * 'a V.t -> binding + + type t = binding Map.t + + let empty = Map.empty + + let is_empty = Map.is_empty + + let mem k m = Map.mem (Key.K k) m + + let add k v m = Map.add (Key.K k) (B (k, v)) m + + let singleton k v = Map.singleton (Key.K k) (B (k, v)) + + let rem k m = Map.remove (Key.K k) m + + let len m = Map.cardinal m + + let find : type a. a key -> t -> a V.t option = + fun k m -> + match Map.find (K k) m with + | B (k', v) -> ( + match eq k.Key.tid k'.Key.tid with + | Some Refl.Refl -> Some v + | None -> None) + | exception Not_found -> None + + type v = Value : 'a key * 'a V.t -> v + + let bindings m = + Map.bindings m + |> List.fold_left + (fun a (Key.K k, B (k', v)) -> + match eq k.Key.tid k'.Key.tid with + | Some Refl.Refl -> Value (k, v) :: a + | None -> a) + [] +end diff --git a/lib/e1.mli b/lib/e1.mli new file mode 100644 index 00000000..d5ccad8d --- /dev/null +++ b/lib/e1.mli @@ -0,0 +1,55 @@ +module Refl : sig + type ('a, 'b) t = Refl : ('a, 'a) t +end + +type identifier = private int + +val identifier_equal : identifier -> identifier -> bool + +val identifier_compare : identifier -> identifier -> int + +module Make (K : Sigs.FUNCTOR) (V : Sigs.FUNCTOR) : sig + type 'a key + + module Key : sig + type 'a info = 'a K.t + + val create : 'a info -> 'a key + + val info : 'a key -> 'a info + + val identifier : 'a key -> identifier + + type t + + val hide : 'a key -> t + + val equal : t -> t -> bool + + val compare : t -> t -> int + + val ( == ) : 'a key -> 'b key -> ('a, 'b) Refl.t option + end + + type t + + val empty : t + + val is_empty : t -> bool + + val add : 'a key -> 'a V.t -> t -> t + + val mem : 'a key -> t -> bool + + val singleton : 'a key -> 'a V.t -> t + + val rem : 'a key -> t -> t + + val find : 'a key -> t -> 'a V.t option + + val len : t -> int + + type v = Value : 'a key * 'a V.t -> v + + val bindings : t -> v list +end diff --git a/lib/index.mld b/lib/index.mld deleted file mode 100644 index ab3c1ffe..00000000 --- a/lib/index.mld +++ /dev/null @@ -1,43 +0,0 @@ -{1 Introduction} - -The {!Conduit} library abstracts the concerns of establishing connections to -peers that may be running within the same host (e.g. in another virtual -machine) or on a remote host via TCP. It consists of: - -- The {!Conduit} module with basic type definitions for endpoints -- OS-specific modules for {{!transport}establishing individual connections} -- The {!Resolver} module for mapping URIs to endpoints -- OS-specific {{!resolution}name resolvers} that use available - resolution mechanisms - -{2:transport Connection Establishment} - -Connections are created by identifying remote nodes using an -{{!Conduit.endp}endp} value. To ensure portability, the -{{!Conduit.endp}endpoints} are translated into concrete connections by separate -modules that target [Lwt_unix], [Async] and [Mirage]. This lets those backends -use the appropriate local technique for creating the connection (such as using -OpenSSL on Unix, or a pure OCaml TLS+TCP implementation on Mirage, or some -other combination). - -The modules dealing with connection establishment are: -{!modules: Conduit_lwt_unix Conduit_async Conduit_mirage} - -{2:resolution Name Resolution} - -This deals with resolving URIs into a list of {{!Conduit.endp}endp} -addresses that can -then be connected to by the {{!transport}connection establishment} modules. - -All of the name resolvers conform to the {!Resolver.S} module type. -The OS-specific implementations of this interface are: -{!modules: Resolver_lwt Resolver_lwt_unix Resolver_mirage} - -{2:resolution Mirage Connections} - -On Mirage, the networking stack is configured via the application -of functors to satisfy various signatures. Some of the available -functors are: -{!modules: Conduit_xenstore Conduit_localhost} - -{!indexlist} diff --git a/lib/resolver.ml b/lib/resolver.ml deleted file mode 100644 index e9056b5d..00000000 --- a/lib/resolver.ml +++ /dev/null @@ -1,175 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Sexplib.Std -open Astring - -type service = { - name: string; - port: int; - tls: bool -} [@@deriving sexp] - -(** Module type for a {{!resolution}resolver} that can map URIs to - concrete {{!Conduit.endp}endpoints} that stream connections can be - established with. *) -module type S = sig - - (** Abstract type of the cooperative threading library used, normally - defined via the {!IO} module type *) - type +'a io - - (** State handle for a running resolver *) - type t [@@deriving sexp] - - (** Abstract type for a service entry, which maps a URI scheme into - a protocol handler and TCP port *) - type svc [@@deriving sexp] - - (** A rewrite function resolves a {{!svc}service} and a URI into - a concrete endpoint. *) - type rewrite_fn = svc -> Uri.t -> Conduit.endp io - - (** A service function maps the string (such as [http] or [ftp]) from - a URI scheme into a {{!svc}service} description that includes - enough metadata about the service to subsequently {{!rewrite_fn}resolve} - it into an {{!Conduit.endp}endpoint}. *) - type service_fn = string -> svc option io - - val (++): service_fn -> service_fn -> service_fn - - (** [init ?service ?rewrites] will initialize the resolver and return - a state handler. The {{!service_fn}service} argument should - contain the system-specific resolution mechanism for URI schemas. - - The [rewrites] argument can optionally override a subset of the - URI domain name with the given {!rewrite_fn} to permit custom - resolution rules. For example, a rewrite rule for ".xen" would - let the rewrite function resolve hostnames such as "foo.xen" - into a shared memory channel for the "foo" virtual machine. *) - val init : - ?service:service_fn -> ?rewrites:(string * rewrite_fn) list -> - unit -> t - - (** [add_rewrite ~host f t] will add to the [t] resolver the [f] rewrite rule - for all the domain names that shortest-prefix match [host] *) - val add_rewrite : host:string -> f:rewrite_fn -> t -> unit - - val set_service : f:service_fn -> t -> unit - val service: t -> service_fn - - (** [resolve_uri ?rewrites ~uri t] will use [t] to resolve the - [uri] into a concrete endpoint. Any [rewrites] that are passed - in will be overlayed on the existing rules within the [t] - resolver, but not otherwise modify it. *) - val resolve_uri : - ?rewrites:(string * rewrite_fn) list -> - uri:Uri.t -> t -> Conduit.endp io -end - -module Make(IO:Conduit.IO) = struct - open IO - - type svc = service [@@deriving sexp] - type 'a io = 'a IO.t - - (** A rewrite modifies an input URI with more specialization - towards a concrete [endp] *) - type rewrite_fn = service -> Uri.t -> Conduit.endp IO.t [@@deriving sexp] - type service_fn = string -> service option IO.t [@@deriving sexp] - - type t = { - default_lookup : rewrite_fn; - mutable domains: rewrite_fn Conduit_trie.t; - mutable service: service_fn; - } [@@deriving sexp] - - let default_lookup _ uri = - (* TODO log *) - let host = - match Uri.host uri with - | None -> "" - | Some host -> host - in - return (`Unknown host) - - let default_service _name = - (* TODO log *) - return None - - let host_to_domain_list host = - (* TODO: slow, specialise the Trie to be a rev string list instead *) - String.concat ~sep:"." (List.rev (String.cuts ~sep:"." host)) - - let add_rewrite ~host ~f t = - t.domains <- Conduit_trie.insert (host_to_domain_list host) f t.domains - - let set_service ~f t = - t.service <- f - - let service t = t.service - - let (++) f g h = - f h >>= function - | None -> g h - | x -> return x - - let init ?(service=default_service) ?(rewrites=[]) () = - let domains = Conduit_trie.empty in - let t = { domains; default_lookup; service } in - List.iter (fun (host,f) -> add_rewrite ~host ~f t) rewrites; - t - - let resolve_uri ?rewrites ~uri t = - (* Find the service associated with the URI *) - match Uri.scheme uri with - | None -> - return (`Unknown "no scheme") - | Some scheme -> begin - t.service scheme - >>= function - | None -> return (`Unknown "unknown scheme") - | Some service -> - let host = - match Uri.host uri with - | None -> "localhost" - | Some host -> host - in - let trie = - (* If there are local rewrites, add them to the trie *) - match rewrites with - | None -> t.domains - | Some rewrites -> - List.fold_left (fun acc (host, f) -> - Conduit_trie.insert (host_to_domain_list host) f acc) - t.domains rewrites - in - (* Find the longest prefix function that matches this host *) - let fn = - match Conduit_trie.longest_prefix (host_to_domain_list host) trie - with - | None -> t.default_lookup - | Some fn -> fn - in - fn service uri - >>= fun endp -> - if service.tls then - return (`TLS (host, endp)) - else - return endp - end -end diff --git a/lib/resolver.mli b/lib/resolver.mli deleted file mode 100644 index 22246162..00000000 --- a/lib/resolver.mli +++ /dev/null @@ -1,96 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Resolve URIs to endpoints *) - -(** Description of a single service. - Can be populated from [/etc/services] with the exception of the - [tls] field, which indicates if the connection is intended to be - TLS/SSL-encrypted or not (e.g. for [https]). *) -type service = { - name: string; - port: int; - tls: bool -} [@@deriving sexp] - -(** Module type for a {{!resolution}resolver} that can map URIs to - concrete {{!endp}endpoints} that stream connections can be - established with. *) -module type S = sig - - (** Abstract type of the cooperative threading library used, normally - defined via the {!IO} module type *) - type +'a io - - (** State handle for a running resolver *) - type t [@@deriving sexp] - - (** Abstract type for a service entry, which maps a URI scheme into - a protocol handler and TCP port *) - type svc [@@deriving sexp] - - (** A rewrite function resolves a {{!svc}service} and a URI into - a concrete endpoint. *) - type rewrite_fn = svc -> Uri.t -> Conduit.endp io - - (** A service function maps the string (such as [http] or [ftp]) from - a URI scheme into a {{!svc}service} description that includes - enough metadata about the service to subsequently {{!rewrite_fn}resolve} - it into an {{!endp}endpoint}. *) - type service_fn = string -> svc option io - - val (++): service_fn -> service_fn -> service_fn - (** [f ++ g] is the composition of the service functions [f] and - [g]. *) - - (** [init ?service ?rewrites] will initialize the resolver and return - a state handler. The {{!service_fn}service} argument should - contain the system-specific resolution mechanism for URI schemas. - - The [rewrites] argument can optionally override a subset of the - URI domain name with the given {!rewrite_fn} to permit custom - resolution rules. For example, a rewrite rule for ".xen" would - let the rewrite function resolve hostnames such as "foo.xen" - into a shared memory channel for the "foo" virtual machine. *) - val init : - ?service:service_fn -> ?rewrites:(string * rewrite_fn) list -> - unit -> t - - (** [add_rewrite ~host f t] will add to the [t] resolver the [f] rewrite rule - for all the domain names that shortest-prefix match [host] *) - val add_rewrite : host:string -> f:rewrite_fn -> t -> unit - - val set_service : f:service_fn -> t -> unit - - val service: t -> service_fn - (** [service t] is the function which is called when trying to - resolve a hostname with [t]. *) - - (** [resolve_uri ?rewrites ~uri t] will use [t] to resolve the - [uri] into a concrete endpoint. Any [rewrites] that are passed - in will be overlayed on the existing rules within the [t] - resolver, but not otherwise modify it. *) - val resolve_uri : - ?rewrites:(string * rewrite_fn) list -> - uri:Uri.t -> t -> Conduit.endp io -end - -(** Functor to construct a concrete resolver using a {!Conduit.IO} - implementation, usually via either Lwt or Async *) -module Make (IO : Conduit.IO) : S - with type svc = service - and type 'a io = 'a IO.t diff --git a/lib/sigs.ml b/lib/sigs.ml new file mode 100644 index 00000000..6458eb95 --- /dev/null +++ b/lib/sigs.ml @@ -0,0 +1,98 @@ +type kind = UDP | TCP + +type description = { name : string; port : int; kind : kind } + +type 'x or_end_of_input = [ `End_of_input | `Input of 'x ] + +module type FUNCTOR = sig + type 'a t +end + +module type SINGLETON = sig + type t +end + +type (+'a, 's) app + +type 's scheduler = { + bind : 'a 'b. ('a, 's) app -> ('a -> ('b, 's) app) -> ('b, 's) app; + return : 'a. 'a -> ('a, 's) app; +} + +module type BIJECTION = sig + type +'a s + + type t + + external inj : 'a s -> ('a, t) app = "%identity" + + external prj : ('a, t) app -> 'a s = "%identity" +end + +module Higher (Functor : sig + type +'a t +end) : BIJECTION with type +'a s = 'a Functor.t = struct + type +'a s = 'a Functor.t + + type t + + external inj : 'a s -> ('a, t) app = "%identity" + + external prj : ('a, t) app -> 'a s = "%identity" +end + +module type SCHEDULER = sig + type +'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t +end + +module type FLOW = sig + type +'a s + + type flow + + type error + + type input + + and output + + val pp_error : error Fmt.t + + val recv : flow -> input -> (int or_end_of_input, error) result s + + val send : flow -> output -> (int, error) result s + + val close : flow -> (unit, error) result s +end + +module type PROTOCOL = sig + include FLOW + + type endpoint + + val flow : endpoint -> (flow, error) result s +end + +module type SERVICE = sig + type +'a s + + type flow + + type t + + type error + + type endpoint + + val make : endpoint -> (t, error) result s + + val pp_error : error Fmt.t + + val accept : t -> (flow, error) result s + + val close : t -> (unit, error) result s +end From 087e8e02541fd454993bc46d19161714331979e0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:49:29 +0200 Subject: [PATCH 006/140] New implementation of conduit-tls which provides a composition mechanism of the TLS layer with another protocol `ocaml-tls` is a new package which provides internally a _functor_ to compose a Conduit.Sigs.PROTOCOL with TLS. It gives an example of composition of protocols in `conduit`. It requires an implementation of `conduit` which, at least, uses `Cstruct.t` as `input` and `output`. A realistic example is the composition of tcp/ip protocols provided by: - `conduit-lwt-unix` - `conduit-async` - `conduit-mirage` Each of them are differents (about type and implementation) but they use this package to provide a TLS layer on top of them. At the end, composition should be less than 10 lines of code. Due to the non ability to use the scheduler, provided implementation is not protected against data-race condition. The documentation tells you more about that. --- tls/conduit_tls.ml | 375 ++++++++++++++++++++++++++++++++++++++++++++ tls/conduit_tls.mli | 70 +++++++++ tls/dune | 4 + 3 files changed, 449 insertions(+) create mode 100644 tls/conduit_tls.ml create mode 100644 tls/conduit_tls.mli create mode 100644 tls/dune diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml new file mode 100644 index 00000000..a4b8a90e --- /dev/null +++ b/tls/conduit_tls.ml @@ -0,0 +1,375 @@ +module Ke = Ke.Rke +module Sigs = Conduit.Sigs + +let option_fold ~none ~some = function Some x -> some x | None -> none + +(* NOTE(dinosaure): we use an unbound queue where TLS can produce + something bigger than the given input. It seems hard to limit + the internal queue and arbitrary limit (like a queue two times + larger than the input) is not good. By this fact, we use [Ke.Rke] + even if it an infinitely grow. *) + +module Make + (Scheduler : Sigs.SCHEDULER) + (Conduit : Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Scheduler.t) = +struct + let return x = Scheduler.return x + + let ( >>= ) x f = Scheduler.bind x f + + let ( >>| ) x f = x >>= fun x -> return (f x) + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> return (Error err) + + let reword_error : ('e0 -> 'e1) -> ('a, 'e0) result -> ('a, 'e1) result = + fun f -> function Ok v -> Ok v | Error err -> Error (f err) + + let src = Logs.Src.create "conduit-tls" + + module Log = (val Logs.src_log src : Logs.LOG) + + type 'flow protocol_with_tls = { + mutable tls : Tls.Engine.state option; + mutable closed : bool; + raw : Cstruct.t; + flow : 'flow; + queue : (char, Bigarray.int8_unsigned_elt) Ke.t; + } + + let underlying { flow; _ } = flow + + let handshake { tls; _ } = + match tls with + | Some tls -> Tls.Engine.handshake_in_progress tls + | None -> false + + module Make_protocol + (Flow : Sigs.PROTOCOL + with type input = Conduit.input + and type output = Conduit.output + and type +'a s = 'a Scheduler.t) = + struct + type input = Conduit.input + + type output = Conduit.output + + type +'a s = 'a Conduit.s + + type endpoint = Flow.endpoint * Tls.Config.client + + type flow = Flow.flow protocol_with_tls + + type error = + [ `Msg of string + | `Flow of Flow.error + | `TLS of Tls.Engine.failure + | `Closed_by_peer ] + + let pp_error : error Fmt.t = + fun ppf -> function + | `Msg err -> Fmt.string ppf err + | `Flow err -> Flow.pp_error ppf err + | `TLS failure -> Fmt.string ppf (Tls.Engine.string_of_failure failure) + | `Closed_by_peer -> Fmt.string ppf "Closed by peer" + + let flow_error err = `Flow err + + let flow_wr_opt : + Flow.flow -> Cstruct.t option -> (unit, error) result Conduit.s = + fun flow -> function + | None -> return (Ok ()) + | Some raw -> + Log.debug (fun m -> m "~> Send %d bytes" (Cstruct.len raw)) ; + let rec go raw = + Flow.send flow raw >>| reword_error flow_error >>? fun len -> + let raw = Cstruct.shift raw len in + if Cstruct.len raw = 0 then return (Ok ()) else go raw in + go raw + + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len + + let queue_wr_opt queue = function + | None -> () + | Some raw -> + Log.debug (fun m -> + m "Fill the queue with %d byte(s)." (Cstruct.len raw)) ; + Ke.N.push queue ~blit ~length:Cstruct.len ~off:0 raw + + let handle_tls : + Tls.Engine.state -> + (char, Bigarray.int8_unsigned_elt) Ke.t -> + Flow.flow -> + Cstruct.t -> + (Tls.Engine.state option, error) result Scheduler.t = + fun tls queue flow raw -> + match Tls.Engine.handle_tls tls raw with + | `Fail (failure, `Response resp) -> + Log.debug (fun m -> m "|- TLS state: Fail") ; + flow_wr_opt flow (Some resp) >>? fun () -> + return (Error (`TLS failure)) + | `Ok (`Alert _alert, `Response resp, `Data data) -> + Log.debug (fun m -> m "|- TLS state: Alert") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) + | `Ok (`Eof, `Response resp, `Data data) -> + Log.debug (fun m -> m "|- TLS state: EOF") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok None) + | `Ok (`Ok tls, `Response resp, `Data data) -> + (* XXX(dinosaure): it seems that decoding TLS inputs can produce + something bigger than expected. For example, decoding 4096 bytes + can produce 4119 byte(s). *) + Log.debug (fun m -> m "|- TLS state: Ok") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) + + let handle_handshake : + Tls.Engine.state -> + (char, Bigarray.int8_unsigned_elt) Ke.t -> + Flow.flow -> + Cstruct.t -> + (Tls.Engine.state option, error) result Scheduler.t = + fun tls queue flow raw0 -> + let rec go tls raw1 = + match Tls.Engine.can_handle_appdata tls with + | true -> + Log.debug (fun m -> m "Start to talk with TLS (handshake is done).") ; + handle_tls tls queue flow raw1 + | false -> ( + assert (Tls.Engine.handshake_in_progress tls = true) ; + Log.debug (fun m -> m "Process TLS handshake.") ; + + (* XXX(dinosaure): assertion, [Tls.Engine.handle_tls] consumes all + bytes of [raw1] and [raw1] is physically a subset of [raw0] (or + is [raw0]). we can re-use [raw0] for [Flow.recv] safely. *) + match Tls.Engine.handle_tls tls raw1 with + | `Ok (`Ok tls, `Response resp, `Data data) -> + Log.debug (fun m -> + m "-- TLS state: OK (data: %d byte(s))" + (option_fold ~none:0 ~some:Cstruct.len data)) ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> + if Tls.Engine.handshake_in_progress tls + then ( + Log.debug (fun m -> m "<- Read the TLS flow") ; + Flow.recv flow raw0 >>| reword_error flow_error >>? function + | `End_of_input -> + Log.warn (fun m -> + m + "Got EOF from underlying connection while \ + handshake.") ; + return (Ok None) + | `Input len -> + let uid = + Hashtbl.hash + (Cstruct.to_string (Cstruct.sub raw0 0 len)) in + Log.debug (fun m -> + m + "<~ [%04x] Got %d bytes (handshake in progress: \ + true)." + uid len) ; + go tls (Cstruct.sub raw0 0 len)) + else ( + Log.debug (fun m -> m "Handshake is done.") ; + return (Ok (Some tls))) + | `Ok (`Eof, `Response resp, `Data data) -> + Log.debug (fun m -> m "-- TLS state: EOF") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok None) + | `Fail (failure, `Response resp) -> + Log.debug (fun m -> m "-- TLS state: Fail") ; + flow_wr_opt flow (Some resp) >>? fun () -> + return (Error (`TLS failure)) + | `Ok (`Alert _alert, `Response resp, `Data data) -> + Log.debug (fun m -> m "-- TLS state: Alert") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls))) + in + go tls raw0 + + let flow (edn, config) = + Flow.flow edn >>| reword_error flow_error >>? fun flow -> + let raw = Cstruct.create 0x1000 in + let queue = Ke.create ~capacity:0x1000 Bigarray.Char in + let tls, buf = Tls.Engine.client config in + let rec go buf = + Log.debug (fun m -> m "Start handshake.") ; + Flow.send flow buf >>| reword_error flow_error >>? fun len -> + let buf = Cstruct.shift buf len in + if Cstruct.len buf = 0 + then return (Ok { tls = Some tls; closed = false; raw; queue; flow }) + else go buf in + go buf + + let blit src src_off dst dst_off len = + let dst = Cstruct.to_bigarray dst in + Bigstringaf.blit src ~src_off dst ~dst_off ~len + + let rec recv t raw = + Log.debug (fun m -> m "<~ Start to receive.") ; + match Ke.N.peek t.queue with + | [] -> ( + Log.debug (fun m -> m "<~ TLS queue is empty.") ; + match t.tls with + | None -> + Log.debug (fun m -> m "<~ Connection is close.") ; + return (Ok `End_of_input) + | Some tls -> ( + Log.debug (fun m -> m "<- Read the TLS flow.") ; + Flow.recv t.flow t.raw >>| reword_error flow_error >>? function + | `End_of_input -> + Log.warn (fun m -> + m "<- Connection closed by underlying protocol.") ; + t.tls <- None ; + return (Ok `End_of_input) + | `Input len -> + let handle = + if Tls.Engine.handshake_in_progress tls + then handle_handshake tls t.queue t.flow + else handle_tls tls t.queue t.flow in + let uid = + Hashtbl.hash (Cstruct.to_string (Cstruct.sub t.raw 0 len)) + in + Log.debug (fun m -> + m "<~ [%04x] Got %d bytes (handshake in progress: %b)." + uid len + (Tls.Engine.handshake_in_progress tls)) ; + handle (Cstruct.sub t.raw 0 len) >>? fun tls -> + t.tls <- tls ; + recv t raw)) + | _ -> + let max = Cstruct.len raw in + let len = min (Ke.length t.queue) max in + Ke.N.keep_exn t.queue ~blit ~length:Cstruct.len ~off:0 ~len raw ; + Ke.N.shift_exn t.queue len ; + return (Ok (`Input len)) + + let rec send t raw = + Log.debug (fun m -> m "~> Start to send.") ; + match t.tls with + | None -> return (Error `Closed_by_peer) + | Some tls when Tls.Engine.can_handle_appdata tls -> ( + let raw = [ raw ] in + match Tls.Engine.send_application_data tls raw with + | Some (tls, resp) -> + t.tls <- Some tls ; + flow_wr_opt t.flow (Some resp) >>? fun () -> + return (Ok (Cstruct.lenv raw)) + | None -> return (Ok (Cstruct.lenv raw))) + | Some tls -> ( + Flow.recv t.flow t.raw >>| reword_error flow_error >>? function + | `End_of_input -> + Log.warn (fun m -> m "[-] Underlying flow already closed.") ; + t.tls <- None ; + return (Error `Closed_by_peer) + | `Input len -> ( + let res = + handle_handshake tls t.queue t.flow (Cstruct.sub t.raw 0 len) + in + res >>= function + | Ok tls -> + t.tls <- tls ; + send t raw (* recall to finish handshake. *) + | Error _ as err -> + Log.err (fun m -> m "[-] Got an error during handshake.") ; + return err)) + + let close t = + Log.debug (fun m -> m "!- Asking to close the TLS connection") ; + if not t.closed + then ( + match t.tls with + | None -> + Log.debug (fun m -> + m "!- TLS state already reached EOF, close the connection.") ; + Flow.close t.flow >>| reword_error flow_error >>= fun res -> + Log.debug (fun m -> m "!- Underlying flow properly closed.") ; + t.closed <- true ; + return res + | Some tls -> + let _tls, resp = Tls.Engine.send_close_notify tls in + t.tls <- None ; + Log.debug (fun m -> m "!- Close the connection.") ; + flow_wr_opt t.flow (Some resp) >>? fun () -> + Flow.close t.flow >>| reword_error flow_error >>? fun () -> + t.closed <- true ; + return (Ok ())) + else return (Ok ()) + end + + let protocol_with_tls : + type edn flow. + key:edn Conduit.key -> + flow Conduit.Witness.protocol -> + (edn * Tls.Config.client) Conduit.key + * flow protocol_with_tls Conduit.Witness.protocol = + fun ~key protocol -> + match Conduit.impl_of_protocol ~key protocol with + | Ok (module Flow) -> + let module M = Make_protocol (Flow) in + let k = Conduit.key (Fmt.strf "%s + tls" (Conduit.name_of_key key)) in + let p = Conduit.register_protocol ~key:k ~protocol:(module M) in + (k, p) + | Error _ -> assert false + + type 'service service_with_tls = { + service : 'service; + tls : Tls.Config.server; + } + + module Make_server (Service : Sigs.SERVICE with type +'a s = 'a Scheduler.t) = + struct + type +'a s = 'a Conduit.s + + type endpoint = Service.endpoint * Tls.Config.server + + type flow = Service.flow protocol_with_tls + + type error = [ `Service of Service.error ] + + let pp_error : error Fmt.t = + fun ppf -> function `Service err -> Service.pp_error ppf err + + let service_error err = `Service err + + type t = Service.t service_with_tls + + let make (edn, tls) = + Service.make edn >>| reword_error service_error >>? fun service -> + Log.info (fun m -> m "Start a TLS service.") ; + return (Ok { service; tls }) + + let accept { service; tls } = + Service.accept service >>| reword_error service_error >>? fun flow -> + let tls = Tls.Engine.server tls in + let raw = Cstruct.create 0x1000 in + let queue = Ke.create ~capacity:0x1000 Bigarray.Char in + Log.info (fun m -> m "A TLS flow is coming.") ; + return (Ok { tls = Some tls; closed = false; raw; queue; flow }) + + let close { service; _ } = + Service.close service >>| reword_error service_error + end + + let service_with_tls : + type edn t flow. + key:edn Conduit.key -> + (t * flow) Conduit.Witness.service -> + flow protocol_with_tls Conduit.Witness.protocol -> + (edn * Tls.Config.server) Conduit.key + * (t service_with_tls * flow protocol_with_tls) Conduit.Witness.service = + fun ~key service protocol -> + match Conduit.impl_of_service ~key service with + | Ok (module Service) -> + let module M = Make_server (Service) in + let k = Conduit.key (Fmt.strf "%s + tls" (Conduit.name_of_key key)) in + let s = Conduit.register_service ~key:k ~service:(module M) ~protocol in + (k, s) + | _ -> assert false +end diff --git a/tls/conduit_tls.mli b/tls/conduit_tls.mli new file mode 100644 index 00000000..7a23f4ad --- /dev/null +++ b/tls/conduit_tls.mli @@ -0,0 +1,70 @@ +(** Common TLS implementation with Conduit. + + The current implementation of the TLS layer over an underlying protocol + respects some assumptions and it has a specific behaviour which is decribed + here: + + The {i handshake} is not done when we initialize the flow. Only a call to + [recv] or [send] really starts the handshake with your peer. In that + context, a concurrent call of these actions should put some trouble into the + handshake and they must be protected by an exclusion. + + In other words due to the non-atomicity of [recv] and [send], while the + handshake, you should ensure to finish a call of one of them before to call + the other. A mutex should be used in this context to protect the mutual + exclusion between [recv] and [send]. In others words, such process is safe: + + {[ + let* _ = Conduit.send tls_flow raw in + let* _ = Conduit.recv tls_flow raw in + ]} + + Where such process is not safe: + + {[ + async (fun () -> Conduit.send tls_flow raw) ; + async (fun () -> Conduit.recv tls_flow raw) + ]} + + The non-atomicity of [send] and [recv] is due to the underlying handshake of + TLS which can appear everytime. By this fact, [send] or [recv] (depends + which is executed first) can start an handshake process which can call + several times underlying [Flow.send] and [Flow.recv] processes (no 0-RTT). + If you use [async], the scheduler can misleading/misorder handshake started + with one to the other call to [send] and [recv]. + + A solution such as a {i mutex} to ensure the exclusivity between [send] and + [recv] can be used - it does not exists at this layer where such abstraction + is not available. *) + +module Make + (Scheduler : Conduit.Sigs.SCHEDULER) + (Conduit : Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Scheduler.t) : sig + type 'flow protocol_with_tls + + val underlying : 'flow protocol_with_tls -> 'flow + (** [underlying flow] returns underlying flow used by the TLS flow. *) + + val handshake : 'flow protocol_with_tls -> bool + (** [handshake flow] returns [true] if {i handshake} is processing. *) + + val protocol_with_tls : + key:'edn Conduit.key -> + 'flow Conduit.Witness.protocol -> + ('edn * Tls.Config.client) Conduit.key + * 'flow protocol_with_tls Conduit.Witness.protocol + (** From a given protocol [witness], it creates a new {i witness} of the + protocol layered with TLS. *) + + type 'service service_with_tls + + val service_with_tls : + key:'edn Conduit.key -> + ('t * 'flow) Conduit.Witness.service -> + 'flow protocol_with_tls Conduit.Witness.protocol -> + ('edn * Tls.Config.server) Conduit.key + * ('t service_with_tls * 'flow protocol_with_tls) Conduit.Witness.service +end diff --git a/tls/dune b/tls/dune new file mode 100644 index 00000000..03c57e9f --- /dev/null +++ b/tls/dune @@ -0,0 +1,4 @@ +(library + (name conduit_tls) + (public_name conduit-tls) + (libraries stdlib-shims logs bigstringaf ke tls conduit)) From 50efb13a2ee9a0bd08d2ad3bcd28294b9f215aa2 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:41:51 +0200 Subject: [PATCH 007/140] New implementation of conduit-lwt with mirage-flow implementation and helper to start a server `conduit-lwt` is roughly an application of `conduit` with: - type input = Cstruct.t - type output = Cstruct.t - type +'a s = 'a Lwt.t Due to the ability to play with the scheduler, `conduit-lwt` provides: - an implementation of the interface `mirage-flow.2.0.1` (deprecated) - an helper to start a server - conduit-tls with lwt The first is deprecated due to the difference between `Conduit.recv` and `Mirage_flow.recv`. The documentation tells you more about that. The second is what `conduit` provided before, a common loop to start the server with an _handler_. It is used by `ocaml-cohttp`. This helper is not restricted to a specific protocol. The third is an application of `conduit-tls` with `conduit-lwt`. --- lwt/conduit_lwt.ml | 53 ++++++++++++++++++++++++++++++++++++++++ lwt/conduit_lwt.mli | 16 ++++++++++++ lwt/conduit_lwt_flow.ml | 41 +++++++++++++++++++++++++++++++ lwt/conduit_lwt_flow.mli | 18 ++++++++++++++ lwt/dune | 16 +++++++----- lwt/resolver_lwt.ml | 28 --------------------- lwt/resolver_lwt.mli | 29 ---------------------- 7 files changed, 138 insertions(+), 63 deletions(-) create mode 100644 lwt/conduit_lwt.ml create mode 100644 lwt/conduit_lwt.mli create mode 100644 lwt/conduit_lwt_flow.ml create mode 100644 lwt/conduit_lwt_flow.mli delete mode 100644 lwt/resolver_lwt.ml delete mode 100644 lwt/resolver_lwt.mli diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml new file mode 100644 index 00000000..47eb8012 --- /dev/null +++ b/lwt/conduit_lwt.ml @@ -0,0 +1,53 @@ +module Lwt_scheduler = struct + type +'a t = 'a Lwt.t + + let bind x f = Lwt.bind x f + + let return x = Lwt.return x +end + +include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let invalid_arg fmt = Format.kasprintf invalid_arg fmt + +let ( >>? ) = Lwt_result.bind + +let serve_with_handler : + type cfg master flow. + handler:(flow Witness.protocol -> flow -> unit Lwt.t) -> + key:cfg key -> + service:(master * flow) Witness.service -> + cfg -> + unit Lwt_condition.t * unit Lwt.t = + fun ~handler ~key ~service cfg -> + let open Lwt.Infix in + let stop = Lwt_condition.create () in + match impl_of_service ~key service with + | Error _ -> invalid_arg "Invalid key %s" (name_of_key key) + | Ok (module Service) -> + let main = + serve ~key cfg ~service >>= function + | Error err -> failwith "%a" pp_error err + | Ok (master, protocol) -> ( + let rec loop () = + let stop = + Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Service.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) + in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler protocol flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Service.close master + | Error err0 -> ( + Service.close master >>= function + | Ok () -> Lwt.return_error err0 + | Error _err1 -> Lwt.return_error err0) in + loop () >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Service.pp_error err) in + (stop, main) diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli new file mode 100644 index 00000000..e2a80bc1 --- /dev/null +++ b/lwt/conduit_lwt.mli @@ -0,0 +1,16 @@ +(** Conduit with LWT. *) + +module Lwt_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t + +include + Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Lwt.t + +val serve_with_handler : + handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> + key:'cfg key -> + service:('master * 'flow) Witness.service -> + 'cfg -> + unit Lwt_condition.t * unit Lwt.t diff --git a/lwt/conduit_lwt_flow.ml b/lwt/conduit_lwt_flow.ml new file mode 100644 index 00000000..d14261bd --- /dev/null +++ b/lwt/conduit_lwt_flow.ml @@ -0,0 +1,41 @@ +open Lwt.Infix + +type flow = Conduit_lwt.flow + +type error = Conduit_lwt.error + +type write_error = [ Mirage_flow.write_error | Conduit_lwt.error ] + +let pp_error = Conduit_lwt.pp_error + +let pp_write_error ppf = function + | #Mirage_flow.write_error as err -> Mirage_flow.pp_write_error ppf err + | #Conduit_lwt.error as err -> Conduit_lwt.pp_error ppf err + +let read flow = + let raw = Cstruct.create 0x1000 in + Conduit_lwt.recv flow raw >>= function + | Ok `End_of_input -> Lwt.return_ok `Eof + | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) + | Error _ as err -> Lwt.return err + +let write flow raw = + let rec go x = + if Cstruct.len x = 0 + then Lwt.return_ok () + else + Conduit_lwt.send flow x >>= function + | Error _ as err -> Lwt.return err + | Ok len -> go (Cstruct.shift x len) in + go raw + +let writev flow cs = + let rec go = function + | [] -> Lwt.return_ok () + | x :: r -> ( + write flow x >>= function + | Ok () -> go r + | Error _ as err -> Lwt.return err) in + go cs + +let close flow = Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit diff --git a/lwt/conduit_lwt_flow.mli b/lwt/conduit_lwt_flow.mli new file mode 100644 index 00000000..f9714023 --- /dev/null +++ b/lwt/conduit_lwt_flow.mli @@ -0,0 +1,18 @@ +(** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. + This module is deprecated when the current implementation of [read] has + another behaviour: + + [conduit] provides: + + {[ val read : flow -> Cstruct.t -> (int or_eoi, error) result Lwt.t ]} + + where [mirage-flow] expects: + + {[ val read : flow -> (Cstruct.t or_eoi, error) result Lwt.t ]} + + This current implementation allocates an {b arbitrary} 4096 bytes buffer to + fit under the [mirage-flow] interface. [conduit] did the choice to follow + the POSIX interface and let the end-user to allocate by himself the input + buffer. *) + +include Mirage_flow.S with type flow = Conduit_lwt.flow diff --git a/lwt/dune b/lwt/dune index 94c64fa4..c170d8cc 100644 --- a/lwt/dune +++ b/lwt/dune @@ -1,7 +1,11 @@ (library - (name conduit_lwt) - (public_name conduit-lwt) - (preprocess (pps ppx_sexp_conv)) - (wrapped false) - (modules resolver_lwt) - (libraries conduit lwt)) + (name conduit_lwt) + (public_name conduit-lwt) + (modules conduit_lwt) + (libraries cstruct lwt conduit)) + +(library + (name conduit_lwt_flow) + (public_name conduit-lwt.flow) + (modules conduit_lwt_flow) + (libraries conduit-lwt mirage-flow)) diff --git a/lwt/resolver_lwt.ml b/lwt/resolver_lwt.ml deleted file mode 100644 index c11ae8b3..00000000 --- a/lwt/resolver_lwt.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -module IO = struct - type 'a t = 'a Lwt.t - let (>>=) = Lwt.bind - let return = Lwt.return -end - -module type S = Resolver.S - with type svc = Resolver.service - and type 'a io = 'a Lwt.t - -include Resolver.Make(IO) diff --git a/lwt/resolver_lwt.mli b/lwt/resolver_lwt.mli deleted file mode 100644 index 35d63ddc..00000000 --- a/lwt/resolver_lwt.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -(** Resolve URIs to endpoints using the - {{:http://ocsigen.org/lwt}Lwt} library *) - -(** IO module compatible with {!Conduit.IO} that uses Lwt *) -module IO : Conduit.IO with type 'a t = 'a Lwt.t - -(** Module type that specialises {!Conduit.RESOLVER} to use Lwt threads *) -module type S = Resolver.S - with type svc = Resolver.service - and type 'a io = 'a Lwt.t - -include S From 8dcb7df7df331df1891e379e525609ff5611f4e4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:45:09 +0200 Subject: [PATCH 008/140] New implementation of conduit-lwt-unix with Lwt's channel, tls and ssl layers This is the first real implementation of `conduit` with some protocols: - tcp/ip with `Lwt_unix` - tls with `conduit-tls` - ssl with `Lwt_ssl` Due to the ability to use `Lwt_io`, this package provides an helper to give `Lwt_io.channel` from an abstracted `Conduit_lwt{_unix}.flow`. It provides TLS + provided tcp/ip protocol, a possible composition with SSL layer (with `Lwt_ssl`) and SSL + provided tcp/ip protocol. It provides a `resolv_conf` function as the main DNS resolver. It's a call of `gethostbyname` and finally trusts on your `resolv.conf`. --- lwt-unix/conduit_lwt_launchd_dummy.ml | 19 - lwt-unix/conduit_lwt_launchd_real.ml | 25 -- lwt-unix/conduit_lwt_server.ml | 99 ------ lwt-unix/conduit_lwt_server.mli | 23 -- lwt-unix/conduit_lwt_tls_dummy.ml | 19 - lwt-unix/conduit_lwt_tls_dummy.mli | 61 ---- lwt-unix/conduit_lwt_tls_real.ml | 61 ---- lwt-unix/conduit_lwt_tls_real.mli | 62 ---- lwt-unix/conduit_lwt_unix.ml | 453 ++---------------------- lwt-unix/conduit_lwt_unix.mli | 239 ++----------- lwt-unix/conduit_lwt_unix_ssl.ml | 170 +++++++++ lwt-unix/conduit_lwt_unix_ssl.mli | 102 ++++++ lwt-unix/conduit_lwt_unix_ssl_dummy.ml | 38 -- lwt-unix/conduit_lwt_unix_ssl_dummy.mli | 60 ---- lwt-unix/conduit_lwt_unix_ssl_real.ml | 96 ----- lwt-unix/conduit_lwt_unix_ssl_real.mli | 60 ---- lwt-unix/conduit_lwt_unix_tcp.ml | 318 +++++++++++++++++ lwt-unix/conduit_lwt_unix_tcp.mli | 77 ++++ lwt-unix/conduit_lwt_unix_tls.ml | 16 + lwt-unix/conduit_lwt_unix_tls.mli | 52 +++ lwt-unix/dune | 39 +- lwt-unix/resolver_lwt_unix.ml | 106 ------ lwt-unix/resolver_lwt_unix.mli | 58 --- 23 files changed, 813 insertions(+), 1440 deletions(-) delete mode 100644 lwt-unix/conduit_lwt_launchd_dummy.ml delete mode 100644 lwt-unix/conduit_lwt_launchd_real.ml delete mode 100644 lwt-unix/conduit_lwt_server.ml delete mode 100644 lwt-unix/conduit_lwt_server.mli delete mode 100644 lwt-unix/conduit_lwt_tls_dummy.ml delete mode 100644 lwt-unix/conduit_lwt_tls_dummy.mli delete mode 100644 lwt-unix/conduit_lwt_tls_real.ml delete mode 100644 lwt-unix/conduit_lwt_tls_real.mli create mode 100644 lwt-unix/conduit_lwt_unix_ssl.ml create mode 100644 lwt-unix/conduit_lwt_unix_ssl.mli delete mode 100644 lwt-unix/conduit_lwt_unix_ssl_dummy.ml delete mode 100644 lwt-unix/conduit_lwt_unix_ssl_dummy.mli delete mode 100644 lwt-unix/conduit_lwt_unix_ssl_real.ml delete mode 100644 lwt-unix/conduit_lwt_unix_ssl_real.mli create mode 100644 lwt-unix/conduit_lwt_unix_tcp.ml create mode 100644 lwt-unix/conduit_lwt_unix_tcp.mli create mode 100644 lwt-unix/conduit_lwt_unix_tls.ml create mode 100644 lwt-unix/conduit_lwt_unix_tls.mli delete mode 100644 lwt-unix/resolver_lwt_unix.ml delete mode 100644 lwt-unix/resolver_lwt_unix.mli diff --git a/lwt-unix/conduit_lwt_launchd_dummy.ml b/lwt-unix/conduit_lwt_launchd_dummy.ml deleted file mode 100644 index 28cbf01c..00000000 --- a/lwt-unix/conduit_lwt_launchd_dummy.ml +++ /dev/null @@ -1,19 +0,0 @@ -(* - * Copyright (c) 2015-2017 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -let activate _fn _name = - Lwt.fail_with "No Launchd support" diff --git a/lwt-unix/conduit_lwt_launchd_real.ml b/lwt-unix/conduit_lwt_launchd_real.ml deleted file mode 100644 index c656225b..00000000 --- a/lwt-unix/conduit_lwt_launchd_real.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* - * Copyright (c) 2015-2017 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix - -let activate fn name = - Lwt_launchd.activate_socket name - >>= fun sockets -> - match (Launchd.error_to_msg sockets) with - | Ok sockets -> Lwt_list.iter_p fn sockets - | Error (`Msg m) -> Lwt.fail_with m diff --git a/lwt-unix/conduit_lwt_server.ml b/lwt-unix/conduit_lwt_server.ml deleted file mode 100644 index d2c81ded..00000000 --- a/lwt-unix/conduit_lwt_server.ml +++ /dev/null @@ -1,99 +0,0 @@ -open Lwt.Infix - -let src = Logs.Src.create "conduit_lwt_server" ~doc:"Conduit Lwt transport" -module Log = (val Logs.src_log src : Logs.LOG) - -let safe_close t = - Lwt.catch - (fun () -> Lwt_io.close t) - (fun _ -> Lwt.return_unit) - -let close (ic, oc) = - safe_close oc >>= fun () -> - safe_close ic - -let with_socket sockaddr f = - let fd = - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in - Lwt.catch (fun () -> f fd) (fun e -> - Lwt.catch - (fun () -> Lwt_unix.close fd) - (fun _ -> Lwt.return_unit) - >>= fun () -> - Lwt.fail e) - -let listen ?(backlog=128) sa = - with_socket sa (fun fd -> - Lwt_unix.(setsockopt fd SO_REUSEADDR true); - Lwt_unix.bind fd sa >|= fun () -> - Lwt_unix.listen fd backlog; - Lwt_unix.set_close_on_exec fd; - fd) - -let process_accept ?timeout callback (sa,ic,oc) = - let c = callback sa ic oc in - let events = match timeout with - | None -> [c] - | Some t -> [c; (Lwt_unix.sleep (float_of_int t)) ] in - Lwt.finalize (fun () -> Lwt.pick events) (fun () -> close (ic, oc)) - -(* File descriptors are a global resource so this has to be a global limit too *) -let maxactive = ref None -let active = ref 0 - -let cond = Lwt_condition.create () -let connected () = incr active -let disconnected () = decr active; Lwt_condition.broadcast cond () - -let rec throttle () = - match !maxactive with - | Some limit when !active > limit -> - Lwt_condition.wait cond >>= throttle - | _ -> Lwt.return_unit - -let set_max_active max_active = - maxactive := Some max_active; - Lwt_condition.broadcast cond () - -let run_handler handler v = - Lwt.async begin fun () -> - Lwt.try_bind - (fun () -> handler v) - (fun () -> disconnected (); Lwt.return_unit) - (fun x -> - disconnected (); - begin match x with - | Lwt.Canceled -> () - | ex -> - Log.warn (fun f -> f "Uncaught exception in handler: %s" - (Printexc.to_string ex)) - end; - Lwt.return_unit) - end - -let init ?(stop = fst (Lwt.wait ())) handler fd = - let stop = Lwt.map (fun () -> `Stop) stop in - let rec loop () = - Lwt.try_bind - (fun () -> - connected (); - throttle () >>= fun () -> - let accept = Lwt.map (fun v -> `Accept v) (Lwt_unix.accept fd) in - Lwt.choose [accept ; stop] >|= function - | `Stop -> - Lwt.cancel accept; - `Stop - | (`Accept _) as x -> x) - (function - | `Stop -> disconnected (); Lwt.return_unit - | `Accept v -> run_handler handler v; loop ()) - (fun exn -> - disconnected (); - match exn with - | Lwt.Canceled -> Lwt.return_unit - | ex -> - Log.warn (fun f -> - f "Uncaught exception accepting connection: %s" - (Printexc.to_string ex)); - Lwt_unix.yield () >>= loop) in - Lwt.finalize loop (fun () -> Lwt_unix.close fd) diff --git a/lwt-unix/conduit_lwt_server.mli b/lwt-unix/conduit_lwt_server.mli deleted file mode 100644 index 8a7bbd13..00000000 --- a/lwt-unix/conduit_lwt_server.mli +++ /dev/null @@ -1,23 +0,0 @@ - -val close : 'a Lwt_io.channel * 'b Lwt_io.channel -> unit Lwt.t - -val set_max_active : int -> unit - -val listen : ?backlog:int -> Unix.sockaddr -> Lwt_unix.file_descr Lwt.t - -val with_socket - : Unix.sockaddr - -> (Lwt_unix.file_descr -> 'a Lwt.t) - -> 'a Lwt.t - -val process_accept - : ?timeout:int - -> ('a -> 'b Lwt_io.channel -> 'c Lwt_io.channel -> unit Lwt.t) - -> 'a * 'b Lwt_io.channel * 'c Lwt_io.channel - -> unit Lwt.t - -val init - : ?stop:unit Lwt.t - -> (Lwt_unix.file_descr * Lwt_unix.sockaddr -> unit Lwt.t) - -> Lwt_unix.file_descr - -> unit Lwt.t diff --git a/lwt-unix/conduit_lwt_tls_dummy.ml b/lwt-unix/conduit_lwt_tls_dummy.ml deleted file mode 100644 index ee67a13d..00000000 --- a/lwt-unix/conduit_lwt_tls_dummy.ml +++ /dev/null @@ -1,19 +0,0 @@ -module X509 = struct - let private_of_pems ~cert:_ ~priv_key:_ = - Lwt.fail_with "Tls not available" -end - -module Client = struct - let connect ?src:_ ?certificates:_ _host _sa = - Lwt.fail_with "Tls not available" -end - -module Server = struct - let init' ?backlog:_ ?stop:_ ?timeout:_ _tls _sa _callback = - Lwt.fail_with "Tls not available" - - let init ?backlog:_ ~certfile:_ ~keyfile:_ ?stop:_ ?timeout:_ _sa _callback = - Lwt.fail_with "Tls not available" -end - -let available = false diff --git a/lwt-unix/conduit_lwt_tls_dummy.mli b/lwt-unix/conduit_lwt_tls_dummy.mli deleted file mode 100644 index 673d6184..00000000 --- a/lwt-unix/conduit_lwt_tls_dummy.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* - * Copyright (c) 2014 Hannes Mehnert - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** TLS/SSL connections via OCaml-TLS *) - -module Client : sig - - val connect : - ?src:Lwt_unix.sockaddr -> - string -> - Lwt_unix.sockaddr -> - (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t - -end - -module Server : sig - val init - : ?backlog:int - -> certfile:string - -> keyfile:string - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> Lwt_unix.sockaddr - -> (Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t - - val init' - : ?backlog:int - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> 'config - -> Lwt_unix.sockaddr - -> (Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t -end - -(**/**) - -val available : bool diff --git a/lwt-unix/conduit_lwt_tls_real.ml b/lwt-unix/conduit_lwt_tls_real.ml deleted file mode 100644 index eadb90c7..00000000 --- a/lwt-unix/conduit_lwt_tls_real.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* - * Copyright (c) 2014 Hannes Mehnert - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix - -module X509 = struct - let private_of_pems ~cert ~priv_key = - X509_lwt.private_of_pems ~cert ~priv_key -end - -module Client = struct - let connect ?src ?certificates host sa = - Conduit_lwt_server.with_socket sa (fun fd -> - (match src with - | None -> Lwt.return_unit - | Some src_sa -> Lwt_unix.bind fd src_sa) >>= fun () -> - let authenticator ~host:_ _ = Ok None in - let config = Tls.Config.client ~authenticator ?certificates () in - Lwt_unix.connect fd sa >>= fun () -> - Tls_lwt.Unix.client_of_fd config ~host fd >|= fun t -> - let ic, oc = Tls_lwt.of_t t in - (fd, ic, oc) - ) -end - -module Server = struct - - let init' ?backlog ?stop ?timeout tls sa callback = - sa - |> Conduit_lwt_server.listen ?backlog - >>= Conduit_lwt_server.init ?stop (fun (fd, addr) -> - Lwt.try_bind - (fun () -> Tls_lwt.Unix.server_of_fd tls fd) - (fun t -> - let (ic, oc) = Tls_lwt.of_t t in - Lwt.return (fd, ic, oc)) - (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn) - >>= Conduit_lwt_server.process_accept ?timeout (callback addr)) - - let init ?backlog ~certfile ~keyfile ?stop ?timeout sa callback = - X509_lwt.private_of_pems ~cert:certfile ~priv_key:keyfile - >>= fun certificate -> - let config = Tls.Config.server ~certificates:(`Single certificate) () in - init' ?backlog ?stop ?timeout config sa callback -end - -let available = true diff --git a/lwt-unix/conduit_lwt_tls_real.mli b/lwt-unix/conduit_lwt_tls_real.mli deleted file mode 100644 index bbfd8e24..00000000 --- a/lwt-unix/conduit_lwt_tls_real.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* - * Copyright (c) 2014 Hannes Mehnert - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** TLS/SSL connections via OCaml-TLS *) - -module Client : sig - - val connect : - ?src:Lwt_unix.sockaddr -> - ?certificates:Tls.Config.own_cert -> - string -> - Lwt_unix.sockaddr -> - (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t - -end - -module Server : sig - val init - : ?backlog:int - -> certfile:string - -> keyfile:string - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> Lwt_unix.sockaddr - -> ( Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t - - val init' - : ?backlog:int - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> Tls.Config.server - -> Lwt_unix.sockaddr - -> (Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t -end - -(**/**) - -val available : bool diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml index 8dade88d..882f9bb8 100644 --- a/lwt-unix/conduit_lwt_unix.ml +++ b/lwt-unix/conduit_lwt_unix.ml @@ -1,419 +1,34 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * Copyright (c) 2014 Hannes Mehnert - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix -open Sexplib.Conv - -let debug = ref false -let debug_print = ref Printf.eprintf -let () = - try - ignore(Sys.getenv "CONDUIT_DEBUG"); - debug := true - with Not_found -> () - -type tls_lib = | OpenSSL | Native | No_tls [@@deriving sexp] -let default_tls_library = - (* TODO build time selection *) - let default = - if Conduit_lwt_tls.available then - Native - else if Conduit_lwt_unix_ssl.available then - OpenSSL - else - No_tls - in - match String.lowercase_ascii (Sys.getenv "CONDUIT_TLS") with - | "native" -> Native - | "openssl" | "libressl" -> OpenSSL - | "none" | "notls" -> No_tls - | _ -> default - | exception Not_found -> default - -let tls_library = ref default_tls_library - -let () = if !debug then - !debug_print "Selected TLS library: %s\n" - (Sexplib.Sexp.to_string (sexp_of_tls_lib !tls_library)) - -type +'a io = 'a Lwt.t -type ic = Lwt_io.input_channel -type oc = Lwt_io.output_channel - -type client_tls_config = - [ `Hostname of string ] * - [ `IP of Ipaddr_sexp.t ] * - [ `Port of int ] -[@@deriving sexp] - -type client = [ - | `TLS of client_tls_config - | `TLS_native of client_tls_config - | `OpenSSL of client_tls_config - | `TCP of [ `IP of Ipaddr_sexp.t ] * [`Port of int ] - | `Unix_domain_socket of [ `File of string ] - | `Vchan_direct of [ `Domid of int ] * [ `Port of string ] - | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ] -] [@@deriving sexp] - -(** Configuration fragment for a listening TLS server *) -type server_tls_config = - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] * - [ `Password of bool -> string | `No_password ] * - [ `Port of int ] -[@@deriving sexp] - -(** Set of ways to create TCP servers *) -type tcp_config = [ - | `Port of int - | `Socket of (Lwt_unix.file_descr [@sexp.opaque]) -] [@@deriving sexp] - -(** Set of supported listening mechanisms that are supported by this module. *) -type server = [ - | `TLS of server_tls_config - | `OpenSSL of server_tls_config - | `TLS_native of server_tls_config - | `TCP of tcp_config - | `Unix_domain_socket of [ `File of string ] - | `Vchan_direct of int * string - | `Vchan_domain_socket of string * string - | `Launchd of string -] [@@deriving sexp] - -type tls_own_key = [ - | `None - | `TLS of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] * - [ `Password of bool -> string | `No_password ] -] [@@deriving sexp] - -type tls_server_key = tls_own_key [@@deriving sexp] - -type ctx = { - src: Unix.sockaddr option; - tls_own_key: tls_own_key; -} - -let string_of_unix_sockaddr sa = - let open Unix in - match sa with - | ADDR_UNIX s -> - Printf.sprintf "ADDR_UNIX(%s)" s - | ADDR_INET (ia, port) -> - Printf.sprintf "ADDR_INET(%s,%d)" (string_of_inet_addr ia) port - -let sexp_of_ctx ctx = - [%sexp_of: string option * tls_own_key ] - ((match ctx.src with - | None -> None - | Some sa -> Some (string_of_unix_sockaddr sa)), - ctx.tls_own_key) - -type tcp_flow = { - fd: (Lwt_unix.file_descr [@sexp.opaque]); - ip: Ipaddr_sexp.t; - port: int; -} [@@deriving sexp] - -type domain_flow = { - fd: (Lwt_unix.file_descr [@sexp.opaque]); - path: string; -} [@@deriving sexp] - -type vchan_flow = { - domid: int; - port: string; -} [@@deriving sexp] - -type flow = - | TCP of tcp_flow - | Domain_socket of domain_flow - | Vchan of vchan_flow -[@@deriving sexp] - -let flow_of_fd fd sa = - match sa with - | Unix.ADDR_UNIX path -> Domain_socket { fd; path } - | Unix.ADDR_INET (ip,port) -> TCP { fd; ip=Ipaddr_unix.of_inet_addr ip; port } - -let default_ctx = - { src=None; tls_own_key=`None } - -let init ?src ?(tls_own_key=`None) ?(tls_server_key=`None) () = - let tls_own_key = - match tls_own_key with `None -> tls_server_key | _ -> tls_own_key in - match src with - | None -> - Lwt.return { src=None; tls_own_key } - | Some host -> - let open Unix in - Lwt_unix.getaddrinfo host "0" [AI_PASSIVE; AI_SOCKTYPE SOCK_STREAM] - >>= function - | {ai_addr;_}::_ -> Lwt.return { src=Some ai_addr; tls_own_key } - | [] -> Lwt.fail_with "Invalid conduit source address specified" - -module Sockaddr_io = struct - let shutdown_no_exn fd mode = - try Lwt_unix.shutdown fd mode - with Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - - let make_fd_state () = - ref `Open - - let make fd = - let fd_state = make_fd_state () in - let close_in () = - match !fd_state with - | `Open -> fd_state := `In_closed; shutdown_no_exn fd Unix.SHUTDOWN_RECEIVE; Lwt.return_unit - | `Out_closed -> fd_state := `Closed; Lwt_unix.close fd - | `In_closed (* repeating on a closed channel is a noop in Lwt_io *) - | `Closed -> Lwt.return_unit in - let close_out () = - match !fd_state with - | `Open -> fd_state := `Out_closed; shutdown_no_exn fd Unix.SHUTDOWN_SEND; Lwt.return_unit - | `In_closed -> fd_state := `Closed; Lwt_unix.close fd - | `Out_closed (* repeating on a closed channel is a noop in Lwt_io *) - | `Closed -> Lwt.return_unit in - let ic = Lwt_io.of_fd ~close:close_in ~mode:Lwt_io.input fd in - let oc = Lwt_io.of_fd ~close:close_out ~mode:Lwt_io.output fd in - (ic, oc) -end - -(* Vanilla sockaddr connection *) -module Sockaddr_client = struct - let connect ?src sa = - Conduit_lwt_server.with_socket sa (fun fd -> - (match src with - | None -> Lwt.return_unit - | Some src_sa -> Lwt_unix.bind fd src_sa) >>= fun () -> - Lwt_unix.connect fd sa >>= fun () -> - let ic, oc = Sockaddr_io.make fd in - Lwt.return (fd, ic, oc) - ) -end - -module Sockaddr_server = struct - - let set_sockopts_no_exn fd = - try Lwt_unix.setsockopt fd Lwt_unix.TCP_NODELAY true - with (* This is expected for Unix domain sockets *) - | Unix.Unix_error(Unix.EOPNOTSUPP, _, _) -> () - - let process_accept ?timeout callback (client,peeraddr) = - set_sockopts_no_exn client; - let ic, oc = Sockaddr_io.make client in - let c = callback (flow_of_fd client peeraddr) ic oc in - let events = match timeout with - |None -> [c] - |Some t -> [c; (Lwt_unix.sleep (float_of_int t)) ] in - Lwt.finalize - (fun () -> Lwt.pick events) - (fun () -> Conduit_lwt_server.close (ic,oc)) - - let init ~on ?stop ?backlog ?timeout callback = - (match on with - | `Socket s -> Lwt.return s - | `Sockaddr sockaddr -> Conduit_lwt_server.listen ?backlog sockaddr) - >>= Conduit_lwt_server.init ?stop (process_accept ?timeout callback) -end - -let set_max_active maxactive = - Conduit_lwt_server.set_max_active maxactive - -(** TLS client connection functions *) - -let connect_with_tls_native ~ctx (`Hostname hostname, `IP ip, `Port port) = - let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip,port) in - (match ctx.tls_own_key with - | `None -> Lwt.return_none - | `TLS (_, _, `Password _) -> - Lwt.fail_with "OCaml-TLS cannot handle encrypted pem files" - | `TLS (`Crt_file_path cert, `Key_file_path priv_key, `No_password) -> - Conduit_lwt_tls.X509.private_of_pems ~cert ~priv_key >|= fun certificate -> - Some (`Single certificate) - ) >>= fun certificates -> - Conduit_lwt_tls.Client.connect ?src:ctx.src ?certificates hostname sa - >|= fun (fd, ic, oc) -> - let flow = TCP { fd ; ip ; port } in - (flow, ic, oc) - -let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) = - let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip,port) in - let ctx_ssl = - match ctx.tls_own_key with - | `None -> None - | `TLS (`Crt_file_path certfile, `Key_file_path keyfile, password) -> - let password = - (match password with - | `No_password -> None - | `Password fn -> Some fn) in - let ctx_ssl = - Conduit_lwt_unix_ssl.Client.create_ctx ~certfile ~keyfile ?password () - in - Some ctx_ssl - in - Conduit_lwt_unix_ssl.Client.connect ?ctx:ctx_ssl ?src:ctx.src ~hostname sa - >>= fun (fd, ic, oc) -> - let flow = TCP {fd;ip;port} in - Lwt.return (flow, ic, oc) - -let connect_with_default_tls ~ctx tls_client_config = - match !tls_library with - | OpenSSL -> connect_with_openssl ~ctx tls_client_config - | Native -> connect_with_tls_native ~ctx tls_client_config - | No_tls -> Lwt.fail_with "No SSL or TLS support compiled into Conduit" - -(** Main connection function *) - -let connect ~ctx (mode:client) = - match mode with - | `TCP (`IP ip, `Port port) -> - let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in - Sockaddr_client.connect ?src:ctx.src sa - >>= fun (fd, ic, oc) -> - let flow = TCP {fd;ip;port} in - Lwt.return (flow, ic, oc) - | `Unix_domain_socket (`File path) -> - Sockaddr_client.connect (Unix.ADDR_UNIX path) - >>= fun (fd, ic, oc) -> - let flow = Domain_socket {fd; path} in - Lwt.return (flow, ic, oc) - | `TLS c -> connect_with_default_tls ~ctx c - | `OpenSSL c -> connect_with_openssl ~ctx c - | `TLS_native c -> connect_with_tls_native ~ctx c - | `Vchan_direct _ -> Lwt.fail_with "Vchan_direct not available on unix" - | `Vchan_domain_socket _uuid -> - Lwt.fail_with "Vchan_domain_socket not implemented" - -let sockaddr_on_tcp_port ctx port = - let open Unix in - match ctx.src with - | Some (ADDR_UNIX _) -> failwith "Cant listen to TCP on a domain socket" - | Some (ADDR_INET (a,_)) -> ADDR_INET (a,port), Ipaddr_unix.of_inet_addr a - | None -> ADDR_INET (inet_addr_any,port), Ipaddr.(V4 V4.any) - -let serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback = - let sockaddr, _ = sockaddr_on_tcp_port ctx port in - let password = - match pass with - | `No_password -> None - | `Password fn -> Some fn - in - Conduit_lwt_unix_ssl.Server.init - ?password ~certfile ~keyfile ?timeout ?stop sockaddr - (fun addr fd ic oc -> callback (flow_of_fd fd addr) ic oc) - -let serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback = - let sockaddr, _ = sockaddr_on_tcp_port ctx port in - (match pass with - | `No_password -> Lwt.return () - | `Password _ -> Lwt.fail_with "OCaml-TLS cannot handle encrypted pem files" - ) >>= fun () -> - Conduit_lwt_tls.Server.init - ~certfile ~keyfile ?timeout ?stop sockaddr - (fun addr fd ic oc -> callback (flow_of_fd fd addr) ic oc) - -let serve_with_default_tls ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback = - match !tls_library with - | OpenSSL -> serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback - | Native -> serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback - | No_tls -> failwith "No SSL or TLS support compiled into Conduit" - -let serve ?backlog ?timeout ?stop - ~on_exn - ~(ctx:ctx) ~(mode:server) callback = - let callback flow ic oc = - Lwt.catch - (fun () -> callback flow ic oc) - (fun exn -> on_exn exn; Lwt.return_unit) - in - match mode with - | `TCP (`Port port) -> - let sockaddr, _ = sockaddr_on_tcp_port ctx port in - Sockaddr_server.init ~on:(`Sockaddr sockaddr) ?backlog ?timeout ?stop callback - | `TCP (`Socket s) -> - Sockaddr_server.init ~on:(`Socket s) ?backlog ?timeout ?stop callback - | `Unix_domain_socket (`File path) -> - let sockaddr = Unix.ADDR_UNIX path in - Sockaddr_server.init ~on:(`Sockaddr sockaddr) ?backlog ?timeout ?stop callback - | `TLS (`Crt_file_path certfile, `Key_file_path keyfile, pass, `Port port) -> - serve_with_default_tls ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback - | `OpenSSL (`Crt_file_path certfile, `Key_file_path keyfile, - pass, `Port port) -> - serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback - | `TLS_native (`Crt_file_path certfile, `Key_file_path keyfile, - pass, `Port port) -> - serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile - ~pass ~port callback - |`Vchan_direct _ -> Lwt.fail_with "Vchan_direct not implemented" - | `Vchan_domain_socket _uuid -> - Lwt.fail_with "Vchan_domain_socket not implemented" - | `Launchd name -> - let fn s = Sockaddr_server.init ~on:(`Socket s) ?timeout ?stop callback in - Conduit_lwt_launchd.activate fn name - -let endp_of_flow = function - | TCP { ip; port; _ } -> `TCP (ip, port) - | Domain_socket { path; _ } -> `Unix_domain_socket path - | Vchan { domid; port } -> `Vchan_direct (domid, port) - -(** Use the configuration of the server to interpret how to - handle a particular endpoint from the resolver into a - concrete implementation of type [client] *) -let endp_to_client ~ctx:_ (endp:Conduit.endp) : client Lwt.t = - match endp with - | `TCP (ip, port) -> Lwt.return (`TCP (`IP ip, `Port port)) - | `Unix_domain_socket file -> Lwt.return (`Unix_domain_socket (`File file)) - | `Vchan_direct (domid, port) -> - Lwt.return (`Vchan_direct (`Domid domid, `Port port)) - | `Vchan_domain_socket (name, port) -> - Lwt.return (`Vchan_domain_socket (`Domain_name name, `Port port)) - | `TLS (host, (`TCP (ip, port))) -> - Lwt.return (`TLS (`Hostname host, `IP ip, `Port port)) - | `TLS (host, endp) -> begin - Lwt.fail_with (Printf.sprintf - "TLS to non-TCP currently unsupported: host=%s endp=%s" - host (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp))) - end - | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err) - -let endp_to_server ~ctx (endp:Conduit.endp) = - match endp with - | `Unix_domain_socket path -> Lwt.return (`Unix_domain_socket (`File path)) - | `TLS (_host, `TCP (_ip, port)) -> - begin match ctx.tls_own_key with - | `None -> Lwt.fail_with "No TLS server key configured" - | `TLS (`Crt_file_path crt, `Key_file_path key, pass) -> - Lwt.return (`TLS (`Crt_file_path crt, `Key_file_path key, - pass, `Port port)) - end - | `TCP (_ip, port) -> Lwt.return (`TCP (`Port port)) - | `Vchan_direct _ as mode -> Lwt.return mode - | `Vchan_domain_socket _ as mode -> Lwt.return mode - | `TLS (_host, _) -> Lwt.fail_with "TLS to non-TCP currently unsupported" - | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err) +include Conduit_lwt + +let failf fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let io_of_flow flow = + let open Lwt.Infix in + let ic_closed = ref false and oc_closed = ref false in + let close () = + if !ic_closed && !oc_closed + then + close flow >>= function + | Ok () -> Lwt.return_unit + | Error err -> failf "%a" pp_error err + else Lwt.return_unit in + let ic_close () = + ic_closed := true ; + close () in + let oc_close () = + oc_closed := true ; + close () in + let recv buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + recv flow raw >>= function + | Ok (`Input len) -> Lwt.return len + | Ok `End_of_input -> Lwt.return 0 + | Error err -> failf "%a" pp_error err in + let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in + let send buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + send flow raw >>= function + | Ok len -> Lwt.return len + | Error err -> failf "%a" pp_error err in + let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in + (ic, oc) diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli index e5db5d08..f6119a26 100644 --- a/lwt-unix/conduit_lwt_unix.mli +++ b/lwt-unix/conduit_lwt_unix.mli @@ -1,217 +1,22 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * Copyright (c) 2014 Hannes Mehnert - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Connection establishment using the - {{:http://ocsigen.org/lwt/api/Lwt_unix}Lwt_unix} library *) - -(** {2 Core types} *) - -(** Configuration fragment for a TLS client connecting to a remote endpoint *) -type client_tls_config = - [ `Hostname of string ] * - [ `IP of Ipaddr.t ] * - [ `Port of int ] -[@@deriving sexp] - -(** Set of supported client connections that are supported by this module: - - - [`TLS (`Hostname host, `IP ip, `Port port)]: Use OCaml-TLS or - OpenSSL (depending on CONDUIT_TLS) to connect to - the given [host], [ip], [port] tuple via TCP. - - [`TLS_native _]: Force use of native OCaml TLS stack to connect. - - [`OpenSSL _]: Force use of Lwt OpenSSL bindings to connect. - - [`TCP (`IP ip, `Port port)]: Use TCP to connect to the given - [ip], [port] tuple. - - [`Unix_domain_socket (`File path)]: Use UNIX domain sockets to - connect to a socket on the [path]. - - [`Vchan_direct (`Domid domid, `Port port)]: Connect to the remote - VM on the [domid], [port] tuple. - - [`Vchan_domain_socket (`Domain_name domain, `Port port_name)]: - Use the Vchan name resolution to connect. - - *) -type client = [ - | `TLS of client_tls_config - | `TLS_native of client_tls_config - (** Force use of native OCaml TLS stack to connect.*) - | `OpenSSL of client_tls_config - (** Force use of Lwt OpenSSL bindings to connect. *) - | `TCP of [ `IP of Ipaddr.t ] * [`Port of int ] - (** Use TCP to connect to the given [ip], [port] tuple. *) - | `Unix_domain_socket of [ `File of string ] - (** Use UNIX domain sockets to connect to a socket on the [path]. *) - | `Vchan_direct of [ `Domid of int ] * [ `Port of string ] - (** Connect to the remote VM on the [domid], [port] tuple. *) - | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ] - (** Use the Vchan name resolution to connect *) -] [@@deriving sexp] - -(** Configuration fragment for a listening TLS server *) -type server_tls_config = - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] * - [ `Password of bool -> string | `No_password ] * - [ `Port of int ] -[@@deriving sexp] - -(** Set of ways to create TCP servers - - [`Port port]: Create a socket listening to provided port. - - [`Socket file_descr]: Use the provided file descriptor to create a server. -*) -type tcp_config = [ - | `Port of int - | `Socket of Lwt_unix.file_descr [@sexp.opaque] -] [@@deriving sexp] - -(** Set of supported listening mechanisms that are supported by this module. - - [`TLS server_tls_config]: Use OCaml-TLS or OpenSSL (depending on CONDUIT_TLS) to connect - to the given [host], [ip], [port] tuple via TCP. - - [`TLS_native _]: Force use of native OCaml TLS stack to connect. - - [`OpenSSL _]: Force use of Lwt OpenSSL bindings to connect. - - [`TCP (`Port port)]: Listen on the specified TCPv4 port. - - [`Unix_domain_socket (`File path)]: Use UNIX domain sockets to listen on the path. - - [`Vchan_direct (domid, port)]: Listen for the remote VM on the [domid], [port] tuple. - - [`Vchan_domain_socket (domain, port_name)]: Use the Vchan name resolution to listen - - [`Listening_socket fd]: Use the socket given, useful for inherited systemd sockets. - - [`Launchd name]: uses MacOS X launchd to start the service, via the name - of the [Sockets] element within the service description plist file. See the - {{:http://mirage.github.io/ocaml-launchd/launchd/}ocaml-launchd} documentation for more. -*) -type server = [ - | `TLS of server_tls_config - | `OpenSSL of server_tls_config - | `TLS_native of server_tls_config - | `TCP of tcp_config - | `Unix_domain_socket of [ `File of string ] - | `Vchan_direct of int * string - | `Vchan_domain_socket of string * string - | `Launchd of string -] [@@deriving sexp] - -type 'a io = 'a Lwt.t -type ic = Lwt_io.input_channel -type oc = Lwt_io.output_channel - -(** [tcp_flow] contains the state of a single TCP connection. *) -type tcp_flow = private { - fd: Lwt_unix.file_descr [@sexp.opaque]; - ip: Ipaddr.t; - port: int; -} [@@deriving sexp_of] - -(** [domain_flow] contains the state of a single Unix domain socket - connection. *) -type domain_flow = private { - fd: Lwt_unix.file_descr [@sexp.opaque]; - path: string; -} [@@deriving sexp_of] - -(** [vchan_flow] contains the state of a single Vchan shared memory - connection. *) -type vchan_flow = private { - domid: int; - port: string; -} [@@deriving sexp_of] - -(** A [flow] contains the state of a single connection, over a specific - transport method. *) -type flow = private - | TCP of tcp_flow - | Domain_socket of domain_flow - | Vchan of vchan_flow -[@@deriving sexp_of] - -(** Type describing where to locate a PEM key in the filesystem *) -type tls_own_key = [ - | `None - | `TLS of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] * - [ `Password of bool -> string | `No_password ] -] [@@deriving sexp] - -(**/**) -type tls_server_key = tls_own_key [@@deriving sexp] -(**/**) - -(** State handler for an active conduit *) -type ctx [@@deriving sexp_of] - -(** {2 Connection and listening} *) - -(** Default context that listens on all source addresses with - no TLS certificate associated with the Conduit *) -val default_ctx : ctx - -(** [init ?src ?tls_own_key ()] will initialize a Unix conduit - that binds to the [src] interface if specified. If TLS server - connections are used, then [tls_server_key] must contain a - valid certificate to be used to advertise a TLS connection *) -val init : - ?src:string -> - ?tls_own_key:tls_own_key -> - ?tls_server_key:tls_own_key (* Deprecated, use tls_own_key. *) -> - unit -> ctx io - -(** [connect ~ctx client] establishes an outgoing connection - via the [ctx] context to the endpoint described by [client] *) -val connect : ctx:ctx -> client -> (flow * ic * oc) io - -(** [serve ?backlog ?timeout ?stop ~on_exn ~ctx ~mode fn] - establishes a listening connection of type [mode], using the [ctx] - context. The [stop] thread will terminate the server if it ever - becomes determined. Every connection will be served in a new - lightweight thread that is invoked via the [fn] callback. The - [fn] callback is passed the {!flow} representing the client - connection and the associated input {!ic} and output {!oc} - channels. If the callback raises an exception, it is passed to - [on_exn]. *) -val serve : - ?backlog:int -> ?timeout:int -> ?stop:(unit io) -> - on_exn:(exn -> unit) -> ctx:ctx -> mode:server -> - (flow -> ic -> oc -> unit io) -> unit io - -(** [set_max_active nconn] sets the maximum number of active connections - accepted. When the limit is hit accept blocks until another server connection is closed. -*) -val set_max_active : int -> unit - -(** [endp_of_flow flow] retrieves the original {!Conduit.endp} - from the established [flow] *) -val endp_of_flow : flow -> Conduit.endp - -(** [endp_to_client ~ctx endp] converts an [endp] into a - a concrete connection mechanism of type [client] *) -val endp_to_client : ctx:ctx -> Conduit.endp -> client io - -(** [endp_to_server ~ctx endp] converts an [endp] into a - a concrete connection mechanism of type [server] *) -val endp_to_server : ctx:ctx -> Conduit.endp -> server io - -(** {2 TLS library selection} *) - -(** Currently selected method of using TLS for client and servers *) -type tls_lib = - | OpenSSL (** The [Lwt_ssl] bindings to the C OpenSSL library *) - | Native (** A pure OCaml TLS implementation *) - | No_tls (** No TLS implementation available, so any connections will fail *) - -(** The default selection is to select {!OpenSSL}, {!Native} and {!No_tls} in - decreasing order of priority. The native OCaml stack can be forced by - setting the [CONDUIT_TLS] Unix environment variable to [native]. *) -val tls_library : tls_lib ref +module Lwt_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t + +include + Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Lwt.t + and type scheduler = Conduit_lwt.scheduler + and type 'a key = ('a * Conduit_lwt.scheduler) Conduit.key + and type 'a Witness.protocol = 'a Conduit_lwt.Witness.protocol + and type 'a Witness.service = 'a Conduit_lwt.Witness.service + and type flow = Conduit_lwt.flow + +val serve_with_handler : + handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> + key:'cfg key -> + service:('master * 'flow) Witness.service -> + 'cfg -> + unit Lwt_condition.t * unit Lwt.t + +val io_of_flow : + flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml new file mode 100644 index 00000000..5842a7ac --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -0,0 +1,170 @@ +open Lwt.Infix + +let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Lwt.return err + +let reword_error f = function Ok _ as v -> v | Error err -> Error (f err) + +let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt + +type ('edn, 'flow) endpoint = { + context : Ssl.context; + endpoint : 'edn; + verify : + Ssl.context -> 'flow -> (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t; +} + +let endpoint ~file_descr ~context ?verify endpoint = + let verify = + match verify with + | Some verify -> verify + | None -> + let verify ctx flow = + let file_descr = file_descr flow in + Lwt_ssl.ssl_connect file_descr ctx >>= fun v -> Lwt.return_ok v in + verify in + { context; endpoint; verify } + +let pf = Format.fprintf + +module Protocol (Flow : Conduit_lwt_unix.PROTOCOL) = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a s = 'a Lwt.t + + type error = [ `Flow of Flow.error | `Verify of string ] + + let pp_error ppf = function + | `Flow err -> Flow.pp_error ppf err + | `Verify err -> pf ppf "%s" err + + type flow = Lwt_ssl.socket + + type nonrec endpoint = (Flow.endpoint, Flow.flow) endpoint + + let flow { context; endpoint; verify } = + Flow.flow endpoint >|= reword_error (fun err -> `Flow err) >>? fun flow -> + verify context flow >>= function + | Ok _ as v -> Lwt.return v + | Error (`Verify _ as err) -> Lwt.return (Error err) + + let recv socket raw = + let { Cstruct.buffer; off; len } = raw in + Lwt_ssl.read_bytes socket buffer off len >>= function + | 0 -> Lwt.return_ok `End_of_input + | len -> Lwt.return_ok (`Input len) + + let send socket raw = + let { Cstruct.buffer; off; len } = raw in + Lwt_ssl.write_bytes socket buffer off len >>= fun len -> Lwt.return_ok len + + let close socket = + Lwt_ssl.ssl_shutdown socket >>= fun () -> + Lwt_ssl.close socket >>= fun () -> Lwt.return_ok () +end + +let protocol_with_ssl : + type edn flow. + key:edn Conduit_lwt_unix.key -> + flow Conduit_lwt_unix.Witness.protocol -> + (edn, flow) endpoint Conduit_lwt_unix.key + * Lwt_ssl.socket Conduit_lwt_unix.Witness.protocol = + fun ~key protocol -> + match Conduit_lwt_unix.impl_of_protocol ~key protocol with + | Ok (module Flow) -> + let module M = Protocol (Flow) in + let k = + Conduit_lwt_unix.key + (Fmt.strf "%s + ssl" (Conduit_lwt_unix.name_of_key key)) in + let p = Conduit_lwt_unix.register_protocol ~key:k ~protocol:(module M) in + (k, p) + | Error _ -> + failwith "Invalid key %s with given protocol" + (Conduit_lwt_unix.name_of_key key) + +type 't master = { master : 't; context : Ssl.context } + +module Service (Service : sig + include Conduit_lwt_unix.SERVICE + + val file_descr : flow -> Lwt_unix.file_descr +end) = +struct + type +'a s = 'a Lwt.t + + type endpoint = Ssl.context * Service.endpoint + + type t = Service.t master + + type flow = Lwt_ssl.socket + + type error = [ `Service of Service.error ] + + let pp_error ppf (`Service err) = Service.pp_error ppf err + + let make (context, edn) = + Service.make edn >|= reword_error (fun err -> `Service err) + >>? fun master -> Lwt.return_ok { master; context } + + let accept { master; context } = + Service.accept master >|= reword_error (fun err -> `Service err) + >>? fun flow -> + let accept () = Lwt_ssl.ssl_accept (Service.file_descr flow) context in + let process socket = Lwt.return_ok socket in + let error exn = + Lwt_unix.close (Service.file_descr flow) >>= fun () -> Lwt.fail exn in + Lwt.try_bind accept process error + + let close { master; _ } = + Service.close master >|= reword_error (fun err -> `Service err) +end + +let service_with_ssl : + type edn t flow. + key:edn Conduit_lwt_unix.key -> + (t * flow) Conduit_lwt_unix.Witness.service -> + file_descr:(flow -> Lwt_unix.file_descr) -> + Lwt_ssl.socket Conduit_lwt_unix.Witness.protocol -> + (Ssl.context * edn) Conduit_lwt_unix.key + * (t master * Lwt_ssl.socket) Conduit_lwt_unix.Witness.service = + fun ~key service ~file_descr protocol -> + match Conduit_lwt_unix.impl_of_service ~key service with + | Ok (module S) -> + let module M = Service (struct + include S + + let file_descr = file_descr + end) in + let k = + Conduit_lwt_unix.key + (Fmt.strf "%s + ssl" (Conduit_lwt_unix.name_of_key key)) in + let s = + Conduit_lwt_unix.register_service ~key:k ~service:(module M) ~protocol + in + (k, s) + | Error _ -> + failwith "Invalid key %s with given service" + (Conduit_lwt_unix.name_of_key key) + +module TCP = struct + let resolv_conf ~port ~context ?verify domain_name = + let file_descr = Conduit_lwt_unix_tcp.Protocol.file_descr in + Conduit_lwt_unix_tcp.resolv_conf ~port domain_name >|= function + | Some edn -> Some (endpoint ~context ~file_descr ?verify edn) + | None -> None + + open Conduit_lwt_unix_tcp + + type verify = + Ssl.context -> + Protocol.flow -> + (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t + + let endpoint, protocol = protocol_with_ssl ~key:endpoint protocol + + let configuration, service = + service_with_ssl ~key:configuration service ~file_descr:Protocol.file_descr + protocol +end diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli new file mode 100644 index 00000000..69d6361b --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -0,0 +1,102 @@ +(** Implementation of the SSL support (according [Lwt_ssl]) with + [conduit-lwt-unix]. + + This implementation assumes that underlying protocol used to compose with + SSL must deliver a [Lwt_unix.file_descr] - such as [Conduit_lwt_unix_tcp]. + From that, we are able to compose your protocol with [Lwt_ssl] such as: + + {[ + let ssl_endpoint, ssl_protocol = + protocol_with_ssl ~key:TCP.endpoint TCP.protocol + + let ssl_configuration, ssl_service = + service_with_ssl ~key:TCP.configuration TCP.service + ~file_descr:TCP.file_descr ssl_protocol + ]} + + Then, TCP + SSL is available as any others [conduit] protocols or services + registered. + + {b NOTE}: [close] implementation properly closes an SSL connection with + [Ssl.ssl_shutdown] AND properly closes the underlying file-descriptor by + itself. From a given implementation of a protocol like [TCP], [TCP.close] + will never be called by the SSL layer - but the file-descriptor will be + closed. + + {b NOTE}: [verify] is called after a call to [flow] (which should do the + [connect] call). So, nothing was exchanged between you and your peer at this + time - even the handshake. *) + +open Conduit_lwt_unix + +type ('edn, 'flow) endpoint = { + context : Ssl.context; + endpoint : 'edn; + verify : + Ssl.context -> 'flow -> (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t; +} + +val endpoint : + file_descr:('flow -> Lwt_unix.file_descr) -> + context:Ssl.context -> + ?verify: + (Ssl.context -> + 'flow -> + (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t) -> + 'edn -> + ('edn, 'flow) endpoint +(** [endpoint ~file_descr ~context ?verify edn] returns an {i endpoint} needed + to initialize a SSL connection from a [Lwt.file_descr]. Even if [endpoint] + is abstracted over the type of the ['flow], we must be able to extract an + [Lwt_unix.file_descr] from it. + + [verify] is the function called just after the initialization of the + underlying ['flow]. It permits to request a verification such as the {i + hostname} with your peer. *) + +val protocol_with_ssl : + key:'edn key -> + 'flow Witness.protocol -> + ('edn, 'flow) endpoint key * Lwt_ssl.socket Witness.protocol +(** [protocol_with_ssl ~key protocol] returns a representation of the given + protocol with SSL. *) + +type 't master +(** Type of the {i master} socket. *) + +val service_with_ssl : + key:'edn key -> + ('t * 'flow) Witness.service -> + file_descr:('flow -> Lwt_unix.file_descr) -> + Lwt_ssl.socket Witness.protocol -> + (Ssl.context * 'edn) key * ('t master * Lwt_ssl.socket) Witness.service +(** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a + representation of the given service with SSL. The service deliver an SSL + flow which must be described by a [Lwt_ssl.socket Witness.protocol] (eg. + {!protocol_with_ssl}). + + [file_descr] is used to extract from the given ['flow] delivered by our + service a [Lwt_unix.file_descr] needed to create a [Lwt_ssl.socket]. *) + +module TCP : sig + open Conduit_lwt_unix_tcp + + val endpoint : (Lwt_unix.sockaddr, Protocol.flow) endpoint key + + val protocol : Lwt_ssl.socket Witness.protocol + + val configuration : (Ssl.context * configuration) key + + val service : (Service.t master * Lwt_ssl.socket) Witness.service + + type verify = + Ssl.context -> + Protocol.flow -> + (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t + + val resolv_conf : + port:int -> + context:Ssl.context -> + ?verify:verify -> + (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver +end diff --git a/lwt-unix/conduit_lwt_unix_ssl_dummy.ml b/lwt-unix/conduit_lwt_unix_ssl_dummy.ml deleted file mode 100644 index b11f8d2e..00000000 --- a/lwt-unix/conduit_lwt_unix_ssl_dummy.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -module Client = struct - let default_ctx = `Ssl_not_available - - let create_ctx ?certfile:_ ?keyfile:_ ?password:_ () = default_ctx - - let connect ?(ctx=default_ctx) ?src:_ ?hostname:_ _sa = - ignore ctx; - Lwt.fail_with "Ssl not available" -end - -module Server = struct - - let default_ctx = `Ssl_not_available - - let init ?(ctx=default_ctx) ?backlog:_ ?password:_ ~certfile:_ ~keyfile:_ ?stop:_ - ?timeout:_ _sa _cb = - ignore ctx; - Lwt.fail_with "Ssl not available" -end - -let available = false diff --git a/lwt-unix/conduit_lwt_unix_ssl_dummy.mli b/lwt-unix/conduit_lwt_unix_ssl_dummy.mli deleted file mode 100644 index 24b73b07..00000000 --- a/lwt-unix/conduit_lwt_unix_ssl_dummy.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** TLS/SSL connections via {{:http://www.openssl.org}OpenSSL} C bindings *) - -module Client : sig - val default_ctx : [`Ssl_not_available] - - val create_ctx : - ?certfile:string -> - ?keyfile:string -> - ?password:(bool -> string) -> - unit -> [`Ssl_not_available] - - val connect : - ?ctx:[`Ssl_not_available] -> - ?src:Lwt_unix.sockaddr -> - ?hostname:string -> - Lwt_unix.sockaddr -> - (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t - -end - -module Server : sig - val default_ctx : [`Ssl_not_available] - - val init - : ?ctx:[`Ssl_not_available] - -> ?backlog:int - -> ?password:(bool -> string) - -> certfile:string - -> keyfile:string - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> Lwt_unix.sockaddr - -> (Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t -end - -(**/**) - -val available : bool diff --git a/lwt-unix/conduit_lwt_unix_ssl_real.ml b/lwt-unix/conduit_lwt_unix_ssl_real.ml deleted file mode 100644 index 9aca9bb8..00000000 --- a/lwt-unix/conduit_lwt_unix_ssl_real.ml +++ /dev/null @@ -1,96 +0,0 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix - -let () = Ssl.init () - -let chans_of_fd sock = - let is_open = ref true in - let shutdown () = if !is_open then Lwt_ssl.ssl_shutdown sock else Lwt.return_unit in - let close () = is_open := false; Lwt_ssl.close sock in - let oc = Lwt_io.make ~mode:Lwt_io.output ~close:shutdown (Lwt_ssl.write_bytes sock) in - let ic = Lwt_io.make ~mode:Lwt_io.input ~close (Lwt_ssl.read_bytes sock) in - ((Lwt_ssl.get_fd sock), ic, oc) - -module Client = struct - let create_ctx ?certfile ?keyfile ?password () = - let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in - Ssl.disable_protocols ctx [Ssl.SSLv23]; - (* Use default CA certificates *) - ignore (Ssl.set_default_verify_paths ctx); - (* Enable peer verification *) - Ssl.set_verify ctx [Ssl.Verify_peer] None; - (match certfile, keyfile with - | Some certfile, Some keyfile -> Ssl.use_certificate ctx certfile keyfile - | None, _ | _, None -> ()); - (match password with - | Some password -> Ssl.set_password_callback ctx password - | None -> ()); - ctx - - let default_ctx = create_ctx () - - let connect ?(ctx=default_ctx) ?src ?hostname sa = - Conduit_lwt_server.with_socket sa (fun fd -> - (match src with - | None -> Lwt.return_unit - | Some src_sa -> Lwt_unix.bind fd src_sa - ) >>= fun () -> - Lwt_unix.connect fd sa >>= fun () -> - begin match hostname with - | Some host -> - let s = Lwt_ssl.embed_uninitialized_socket fd ctx in - let ssl = Lwt_ssl.ssl_socket_of_uninitialized_socket s in - Ssl.set_client_SNI_hostname ssl host; - (* Enable hostname verification *) - Ssl.set_hostflags ssl [Ssl.No_partial_wildcards]; - Ssl.set_host ssl host; - Lwt_ssl.ssl_perform_handshake s - | None -> - Lwt_ssl.ssl_connect fd ctx - end >>= fun sock -> - Lwt.return (chans_of_fd sock) - ) -end - -module Server = struct - - let default_ctx = Ssl.create_context Ssl.SSLv23 Ssl.Server_context - let () = Ssl.disable_protocols default_ctx [Ssl.SSLv23] - - let listen ?(ctx=default_ctx) ?backlog ?password ~certfile ~keyfile sa = - let fd = Conduit_lwt_server.listen ?backlog sa in - (match password with - | None -> () - | Some fn -> Ssl.set_password_callback ctx fn); - Ssl.use_certificate ctx certfile keyfile; - fd - - let init ?(ctx=default_ctx) ?backlog ?password ~certfile ~keyfile ?stop - ?timeout sa cb = - sa - |> listen ~ctx ?backlog ?password ~certfile ~keyfile - >>= Conduit_lwt_server.init ?stop (fun (fd, addr) -> - Lwt.try_bind (fun () -> Lwt_ssl.ssl_accept fd ctx) - (fun sock -> Lwt.return (chans_of_fd sock)) - (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn) - >>= Conduit_lwt_server.process_accept ?timeout (cb addr)) - -end - -let available = true diff --git a/lwt-unix/conduit_lwt_unix_ssl_real.mli b/lwt-unix/conduit_lwt_unix_ssl_real.mli deleted file mode 100644 index 018bc655..00000000 --- a/lwt-unix/conduit_lwt_unix_ssl_real.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* - * Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** TLS/SSL connections via {{:http://www.openssl.org}OpenSSL} C bindings *) - -module Client : sig - val default_ctx : Ssl.context - - val create_ctx : - ?certfile:string -> - ?keyfile:string -> - ?password:(bool -> string) -> - unit -> Ssl.context - - val connect : - ?ctx:Ssl.context -> - ?src:Lwt_unix.sockaddr -> - ?hostname:string -> - Lwt_unix.sockaddr -> - (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t - -end - -module Server : sig - val default_ctx : Ssl.context - - val init - : ?ctx:Ssl.context - -> ?backlog:int - -> ?password:(bool -> string) - -> certfile:string - -> keyfile:string - -> ?stop:(unit Lwt.t) - -> ?timeout:int - -> Lwt_unix.sockaddr - -> (Lwt_unix.sockaddr - -> Lwt_unix.file_descr - -> Lwt_io.input_channel - -> Lwt_io.output_channel - -> unit Lwt.t) - -> unit Lwt.t -end - -(**/**) - -val available : bool diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml new file mode 100644 index 00000000..9b48d118 --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -0,0 +1,318 @@ +open Lwt.Infix + +let pf = Format.fprintf + +let pp_sockaddr ppf = function + | Unix.ADDR_UNIX v -> pf ppf "<%s>" v + | Unix.ADDR_INET (inet_addr, port) -> + pf ppf "<%s:%d>" (Unix.string_of_inet_addr inet_addr) port + +module Protocol = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a s = 'a Lwt.t + + type endpoint = Lwt_unix.sockaddr + + type flow = { + socket : Lwt_unix.file_descr; + sockaddr : Lwt_unix.sockaddr; + linger : Bytes.t; + mutable closed : bool; + } + + let peer { sockaddr; _ } = sockaddr + + let sock { socket; _ } = Lwt_unix.getsockname socket + + let file_descr { socket; _ } = socket + + type error = + [ `Closed_by_peer + | `Operation_not_permitted + | `Address_already_in_use of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Address_family_not_supported_by_protocol of Unix.sockaddr + | `Operation_already_in_progress + | `Bad_address + | `Network_is_unreachable + | `Connection_timed_out + | `Connection_refused + | `Transport_endpoint_is_not_connected ] + + let pp_error ppf = function + | `Closed_by_peer -> pf ppf "Connection closed by peer" + | `Operation_not_permitted -> pf ppf "Operation not permitted" + | `Address_already_in_use sockaddr -> + pf ppf "Address %a already in use" pp_sockaddr sockaddr + | `Cannot_assign_requested_address sockaddr -> + pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr + | `Address_family_not_supported_by_protocol sockaddr -> + pf ppf "Address family %a not supported by protocol" pp_sockaddr + sockaddr + | `Operation_already_in_progress -> pf ppf "Operation already in progress" + | `Bad_address -> pf ppf "Bad address" + | `Network_is_unreachable -> pf ppf "Network is unreachable" + | `Connection_timed_out -> pf ppf "Connection timed out" + | `Connection_refused -> pf ppf "Connection refused" + | `Transport_endpoint_is_not_connected -> + pf ppf "Transport endpoint is not connected" + + let flow sockaddr = + let socket = + Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 + in + let linger = Bytes.create 0x1000 in + let rec go () = + let process () = + Lwt_unix.connect socket sockaddr >>= fun () -> + Lwt.return_ok { socket; sockaddr; linger; closed = false } in + Lwt.catch process @@ function + | Unix.(Unix_error ((EACCES | EPERM), _, _)) -> + Lwt.return_error `Operation_not_permitted + | Unix.(Unix_error (EADDRINUSE, _, _)) -> + Lwt.return_error (`Address_already_in_use sockaddr) + | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> + Lwt.return_error (`Cannot_assign_requested_address sockaddr) + | Unix.(Unix_error (EAFNOSUPPORT, _, _)) -> + Lwt.return_error (`Address_family_not_supported_by_protocol sockaddr) + | Unix.(Unix_error (EALREADY, _, _)) -> + Lwt.return_error `Operation_already_in_progress + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ENETUNREACH, _, _)) -> + Lwt.return_error `Network_is_unreachable + | Unix.(Unix_error (ETIMEDOUT, _, _)) -> + Lwt.return_error `Connection_timed_out + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> go () + | Unix.(Unix_error (EINTR, _, _)) -> go () + | Unix.(Unix_error (ECONNREFUSED, _, _)) -> + Lwt.return_error `Connection_refused + | exn -> Lwt.fail exn + (* | EPROTOTYPE: impossible *) + (* | EISCONN: impossible *) + (* | ENOTSOCK: impossible *) + (* | EBADF: impossible *) + (* | EINPROGRESS: TODO *) in + go () + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Lwt.return err + + (* XXX(dinosaure): [recv] wants to fill [raw] as much as possible until + it has reached [`End_of_file]. *) + let rec recv ({ socket; closed; _ } as t) raw = + if closed + then Lwt.return_ok `End_of_input + else + let process () = + let max = Cstruct.len raw in + Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) + >>= fun len -> + if len = 0 + then Lwt.return_ok `End_of_input + else ( + Cstruct.blit_from_bytes t.linger 0 raw 0 len ; + if len = Bytes.length t.linger && max > Bytes.length t.linger + then + if Lwt_unix.readable t.socket + then + recv t (Cstruct.shift raw len) >>? function + | `End_of_input -> Lwt.return_ok (`Input len) + | `Input rest -> Lwt.return_ok (`Input (len + rest)) + else Lwt.return_ok (`Input len) + else Lwt.return_ok (`Input len)) in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw + | Unix.(Unix_error (EINTR, _, _)) -> recv t raw + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ENOTCONN, _, _)) -> + Lwt.return_error `Transport_endpoint_is_not_connected + (* | Unix.(Unix_error (ECONNREFUSED, _, _)): TODO *) + (* | EBADF: impossible *) + | exn -> Lwt.fail exn + + (* XXX(dinosaure): [send] tries to send as much as it can [raw]. However, + if [send] returns something smaller that what we requested, we stop + the process and return how many byte(s) we sended. + + Try to send into a closed socket is an error. *) + let rec send ({ socket; closed; _ } as t) raw = + if closed + then Lwt.return_error `Closed_by_peer + else + let max = Cstruct.len raw in + let len0 = min (Bytes.length t.linger) max in + Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; + let process () = + Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> + if len1 = len0 + then + if max > len0 + then send t (Cstruct.shift raw len0) + else Lwt.return_ok max + else Lwt.return_ok len1 + (* worst case *) in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> send t raw + | Unix.(Unix_error (EINTR, _, _)) -> send t raw + | Unix.(Unix_error (EACCES, _, _)) -> + Lwt.return_error `Operation_not_permitted + | Unix.(Unix_error (ECONNRESET, _, _)) -> + Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; + t.closed <- true ; + Lwt.return_error `Closed_by_peer + | Unix.(Unix_error (EPIPE, _, _)) -> + Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; + t.closed <- true ; + Lwt.return_error `Closed_by_peer + | Unix.(Unix_error (EDESTADDRREQ, _, _)) + | Unix.(Unix_error (ENOTCONN, _, _)) -> + Lwt.return_error `Transport_endpoint_is_not_connected + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + (* ENOTSOCK: impossible *) + (* EISCONN: TODO *) + (* EOPNOTSUPP: TODO *) + (* ENOBUFS: TODO & impossible into Linux *) + | exn -> Lwt.fail exn + + let rec close t = + let process () = + if not t.closed + then ( + Lwt_unix.close t.socket >>= fun () -> + t.closed <- true ; + Lwt.return_ok ()) + else Lwt.return_ok () in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> close t + | Unix.(Unix_error (EINTR, _, _)) -> close t + | exn -> Lwt.fail exn +end + +type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } + +module Service = struct + type +'a s = 'a Lwt.t + + type endpoint = configuration = { + sockaddr : Lwt_unix.sockaddr; + capacity : int; + } + + type t = Lwt_unix.file_descr + + type flow = Protocol.flow + + type error = + [ `Address_is_protected of Unix.sockaddr + | `Operation_not_permitted of Unix.sockaddr + | `Address_already_in_use of Unix.sockaddr + | `Address_is_not_valid of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Bad_address + | `Too_many_symbolic_links of Unix.sockaddr + | `Name_too_long of Unix.sockaddr + | `Operation_not_supported + | `Limit_reached + | `Protocol_error + | `Firewall_rules_forbid_connection ] + + let pp_error ppf = function + | `Address_is_protected sockaddr -> + pf ppf "Address %a is protected" pp_sockaddr sockaddr + | `Operation_not_permitted sockaddr -> + pf ppf "Operation on %a is not permitted" pp_sockaddr sockaddr + | `Address_already_in_use sockaddr -> + pf ppf "Address %a already in use" pp_sockaddr sockaddr + | `Address_is_not_valid sockaddr -> + pf ppf "Address %a is not valid" pp_sockaddr sockaddr + | `Cannot_assign_requested_address sockaddr -> + pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr + | `Bad_address -> pf ppf "Bad address" + | `Too_many_symbolic_links sockaddr -> + pf ppf "Too many symbolic links on %a" pp_sockaddr sockaddr + | `Name_too_long sockaddr -> pf ppf "Name %a too long" pp_sockaddr sockaddr + | `Operation_not_supported -> pf ppf "Operation not supported" + | `Limit_reached -> pf ppf "Limit of file-descriptors reached" + | `Protocol_error -> pf ppf "Protocol error" + | `Firewall_rules_forbid_connection -> + pf ppf "Firewill rules forbid connection" + + let is_addr_inet = function + | Unix.ADDR_INET _ -> true + | Unix.ADDR_UNIX _ -> false + + let make { sockaddr; capacity } = + let socket = + Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 + in + Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true ; + let process () = + Lwt_unix.bind socket sockaddr >>= fun () -> + Lwt_unix.listen socket capacity ; + Lwt.return_ok socket in + Lwt.catch process @@ function + (* bind *) + | Unix.(Unix_error (EACCES, _, _)) when is_addr_inet sockaddr -> + Lwt.return_error (`Address_is_protected sockaddr) + | Unix.(Unix_error (EACCES, _, _)) (* when is_addr_unix sockaddr *) -> + Lwt.return_error (`Operation_not_permitted sockaddr) + | Unix.(Unix_error (EADDRINUSE, _, _)) -> + Lwt.return_error (`Address_already_in_use sockaddr) + | Unix.(Unix_error (EINVAL, _, _)) -> + Lwt.return_error (`Address_is_not_valid sockaddr) + (* | ENOTSOCK: impossible *) + | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> + Lwt.return_error (`Cannot_assign_requested_address sockaddr) + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ELOOP, _, _)) -> + Lwt.return_error (`Too_many_symbolic_links sockaddr) + | Unix.(Unix_error (ENAMETOOLONG, _, _)) -> + Lwt.return_error (`Name_too_long sockaddr) + (* listen *) + (* | Unix.(Unix_error (EADDRINUSE, _, _)) -> *) + | Unix.(Unix_error (EOPNOTSUPP, _, _)) -> + Lwt.return_error `Operation_not_supported + | exn -> Lwt.fail exn + + let rec accept master = + let process () = + Lwt_unix.accept master >>= fun (socket, sockaddr) -> + let linger = Bytes.create 0x1000 in + Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept master + | Unix.(Unix_error (EINTR, _, _)) -> accept master + | Unix.(Unix_error (EMFILE, _, _)) + | Unix.(Unix_error ((ENOBUFS | ENOMEM), _, _)) -> + Lwt.return_error `Limit_reached + | Unix.(Unix_error (EPROTOTYPE, _, _)) -> Lwt.return_error `Protocol_error + | Unix.(Unix_error (EPERM, _, _)) -> + Lwt.return_error `Firewall_rules_forbid_connection + | exn -> Lwt.fail exn + + let close _master = + (* XXX(dinosaure): it seems that on MacOS, try to close the [master] + socket raises an error. *) + Lwt.return_ok () +end + +let endpoint = Conduit_lwt.key "tcp-endpoint" + +let protocol = + Conduit_lwt.register_protocol ~key:endpoint ~protocol:(module Protocol) + +let configuration = Conduit_lwt.key "tcp-configuration" + +let service = + Conduit_lwt.register_service ~key:configuration + ~service:(module Service) + ~protocol + +let resolv_conf ~port domain_name = + Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> Lwt.return_none diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli new file mode 100644 index 00000000..1950179d --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_tcp.mli @@ -0,0 +1,77 @@ +(** Implementation of TCP protocol using [Lwt_unix]. *) + +(** Implementation of TCP protocol as a client. + + Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. + This is a description of what they currently do. + + {b NOTE}: [recv] wants to fill the given buffer as much as possible until it + has reached {i end-of-input}. In other words, [recv] can do a multiple call + to [Lwt_unix.recv] to fill the given buffer. + + {b NOTE}: [send] tries to send as much as it can the given buffer. However, + if internal call of [Lwt_unix.send] returns something smaller than what we + requested, we stop the process and return how many byte(s) we sended. In + other word, [send] can do a multiple call to [Lwt_unix.send] until we fully + sended what we wanted. *) + +open Conduit_lwt_unix + +module Protocol : sig + include + PROTOCOL + with type endpoint = Lwt_unix.sockaddr + and type error = + [ `Closed_by_peer + | `Operation_not_permitted + | `Address_already_in_use of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Address_family_not_supported_by_protocol of Unix.sockaddr + | `Operation_already_in_progress + | `Bad_address + | `Network_is_unreachable + | `Connection_timed_out + | `Connection_refused + | `Transport_endpoint_is_not_connected ] + + val file_descr : flow -> Lwt_unix.file_descr + (** [file_descr] returns the underlying [Lwt_unix.file_descr] used to + communicate over TCP. *) + + val peer : flow -> Unix.sockaddr + (** [peer flow] retunrs the address of the peer connected to the given [flow]. *) + + val sock : flow -> Unix.sockaddr + (** [sock flow] returns the current addres to which the socket is bound. *) +end + +type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } + +module Service : + SERVICE + with type endpoint = configuration + and type t = Lwt_unix.file_descr + and type flow = Protocol.flow + and type error = + [ `Address_is_protected of Unix.sockaddr + | `Operation_not_permitted of Unix.sockaddr + | `Address_already_in_use of Unix.sockaddr + | `Address_is_not_valid of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Bad_address + | `Too_many_symbolic_links of Unix.sockaddr + | `Name_too_long of Unix.sockaddr + | `Operation_not_supported + | `Limit_reached + | `Protocol_error + | `Firewall_rules_forbid_connection ] + +val endpoint : Lwt_unix.sockaddr key + +val protocol : Protocol.flow Witness.protocol + +val configuration : configuration key + +val service : (Service.t * Protocol.flow) Witness.service + +val resolv_conf : port:int -> Lwt_unix.sockaddr resolver diff --git a/lwt-unix/conduit_lwt_unix_tls.ml b/lwt-unix/conduit_lwt_unix_tls.ml new file mode 100644 index 00000000..cad4d23a --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_tls.ml @@ -0,0 +1,16 @@ +include Conduit_tls.Make (Conduit_lwt.Lwt_scheduler) (Conduit_lwt) + +module TCP = struct + open Conduit_lwt_unix_tcp + + let endpoint, protocol = protocol_with_tls ~key:endpoint protocol + + let configuration, service = + service_with_tls ~key:configuration service protocol + + let resolv_conf ~port ~config domain_name = + let open Lwt.Infix in + resolv_conf ~port domain_name >|= function + | Some edn -> Some (edn, config) + | None -> None +end diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt-unix/conduit_lwt_unix_tls.mli new file mode 100644 index 00000000..c57d1b62 --- /dev/null +++ b/lwt-unix/conduit_lwt_unix_tls.mli @@ -0,0 +1,52 @@ +(** Implementation of the TLS support (according [ocaml-tls]) with + [conduit-lwt-unix]. + + This implementation is a {i specialization} of [conduit-tls] with + [conduit-lwt-unix]. Underlying protocol or service can be anything into the + scope of [conduit-lwt]/[conduit-lwt-unix]. + + For more details about behaviours, you should look into [conduit-tls]. *) + +open Conduit_lwt_unix + +type 'flow protocol_with_tls + +val underlying : 'flow protocol_with_tls -> 'flow +(** [underlying tls_flow] returns the underlying [flow] used with TLS. *) + +val handshake : 'flow protocol_with_tls -> bool +(** [handshake flow] returns [true] if the handshake is processing. Otherwise, + it returns [false]. *) + +val protocol_with_tls : + key:'edn key -> + 'flow Witness.protocol -> + ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + +type 'service service_with_tls + +val service_with_tls : + key:'edn key -> + ('t * 'flow) Witness.service -> + 'flow protocol_with_tls Witness.protocol -> + ('edn * Tls.Config.server) key + * ('t service_with_tls * 'flow protocol_with_tls) Witness.service + +module TCP : sig + open Conduit_lwt_unix_tcp + + val endpoint : (Lwt_unix.sockaddr * Tls.Config.client) key + + val protocol : Protocol.flow protocol_with_tls Witness.protocol + + val configuration : (configuration * Tls.Config.server) key + + val service : + (Service.t service_with_tls * Protocol.flow protocol_with_tls) + Witness.service + + val resolv_conf : + port:int -> + config:Tls.Config.client -> + (Lwt_unix.sockaddr * Tls.Config.client) resolver +end diff --git a/lwt-unix/dune b/lwt-unix/dune index 3e64fd7c..11984328 100644 --- a/lwt-unix/dune +++ b/lwt-unix/dune @@ -1,18 +1,23 @@ (library - (name conduit_lwt_unix) - (public_name conduit-lwt-unix) - (preprocess (pps ppx_sexp_conv)) - (wrapped false) - (modules resolver_lwt_unix conduit_lwt_unix conduit_lwt_server - conduit_lwt_tls conduit_lwt_unix_ssl conduit_lwt_launchd) - (libraries conduit-lwt lwt.unix uri.services ipaddr-sexp ipaddr.unix logs - (select conduit_lwt_launchd.ml from - (launchd.lwt -> conduit_lwt_launchd_real.ml) - (-> conduit_lwt_launchd_dummy.ml)) - (select conduit_lwt_unix_ssl.ml from - (lwt_ssl -> conduit_lwt_unix_ssl_real.ml) - (-> conduit_lwt_unix_ssl_dummy.ml)) - (select conduit_lwt_tls.ml from - (tls.lwt -> conduit_lwt_tls_real.ml) - (-> conduit_lwt_tls_dummy.ml)) - )) + (name conduit_lwt_unix) + (public_name conduit-lwt-unix) + (modules conduit_lwt_unix) + (libraries conduit-lwt lwt.unix)) + +(library + (name conduit_lwt_unix_tcp) + (public_name conduit-lwt-unix.tcp) + (modules conduit_lwt_unix_tcp) + (libraries conduit-lwt-unix)) + +(library + (name conduit_lwt_unix_tls) + (public_name conduit-lwt-unix.tls) + (modules conduit_lwt_unix_tls) + (libraries conduit-lwt-unix conduit-lwt-unix.tcp conduit-tls)) + +(library + (name conduit_lwt_unix_ssl) + (public_name conduit-lwt-unix.ssl) + (modules conduit_lwt_unix_ssl) + (libraries conduit-lwt-unix conduit-lwt-unix.tcp lwt_ssl)) diff --git a/lwt-unix/resolver_lwt_unix.ml b/lwt-unix/resolver_lwt_unix.ml deleted file mode 100644 index 9e108e1f..00000000 --- a/lwt-unix/resolver_lwt_unix.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix - -let debug = ref false -let debug_print = ref Printf.eprintf -let () = - try - ignore(Sys.getenv "CONDUIT_DEBUG"); - debug := true - with Not_found -> () - -let return_endp name svc uri endp = - if !debug then - !debug_print "Resolver %s: %s %s -> %s\n%!" - name (Uri.to_string uri) - (Sexplib.Sexp.to_string_hum (Resolver.sexp_of_service svc)) - (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp)); - Lwt.return endp - -let is_tls_service = - (* TODO fill in the blanks. nowhere else to get this information *) - function - | "https" | "imaps" -> true - | _ -> false - -let system_service name = - (* TODO memoize *) - Lwt.catch - (fun () -> - Lwt_unix.getservbyname name "tcp" >>= fun s -> - let tls = is_tls_service name in - let svc = { Resolver.name; port=s.Lwt_unix.s_port; tls } in - Lwt.return (Some svc)) - (function Not_found -> Lwt.return_none | e -> Lwt.fail e) - -let static_service name = - match Uri_services.tcp_port_of_service name with - | [] -> Lwt.return_none - | port::_ -> - let tls = is_tls_service name in - let svc = { Resolver.name; port; tls } in - Lwt.return (Some svc) - -let get_host uri = - match Uri.host uri with - | None -> "localhost" - | Some host -> - match Ipaddr.of_string host with - | Ok ip -> Ipaddr.to_string ip - | Error _ -> host - -let get_port service uri = - match Uri.port uri with - | None -> service.Resolver.port - | Some port -> port - -(* Build a default resolver that uses the system gethostbyname and - the /etc/services file *) -let system_resolver service uri = - let open Lwt_unix in - let host = get_host uri in - let port = get_port service uri in - getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] - >>= fun addrinfos -> - (* In case both IPv4 and IPv6 addresses exist, favor IPv4: *) - let v4, rest = List.partition (fun i -> i.ai_family = PF_INET) addrinfos in - match List.rev_append v4 rest with - | [] -> return_endp "system" service uri (`Unknown ("name resolution failed")) - | {ai_addr=ADDR_INET (addr,port);_}::_ -> - return_endp "system" service uri - (`TCP (Ipaddr_unix.of_inet_addr addr, port)) - | {ai_addr=ADDR_UNIX file;_}::_ -> - return_endp "system" service uri (`Unix_domain_socket file) - -let static_resolver hosts service uri = - try - return_endp "static" service uri (Hashtbl.find hosts (get_host uri)) - with Not_found -> - return_endp "static" service uri (`Unknown ("name resolution failed")) - -let system = - let service = system_service in - let rewrites = ["", system_resolver] in - Resolver_lwt.init ~service ~rewrites () - -(* Build a default resolver from a static set of lookup rules *) -let static hosts = - let service = static_service in - let rewrites = ["", static_resolver hosts] in - Resolver_lwt.init ~service ~rewrites () diff --git a/lwt-unix/resolver_lwt_unix.mli b/lwt-unix/resolver_lwt_unix.mli deleted file mode 100644 index 005d8260..00000000 --- a/lwt-unix/resolver_lwt_unix.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Resolve URIs to endpoints using Unix system calls *) - -(** {2 Prebuilt resolvers} *) - -(** Use the Unix system name resolver via [getaddrinfo] and - [getservbyname] *) -val system : Resolver_lwt.t - -(** [static hosts] constructs a resolver that looks up any resolution - requests from the static [hosts] hashtable instead of using the - system resolver. *) -val static : (string, Conduit.endp) Hashtbl.t -> Resolver_lwt.t - -(** {2 Rewrite and service functions} - These can be used to assemble your own resolvers if the - prebuilt ones are not quite what you need. *) - -(** Perform service lookup using [getservbyname] *) -val system_service : string -> Resolver_lwt.svc option Lwt.t - -(** Perform service lookup using the builtin {!Uri_services} module *) -val static_service : string -> Resolver_lwt.svc option Lwt.t - -(** Rewrite function that uses the {!system_service} and {!static_service} - to resolve hosts *) -val system_resolver : Resolver_lwt.rewrite_fn - -(** {2 Debugging Hooks} *) - -(** If [debug] is true, the builtin resolvers will output their - resolution responses via the {!debug_print} function. The default - value of [debug] is true if the [CONDUIT_DEBUG] environment variable - is set, and false otherwise. *) -val debug : bool ref - -(** [debug_print] is called by the {!debug} functions to output the - results of resolution. Defaults to {!Printf.eprintf} to go to - the standard error. *) -val debug_print : - ((string -> string -> string -> string -> unit, out_channel, unit) - format -> string -> string -> string -> string -> unit) ref From 8c44f503cb7bee4acc30173008b46abbdcdb0240 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:46:43 +0200 Subject: [PATCH 009/140] New implementation of conduit-mirage with tcp/ip and tls layers `conduit-lwt` with the tcp/ip stack provided by `mirage` and a composition of it with the TLS layer provided by `conduit-tls`. It exposes a `mirage-flow` implementation as `conduit-lwt` (deprecated). --- mirage/conduit_mirage.ml | 350 +-------------------------------- mirage/conduit_mirage.mli | 162 ++------------- mirage/conduit_mirage_flow.ml | 1 + mirage/conduit_mirage_flow.mli | 18 ++ mirage/conduit_mirage_tcp.ml | 282 ++++++++++++++++++++++++++ mirage/conduit_mirage_tcp.mli | 32 +++ mirage/conduit_mirage_tls.ml | 1 + mirage/conduit_mirage_tls.mli | 21 ++ mirage/conduit_xenstore.ml | 99 ---------- mirage/conduit_xenstore.mli | 27 --- mirage/dune | 30 ++- mirage/resolver_mirage.ml | 126 ------------ mirage/resolver_mirage.mli | 42 ---- 13 files changed, 398 insertions(+), 793 deletions(-) create mode 100644 mirage/conduit_mirage_flow.ml create mode 100644 mirage/conduit_mirage_flow.mli create mode 100644 mirage/conduit_mirage_tcp.ml create mode 100644 mirage/conduit_mirage_tcp.mli create mode 100644 mirage/conduit_mirage_tls.ml create mode 100644 mirage/conduit_mirage_tls.mli delete mode 100644 mirage/conduit_xenstore.ml delete mode 100644 mirage/conduit_xenstore.mli delete mode 100644 mirage/resolver_mirage.ml delete mode 100644 mirage/resolver_mirage.mli diff --git a/mirage/conduit_mirage.ml b/mirage/conduit_mirage.ml index b9db6b34..468754f3 100644 --- a/mirage/conduit_mirage.ml +++ b/mirage/conduit_mirage.ml @@ -1,348 +1,2 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * Copyright (c) 2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Sexplib.Conv - -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) - -let fail fmt = Fmt.kstrf (fun s -> Lwt.fail (Failure s)) fmt -let err_tcp_not_supported = fail "%s: TCP is not supported" -let err_tls_not_supported = fail "%s: TLS is not supported" -let err_domain_sockets_not_supported = - fail "%s: Unix domain sockets are not supported inside Unikernels" -let err_vchan_not_supported = fail "%s: VCHAN is not supported" -let err_unknown = fail "%s: unknown endpoint type" -let err_ipv6 = fail "%s: IPv6 is not supported" - -module Flow = struct - type error = [`Msg of string] - type write_error = [ Mirage_flow.write_error | error ] - - let pp_error ppf (`Msg s) = Fmt.string ppf s - - let pp_write_error ppf = function - | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e - | #error as e -> pp_error ppf e - - open Mirage_flow_combinators - - type flow = Flow: (module CONCRETE with type flow = 'a) * 'a -> flow - - let create (type a) (module M: Mirage_flow.S with type flow = a) t = - let m = (module Concrete(M): CONCRETE with type flow = a) in - Flow (m , t) - - let read (Flow ((module F), flow)) = F.read flow - let write (Flow ((module F), flow)) b = F.write flow b - let writev (Flow ((module F), flow)) b = F.writev flow b - let close (Flow ((module F), flow)) = F.close flow -end - -type callback = Flow.flow -> unit Lwt.t - -module type Handler = sig - (** Runtime handler *) - type t - type client [@@deriving sexp] - type server [@@deriving sexp] - val connect: t -> client -> Flow.flow Lwt.t - val listen: t -> server -> callback -> unit Lwt.t -end - -type tcp_client = [ `TCP of Ipaddr_sexp.t * int ] [@@deriving sexp] -type tcp_server = [ `TCP of int ] [@@deriving sexp] - -type 'a stackv4 = (module Mirage_stack.V4 with type t = 'a) -let stackv4 x = x - -module type VCHAN = Vchan.S.ENDPOINT with type port = Vchan.Port.t -module type XS = Xs_client_lwt.S - -type vchan_client = [ - | `Vchan of [ - | `Direct of int * Vchan.Port.t (** domain id, port *) - | `Domain_socket of string * Vchan.Port.t (** Vchan Xen domain socket *) - ] -] [@@deriving sexp] - -type vchan_server = [ - | `Vchan of [ - | `Direct of int * Vchan.Port.t (** domain id, port *) - | `Domain_socket (** Vchan Xen domain socket *) - ] -] [@@deriving sexp] - -type vchan = (module VCHAN) -type xs = (module XS) - -let vchan x = x -let xs x = x - -type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] [@@deriving sexp] -type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] [@@deriving sexp] - -type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp] -type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp] - -type tls_client' = client tls_client [@@deriving sexp] -type tls_server' = server tls_server [@@deriving sexp] - -type ('c, 's) handler = - S: (module Handler with type t = 'a and type client = 'c and type server = 's) - * 'a -> ('c, 's) handler - -let tcp_client i p = Lwt.return (`TCP (i, p)) -let tcp_server _ p = Lwt.return (`TCP p) - -type t = { - tcp : (tcp_client , tcp_server ) handler option; - tls : (tls_client' , tls_server' ) handler option; - vchan: (vchan_client, vchan_server) handler option; -} - -let empty = { tcp = None; tls = None; vchan = None } - -let connect t (c:client) = match c with - | `TCP _ as x -> - begin match t.tcp with - | None -> err_tcp_not_supported "connect" - | Some (S ((module S), t)) -> S.connect t x - end - | `Vchan _ as x -> - begin match t.vchan with - | None -> err_vchan_not_supported "connect" - | Some (S ((module S), t)) -> S.connect t x - end - | `TLS _ as x -> - begin match t.tls with - | None -> err_tls_not_supported "connect" - | Some (S ((module S), t)) -> S.connect t x - end - -let listen t (s:server) f = match s with - | `TCP _ as x -> - begin match t.tcp with - | None -> err_tcp_not_supported "listen" - | Some (S ((module S), t)) -> S.listen t x f - end - | `Vchan _ as x -> - begin match t.vchan with - | None -> err_vchan_not_supported "listen"; - | Some (S ((module S), t)) -> S.listen t x f - end - | `TLS _ as x -> - begin match t.tls with - | None -> err_tls_not_supported "listen" - | Some (S ((module S), t)) -> S.listen t x f - end - -(******************************************************************************) -(* Implementation of handlers *) -(******************************************************************************) - -(* TCP *) - -module TCP (S: Mirage_stack.V4) = struct - - type t = S.t - type client = tcp_client [@@deriving sexp] - type server = tcp_server [@@deriving sexp] - let err_tcp e = Lwt.fail @@ Failure - (Format.asprintf "TCP connection failed: %a" S.TCPV4.pp_error e) - - let connect t (`TCP (ip, port): client) = - match Ipaddr.to_v4 ip with - | None -> err_ipv6 "connect" - | Some ip -> - S.TCPV4.create_connection (S.tcpv4 t) (ip, port) >>= function - | Error e -> err_tcp e - | Ok flow -> - let flow = Flow.create (module S.TCPV4) flow in - Lwt.return flow - - let listen t (`TCP port: server) fn = - let s, _u = Lwt.task () in - S.listen_tcpv4 t ~port (fun flow -> - let f = Flow.create (module S.TCPV4) flow in - fn f - ); - s - -end - -module With_tcp(S : Mirage_stack.V4) = struct - module M = TCP(S) - let handler stack = Lwt.return (S ((module M),stack)) - let connect stack t = handler stack >|= fun x -> { t with tcp = Some x } -end - -let with_tcp (type t) t (module S: Mirage_stack.V4 with type t = t) stack = - let module M = With_tcp(S) in - M.connect stack t - -(* VCHAN *) - -let err_vchan_port = fail "%s: invalid Vchan port" - -let port p = - match Vchan.Port.of_string p with - | Error (`Msg s) -> err_vchan_port s - | Ok p -> Lwt.return p - -let vchan_client = function - | `Vchan_direct (i, p) -> port p >|= fun p -> `Vchan (`Direct (i, p)) - | `Vchan_domain_socket (i, p) -> - port p >|= fun p -> `Vchan (`Domain_socket (i, p)) - -let vchan_server = function - | `Vchan_direct (i, p) -> port p >|= fun p -> `Vchan (`Direct (i, p)) - | `Vchan_domain_socket _-> Lwt.return (`Vchan `Domain_socket) - -module Vchan (Xs: Xs_client_lwt.S) (V: VCHAN) = struct - - module XS = Conduit_xenstore.Make(Xs) - - type t = XS.t - type client = vchan_client [@@deriving sexp] - type server = vchan_server [@@deriving sexp] - - let register = XS.register - - let rec connect t (c:vchan_client) = match c with - | `Vchan (`Domain_socket (uid, port)) -> - XS.connect t ~remote_name:uid ~port >>= fun endp -> - connect t (`Vchan endp :> vchan_client) - | `Vchan (`Direct (domid, port)) -> - V.client ~domid ~port () >>= fun flow -> - Lwt.return (Flow.create (module V) flow) - - let listen (t:t) (server:vchan_server) fn = match server with - | `Vchan (`Direct (domid, port)) -> - V.server ~domid ~port () >>= fun t -> - fn (Flow.create (module V) t) - | `Vchan `Domain_socket -> - XS.listen t >>= fun conns -> - Lwt_stream.iter_p (function - | `Direct (domid, port) -> - V.server ~domid ~port () >>= fun t -> - fn (Flow.create (module V) t) - ) conns - -end - -let mk_vchan (module X: XS) (module V: VCHAN) t = - let module V = Vchan(X)(V) in - V.register t >|= fun t -> - S ((module V), t) - -let with_vchan t x y z = mk_vchan x y z >|= fun x -> { t with vchan = Some x } - -(* TLS *) - -let client_of_bytes _ = - (* an https:// request doesn't need client-side authentication *) - let authenticator ~host:_ _ = Ok None in - Tls.Config.client ~authenticator () - -let server_of_bytes str = Tls.Config.server_of_sexp (Sexplib.Sexp.of_string str) - -let tls_client c x = Lwt.return (`TLS (client_of_bytes c, x)) -let tls_server s x = Lwt.return (`TLS (server_of_bytes s, x)) - -module TLS = struct - - module TLS = Tls_mirage.Make(Flow) - let err_flow_write m e = fail "%s: %a" m TLS.pp_write_error e - - type x = t - type t = x - - type client = tls_client' [@@deriving sexp] - type server = tls_server' [@@deriving sexp] - - let connect (t:t) (`TLS (c, x): client) = - connect t x >>= fun flow -> - TLS.client_of_flow c flow >>= function - | Error e -> err_flow_write "connect" e - | Ok flow -> Lwt.return (Flow.create (module TLS) flow) - - let listen (t:t) (`TLS (c, x): server) fn = - listen t x (fun flow -> - TLS.server_of_flow c flow >>= function - | Error e -> err_flow_write "listen" e - | Ok flow -> fn (Flow.create (module TLS) flow) - ) - -end - -let tls t = Lwt.return (S ( (module TLS), t)) - -let with_tls t = tls t >|= fun x -> { t with tls = Some x } - -type conduit = t - -module type S = sig - type t = conduit - val empty: t - module With_tcp (S:Mirage_stack.V4) : sig - val connect : S.t -> t -> t Lwt.t - end - val with_tcp: t -> 'a stackv4 -> 'a -> t Lwt.t - val with_tls: t -> t Lwt.t - val with_vchan: t -> xs -> vchan -> string -> t Lwt.t - val connect: t -> client -> Flow.flow Lwt.t - val listen: t -> server -> callback -> unit Lwt.t -end - -let rec client (e:Conduit.endp): client Lwt.t = match e with - | `TCP (x, y) -> tcp_client x y - | `Unix_domain_socket _ -> err_domain_sockets_not_supported "client" - | `Vchan_direct _ - | `Vchan_domain_socket _ as x -> vchan_client x - | `TLS (x, y) -> client y >>= fun c -> tls_client x c - | `Unknown s -> err_unknown s - -let rec server (e:Conduit.endp): server Lwt.t = match e with - | `TCP (x, y) -> tcp_server x y - | `Unix_domain_socket _ -> err_domain_sockets_not_supported "server" - | `Vchan_direct _ - | `Vchan_domain_socket _ as x -> vchan_server x - | `TLS (x, y) -> server y >>= fun s -> tls_server x s - | `Unknown s -> err_unknown s - -module Context (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK) (S: Mirage_stack.V4) = struct - - type t = Resolver_lwt.t * conduit - - module RES = Resolver_mirage.Make_with_stack(R)(T)(C)(S) - - let conduit = empty - let stackv4 = stackv4 (module S: Mirage_stack.V4 with type t = S.t) - - let create ?(tls=false) stack = - let res = Resolver_lwt.init () in - RES.R.register ~stack res; - with_tcp conduit stackv4 stack >>= fun conduit -> - if tls then - with_tls conduit >|= fun conduit -> - res, conduit - else - Lwt.return (res, conduit) - -end +module Mirage_scheduler = Conduit_lwt.Lwt_scheduler +include Conduit_lwt diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 1774eb86..e4047a7d 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -1,143 +1,19 @@ -(* - * Copyright (c) 2012-2015 Anil Madhavapeddy - * Copyright (c) 2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Functorial connection establishment interface that is compatible with - the Mirage libraries. - *) - -module Flow: Mirage_flow.S -(** Dynamic flows. *) - -type callback = Flow.flow -> unit Lwt.t -(** The type for callback values. *) - -module type Handler = sig - (** The signature for runtime handlers *) - - type t - (** The type for runtime handlers. *) - - type client [@@deriving sexp] - (** The type for client configuration values. *) - - type server [@@deriving sexp] - (** The type for server configuration values. *) - - val connect: t -> client -> Flow.flow Lwt.t - (** Connect a conduit using client configuration. *) - - val listen: t -> server -> callback -> unit Lwt.t - (** Listen to a conduit using a server configuration. *) - -end - -(** {2 TCP} *) - -(** The type for client connections. *) - -type tcp_client = [ `TCP of Ipaddr.t * int ] (** address and destination port *) -and tcp_server = [ `TCP of int ] (** listening port *) - -type 'a stackv4 -val stackv4: (module Mirage_stack.V4 with type t = 'a) -> 'a stackv4 - -(** {2 VCHAN} *) - -type vchan_client = [ - | `Vchan of [ - | `Direct of int * Vchan.Port.t (** domain id, port *) - | `Domain_socket of string * Vchan.Port.t (** Vchan Xen domain socket *) - ]] - -type vchan_server = [ - | `Vchan of [ - | `Direct of int * Vchan.Port.t (** domain id, port *) - | `Domain_socket (** Vchan Xen domain socket *) - ]] - -module type VCHAN = Vchan.S.ENDPOINT with type port = Vchan.Port.t -module type XS = Xs_client_lwt.S - -type vchan -type xs - -val vchan: (module VCHAN) -> vchan -val xs: (module XS) -> xs - -(** {2 TLS} *) - -type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] -type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] - -type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp] -(** The type for client configuration values. *) - -type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp] -(** The type for server configuration values. *) - -val client: Conduit.endp -> client Lwt.t -(** Resolve a conduit endpoint into a client configuration. *) - -val server: Conduit.endp -> server Lwt.t -(** Resolve a confuit endpoint into a server configuration. *) - -type conduit -(** The type for conduit values. *) - -module type S = sig - (** The signature for Conduit implementations. *) - - type t = conduit - - val empty: t - (** The empty conduit. *) - - module With_tcp (S:Mirage_stack.V4) : sig - val connect : S.t -> t -> t Lwt.t - end - - val with_tcp: t -> 'a stackv4 -> 'a -> t Lwt.t - (** Extend a conduit with an implementation for TCP. *) - - val with_tls: t -> t Lwt.t - (** Extend a conduit with an implementation for TLS. *) - - val with_vchan: t -> xs -> vchan -> string -> t Lwt.t - (** Extend a conduit with an implementation for VCHAN. *) - - val connect: t -> client -> Flow.flow Lwt.t - (** Connect a conduit using a client configuration value. *) - - val listen: t -> server -> callback -> unit Lwt.t - (** Configure a server using a conduit configuration value. *) - -end - -include S - -(** {2 Context for MirageOS conduit resolvers} *) -module Context (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK) (S: Mirage_stack.V4): sig - - type t = Resolver_lwt.t * conduit - (** The type for contexts of conduit resolvers. *) - - val create: ?tls:bool -> S.t -> t Lwt.t - (** Create a new context. If [tls] is specified (by defaut, it is not), - set-up the conduit to accept TLS connections. *) - -end +module Mirage_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t + +include + Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Lwt.t + and type scheduler = Conduit_lwt.scheduler + and type 'a key = ('a * Conduit_lwt.scheduler) Conduit.key + and type 'a Witness.protocol = 'a Conduit_lwt.Witness.protocol + and type 'a Witness.service = 'a Conduit_lwt.Witness.service + and type flow = Conduit_lwt.flow + +val serve_with_handler : + handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> + key:'cfg key -> + service:('master * 'flow) Witness.service -> + 'cfg -> + unit Lwt_condition.t * unit Lwt.t diff --git a/mirage/conduit_mirage_flow.ml b/mirage/conduit_mirage_flow.ml new file mode 100644 index 00000000..65ff904a --- /dev/null +++ b/mirage/conduit_mirage_flow.ml @@ -0,0 +1 @@ +include Conduit_lwt_flow diff --git a/mirage/conduit_mirage_flow.mli b/mirage/conduit_mirage_flow.mli new file mode 100644 index 00000000..1135b37d --- /dev/null +++ b/mirage/conduit_mirage_flow.mli @@ -0,0 +1,18 @@ +(** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. + This module is deprecated when the current implementation of [read] has + another behaviour: + + [conduit] provides: + + {[ val read : flow -> Cstruct.t -> (int or_eoi, error) result Lwt.t ]} + + where [mirage-flow] expects: + + {[ val read : flow -> (Cstruct.t or_eoi, error) result Lwt.t ]} + + This current implementation allocates an {b arbitrary} 4096 bytes buffer to + fit under the [mirage-flow] interface. [conduit] did the choice to follow + the POSIX interface and let the end-user to allocate by himself the input + buffer. *) + +include Mirage_flow.S with type flow = Conduit_mirage.flow diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml new file mode 100644 index 00000000..06e4f6a9 --- /dev/null +++ b/mirage/conduit_mirage_tcp.ml @@ -0,0 +1,282 @@ +module Ke = Ke.Rke.Weighted + +type ('stack, 'ip) endpoint = { + stack : 'stack; + keepalive : Mirage_protocols.Keepalive.t option; + nodelay : bool; + ip : 'ip; + port : int; +} + +type 'stack configuration = { + stack : 'stack; + keepalive : Mirage_protocols.Keepalive.t option; + nodelay : bool; + port : int; +} + +module Make (StackV4 : Mirage_stack.V4) = struct + open Rresult + open Lwt.Infix + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> Lwt.return (Error err) + + let src = Logs.Src.create "tuyau-mirage-tcpip" + + module Log = (val Logs.src_log src : Logs.LOG) + + type protocol = { + flow : StackV4.TCPV4.flow; + nodelay : bool; + queue : (char, Bigarray.int8_unsigned_elt) Ke.t; + mutable closed : bool; + } + + let dst { flow; _ } = StackV4.TCPV4.dst flow + + type nonrec endpoint = (StackV4.t, Ipaddr.V4.t) endpoint + + module Protocol = struct + type input = Conduit_mirage.input + + type output = Conduit_mirage.output + + type +'a s = 'a Conduit_mirage.s + + type error = + | Input_too_large + | TCP_error of StackV4.TCPV4.error + | Write_error of StackV4.TCPV4.write_error + | Exn of exn + (* XXX(dinosaure): it appears that [Tcpip_stack_socket] can raise + exception. We should handle them and consider our fd ressource + as close. *) + | Closed_by_peer + + let pp_error ppf = function + | Input_too_large -> Fmt.string ppf "Input too large" + | TCP_error err -> StackV4.TCPV4.pp_error ppf err + | Write_error err -> StackV4.TCPV4.pp_write_error ppf err + | Exn exn -> Fmt.pf ppf "Exception: %s" (Printexc.to_string exn) + | Closed_by_peer -> Fmt.pf ppf "Closed by peer" + + let error : StackV4.TCPV4.error -> error = fun err -> TCP_error err + + let write_error : StackV4.TCPV4.write_error -> error = + fun err -> Write_error err + + type flow = protocol = { + flow : StackV4.TCPV4.flow; + nodelay : bool; + queue : (char, Bigarray.int8_unsigned_elt) Ke.t; + mutable closed : bool; + } + + type nonrec endpoint = endpoint + + let flow { stack; keepalive; nodelay; ip; port } = + let tcpv4 = StackV4.tcpv4 stack in + StackV4.TCPV4.create_connection tcpv4 ?keepalive (ip, port) + >|= R.reword_error error + >>? fun flow -> + let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in + Lwt.return (Ok { flow; nodelay; queue; closed = false }) + + let length = Cstruct.len + + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len + + let recv t raw = + match Ke.N.peek t.queue with + | [] -> + if not t.closed + then ( + Log.debug (fun m -> m "<- Read the TCP flow.") + (* XXX(dinosaure): with [Tcpip_stack_socket], [read] can raise [Lwt.Canceled] + if the ressource take a time (a [Timeout] is returned by [select]). To prevent + that, we decide to protect [StackV4.TCPV4.read] with [Lwt.no_cancel]. *) ; + Lwt.catch + (fun () -> + Lwt.no_cancel (StackV4.TCPV4.read t.flow) + >|= R.reword_error error) + (fun exn -> Lwt.return_error (Exn exn)) + >>= function + | Error err as v -> + Log.err (fun m -> + m "Got an error while reading: %a" pp_error err) ; + t.closed <- true ; + Lwt.return v + | Ok `Eof -> + t.closed <- true ; + Log.debug (fun m -> m "<- End of input.") ; + Lwt.return (Ok `End_of_input) + | Ok (`Data buf) -> + Log.debug (fun m -> m "<- Got %d byte(s)." (Cstruct.len buf)) ; + (* XXX(dinosaure): [telnet] send '\004' (End Of Transmission) to ask + the service to close the connection. [mirage-tcpip] does not handle + this _opcode_ so we handle it in this place. *) + if Cstruct.len buf = 1 && Cstruct.get_char buf 0 = '\004' + then ( + StackV4.TCPV4.close t.flow >>= fun () -> + Log.debug (fun m -> m "<- End of input (end of transmission)") ; + Lwt.return (Ok `End_of_input)) + else + let max_buf = Cstruct.len buf in + let max_raw = Cstruct.len raw in + if max_buf <= max_raw + then ( + Cstruct.blit buf 0 raw 0 max_buf ; + Lwt.return (Ok (`Input max_buf))) + else ( + Cstruct.blit buf 0 raw 0 max_raw ; + let len = min (max_buf - max_raw) (Ke.available t.queue) in + Log.debug (fun m -> m "<- Save %d into the queue." len) ; + let _ = + Ke.N.push_exn ~blit ~length ~off:max_raw ~len t.queue buf + in + if len = max_buf - max_raw + then Lwt.return (Ok (`Input max_raw)) + else Lwt.return (Error Input_too_large))) + else Lwt.return_ok `End_of_input + | lst -> + let rec go consumed raw = function + | [] -> + Log.debug (fun m -> m "<- Shift %d bytes." consumed) ; + Ke.N.shift_exn t.queue consumed ; + + (* XXX(dinosaure): it's important to return what we can instead + to fill [raw] as much as we can. Into details, it's pretty close to the TLS + stack when [Tls.Engine.state] expects to terminate the handshake as soon as + possible. In this case, pending payload can serve the end of the handshake + and ask then to [Tls.Engine.state] to send something and go to the next + action (according the underlying server logic) when the client side, at + this step expect to read some bytes. *) + Lwt.return (Ok (`Input consumed)) + | x :: r -> + let x = Cstruct.of_bigarray x in + let len = min (Cstruct.len x) (Cstruct.len raw) in + Cstruct.blit x 0 raw 0 len ; + if len = Cstruct.len raw + then ( + Log.debug (fun m -> m "<- Shift %d bytes." (consumed + len)) ; + Ke.N.shift_exn t.queue (consumed + len) ; + Lwt.return (Ok (`Input (consumed + len)))) + else go (consumed + len) (Cstruct.shift raw len) r in + go 0 raw lst + + let send t raw = + (* XXX(dinosaure): with [Tcpip_stack_socket], protect against SIGPIPE. *) + if t.closed + then Lwt.return_error Closed_by_peer + else ( + Log.debug (fun m -> m "-> Start to write %d byte(s)." (Cstruct.len raw)) ; + let send flow raw = + if t.nodelay + then StackV4.TCPV4.write_nodelay flow raw + else StackV4.TCPV4.write flow raw in + Lwt.catch + (fun () -> send t.flow raw >|= R.reword_error write_error) + (fun exn -> Lwt.return_error (Exn exn)) + >>= function + | Error err as v -> + t.closed <- true ; + Log.err (fun m -> m "-> Got an error when writing: %a" pp_error err) ; + Lwt.return v + | Ok () -> + Log.debug (fun m -> m "-> Write %d byte(s)." (Cstruct.len raw)) ; + Lwt.return_ok (Cstruct.len raw)) + + let close t = + if t.closed + then ( + Log.debug (fun m -> m "Connection already closed.") ; + Lwt.return_ok ()) + else ( + Log.debug (fun m -> m "Close the connection") ; + StackV4.TCPV4.close t.flow >>= fun () -> Lwt.return_ok ()) + end + + let endpoint : endpoint Conduit_mirage.key = Conduit_mirage.key "tcp-mirage" + + let protocol = + Conduit_mirage.register_protocol ~key:endpoint ~protocol:(module Protocol) + + type nonrec configuration = StackV4.t configuration + + type service = { + stack : StackV4.t; + queue : StackV4.TCPV4.flow Queue.t; + condition : unit Lwt_condition.t; + mutex : Lwt_mutex.t; + nodelay : bool; + mutable closed : bool; + } + + module Service = struct + type +'a s = 'a Conduit_mirage.s + + type error = Connection_aborted + + let pp_error : error Fmt.t = + fun ppf -> function + | Connection_aborted -> Fmt.string ppf "Connection aborted" + + type flow = protocol + + type endpoint = configuration + + type t = service + + let make { stack; keepalive; nodelay; port } = + let queue = Queue.create () in + let condition = Lwt_condition.create () in + let mutex = Lwt_mutex.create () in + let listener flow = + Lwt_mutex.lock mutex >>= fun () -> + Queue.push flow queue ; + Lwt_condition.signal condition () ; + Lwt_mutex.unlock mutex ; + Lwt.return () in + StackV4.listen_tcpv4 ?keepalive stack ~port listener ; + Lwt.return + (Ok { stack; queue; condition; mutex; nodelay; closed = false }) + + let rec accept ({ queue; condition; mutex; nodelay; closed; _ } as t) = + Lwt_mutex.lock mutex >>= fun () -> + let rec await () = + if Queue.is_empty queue && not closed + then Lwt_condition.wait condition ~mutex >>= await + else Lwt.return () in + await () >>= fun () -> + match Queue.pop queue with + | flow -> + let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in + Lwt_mutex.unlock mutex ; + Lwt.return (Ok { flow; nodelay; queue; closed = false }) + | exception Queue.Empty -> + if closed + then ( + Lwt_mutex.unlock mutex ; + Lwt.return (Error Connection_aborted)) + else ( + Lwt_mutex.unlock mutex ; + accept t) + + let close ({ stack; mutex; _ } as t) = + Lwt_mutex.with_lock mutex (fun () -> + StackV4.disconnect stack >>= fun () -> + t.closed <- true ; + Lwt.return (Ok ())) + end + + let configuration : configuration Conduit_mirage.key = + Conduit_mirage.key "tcp-mirage" + + let service = + Conduit_mirage.register_service ~key:configuration + ~service:(module Service) + ~protocol +end diff --git a/mirage/conduit_mirage_tcp.mli b/mirage/conduit_mirage_tcp.mli new file mode 100644 index 00000000..a8b516c1 --- /dev/null +++ b/mirage/conduit_mirage_tcp.mli @@ -0,0 +1,32 @@ +open Conduit_mirage + +type ('stack, 'ip) endpoint = { + stack : 'stack; + keepalive : Mirage_protocols.Keepalive.t option; + nodelay : bool; + ip : 'ip; + port : int; +} + +type 'stack configuration = { + stack : 'stack; + keepalive : Mirage_protocols.Keepalive.t option; + nodelay : bool; + port : int; +} + +module Make (StackV4 : Mirage_stack.V4) : sig + type protocol + + val endpoint : (StackV4.t, Ipaddr.V4.t) endpoint key + + val protocol : protocol Witness.protocol + + val dst : protocol -> Ipaddr.V4.t * int + + type service + + val configuration : StackV4.t configuration key + + val service : (service * protocol) Witness.service +end diff --git a/mirage/conduit_mirage_tls.ml b/mirage/conduit_mirage_tls.ml new file mode 100644 index 00000000..1c676d73 --- /dev/null +++ b/mirage/conduit_mirage_tls.ml @@ -0,0 +1 @@ +include Conduit_tls.Make (Conduit_mirage.Mirage_scheduler) (Conduit_mirage) diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli new file mode 100644 index 00000000..40490369 --- /dev/null +++ b/mirage/conduit_mirage_tls.mli @@ -0,0 +1,21 @@ +open Conduit_mirage + +type 'flow protocol_with_tls + +val underlying : 'flow protocol_with_tls -> 'flow + +val handshake : 'flow protocol_with_tls -> bool + +val protocol_with_tls : + key:'edn key -> + 'flow Witness.protocol -> + ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + +type 'service service_with_tls + +val service_with_tls : + key:'edn key -> + ('t * 'flow) Witness.service -> + 'flow protocol_with_tls Witness.protocol -> + ('edn * Tls.Config.server) key + * ('t service_with_tls * 'flow protocol_with_tls) Witness.service diff --git a/mirage/conduit_xenstore.ml b/mirage/conduit_xenstore.ml deleted file mode 100644 index 47911369..00000000 --- a/mirage/conduit_xenstore.ml +++ /dev/null @@ -1,99 +0,0 @@ -(* - * Copyright (c) 2014-2015 Anil Madhavapeddy - * Copyright (c) 2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -open Sexplib.Conv - -type direct = [`Direct of int * Vchan.Port.t] - -let (>>=) = Lwt.(>>=) -let (/) = Filename.concat - -let fail fmt = Printf.ksprintf (fun m -> Lwt.fail (Failure m)) fmt -let err_peer_not_found = fail "Conduit_xenstore: %s peer not found" -let err_no_entry_found () = - fail "No /conduit Xenstore entry found. Run `xenstore-conduit-init`" -let err_port = fail "%s: invalid port" - -module Make (Xs: Xs_client_lwt.S) = struct - - type t = { xs: (Xs.client [@sexp.opaque]); name: string } [@@deriving sexp_of] - - let get_my_id xs = Xs.(immediate xs (fun h -> read h "domid")) - - let xenstore_register xs myname = - get_my_id xs >>= fun domid -> - Xs.(immediate xs (fun h -> write h ("/conduit" / myname) domid)) - - let get_peer_id xs name = - Lwt.catch - (fun () -> Xs.(immediate xs (fun h -> read h ("/conduit" / name)))) - (fun _ -> err_peer_not_found name) - - let readdir h d = - Xs.(directory h d) >>= fun dirs -> - let dirs = List.filter (fun p -> p <> "") dirs in - match dirs with - | [] -> Lwt.fail Xs_protocol.Eagain - | hd::_ -> Lwt.return hd - - let register name = - Xs.make () >>= fun xs -> - (* Check that a /conduit directory exists *) - Lwt.catch - (fun () -> - Xs.(immediate xs (fun h -> read h "/conduit")) >>= fun _ -> - Lwt.return_unit) - (fun _ -> err_no_entry_found ()) - >>= fun () -> - xenstore_register xs name >>= fun () -> - Lwt.return { xs; name } - - let accept {xs; name } = - let waitfn h = - readdir h ("/conduit" / name) >>= fun remote_name -> - readdir h ("/conduit" / name / remote_name) >>= fun port -> - Xs.read h ("/conduit" / remote_name) >>= fun remote_domid -> - let remote_domid = int_of_string remote_domid in - Xs.rm h ("/conduit" / name / remote_name) >>= fun () -> - match Vchan.Port.of_string port with - | Error (`Msg e) -> err_port e - | Ok port -> Lwt.return (`Direct (remote_domid, port)) - in - Xs.wait xs waitfn - - let listen ({name; _} as v) = - (* TODO cancellation *) - let conn, push_conn = Lwt_stream.create () in - Printf.printf "Conduit_xenstore: listen on %s\n%!" name; - let rec loop () = - accept v >>= fun c -> - push_conn (Some c); - loop () - in - Lwt.ignore_result (loop ()); - Lwt.return conn - - let connect {xs; name} ~remote_name ~port = - let port_str = Vchan.Port.to_string port in - get_peer_id xs remote_name >>= fun remote_domid -> - let remote_domid = int_of_string remote_domid in - let path = "/conduit" / remote_name / name / port_str in - Xs.(immediate xs (fun h -> write h path port_str)) >>= fun () -> - Lwt.return (`Direct (remote_domid, port)) - -end diff --git a/mirage/conduit_xenstore.mli b/mirage/conduit_xenstore.mli deleted file mode 100644 index d87a9d4e..00000000 --- a/mirage/conduit_xenstore.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -(** Establish Vchans via named endpoints in XenStore *) - -type direct = [`Direct of int * Vchan.Port.t] - -module Make (Xs: Xs_client_lwt.S): sig - type t - val register: string -> t Lwt.t - val listen: t -> direct Lwt_stream.t Lwt.t - val connect: t -> remote_name:string -> port:Vchan.Port.t -> direct Lwt.t -end diff --git a/mirage/dune b/mirage/dune index 82cb38c9..62bea036 100644 --- a/mirage/dune +++ b/mirage/dune @@ -1,9 +1,23 @@ (library - (name conduit_mirage) - (public_name conduit-mirage) - (preprocess (pps ppx_sexp_conv)) - (modules conduit_mirage resolver_mirage conduit_xenstore) - (wrapped false) - (libraries conduit conduit-lwt mirage-stack mirage-clock mirage-random mirage-time - mirage-flow mirage-flow-combinators dns-client.mirage ipaddr-sexp - vchan tls tls-mirage xenstore.client uri.services)) + (name conduit_mirage) + (public_name conduit-mirage) + (modules conduit_mirage) + (libraries conduit conduit-lwt)) + +(library + (name conduit_mirage_tls) + (public_name conduit-mirage.tls) + (modules conduit_mirage_tls) + (libraries conduit-mirage conduit-tls)) + +(library + (name conduit_mirage_flow) + (public_name conduit-mirage.flow) + (modules conduit_mirage_flow) + (libraries conduit-mirage conduit-lwt.flow)) + +(library + (name conduit_mirage_tcp) + (public_name conduit-mirage.tcp) + (modules conduit_mirage_tcp) + (libraries logs mirage-stack bigstringaf ke tcpip.tcp conduit-mirage)) diff --git a/mirage/resolver_mirage.ml b/mirage/resolver_mirage.ml deleted file mode 100644 index e95ca2f3..00000000 --- a/mirage/resolver_mirage.ml +++ /dev/null @@ -1,126 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -open Lwt.Infix - -let is_tls_service = - (* TODO fill in the blanks. nowhere else to get this information *) - function - | "https" | "imaps" -> true - | _ -> false - -let get_host uri = - match Uri.host uri with - | None -> "localhost" - | Some host -> - match Ipaddr.of_string host with - | Ok ip -> Ipaddr.to_string ip - | Error _ -> host - -let get_port service uri = - match Uri.port uri with - | None -> service.Resolver.port - | Some port -> port - -let static_resolver hosts service uri = - let port = get_port service uri in - try - let fn = Hashtbl.find hosts (get_host uri) in - Lwt.return (fn ~port) - with Not_found -> - Lwt.return (`Unknown ("name resolution failed")) - -let static_service name = - match Uri_services.tcp_port_of_service name with - | [] -> Lwt.return_none - | port::_ -> - let tls = is_tls_service name in - let svc = { Resolver.name; port; tls } in - Lwt.return (Some svc) - -let static hosts = - let service = static_service in - let rewrites = ["", static_resolver hosts] in - Resolver_lwt.init ~service ~rewrites () - -let localhost = - let hosts = Hashtbl.create 3 in - Hashtbl.add hosts "localhost" - (fun ~port -> `TCP (Ipaddr.(V4 V4.localhost), port)); - static hosts - -module Make_with_stack (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK) (S: Mirage_stack.V4) = struct - include Resolver_lwt - - module R = struct - let vchan_resolver ~tld = - let tld_len = String.length tld in - let get_short_host uri = - let n = get_host uri in - let len = String.length n in - if len > tld_len && (String.sub n (len-tld_len) tld_len = tld) then - String.sub n 0 (len-tld_len) - else - n - in - fun service uri -> - (* Strip the tld from the hostname *) - let remote_name = get_short_host uri in - Printf.printf "vchan_lookup: %s %s -> normalizes to %s\n%!" - (Sexplib.Sexp.to_string_hum (Resolver.sexp_of_service service)) - (Uri.to_string uri) remote_name; - Lwt.return (`Vchan_domain_socket (remote_name, service.Resolver.name)) - - module DNS = Dns_client_mirage.Make(R)(T)(C)(S) - - let dns_stub_resolver dns service uri : Conduit.endp Lwt.t = - let hostn = get_host uri in - let port = get_port service uri in - (match Ipaddr.V4.of_string hostn with - | Ok addr -> Lwt.return (Ok addr) - | Error _ -> - match Domain_name.of_string hostn with - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - | Ok domain -> - match Domain_name.host domain with - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - | Ok host -> DNS.gethostbyname dns host) >|= function - | Error (`Msg err) -> `Unknown ("name resolution failed: " ^ err) - | Ok addr -> `TCP (Ipaddr.V4 addr, port) - - let register ?ns ?(ns_port = 53) ?stack res = - begin match stack with - | Some s -> - (* DNS stub resolver *) - let nameserver = match ns with None -> None | Some ip -> Some (`TCP, (ip, ns_port)) in - let dns = DNS.create ?nameserver s in - let f = dns_stub_resolver dns in - Resolver_lwt.add_rewrite ~host:"" ~f res - | None -> () - end; - let service = Resolver_lwt.(service res ++ static_service) in - Resolver_lwt.set_service ~f:service res; - let vchan_tld = ".xen" in - let vchan_res = vchan_resolver ~tld:vchan_tld in - Resolver_lwt.add_rewrite ~host:vchan_tld ~f:vchan_res res - - let init ?ns ?ns_port ?stack () = - let res = Resolver_lwt.init () in - register ?ns ?ns_port ?stack res; - res - end -end diff --git a/mirage/resolver_mirage.mli b/mirage/resolver_mirage.mli deleted file mode 100644 index 164ce8ad..00000000 --- a/mirage/resolver_mirage.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -(** Functorial interface for resolving URIs to endpoints. *) - -(** [static hosts] constructs a resolver that looks up any resolution - requests from the static [hosts] hashtable instead of using the - system resolver. *) -val static : (string, (port:int -> Conduit.endp)) Hashtbl.t -> Resolver_lwt.t - -(** [localhost] is a static resolver that has a single entry that - maps [localhost] to [127.0.0.1], and fails on all other hostnames. *) -val localhost : Resolver_lwt.t - -(** Provides a DNS-enabled {!Resolver_lwt} given a network stack. - See {!Make}. -*) -module Make_with_stack (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK) (S: Mirage_stack.V4) : sig - include Resolver_lwt.S with type t = Resolver_lwt.t - - module R : sig - val register : ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:S.t -> Resolver_lwt.t -> unit - - (** [init ?ns ?ns_port ?stack ()] TODO *) - val init: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:S.t -> unit -> t - end -end From 1ce0f9a525d21a16a8589ed779bd9872d7c9d21c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:47:58 +0200 Subject: [PATCH 010/140] New implementation of conduit-async with reader/writer helpers, tcp/ip, tls and ssl layers `conduit` with `async` and: - tcp/ip layer provided by `Async.Tcp` - ssl layer with `Async_ssl` and its implementation with the given tcp/ip stack - tls layer with `conduit-tls` and its implementation with the given tcp/ip stack - An helper to get `Reader.t`/`Writer.t` from an abstracted `Conduit_async.flow` - a `resolv_conf` resolver which trusts on your `resolv.conf` --- async/conduit_async.ml | 108 +++++++++--- async/conduit_async.mli | 20 +++ async/conduit_async_ssl.ml | 332 ++++++++++++++++++++++++++++++++++++ async/conduit_async_ssl.mli | 73 ++++++++ async/conduit_async_tcp.ml | 168 ++++++++++++++++++ async/conduit_async_tcp.mli | 28 +++ async/conduit_async_tls.ml | 16 ++ async/conduit_async_tls.mli | 40 +++++ async/dune | 36 ++-- async/private_ssl_dummy.ml | 65 ------- async/private_ssl_real.ml | 247 --------------------------- async/s.ml | 282 ------------------------------ async/v1.ml | 145 ---------------- async/v1_dummy.mli | 4 - async/v1_real.mli | 6 - async/v2.ml | 116 ------------- async/v2_dummy.mli | 8 - async/v2_real.mli | 9 - async/v3.ml | 161 ----------------- async/v3_dummy.mli | 8 - async/v3_real.mli | 9 - 21 files changed, 780 insertions(+), 1101 deletions(-) create mode 100644 async/conduit_async.mli create mode 100644 async/conduit_async_ssl.ml create mode 100644 async/conduit_async_ssl.mli create mode 100644 async/conduit_async_tcp.ml create mode 100644 async/conduit_async_tcp.mli create mode 100644 async/conduit_async_tls.ml create mode 100644 async/conduit_async_tls.mli delete mode 100644 async/private_ssl_dummy.ml delete mode 100644 async/private_ssl_real.ml delete mode 100644 async/s.ml delete mode 100644 async/v1.ml delete mode 100644 async/v1_dummy.mli delete mode 100644 async/v1_real.mli delete mode 100644 async/v2.ml delete mode 100644 async/v2_dummy.mli delete mode 100644 async/v2_real.mli delete mode 100644 async/v3.ml delete mode 100644 async/v3_dummy.mli delete mode 100644 async/v3_real.mli diff --git a/async/conduit_async.ml b/async/conduit_async.ml index 74aadb8b..8fb8d71f 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -1,23 +1,85 @@ -(* - * Copyright (c) 2012-2017 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -module V1 = V1 -module V2 = V2 -module V3 = V3 - -[@@@deprecated "Use Conduit_async.V1"] -include V1.Conduit_async +module Async_scheduler = struct + type +'a t = 'a Async.Deferred.t + + let bind x f = Async.Deferred.bind x ~f + + let return x = Async.Deferred.return x +end + +include Conduit.Make (Async_scheduler) (Cstruct) (Cstruct) + +let invalid_arg fmt = Format.kasprintf invalid_arg fmt + +let failwith fmt = Format.kasprintf failwith fmt + +let ( >>? ) x f = Async.Deferred.Result.bind x ~f + +let serve_with_handler : + type cfg master flow. + handler:(flow Witness.protocol -> flow -> unit Async.Deferred.t) -> + key:cfg key -> + service:(master * flow) Witness.service -> + cfg -> + unit Async.Condition.t * unit Async.Deferred.t = + fun ~handler ~key ~service cfg -> + let open Async in + let stop = Async.Condition.create () in + match impl_of_service ~key service with + | Error _ -> invalid_arg "Invalid key %s" (name_of_key key) + | Ok (module Service) -> + let main = + serve ~key cfg ~service >>= function + | Error err -> failwith "%a" pp_error err + | Ok (master, protocol) -> ( + let rec loop () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in + let accept = + Service.accept master >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in + + Async.Deferred.any [ close; accept ] >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for (handler protocol flow) ; + Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () + | Ok `Stop -> Service.close master + | Error err0 -> ( + Service.close master >>= function + | Ok () -> Async.return (Error err0) + | Error _err1 -> Async.return (Error err0)) in + loop () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Service.pp_error err) in + (stop, main) + +let reader_and_writer_of_flow flow = + let open Async in + let recv flow writer = + let tmp = Cstruct.create 0x1000 in + let rec loop () = + recv flow tmp >>= function + | Ok (`Input len) -> + Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop + | Ok `End_of_input -> + Pipe.close writer ; + Async.return () + | Error err -> failwith "%a" pp_error err in + loop () in + let send flow reader = + let rec loop () = + Pipe.read reader >>= function + | `Eof -> Async.return () + | `Ok v -> + let rec go tmp = + if Cstruct.len tmp = 0 + then Async.return () + else + send flow tmp >>= function + | Ok shift -> go (Cstruct.shift tmp shift) + | Error err -> failwith "%a" pp_error err in + go (Cstruct.of_string v) >>= loop in + loop () in + let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in + let pwriter = Pipe.create_writer (send flow) in + Reader.of_pipe (Core.Info.of_string "reader") preader >>= fun reader -> + Writer.of_pipe (Core.Info.of_string "writer") pwriter >>= fun (writer, _) -> + Async.return (reader, writer) diff --git a/async/conduit_async.mli b/async/conduit_async.mli new file mode 100644 index 00000000..ba82672e --- /dev/null +++ b/async/conduit_async.mli @@ -0,0 +1,20 @@ +(** Conduit with Async. *) + +module Async_scheduler : + Conduit.Sigs.SCHEDULER with type +'a t = 'a Async.Deferred.t + +include + Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a s = 'a Async.Deferred.t + +val serve_with_handler : + handler:('flow Witness.protocol -> 'flow -> unit Async.Deferred.t) -> + key:'cfg key -> + service:('master * 'flow) Witness.service -> + 'cfg -> + unit Async.Condition.t * unit Async.Deferred.t + +val reader_and_writer_of_flow : + flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml new file mode 100644 index 00000000..27428ebc --- /dev/null +++ b/async/conduit_async_ssl.ml @@ -0,0 +1,332 @@ +open Async_ssl +open Async +open Core + +let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Async.return err + +let reword_error f = function Ok _ as v -> v | Error err -> Error (f err) + +let teardown_connection reader writer = + Writer.close ~force_close:Clock.(after (sec 30.)) writer >>= fun () -> + Reader.close reader + +let reader_writer_pipes reader writer = + let reader_pipe_reader, reader_pipe_writer = Pipe.create () in + let writer_pipe = Writer.pipe writer in + Async.upon (Reader.transfer reader reader_pipe_writer) (fun () -> + teardown_connection reader writer >>> fun () -> + Pipe.close reader_pipe_writer) ; + Async.upon (Pipe.closed writer_pipe) (fun () -> + Deferred.choose + [ + Deferred.choice Clock.(after (sec 30.)) (fun () -> ()); + Deferred.choice (Pipe.downstream_flushed writer_pipe) + (fun (_ : Pipe.Flushed_result.t) -> ()); + ] + >>> fun () -> don't_wait_for (teardown_connection reader writer)) ; + (reader_pipe_reader, writer_pipe) + +let reader_writer_of_pipes app_rd app_wr = + Reader.of_pipe (Info.of_string "async-conduit-ssl-reader") app_rd + >>= fun app_reader -> + Async.upon (Reader.close_finished app_reader) (fun () -> + Pipe.close_read app_rd) ; + Writer.of_pipe (Info.of_string "async-conduit-ssl-writer") app_wr + >>= fun (app_writer, _) -> + Writer.set_raise_when_consumer_leaves app_writer false ; + Async.return (app_reader, app_writer) + +type context = { + version : Ssl.Version.t option; + options : Ssl.Opt.t list option; + name : string option; + hostname : string option; + allowed_ciphers : + [ `Only of string list | `Openssl_default | `Secure ] option; + ca_file : string option; + ca_path : string option; + crt_file : string option; + key_file : string option; + session : Ssl.Session.t option; + verify_modes : Verify_mode.t list option; + verify : (Ssl.Connection.t -> bool Async.Deferred.t) option; +} + +let context ?version ?options ?name ?hostname ?allowed_ciphers ?ca_file ?ca_path + ?crt_file ?key_file ?session ?verify_modes ?verify () = + { + version; + options; + name; + hostname; + allowed_ciphers; + ca_file; + ca_path; + crt_file; + key_file; + session; + verify_modes; + verify; + } + +type 'flow with_ssl = { + connection : Ssl.Connection.t; + reader : Reader.t; + writer : Writer.t; + underlying : 'flow; +} + +module Protocol (Protocol : sig + include Conduit_async.PROTOCOL + + val reader : flow -> Reader.t + + val writer : flow -> Writer.t +end) = +struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a s = 'a Async.Deferred.t + + type endpoint = context * Protocol.endpoint + + type flow = Protocol.flow with_ssl + + exception Invalid_connection + + type error = Core of Core.Error.t | Protocol of Protocol.error + + let pp_error ppf = function + | Core err -> Core.Error.pp ppf err + | Protocol err -> Protocol.pp_error ppf err + + let flow + ( { + version; + options; + name; + hostname; + allowed_ciphers; + ca_file; + ca_path; + crt_file; + key_file; + session; + verify_modes; + verify; + }, + edn ) = + Protocol.flow edn >>| reword_error (fun err -> Protocol err) + >>? fun underlying -> + let reader = Protocol.reader underlying in + let writer = Protocol.writer underlying in + + let net_to_ssl, ssl_to_net = reader_writer_pipes reader writer in + let app_to_ssl, app_writer = Pipe.create () in + let app_reader, ssl_to_app = Pipe.create () in + let verify_connection = + match verify with None -> Fn.const (return true) | Some verify -> verify + in + Monitor.try_with_join_or_error (fun () -> + Ssl.client ?version ?options ?name ?hostname ?allowed_ciphers ?ca_file + ?ca_path ?crt_file ?key_file ?session ?verify_modes ~app_to_ssl + ~ssl_to_app ~net_to_ssl ~ssl_to_net ()) + >>| reword_error (fun err -> Core err) + >>= function + | Error _ as err -> + teardown_connection reader writer >>= fun () -> Async.return err + | Ok conn -> ( + verify_connection conn >>= function + | true -> + reader_writer_of_pipes app_reader app_writer + >>= fun (app_reader, app_writer) -> + Async.return + (Ok + { + connection = conn; + reader = app_reader; + writer = app_writer; + underlying; + }) + | false -> + teardown_connection reader writer >>= fun () -> + Async.return (Error (Core (Core.Error.of_exn Invalid_connection)))) + + let of_cstruct raw = + let { Cstruct.buffer; off; len } = raw in + Core.Bigsubstring.create ~pos:off ~len buffer + + let recv { reader; _ } raw = + Reader.read_bigsubstring reader (of_cstruct raw) >>= function + | `Eof -> Async.return (Ok `End_of_input) + | `Ok n -> Async.return (Ok (`Input n)) + + let send { writer; _ } raw = + Writer.write_bigsubstring writer (of_cstruct raw) ; + Async.return (Ok (Cstruct.len raw)) + + let close { reader; writer; _ } = + Reader.close reader >>= fun () -> + Writer.close writer >>= fun () -> Async.return (Ok ()) +end + +let protocol_with_ssl : + type edn flow. + key:edn Conduit_async.key -> + reader:(flow -> Reader.t) -> + writer:(flow -> Writer.t) -> + flow Conduit_async.Witness.protocol -> + (context * edn) Conduit_async.key + * flow with_ssl Conduit_async.Witness.protocol = + fun ~key ~reader ~writer protocol -> + match Conduit_async.impl_of_protocol ~key protocol with + | Ok (module F) -> + let module Flow = struct + include F + + let reader = reader + + let writer = writer + end in + let module M = Protocol (Flow) in + let k = + Conduit_async.key + (Format.asprintf "%s + ssl" (Conduit_async.name_of_key key)) in + let p = Conduit_async.register_protocol ~key:k ~protocol:(module M) in + (k, p) + | _ -> invalid_arg "Invalid key" + +module Make (Service : sig + include Conduit_async.SERVICE + + val reader : flow -> Reader.t + + val writer : flow -> Writer.t +end) = +struct + type +'a s = 'a Async.Deferred.t + + type error = + | Service of Service.error + | Core of Core.Error.t + | Missing_crt_or_key + + let pp_error ppf = function + | Service err -> Service.pp_error ppf err + | Core err -> Core.Error.pp ppf err + | Missing_crt_or_key -> + Format.fprintf ppf "Missing crt of key values into context" + + type endpoint = context * Service.endpoint + + type t = context * Service.t + + type flow = Service.flow with_ssl + + let make (context, edn) = + match (context.crt_file, context.key_file) with + | None, None | Some _, None | None, Some _ -> + Async.return (Error Missing_crt_or_key) + | _ -> ( + Service.make edn >>= function + | Ok t -> Async.return (Ok (context, t)) + | Error err -> Async.return (Error (Service err))) + + let accept + ( { + version; + options; + name; + allowed_ciphers; + ca_file; + ca_path; + crt_file; + key_file; + verify_modes; + _; + }, + service ) = + Service.accept service >>= function + | Error err -> Async.return (Error (Service err)) + | Ok flow -> ( + let crt_file, key_file = + match (crt_file, key_file) with + | Some crt_file, Some key_file -> (crt_file, key_file) + | _ -> assert false in + let reader = Service.reader flow in + let writer = Service.writer flow in + let net_to_ssl, ssl_to_net = reader_writer_pipes reader writer in + let app_to_ssl, app_writer = Pipe.create () in + let app_reader, ssl_to_app = Pipe.create () in + Ssl.server ?version ?options ?name ?allowed_ciphers ?ca_file ?ca_path + ~crt_file ~key_file ?verify_modes ~app_to_ssl ~ssl_to_app ~net_to_ssl + ~ssl_to_net () + >>= function + | Error error -> + teardown_connection reader writer >>= fun () -> + Async.return (Error (Core error)) + | Ok conn -> + reader_writer_of_pipes app_reader app_writer + >>| fun (app_reader, app_writer) -> + Ok + { + underlying = flow; + reader = app_reader; + writer = app_writer; + connection = conn; + }) + + let close (_, t) = + Service.close t >>= function + | Error err -> Async.return (Error (Service err)) + | Ok _ as v -> Async.return v +end + +let service_with_ssl : + type edn t flow. + key:edn Conduit_async.key -> + (t * flow) Conduit_async.Witness.service -> + reader:(flow -> Reader.t) -> + writer:(flow -> Writer.t) -> + flow with_ssl Conduit_async.Witness.protocol -> + (context * edn) Conduit_async.key + * ((context * t) * flow with_ssl) Conduit_async.Witness.service = + fun ~key service ~reader ~writer protocol -> + match Conduit_async.impl_of_service ~key service with + | Ok (module S) -> + let module Service = struct + include S + + let reader = reader + + let writer = writer + end in + let module M = Make (Service) in + let k = + Conduit_async.key + (Format.asprintf "%s + ssl" (Conduit_async.name_of_key key)) in + let s = + Conduit_async.register_service ~key:k ~service:(module M) ~protocol + in + (k, s) + | _ -> invalid_arg "Invalid key" + +module TCP = struct + open Conduit_async_tcp + + let endpoint, protocol = + protocol_with_ssl ~key:endpoint ~reader:Protocol.reader + ~writer:Protocol.writer protocol + + let configuration, service = + service_with_ssl ~key:configuration service ~reader:Protocol.reader + ~writer:Protocol.writer protocol + + let resolv_conf ~port ~context domain_name = + resolv_conf ~port domain_name >>| function + | Some edn -> Some (context, edn) + | None -> None +end diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli new file mode 100644 index 00000000..5ce30daf --- /dev/null +++ b/async/conduit_async_ssl.mli @@ -0,0 +1,73 @@ +open Async +open Async_ssl +open Conduit_async + +type 'flow with_ssl = { + connection : Ssl.Connection.t; + reader : Reader.t; + writer : Writer.t; + underlying : 'flow; +} + +type context = { + version : Ssl.Version.t option; + options : Ssl.Opt.t list option; + name : string option; + hostname : string option; + allowed_ciphers : + [ `Only of string list | `Openssl_default | `Secure ] option; + ca_file : string option; + ca_path : string option; + crt_file : string option; + key_file : string option; + session : Ssl.Session.t option; + verify_modes : Verify_mode.t list option; + verify : (Ssl.Connection.t -> bool Async.Deferred.t) option; +} + +val context : + ?version:Ssl.Version.t -> + ?options:Ssl.Opt.t list -> + ?name:string -> + ?hostname:string -> + ?allowed_ciphers:[ `Only of string list | `Openssl_default | `Secure ] -> + ?ca_file:string -> + ?ca_path:string -> + ?crt_file:string -> + ?key_file:string -> + ?session:Ssl.Session.t -> + ?verify_modes:Verify_mode.t list -> + ?verify:(Ssl.Connection.t -> bool Async.Deferred.t) -> + unit -> + context + +val protocol_with_ssl : + key:'edn Conduit_async.key -> + reader:('flow -> Reader.t) -> + writer:('flow -> Writer.t) -> + 'flow Conduit_async.Witness.protocol -> + (context * 'edn) Conduit_async.key + * 'flow with_ssl Conduit_async.Witness.protocol + +val service_with_ssl : + key:'edn Conduit_async.key -> + ('t * 'flow) Conduit_async.Witness.service -> + reader:('flow -> Reader.t) -> + writer:('flow -> Writer.t) -> + 'flow with_ssl Conduit_async.Witness.protocol -> + (context * 'edn) Conduit_async.key + * ((context * 't) * 'flow with_ssl) Conduit_async.Witness.service + +module TCP : sig + open Conduit_async_tcp + + val endpoint : (context * endpoint) key + + val protocol : Protocol.flow with_ssl Witness.protocol + + val configuration : (context * Conduit_async_tcp.configuration) key + + val service : ((context * Service.t) * Protocol.flow with_ssl) Witness.service + + val resolv_conf : port:int -> context:context -> (context * endpoint) resolver +end diff --git a/async/conduit_async_tcp.ml b/async/conduit_async_tcp.ml new file mode 100644 index 00000000..af63c50f --- /dev/null +++ b/async/conduit_async_tcp.ml @@ -0,0 +1,168 @@ +open Async +open Async_unix + +type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t + +module Protocol = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a s = 'a Async.Deferred.t + + type flow = + | Socket : { + address : [< Socket.Address.t ]; + socket : ([ `Active ], [< Socket.Address.t ]) Socket.t; + reader : Async.Reader.t; + writer : Async.Writer.t; + } + -> flow + + let address (Socket { address; _ }) = + match address with #Socket.Address.t as addr -> addr + + let reader (Socket { reader; _ }) = reader + + let writer (Socket { writer; _ }) = writer + + type nonrec endpoint = endpoint = + | Inet of Socket.Address.Inet.t + | Unix of Socket.Address.Unix.t + + type error = Core.Error.t + + let pp_error = Core.Error.pp + + let flow edn = + let connect = function + | Inet address -> + Tcp.connect (Tcp.Where_to_connect.of_inet_address address) + >>| fun (socket, reader, writer) -> + Socket { address; socket; reader; writer } + | Unix address -> + Tcp.connect (Tcp.Where_to_connect.of_unix_address address) + >>| fun (socket, reader, writer) -> + Socket { address; socket; reader; writer } in + Monitor.try_with (fun () -> connect edn) >>= function + | Ok _ as v -> Async.return v + | Error exn -> Async.return (Error (Core.Error.of_exn exn)) + + let of_cstruct raw = + let { Cstruct.buffer; off; len } = raw in + Core.Bigsubstring.create ~pos:off ~len buffer + + (* XXX(dinosaure): as [lwt] and seems required for [conduit-tls], [recv] wants to read + as much as possible. Due to underlying non-blocking socket, even if we reached [`Eof], + we must retry to read until we have something or the underlying socket was closed. *) + let rec recv (Socket { socket; reader; _ } as flow) raw = + Monitor.try_with (fun () -> + Reader.read_bigsubstring reader (of_cstruct raw)) + >>= function + | Error err -> + Reader.close reader >>= fun () -> + Async.return (Error (Core.Error.of_exn err)) + | Ok (`Ok n) -> Async.return (Ok (`Input n)) + | Ok `Eof -> ( + Fd.ready_to (Socket.fd socket) `Read >>= function + | `Bad_fd | `Closed -> Async.return (Ok `End_of_input) + | `Ready -> Scheduler.yield () >>= fun () -> recv flow raw) + + let send (Socket { writer; _ }) raw = + Writer.write_bigsubstring writer (of_cstruct raw) ; + Writer.flushed writer >>= fun () -> Async.return (Ok (Cstruct.len raw)) + + let close (Socket { socket; reader; writer; _ }) = + (* XXX(dinosaure): we should be protected against the double-close. *) + if Reader.is_closed reader + && Writer.is_closed writer + && Fd.is_closed (Socket.fd socket) + then Async.return (Ok ()) + else ( + Socket.shutdown socket `Both ; + Reader.close reader >>= fun () -> + Writer.close writer >>= fun () -> Async.return (Ok ())) +end + +let endpoint = Conduit_async.key "tcp-endpoint" + +let protocol = + Conduit_async.register_protocol ~key:endpoint ~protocol:(module Protocol) + +type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration + +module Service = struct + type +'a s = 'a Async.Deferred.t + + type flow = Protocol.flow + + type error = Exn of [ `Make | `Accept ] * exn | Socket_closed + + let pp_error ppf = function + | Exn (`Make, exn) -> + Format.fprintf ppf "Got an exception while making socket: %s" + (Printexc.to_string exn) + | Exn (`Accept, exn) -> + Format.fprintf ppf "Got an exception while accepting socket: %s" + (Printexc.to_string exn) + | Socket_closed -> Format.fprintf ppf "Socket closed" + + type endpoint = configuration = + | Listen : ('a, 'b) Tcp.Where_to_listen.t -> endpoint + + type t = + | Master : ([ `Passive ], ([< Socket.Address.t ] as 'a)) Socket.t * 'a -> t + + let close_socket_on_error ~process socket ~f = + Monitor.try_with f >>| function + | Ok v -> Ok v + | Error exn -> + Async.don't_wait_for (Unix.close (Socket.fd socket)) ; + Error (Exn (process, exn)) + + type socket_type = + | Socket_type : + ([< Socket.Address.t ] as 'a) Socket.Type.t * 'a + -> socket_type + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Async.return err + + let make (Listen where_to_listen) = + let (Socket_type (socket_type, addr)) = + match Tcp.Where_to_listen.address where_to_listen with + | `Inet _ as addr -> Socket_type (Socket.Type.tcp, addr) + | `Unix _ as addr -> Socket_type (Socket.Type.unix, addr) in + let socket = Socket.create socket_type in + let f () = Socket.bind socket addr >>| Socket.listen in + close_socket_on_error ~process:`Make socket ~f >>? fun socket -> + Async.return (Ok (Master (socket, addr))) + + let accept (Master (socket, _)) = + Socket.accept socket >>= function + | `Ok (socket, address) -> + let reader = Reader.create (Socket.fd socket) in + let writer = Writer.create (Socket.fd socket) in + let flow = Protocol.Socket { socket; reader; writer; address } in + Async.return (Ok flow) + | `Socket_closed -> Async.return (Error Socket_closed) + + let close (Master (socket, _)) = + Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) +end + +let configuration = Conduit_async.key "tcp-configuration" + +let service = + Conduit_async.register_service ~key:configuration + ~service:(module Service) + ~protocol + +let resolv_conf ~port domain_name = + Monitor.try_with (fun () -> + Unix.Inet_addr.of_string_or_getbyname (Domain_name.to_string domain_name)) + >>= function + | Ok inet_addr -> + let inet_addr = Socket.Address.Inet.create inet_addr ~port in + Async.return (Some (Inet inet_addr)) + | _ -> Async.return None diff --git a/async/conduit_async_tcp.mli b/async/conduit_async_tcp.mli new file mode 100644 index 00000000..988de417 --- /dev/null +++ b/async/conduit_async_tcp.mli @@ -0,0 +1,28 @@ +open Async +open Conduit_async + +type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t + +module Protocol : sig + include Conduit_async.PROTOCOL + + val address : flow -> Socket.Address.t + + val reader : flow -> Reader.t + + val writer : flow -> Writer.t +end + +val endpoint : endpoint key + +val protocol : Protocol.flow Witness.protocol + +type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration + +module Service : SERVICE with type endpoint = configuration + +val configuration : configuration key + +val service : (Service.t * Protocol.flow) Witness.service + +val resolv_conf : port:int -> endpoint resolver diff --git a/async/conduit_async_tls.ml b/async/conduit_async_tls.ml new file mode 100644 index 00000000..82faad9f --- /dev/null +++ b/async/conduit_async_tls.ml @@ -0,0 +1,16 @@ +open Async +include Conduit_tls.Make (Conduit_async.Async_scheduler) (Conduit_async) + +module TCP = struct + open Conduit_async_tcp + + let endpoint, protocol = protocol_with_tls ~key:endpoint protocol + + let configuration, service = + service_with_tls ~key:configuration service protocol + + let resolv_conf ~port ~config domain_name = + resolv_conf ~port domain_name >>| function + | Some edn -> Some (edn, config) + | None -> None +end diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli new file mode 100644 index 00000000..b45e146d --- /dev/null +++ b/async/conduit_async_tls.mli @@ -0,0 +1,40 @@ +open Conduit_async + +type 'flow protocol_with_tls + +val underlying : 'flow protocol_with_tls -> 'flow + +val handshake : 'flow protocol_with_tls -> bool + +val protocol_with_tls : + key:'edn key -> + 'flow Witness.protocol -> + ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + +type 'service service_with_tls + +val service_with_tls : + key:'edn key -> + ('t * 'flow) Witness.service -> + 'flow protocol_with_tls Witness.protocol -> + ('edn * Tls.Config.server) key + * ('t service_with_tls * 'flow protocol_with_tls) Witness.service + +module TCP : sig + open Conduit_async_tcp + + val endpoint : (endpoint * Tls.Config.client) key + + val protocol : Protocol.flow protocol_with_tls Witness.protocol + + val configuration : (configuration * Tls.Config.server) key + + val service : + (Service.t service_with_tls * Protocol.flow protocol_with_tls) + Witness.service + + val resolv_conf : + port:int -> + config:Tls.Config.client -> + (endpoint * Tls.Config.client) resolver +end diff --git a/async/dune b/async/dune index 1f2100ad..01bb5cf6 100644 --- a/async/dune +++ b/async/dune @@ -1,23 +1,23 @@ (library - (name conduit_async) + (name conduit_async) (public_name conduit-async) - (modules conduit_async private_ssl v1 v2 v3 s) - (preprocess (pps ppx_here ppx_sexp_conv)) - (libraries - conduit async ipaddr.unix uri.services + (modules conduit_async) + (libraries cstruct async conduit)) - (select private_ssl.ml from - (async_ssl -> private_ssl_real.ml) - (!async_ssl -> private_ssl_dummy.ml)) - - (select v1.mli from - (async_ssl -> v1_real.mli) - (!async_ssl -> v1_dummy.mli)) +(library + (name conduit_async_tcp) + (public_name conduit-async.tcp) + (modules conduit_async_tcp) + (libraries async_unix conduit-async)) - (select v2.mli from - (async_ssl -> v2_real.mli) - (!async_ssl -> v2_dummy.mli)) +(library + (name conduit_async_tls) + (public_name conduit-async.tls) + (modules conduit_async_tls) + (libraries conduit-tls conduit-async conduit-async.tcp)) - (select v3.mli from - (async_ssl -> v3_real.mli) - (!async_ssl -> v3_dummy.mli)))) +(library + (name conduit_async_ssl) + (public_name conduit-async.ssl) + (modules conduit_async_ssl) + (libraries core async_ssl conduit-async conduit-async.tcp)) diff --git a/async/private_ssl_dummy.ml b/async/private_ssl_dummy.ml deleted file mode 100644 index f87b8806..00000000 --- a/async/private_ssl_dummy.ml +++ /dev/null @@ -1,65 +0,0 @@ -open Core - -module V1 = struct - module Ssl = struct - module Config = struct - type t = [`Ssl_not_compiled_in] [@@deriving sexp] - - let verify_certificate _ = - failwith "Ssl not available, recompile with Async_ssl" - - let create ?version:_ ?name:_ ?ca_file:_ ?ca_path:_ ?session:_ ?verify:_ - () = failwith "Ssl not available, recompile with Async_ssl" - end - - let connect _cfg _r _w = - failwith "Ssl not available, recompile with Async_ssl" - - let listen ?version:_ ?ca_file:_ ?ca_path:_ ~crt_file:_ ~key_file:_ _ _ = - failwith "Ssl not available, recompile with Async_ssl" - - type session = [`Ssl_not_compiled_in] [@@deriving sexp] - type version = [`Ssl_not_compiled_in] [@@deriving sexp] - type connection = [`Ssl_not_compiled_in] [@@deriving sexp] - end -end - -module V2 = struct - module Ssl = struct - module Config = struct - type t = [`Ssl_not_compiled_in] [@@deriving sexp] - - let verify_certificate _ = - failwith "Ssl not available, recompile with Async_ssl" - - let create - ?version:_ - ?options:_ - ?name:_ - ?hostname:_ - ?allowed_ciphers:_ - ?ca_file:_ - ?ca_path:_ - ?crt_file:_ - ?key_file:_ - ?session:_ - ?verify_modes:_ - ?verify:_ - () = - failwith "Ssl not available, recompile with Async_ssl" - end - - let connect ?cfg:_ _r _w = - failwith "Ssl not available, recompile with Async_ssl" - - let listen _ _r _w = - failwith "Ssl not available, recompile with Async_ssl" - - type version = [`Ssl_not_compiled_in] [@@deriving sexp] - type session = [`Ssl_not_compiled_in] [@@deriving sexp] - type verify = [`Ssl_not_compiled_in] [@@deriving sexp] - type connection = [`Ssl_not_compiled_in] [@@deriving sexp] - type verify_mode = [`Ssl_not_compiled_in] [@@deriving sexp] - type opt = [`Ssl_not_compiled_in] [@@deriving sexp] - end -end diff --git a/async/private_ssl_real.ml b/async/private_ssl_real.ml deleted file mode 100644 index bb517f14..00000000 --- a/async/private_ssl_real.ml +++ /dev/null @@ -1,247 +0,0 @@ -open Core -open Async -open Async_ssl - -let verify_certificate connection = - match Ssl.Connection.peer_certificate connection with - | None -> return false - | Some (Error _) -> return false - | Some (Ok _) -> return true - -let teardown_connection r w = - Writer.close ~force_close:(Clock.after (sec 30.)) w >>= fun () -> - Reader.close r - -(* One needs to be careful around Async Readers and Writers that share the same underyling - file descriptor, which is something that happens when they're used for sockets. - - Closing the Reader before the Writer will cause the Writer to throw and complain about - its underlying file descriptor being closed. This is why instead of using Reader.pipe - directly below, we write out an equivalent version which will first close the Writer - before closing the Reader once the input pipe is fully consumed. - - Additionally, [Writer.pipe] will not close the writer if the pipe is closed, so in - order to avoid leaking file descriptors, we allow the pipe 30 seconds to flush before - closing the writer. *) -let reader_writer_pipes r w = - let reader_pipe_r, reader_pipe_w = Pipe.create () in - let writer_pipe = Writer.pipe w in - upon (Reader.transfer r reader_pipe_w) (fun () -> - teardown_connection r w >>> fun () -> - Pipe.close reader_pipe_w); - upon (Pipe.closed writer_pipe) (fun () -> - Deferred.choose - [ Deferred.choice (Clock.after (sec 30.)) - (fun () -> ()) - ; Deferred.choice (Pipe.downstream_flushed writer_pipe) - (fun (_ : Pipe.Flushed_result.t) -> ()) ] >>> fun () -> - don't_wait_for (teardown_connection r w)); - reader_pipe_r, writer_pipe - -(* [Reader.of_pipe] will not close the pipe when the returned [Reader] is closed, so we - manually do that ourselves. - - [Writer.of_pipe] will create a writer that will raise once the pipe is closed, so we - set [raise_when_consumer_leaves] to false. *) -let reader_writer_of_pipes app_rd app_wr = - Reader.of_pipe (Info.of_string "async_conduit_ssl_reader") app_rd >>= fun app_reader -> - upon (Reader.close_finished app_reader) (fun () -> Pipe.close_read app_rd); - Writer.of_pipe (Info.of_string "async_conduit_ssl_writer") app_wr >>| fun (app_writer,_) -> - Writer.set_raise_when_consumer_leaves app_writer false; - app_reader, app_writer - -module V1 = struct - module Ssl = struct - module Config = struct - type t = { - version : Ssl.Version.t option; - name : string option; - ca_file : string option; - ca_path : string option; - session : Ssl.Session.t option sexp_opaque; - verify : (Ssl.Connection.t -> bool Deferred.t) option; - } [@@deriving sexp] - - let verify_certificate = verify_certificate - - let create ?version ?name ?ca_file ?ca_path ?session ?verify () = - { version; name; ca_file; ca_path; session; verify} - end - - let connect cfg r w = - let {Config.version; name; ca_file; ca_path; session; verify} = cfg in - let net_to_ssl, ssl_to_net = reader_writer_pipes r w in - let app_to_ssl, app_wr = Pipe.create () in - let app_rd, ssl_to_app = Pipe.create () in - let verify_connection = match verify with - | None -> Fn.const (return true) - | Some f -> f - in - Ssl.client - ?version - ?name - ?ca_file - ?ca_path - ?session - ~app_to_ssl - ~ssl_to_app - ~net_to_ssl - ~ssl_to_net - () - >>= function - | Error error -> - teardown_connection r w >>= fun () -> - Error.raise error - | Ok conn -> - verify_connection conn >>= function - | false -> - teardown_connection r w >>= fun () -> - failwith "Connection verification failed." - | true -> - reader_writer_of_pipes app_rd app_wr >>| fun (app_reader, app_writer) -> - (app_reader, app_writer) - - let listen ?(version=Ssl.Version.Tlsv1_2) ?ca_file ?ca_path ~crt_file ~key_file r w = - let net_to_ssl, ssl_to_net = reader_writer_pipes r w in - let app_to_ssl, app_wr = Pipe.create () in - let app_rd, ssl_to_app = Pipe.create () in - Ssl.server - ?ca_file - ?ca_path - ~version - ~crt_file - ~key_file - ~app_to_ssl - ~ssl_to_app - ~net_to_ssl - ~ssl_to_net - () - >>= function - | Error error -> - teardown_connection r w >>= fun () -> - Error.raise error - | Ok _ -> - reader_writer_of_pipes app_rd app_wr >>| fun (app_reader, app_writer) -> - (app_reader, app_writer) - - type session = Ssl.Session.t sexp_opaque [@@deriving sexp] - type version = Ssl.Version.t [@@deriving sexp] - type connection = Ssl.Connection.t sexp_opaque [@@deriving sexp] - end -end - -module V2 = struct - module Ssl = struct - type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] - [@@deriving sexp] - - module Config = struct - type t = { - version : Ssl.Version.t option; - options: Ssl.Opt.t list option; - name : string option; - hostname : string option; - allowed_ciphers: allowed_ciphers option; - ca_file : string option; - ca_path : string option; - crt_file : string option; - key_file : string option; - session : Ssl.Session.t option sexp_opaque; - verify_modes:Verify_mode.t sexp_opaque list option; - verify : (Ssl.Connection.t -> bool Deferred.t) option; - } [@@deriving sexp_of] - - let verify_certificate = verify_certificate - - let create - ?version ?options ?name ?hostname ?allowed_ciphers - ?ca_file ?ca_path ?crt_file ?key_file - ?session ?verify_modes ?verify () = - { version; options; name; hostname; allowed_ciphers; - ca_file; ca_path; crt_file; key_file; session; verify_modes; - verify} - end - - let connect ?(cfg=Config.create ()) r w = - let { Config.version; options; name; hostname; - allowed_ciphers; ca_file; ca_path; - crt_file; key_file; session; verify_modes; verify } = cfg in - let net_to_ssl, ssl_to_net = reader_writer_pipes r w in - let app_to_ssl, app_wr = Pipe.create () in - let app_rd, ssl_to_app = Pipe.create () in - let verify_connection = match verify with - | None -> Fn.const (return true) - | Some f -> f - in - Ssl.client - ?version - ?options - ?name - ?hostname - ?allowed_ciphers - ?ca_file - ?ca_path - ?crt_file - ?key_file - ?session - ?verify_modes - ~app_to_ssl - ~ssl_to_app - ~net_to_ssl - ~ssl_to_net - () - >>= function - | Error error -> - teardown_connection r w >>= fun () -> - Error.raise error - | Ok conn -> - verify_connection conn >>= function - | false -> - teardown_connection r w >>= fun () -> - failwith "Connection verification failed." - | true -> - reader_writer_of_pipes app_rd app_wr >>| fun (app_reader, app_writer) -> - (app_reader, app_writer) - - let listen - { Config.version; options; name; allowed_ciphers; ca_file; ca_path; - crt_file; key_file; verify_modes ; _ } r w = - let crt_file, key_file = - match crt_file, key_file with - | Some crt_file, Some key_file -> crt_file, key_file - | _ -> invalid_arg "Conduit_async_ssl.ssl_listen: crt_file and \ - key_file must be specified in cfg." in - let net_to_ssl, ssl_to_net = reader_writer_pipes r w in - let app_to_ssl, app_wr = Pipe.create () in - let app_rd, ssl_to_app = Pipe.create () in - Ssl.server - ?version - ?options - ?name - ?allowed_ciphers - ?ca_file - ?ca_path - ~crt_file - ~key_file - ?verify_modes - ~app_to_ssl - ~ssl_to_app - ~net_to_ssl - ~ssl_to_net - () - >>= function - | Error error -> - teardown_connection r w >>= fun () -> - Error.raise error - | Ok _ -> - reader_writer_of_pipes app_rd app_wr >>| fun (app_reader, app_writer) -> - (app_reader, app_writer) - - type verify_mode = Ssl.Verify_mode.t [@@deriving sexp_of] - type session = Ssl.Session.t sexp_opaque [@@deriving sexp_of] - type version = Ssl.Version.t [@@deriving sexp] - type connection = Ssl.Connection.t [@@deriving sexp_of] - type opt = Ssl.Opt.t [@@deriving sexp] - end -end diff --git a/async/s.ml b/async/s.ml deleted file mode 100644 index 5a17d43d..00000000 --- a/async/s.ml +++ /dev/null @@ -1,282 +0,0 @@ -open Async - -module type V1 = sig - type session [@@deriving sexp_of] - type ssl_conn [@@deriving sexp_of] - type ssl_version [@@deriving sexp] - - module Conduit_async : sig - module Ssl : sig - type config [@@deriving sexp] - - val verify_certificate : ssl_conn -> bool Deferred.t - - val configure - : ?version:ssl_version - -> ?name:string - -> ?ca_file:string - -> ?ca_path:string - -> ?session:session - -> ?verify:(ssl_conn -> bool Deferred.t) - -> unit - -> config - end - - type +'a io = 'a Deferred.t - type ic = Reader.t - type oc = Writer.t - - type addr = [ - | `OpenSSL of string * Ipaddr.t * int - | `OpenSSL_with_config of string * Ipaddr.t * int * Ssl.config - | `TCP of Ipaddr.t * int - | `Unix_domain_socket of string - ] [@@deriving sexp] - - val connect : ?interrupt:unit io -> addr -> (ic * oc) io - val with_connection : ?interrupt:unit io -> addr -> (ic -> oc -> unit io) -> unit io - - type trust_chain = - [ `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] - ] [@@deriving sexp] - - type openssl = - [ `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] - ] [@@deriving sexp] - - type server = [ - | openssl - | `TCP - | `OpenSSL_with_trust_chain of - (openssl * trust_chain) - ] [@@deriving sexp] - - val serve : - ?max_connections:int -> - ?backlog:int -> - ?buffer_age_limit:Writer.buffer_age_limit -> - on_handler_error:[ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit - | `Ignore - | `Raise ] -> - server -> - ('a, 'b) Tcp.Where_to_listen.t -> - ('a -> ic -> oc -> unit io) -> - ('a, 'b) Tcp.Server.t io - end - - module Conduit_async_ssl : sig - module Ssl_config = Conduit_async.Ssl - - val ssl_connect : Conduit_async.Ssl.config -> Reader.t -> Writer.t -> - (Reader.t * Writer.t) Deferred.t - - val ssl_listen - : ?version:ssl_version - -> ?ca_file:string - -> ?ca_path:string - -> crt_file:string - -> key_file:string - -> Reader.t - -> Writer.t - -> (Reader.t * Writer.t) Deferred.t - end -end - -module type V2 = sig - type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] - [@@deriving sexp] - type ssl_version [@@deriving sexp] - type session [@@deriving sexp_of] - type verify_mode [@@deriving sexp_of] - type ssl_opt [@@deriving sexp] - type ssl_conn [@@deriving sexp_of] - - - module Ssl : sig - module Config : sig - type t [@@deriving sexp_of] - - val create - : ?version:ssl_version - -> ?options:ssl_opt list - -> ?name:string - -> ?hostname:string - -> ?allowed_ciphers:allowed_ciphers - -> ?ca_file:string - -> ?ca_path:string - -> ?crt_file:string - -> ?key_file:string - -> ?session:session - -> ?verify_modes:verify_mode list - -> ?verify:(ssl_conn -> bool Deferred.t) - -> unit - -> t - end - end - - type addr = [ - | `OpenSSL of Ipaddr.t * int * Ssl.Config.t - | `TCP of Ipaddr.t * int - | `Unix_domain_socket of string - ] [@@deriving sexp_of] - - val connect - : ?interrupt:unit Deferred.t - -> addr - -> (Reader.t * Writer.t) Deferred.t - - val with_connection - : ?interrupt:unit Deferred.t - -> addr - -> (Reader.t -> Writer.t -> unit Deferred.t) - -> unit Deferred.t - - type trust_chain = - [ `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] - ] [@@deriving sexp] - - type openssl = - [ `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] - ] [@@deriving sexp] - - type server = [ - | openssl - | `TCP - | `OpenSSL_with_trust_chain of - (openssl * trust_chain) - ] [@@deriving sexp] - - val serve : - ?max_connections:int -> - ?backlog:int -> - ?buffer_age_limit:Writer.buffer_age_limit -> - on_handler_error:[ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit - | `Ignore - | `Raise ] -> - server -> - ('a, 'b) Tcp.Where_to_listen.t -> - ('a -> Reader.t -> Writer.t -> unit Deferred.t) -> - ('a, 'b) Tcp.Server.t Deferred.t -end - -module type V3 = sig - type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] - [@@deriving sexp] - type ssl_version [@@deriving sexp] - type session [@@deriving sexp_of] - type verify_mode [@@deriving sexp_of] - type ssl_opt [@@deriving sexp] - type ssl_conn [@@deriving sexp_of] - - - module Ssl : sig - module Config : sig - type t [@@deriving sexp_of] - - val create - : ?version:ssl_version - -> ?options:ssl_opt list - -> ?name:string - -> ?hostname:string - -> ?allowed_ciphers:allowed_ciphers - -> ?ca_file:string - -> ?ca_path:string - -> ?crt_file:string - -> ?key_file:string - -> ?session:session - -> ?verify_modes:verify_mode list - -> ?verify:(ssl_conn -> bool Deferred.t) - -> unit - -> t - end - end - - type _ addr = - | OpenSSL : Socket.Address.Inet.t * Ssl.Config.t -> Socket.Address.Inet.t addr - | Inet : Socket.Address.Inet.t -> Socket.Address.Inet.t addr - | Unix : Socket.Address.Unix.t -> Socket.Address.Unix.t addr - [@@deriving sexp_of] - - type _ tcp_sock = - | Inet_sock : - ([`Active], Socket.Address.Inet.t) Socket.t -> - Socket.Address.Inet.t tcp_sock - | Unix_sock : - ([`Active], Socket.Address.Unix.t) Socket.t -> - Socket.Address.Unix.t tcp_sock - - val resolve_uri : - ?options:Unix.Addr_info.getaddrinfo_option list -> Uri.t -> - Socket.Address.Inet.t addr Deferred.t - - val connect - : ?interrupt:unit Deferred.t - -> 'a addr - -> ('a tcp_sock * Reader.t * Writer.t) Deferred.t - - val with_connection - : ?interrupt:unit Deferred.t - -> 'a addr - -> ('a tcp_sock -> Reader.t -> Writer.t -> 'b Deferred.t) - -> 'b Deferred.t - - val connect_uri : - ?options:Unix.Addr_info.getaddrinfo_option list -> - ?interrupt:unit Deferred.t - -> Uri.t - -> (Socket.Address.Inet.t tcp_sock * Reader.t * Writer.t) Deferred.t - - val with_connection_uri : - ?options:Unix.Addr_info.getaddrinfo_option list -> - ?interrupt:unit Deferred.t - -> Uri.t - -> (Socket.Address.Inet.t tcp_sock -> Reader.t -> Writer.t -> 'a Deferred.t) - -> 'a Deferred.t - - type trust_chain = - [ `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] - ] [@@deriving sexp] - - type openssl = - [ `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] - ] [@@deriving sexp] - - type server = [ - | openssl - | `TCP - | `OpenSSL_with_trust_chain of - (openssl * trust_chain) - ] [@@deriving sexp] - - val serve : - ?max_connections:int -> - ?backlog:int -> - ?buffer_age_limit:Writer.buffer_age_limit -> - on_handler_error:[ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit - | `Ignore - | `Raise ] -> - server -> - ('a, 'b) Tcp.Where_to_listen.t -> - ('a -> Reader.t -> Writer.t -> unit Deferred.t) -> - ('a, 'b) Tcp.Server.t Deferred.t -end diff --git a/async/v1.ml b/async/v1.ml deleted file mode 100644 index 836f27af..00000000 --- a/async/v1.ml +++ /dev/null @@ -1,145 +0,0 @@ -open Core -open Async -open Private_ssl.V1 - -type session = Ssl.session [@@deriving sexp] -type ssl_version = Ssl.version [@@deriving sexp] -type ssl_conn = Ssl.connection [@@deriving sexp] - -module Conduit_async = struct - module Ssl = struct - include Ssl - - type nonrec config = Config.t [@@deriving sexp] - let configure = Config.create - let verify_certificate = Config.verify_certificate - end - - type oc = Writer.t - type ic = Reader.t - type 'a io = 'a Deferred.t - - type addr = [ - | `OpenSSL of string * Ipaddr_sexp.t * int - | `OpenSSL_with_config of string * Ipaddr_sexp.t * int * Ssl.config - | `TCP of Ipaddr_sexp.t * int - | `Unix_domain_socket of string - ] [@@deriving sexp] - - let connect ?interrupt dst = - match dst with - | `TCP (ip, port) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp) - >>= fun (_, rd, wr) -> return (rd,wr) - | `OpenSSL (_, ip, port) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp) - >>= fun (_, rd, wr) -> - let config = Ssl.configure () in - Ssl.connect config rd wr - | `OpenSSL_with_config (_, ip, port, config) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp) - >>= fun (_, rd, wr) -> - Ssl.connect config rd wr - | `Unix_domain_socket file -> - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_file file) - >>= fun (_, rd, wr) -> - return (rd,wr) - - let with_connection ?interrupt dst f = - match dst with - | `TCP (ip, port) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_host_and_port endp) - (fun _ rd wr -> f rd wr) - | `OpenSSL (_, ip, port) -> - let config = Ssl.configure () in - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_host_and_port endp) - begin fun _ rd wr -> - Ssl.connect config rd wr >>= fun (rd, wr) -> - Monitor.protect (fun () -> f rd wr) ~finally:begin fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ] - end - end - | `OpenSSL_with_config (_, ip, port, config) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_host_and_port endp) - begin fun _ rd wr -> - Ssl.connect config rd wr >>= fun (rd, wr) -> - Monitor.protect (fun () -> f rd wr) ~finally:begin fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ] - end - end - | `Unix_domain_socket file -> - Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_file file) - (fun _ rd wr -> f rd wr) - - type trust_chain = [ - | `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] - ] [@@deriving sexp] - - type openssl = [ - | `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] - ] [@@deriving sexp] - - type requires_async_ssl = [ - | openssl - | `OpenSSL_with_trust_chain of openssl * trust_chain - ] [@@deriving sexp] - - type server = [ - | `TCP - | requires_async_ssl - ] [@@deriving sexp] - - let serve - ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error mode where_to_listen handle_request = - let handle_client handle_request sock rd wr = - match mode with - | `TCP -> handle_request sock rd wr - | #requires_async_ssl as async_ssl -> - let (crt_file, key_file, ca_file, ca_path) = - match async_ssl with - | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) -> - (crt_file, key_file, None, None) - | `OpenSSL_with_trust_chain - (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain) -> - let (ca_file, ca_path) = - match trust_chain with - | `Ca_file ca_file -> (Some ca_file, None) - | `Ca_path ca_path -> (None, Some ca_path) - | `Search_file_first_then_path (`File ca_file, `Path ca_path) -> - (Some ca_file, Some ca_path) - in - (crt, key, ca_file, ca_path) - in - Ssl.listen - ?ca_file ?ca_path ~crt_file ~key_file rd wr >>= fun (rd,wr) -> - Monitor.protect - (fun () -> handle_request sock rd wr) - ~finally:(fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ]) - in - Tcp.Server.create ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error - where_to_listen (handle_client handle_request) -end - -module Conduit_async_ssl = struct - module Ssl_config = Conduit_async.Ssl - let ssl_connect = Ssl.connect - let ssl_listen = Ssl.listen -end diff --git a/async/v1_dummy.mli b/async/v1_dummy.mli deleted file mode 100644 index 5e3e01ff..00000000 --- a/async/v1_dummy.mli +++ /dev/null @@ -1,4 +0,0 @@ -include S.V1 - with type session = [`Ssl_not_compiled_in] - and type ssl_version = [`Ssl_not_compiled_in] - and type ssl_conn = [`Ssl_not_compiled_in] diff --git a/async/v1_real.mli b/async/v1_real.mli deleted file mode 100644 index 182787d8..00000000 --- a/async/v1_real.mli +++ /dev/null @@ -1,6 +0,0 @@ -open Async_ssl - -include S.V1 - with type session = Ssl.Session.t - and type ssl_version = Ssl.Version.t - and type ssl_conn = Ssl.Connection.t diff --git a/async/v2.ml b/async/v2.ml deleted file mode 100644 index 0a5832f3..00000000 --- a/async/v2.ml +++ /dev/null @@ -1,116 +0,0 @@ -open Core -open Async -open Private_ssl.V2 - -type addr = [ - | `OpenSSL of Ipaddr_sexp.t * int * Ssl.Config.t - | `TCP of Ipaddr_sexp.t * int - | `Unix_domain_socket of string -] [@@deriving sexp_of] - -let connect ?interrupt dst = - match dst with - | `TCP (ip, port) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp) - >>= fun (_, rd, wr) -> return (rd,wr) - | `OpenSSL (ip, port, cfg) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp) - >>= fun (_, rd, wr) -> - Ssl.connect ~cfg rd wr - | `Unix_domain_socket file -> - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_file file) - >>= fun (_, rd, wr) -> - return (rd,wr) - -let with_connection ?interrupt dst f = - match dst with - | `TCP (ip, port) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_host_and_port endp) - (fun _ rd wr -> f rd wr) - | `OpenSSL (ip, port, cfg) -> - let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_host_and_port endp) - begin fun _ rd wr -> - Ssl.connect ~cfg rd wr >>= fun (rd, wr) -> - Monitor.protect (fun () -> f rd wr) ~finally:begin fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ] - end - end - | `Unix_domain_socket file -> - Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_file file) - (fun _ rd wr -> f rd wr) - -type trust_chain = [ - | `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] -] [@@deriving sexp] - -type openssl = [ - | `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] -] [@@deriving sexp] - -type requires_async_ssl = [ - | openssl - | `OpenSSL_with_trust_chain of openssl * trust_chain -] [@@deriving sexp] - -type server = [ - | `TCP - | requires_async_ssl -] [@@deriving sexp] - -let serve - ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error mode where_to_listen handle_request = - let handle_client handle_request sock rd wr = - match mode with - | `TCP -> handle_request sock rd wr - | #requires_async_ssl as async_ssl -> - let (crt_file, key_file, ca_file, ca_path) = - match async_ssl with - | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) -> - (crt_file, key_file, None, None) - | `OpenSSL_with_trust_chain - (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain) -> - let (ca_file, ca_path) = - match trust_chain with - | `Ca_file ca_file -> (Some ca_file, None) - | `Ca_path ca_path -> (None, Some ca_path) - | `Search_file_first_then_path (`File ca_file, `Path ca_path) -> - (Some ca_file, Some ca_path) - in - (crt, key, ca_file, ca_path) - in - let cfg = Ssl.Config.create - ?ca_file ?ca_path ~crt_file ~key_file () in - Ssl.listen cfg rd wr >>= fun (rd,wr) -> - Monitor.protect - (fun () -> handle_request sock rd wr) - ~finally:(fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ]) - in - Tcp.Server.create ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error - where_to_listen (handle_client handle_request) - -type ssl_version = Ssl.version [@@deriving sexp] -type ssl_opt = Ssl.opt [@@deriving sexp] -type ssl_conn = Ssl.connection [@@deriving sexp_of] -type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] -[@@deriving sexp] -type verify_mode = Ssl.verify_mode [@@deriving sexp_of] -type session = Ssl.session [@@deriving sexp_of] -module Ssl = struct - module Config = Ssl.Config -end diff --git a/async/v2_dummy.mli b/async/v2_dummy.mli deleted file mode 100644 index 61a80344..00000000 --- a/async/v2_dummy.mli +++ /dev/null @@ -1,8 +0,0 @@ -include S.V2 - with type session = [`Ssl_not_compiled_in] - and type ssl_version = [`Ssl_not_compiled_in] - and type ssl_conn = [`Ssl_not_compiled_in] - and type ssl_opt = [`Ssl_not_compiled_in] - and type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] - diff --git a/async/v2_real.mli b/async/v2_real.mli deleted file mode 100644 index edd941ba..00000000 --- a/async/v2_real.mli +++ /dev/null @@ -1,9 +0,0 @@ -open Async_ssl -include S.V2 - with type session = Ssl.Session.t - and type ssl_version = Ssl.Version.t - and type ssl_conn = Ssl.Connection.t - and type ssl_opt = Ssl.Opt.t - and type verify_mode = Ssl.Verify_mode.t - and type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] diff --git a/async/v3.ml b/async/v3.ml deleted file mode 100644 index 253f7ac7..00000000 --- a/async/v3.ml +++ /dev/null @@ -1,161 +0,0 @@ -open Core -open Async -open Private_ssl.V2 - -type _ addr = - | OpenSSL : Socket.Address.Inet.t * Ssl.Config.t -> Socket.Address.Inet.t addr - | Inet : Socket.Address.Inet.t -> Socket.Address.Inet.t addr - | Unix : Socket.Address.Unix.t -> Socket.Address.Unix.t addr -[@@deriving sexp_of] - -type _ tcp_sock = - | Inet_sock : - ([`Active], Socket.Address.Inet.t) Socket.t -> - Socket.Address.Inet.t tcp_sock - | Unix_sock : - ([`Active], Socket.Address.Unix.t) Socket.t -> - Socket.Address.Unix.t tcp_sock - -let ssl_schemes = [ - "https" ; - "wss" -] - -let mem_scheme s = - List.mem ssl_schemes ~equal:String.equal s - -let resolve_uri ?(options=[]) uri = - let host = - Option.value_exn - ~here:[%here] - ~message:"no host in URL" (Uri.host uri) in - let service = - match Uri.port uri, Uri_services.tcp_port_of_uri uri with - | Some p, _ -> Some (string_of_int p) - | None, Some p -> Some (string_of_int p) - | _ -> None in - (* Async_extra does not yet support IPv6 *) - let options = (Unix.Addr_info.AI_FAMILY PF_INET) :: options in - Unix.Addr_info.get ~host ?service options >>= function - | [] -> - failwithf "unable to resolve %s" (Uri.to_string uri) () - | { ai_addr; _ } :: _ -> - match Uri.scheme uri, ai_addr with - | _, ADDR_UNIX _ -> - invalid_arg "uri must resolve to inet address" - | Some s, (ADDR_INET (h, p)) when mem_scheme s -> - return (OpenSSL ((`Inet (h, p)), Ssl.Config.create ())) - | _, ADDR_INET (h, p) -> - return (Inet (`Inet (h, p))) - -let connect (type a) ?interrupt (addr: a addr) : - (a tcp_sock * Reader.t * Writer.t) Deferred.t = - match addr with - | Inet addr -> - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_inet_address addr) - >>| fun (s, r, w) -> (Inet_sock s, r, w) - | OpenSSL (addr, cfg) -> - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_inet_address addr) - >>= fun (s, rd, wr) -> Ssl.connect ~cfg rd wr >>| fun (rd, wr) -> - (Inet_sock s, rd, wr) - | Unix addr -> - Tcp.connect ?interrupt (Tcp.Where_to_connect.of_unix_address addr) - >>| fun (s, r, w) -> (Unix_sock s, r, w) - -let with_connection (type a) ?interrupt (addr: a addr) - (f : a tcp_sock -> Reader.t -> Writer.t -> 'a Deferred.t) = - match addr with - | Inet addr -> - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_inet_address addr) - (fun s rd wr -> f (Inet_sock s) rd wr) - | OpenSSL (addr, cfg) -> - Tcp.with_connection ?interrupt - (Tcp.Where_to_connect.of_inet_address addr) - begin fun s rd wr -> - Ssl.connect ~cfg rd wr >>= fun (rd, wr) -> - Monitor.protect (fun () -> f (Inet_sock s) rd wr) ~finally:begin fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ] - end - end - | Unix addr -> - Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_unix_address addr) - (fun s rd wr -> f (Unix_sock s) rd wr) - -let connect_uri ?options ?interrupt uri = - resolve_uri ?options uri >>= fun addr -> - connect ?interrupt addr - -let with_connection_uri ?options ?interrupt uri f = - resolve_uri ?options uri >>= fun addr -> - with_connection ?interrupt addr f - -type trust_chain = [ - | `Ca_file of string - | `Ca_path of string - | `Search_file_first_then_path of - [ `File of string ] * - [ `Path of string ] -] [@@deriving sexp] - -type openssl = [ - | `OpenSSL of - [ `Crt_file_path of string ] * - [ `Key_file_path of string ] -] [@@deriving sexp] - -type requires_async_ssl = [ - | openssl - | `OpenSSL_with_trust_chain of openssl * trust_chain -] [@@deriving sexp] - -type server = [ - | `TCP - | requires_async_ssl -] [@@deriving sexp] - -let serve - ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error mode where_to_listen handle_request = - let handle_client handle_request sock rd wr = - match mode with - | `TCP -> handle_request sock rd wr - | #requires_async_ssl as async_ssl -> - let (crt_file, key_file, ca_file, ca_path) = - match async_ssl with - | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) -> - (crt_file, key_file, None, None) - | `OpenSSL_with_trust_chain - (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain) -> - let (ca_file, ca_path) = - match trust_chain with - | `Ca_file ca_file -> (Some ca_file, None) - | `Ca_path ca_path -> (None, Some ca_path) - | `Search_file_first_then_path (`File ca_file, `Path ca_path) -> - (Some ca_file, Some ca_path) - in - (crt, key, ca_file, ca_path) - in - let cfg = Ssl.Config.create - ?ca_file ?ca_path ~crt_file ~key_file () in - Ssl.listen cfg rd wr >>= fun (rd,wr) -> - Monitor.protect - (fun () -> handle_request sock rd wr) - ~finally:(fun () -> - Deferred.all_unit [ Reader.close rd ; Writer.close wr ]) - in - Tcp.Server.create ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error - where_to_listen (handle_client handle_request) - -type ssl_version = Ssl.version [@@deriving sexp] -type ssl_opt = Ssl.opt [@@deriving sexp] -type ssl_conn = Ssl.connection [@@deriving sexp_of] -type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] -[@@deriving sexp] -type verify_mode = Ssl.verify_mode [@@deriving sexp_of] -type session = Ssl.session [@@deriving sexp_of] -module Ssl = struct - module Config = Ssl.Config -end diff --git a/async/v3_dummy.mli b/async/v3_dummy.mli deleted file mode 100644 index 6e5330fb..00000000 --- a/async/v3_dummy.mli +++ /dev/null @@ -1,8 +0,0 @@ -include S.V3 - with type session = [`Ssl_not_compiled_in] - and type ssl_version = [`Ssl_not_compiled_in] - and type ssl_conn = [`Ssl_not_compiled_in] - and type ssl_opt = [`Ssl_not_compiled_in] - and type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] - diff --git a/async/v3_real.mli b/async/v3_real.mli deleted file mode 100644 index afd4eeb0..00000000 --- a/async/v3_real.mli +++ /dev/null @@ -1,9 +0,0 @@ -open Async_ssl -include S.V3 - with type session = Ssl.Session.t - and type ssl_version = Ssl.Version.t - and type ssl_conn = Ssl.Connection.t - and type ssl_opt = Ssl.Opt.t - and type verify_mode = Ssl.Verify_mode.t - and type allowed_ciphers = - [ `Only of string list | `Openssl_default | `Secure ] From 402b68eb6815ec8554a58bb30a295c4ccaf14097 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 16:50:43 +0200 Subject: [PATCH 011/140] Add a ping-pong server to test conduit-{lwt-unix,async} --- tests/Makefile | 11 -- tests/README.md | 26 +++ tests/async/build.sh | 3 - tests/async/ssl_echo.ml | 61 ------- tests/client0 | 1 + tests/client1 | 1 + tests/client2 | 4 + tests/dune | 52 ++++++ tests/mirage/Makefile | 14 -- tests/mirage/http-fetch/.gitignore | 8 - tests/mirage/http-fetch/config.ml | 11 -- tests/mirage/http-fetch/unikernel.ml | 46 ----- tests/mirage/http-server/.gitignore | 8 - tests/mirage/http-server/config.ml | 10 -- tests/mirage/http-server/unikernel.ml | 30 ---- tests/mirage/simple/dune | 4 - tests/mirage/simple/test.ml | 10 -- tests/mirage/vchan/config_client.ml | 9 - tests/mirage/vchan/config_server.ml | 9 - tests/mirage/vchan/init-xenstore.sh | 6 - tests/mirage/vchan/run.sh | 6 - tests/mirage/vchan/unikernel.ml | 71 -------- tests/ping_pong.ml | 225 +++++++++++++++++++++++++ tests/server.key | 52 ++++++ tests/server.pem | 31 ++++ tests/test_async.ml | 59 +++++++ tests/test_lwt.ml | 57 +++++++ tests/unix/.gitignore | 3 - tests/unix/cdtest.ml | 93 ----------- tests/unix/cdtest_tls.ml | 64 ------- tests/unix/exit_test.ml | 39 ----- tests/unix/gen.sh | 29 ---- tests/unix/server.conf | 22 --- tests/with_async.ml | 232 ++++++++++++++++++++++++++ 34 files changed, 740 insertions(+), 567 deletions(-) delete mode 100644 tests/Makefile create mode 100644 tests/README.md delete mode 100755 tests/async/build.sh delete mode 100644 tests/async/ssl_echo.ml create mode 100644 tests/client0 create mode 100644 tests/client1 create mode 100644 tests/client2 create mode 100644 tests/dune delete mode 100644 tests/mirage/Makefile delete mode 100644 tests/mirage/http-fetch/.gitignore delete mode 100644 tests/mirage/http-fetch/config.ml delete mode 100644 tests/mirage/http-fetch/unikernel.ml delete mode 100644 tests/mirage/http-server/.gitignore delete mode 100644 tests/mirage/http-server/config.ml delete mode 100644 tests/mirage/http-server/unikernel.ml delete mode 100644 tests/mirage/simple/dune delete mode 100644 tests/mirage/simple/test.ml delete mode 100644 tests/mirage/vchan/config_client.ml delete mode 100644 tests/mirage/vchan/config_server.ml delete mode 100755 tests/mirage/vchan/init-xenstore.sh delete mode 100755 tests/mirage/vchan/run.sh delete mode 100644 tests/mirage/vchan/unikernel.ml create mode 100644 tests/ping_pong.ml create mode 100644 tests/server.key create mode 100644 tests/server.pem create mode 100644 tests/test_async.ml create mode 100644 tests/test_lwt.ml delete mode 100644 tests/unix/.gitignore delete mode 100644 tests/unix/cdtest.ml delete mode 100644 tests/unix/cdtest_tls.ml delete mode 100644 tests/unix/exit_test.ml delete mode 100755 tests/unix/gen.sh delete mode 100644 tests/unix/server.conf create mode 100644 tests/with_async.ml diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 index a951fd80..00000000 --- a/tests/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -.PHONY: mirage - -all: mirage - @ - -mirage: - opam install -y mirage - make -C mirage - -async: - make -C async diff --git a/tests/README.md b/tests/README.md new file mode 100644 index 00000000..3545bd40 --- /dev/null +++ b/tests/README.md @@ -0,0 +1,26 @@ +### ping-pong tests + +`ping-pong` wants to test `conduit-lwt-unix`. The process to test it is: +- we start a server which respond with "ping" if it receives "pong" and vice-versa +- we launch many clients to communicate with it + +Currently, `ping-pong` tests: +- a simple TCP/IP server/clients +- a TLS + TCP/IP server/clients +- a SSL + TCP/IP server/clients + +All of these share the same server and the same client implementation. The test shows to +us that the logic of the server/client is independent from the protocol used. + +Finally, where all clients are finished, we stop the server. + +### Async tests + +`with_async` does the same job as `ping_pong` and it ~is~ implemented in the same way than +`ping_pong` but with `async`. The test does not take the advantage of `Reader.t` or `Writer.t` +due to the non-atomicity of `Conduit_async_tls.Protocol.{recv,send}` (see `conduit-tls` for +more details). So we re-use a `getline` implementation as `ping_pong`. + +### Results + +The test wants to show that these programs terminate correctly! diff --git a/tests/async/build.sh b/tests/async/build.sh deleted file mode 100755 index 4660345c..00000000 --- a/tests/async/build.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -corebuild -tag annot -pkgs conduit.async ssl_echo.native diff --git a/tests/async/ssl_echo.ml b/tests/async/ssl_echo.ml deleted file mode 100644 index 97304a71..00000000 --- a/tests/async/ssl_echo.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* - * Copyright (c) 2015 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * -*) - -open Core.Std -open Async.Std - -let handler sock ic oc = - Reader.pipe ic |> fun rd -> - Writer.pipe oc |> fun wr -> - Pipe.transfer_id rd wr - -let determine_mode cert_file_path key_file_path = - (* Determines if the server runs in http or https *) - match (cert_file_path, key_file_path) with - | Some c, Some k -> `OpenSSL (`Crt_file_path c, `Key_file_path k) - | None, None -> `TCP - | _ -> failwith "Error: must specify both certificate and key for TLS" - -let start_server port host cert_file key_file () = - let mode = determine_mode cert_file key_file in - let mode_str = (match mode with `OpenSSL _ -> "OpenSSL" | `TCP -> "TCP") in - printf "Listening for %s requests on: %s %d\n%!" mode_str host port; - Unix.Inet_addr.of_string_or_getbyname host - >>= fun host -> - let listen_on = Tcp.Where_to_listen.create - ~socket_type:Socket.Type.tcp - ~address:(`Inet (host,port)) - ~listening_on:(fun _ -> port) - in - Conduit_async.serve - ~on_handler_error:`Raise - mode - listen_on handler - >>= fun _ -> never () - -let _ = - Command.async_basic - ~summary:"Echo server over SSL" - Command.Spec.( - empty - +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" - +> flag "-s" (optional_with_default "0.0.0.0" string) ~doc:"address IP address to listen on" - +> flag "-cert-file" (optional file) ~doc:"file Certificate file" - +> flag "-key-file" (optional file) ~doc:"File Private key file" - ) start_server - |> Command.run - diff --git a/tests/client0 b/tests/client0 new file mode 100644 index 00000000..f68190ac --- /dev/null +++ b/tests/client0 @@ -0,0 +1 @@ +ping diff --git a/tests/client1 b/tests/client1 new file mode 100644 index 00000000..8e554694 --- /dev/null +++ b/tests/client1 @@ -0,0 +1 @@ +pong diff --git a/tests/client2 b/tests/client2 new file mode 100644 index 00000000..c137d8fe --- /dev/null +++ b/tests/client2 @@ -0,0 +1,4 @@ +ping +ping +pong +ping diff --git a/tests/dune b/tests/dune new file mode 100644 index 00000000..93b5e7c9 --- /dev/null +++ b/tests/dune @@ -0,0 +1,52 @@ +(executable + (name ping_pong) + (modules ping_pong) + (libraries bigstringaf ke fmt rresult fmt.tty logs.fmt + mirage-crypto-rng.unix conduit-lwt-unix.tcp conduit-lwt-unix.tls + conduit-lwt-unix.ssl)) + +(executable + (name with_async) + (modules with_async) + (libraries stdlib-shims bigstringaf ke fmt rresult fmt.tty logs.fmt + mirage-crypto-rng.unix conduit-async.tcp conduit-async.tls + conduit-async.ssl)) + +(executable + (name test_lwt) + (modules test_lwt) + (libraries unix)) + +(rule + (alias runtest) + (package conduit-lwt-unix) + (deps + (:test test_lwt.exe) + ping_pong.exe + server.pem + server.key + client0 + client1 + client2) + (action + (run %{test}))) + +(executable + (name test_async) + (modules test_async) + (libraries unix)) + +(rule + (alias runtest) + (package conduit-async) + (deps + (:test test_async.exe) + ping_pong.exe + with_async.exe + server.pem + server.key + client0 + client1 + client2) + (action + (run %{test}))) diff --git a/tests/mirage/Makefile b/tests/mirage/Makefile deleted file mode 100644 index 69b2f7fe..00000000 --- a/tests/mirage/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -all: http-server-unix http-fetch-unix vchan-client-xen vchan-server-xen - @ - -http-server-unix: - cd http-server && mirage configure -t unix && make - -http-fetch-unix: - cd http-fetch && mirage configure -t unix && make - -vchan-client-xen: - cd vchan && mirage configure -f config_client.ml -t xen && make - -vchan-server-xen: - cd vchan && mirage configure -f config_server.ml -t xen && make diff --git a/tests/mirage/http-fetch/.gitignore b/tests/mirage/http-fetch/.gitignore deleted file mode 100644 index 387ca575..00000000 --- a/tests/mirage/http-fetch/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -Makefile -*.xe -*.xl -_build -main.ml -mir-conduit-client -log -*.xen diff --git a/tests/mirage/http-fetch/config.ml b/tests/mirage/http-fetch/config.ml deleted file mode 100644 index 3db440ad..00000000 --- a/tests/mirage/http-fetch/config.ml +++ /dev/null @@ -1,11 +0,0 @@ -open Mirage - - -let client = - foreign ~deps:[abstract nocrypto] "Unikernel.Client" @@ console @-> stackv4 @-> job - -let () = - register - ~libraries:[ "conduit.lwt"; "conduit.mirage"; "dns.mirage" ] - ~packages:[ "mirage-dns"; "conduit" ] - "conduit-client" [ client $ default_console $ generic_stackv4 default_console tap0 ] diff --git a/tests/mirage/http-fetch/unikernel.ml b/tests/mirage/http-fetch/unikernel.ml deleted file mode 100644 index cd33fcb0..00000000 --- a/tests/mirage/http-fetch/unikernel.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Lwt.Infix -open Mirage_types_lwt -open Printf - -let red fmt = sprintf ("\027[31m"^^fmt^^"\027[m") -let green fmt = sprintf ("\027[32m"^^fmt^^"\027[m") -let yellow fmt = sprintf ("\027[33m"^^fmt^^"\027[m") -let blue fmt = sprintf ("\027[36m"^^fmt^^"\027[m") - -let domain = "anil.recoil.org" -let uri = Uri.of_string "http://anil.recoil.org" -let ns = "8.8.8.8" - -module Client (C:CONSOLE) (S:STACKV4) = struct - - module DNS = Dns_resolver_mirage.Make(OS.Time)(S) - module RES = Resolver_mirage.Make(DNS) - - let mk_conduit s = - let stackv4 = Conduit_mirage.stackv4 (module S) in - Conduit_mirage.with_tcp Conduit_mirage.empty stackv4 s - - let start c stack _ = - C.log_s c (sprintf "Resolving in 3s using DNS server %s" ns) >>= fun () -> - OS.Time.sleep 3.0 >>= fun () -> - let res = Resolver_lwt.init () in - RES.register ~ns:(Ipaddr.V4.of_string_exn ns) ~stack res; - Resolver_lwt.resolve_uri ~uri res >>= fun endp -> - mk_conduit stack >>= fun conduit -> - Conduit_mirage.client endp >>= fun client -> - let endp = Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp) in - C.log_s c endp >>= fun () -> - Conduit_mirage.connect conduit client >>= fun flow -> - let page = Io_page.(to_cstruct (get 1)) in - let http_get = "GET / HTTP/1.1\nHost: anil.recoil.org\n\n" in - Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); - let buf = Cstruct.sub page 0 (String.length http_get) in - Conduit_mirage.Flow.write flow buf >>= function - | `Eof -> C.log_s c "EOF on write" - | `Error _ -> C.log_s c "ERR on write" - | `Ok buf -> Conduit_mirage.Flow.read flow >>= function - | `Eof -> C.log_s c "EOF" - | `Error _ -> C.log_s c "ERR" - | `Ok buf -> C.log_s c (sprintf "OK\n%s\n" (Cstruct.to_string buf)) - -end diff --git a/tests/mirage/http-server/.gitignore b/tests/mirage/http-server/.gitignore deleted file mode 100644 index 7af49d82..00000000 --- a/tests/mirage/http-server/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -Makefile -*.xe -*.xl -_build -main.ml -mir-http-server -log -*.xen diff --git a/tests/mirage/http-server/config.ml b/tests/mirage/http-server/config.ml deleted file mode 100644 index d0a8dc45..00000000 --- a/tests/mirage/http-server/config.ml +++ /dev/null @@ -1,10 +0,0 @@ -open Mirage - -let client = - foreign ~deps:[abstract nocrypto] "Unikernel.Client" @@ console @-> stackv4 @-> job - -let () = - register - ~libraries:[ "conduit.lwt"; "conduit.mirage"; "vchan" ] - "http-server" - [ client $ default_console $ generic_stackv4 default_console tap0 ] diff --git a/tests/mirage/http-server/unikernel.ml b/tests/mirage/http-server/unikernel.ml deleted file mode 100644 index 74be5cb0..00000000 --- a/tests/mirage/http-server/unikernel.ml +++ /dev/null @@ -1,30 +0,0 @@ -open Lwt.Infix -open Mirage_types_lwt -open Printf - -let red fmt = sprintf ("\027[31m"^^fmt^^"\027[m") -let green fmt = sprintf ("\027[32m"^^fmt^^"\027[m") -let yellow fmt = sprintf ("\027[33m"^^fmt^^"\027[m") -let blue fmt = sprintf ("\027[36m"^^fmt^^"\027[m") - -let uri = Uri.of_string "http://localhost" - -module Client (C:CONSOLE) (S:STACKV4) = struct - - let mk_conduit s = - let stackv4 = Conduit_mirage.stackv4 (module S) in - Conduit_mirage.with_tcp Conduit_mirage.empty stackv4 s - - let callback c _flow = - C.log_s c "Connection!" - - let start c stack _ = - let r = Resolver_mirage.localhost in - mk_conduit stack >>= fun conduit -> - Resolver_lwt.resolve_uri ~uri r >>= fun endp -> - Conduit_mirage.server endp >>= fun mode -> - let endp = Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp) in - C.log_s c endp >>= fun () -> - Conduit_mirage.listen conduit mode (callback c) - -end diff --git a/tests/mirage/simple/dune b/tests/mirage/simple/dune deleted file mode 100644 index 9ad161ba..00000000 --- a/tests/mirage/simple/dune +++ /dev/null @@ -1,4 +0,0 @@ -(test - (name test) - (libraries conduit-mirage) - (package conduit-mirage)) diff --git a/tests/mirage/simple/test.ml b/tests/mirage/simple/test.ml deleted file mode 100644 index 59318876..00000000 --- a/tests/mirage/simple/test.ml +++ /dev/null @@ -1,10 +0,0 @@ -(* this is just to test that linking works properly *) - -let client: Conduit_mirage.client = - `TCP (Ipaddr.of_string_exn "127.0.0.1", 12345) - -let server: Conduit_mirage.server = - `TCP 12345 - -let _client () = Conduit_mirage.(connect empty) client -let _server () = Conduit_mirage.(listen empty) server diff --git a/tests/mirage/vchan/config_client.ml b/tests/mirage/vchan/config_client.ml deleted file mode 100644 index b8d5dc24..00000000 --- a/tests/mirage/vchan/config_client.ml +++ /dev/null @@ -1,9 +0,0 @@ -open Mirage - -let main = foreign "Unikernel.Client" (time @-> job) - -let () = - register - ~libraries:["conduit.mirage"; "vchan.xen"] - ~packages:["conduit"; "vchan"] - "vchan_client" [ main $ default_time ] diff --git a/tests/mirage/vchan/config_server.ml b/tests/mirage/vchan/config_server.ml deleted file mode 100644 index 9ff9d520..00000000 --- a/tests/mirage/vchan/config_server.ml +++ /dev/null @@ -1,9 +0,0 @@ -open Mirage - -let main = foreign "Unikernel.Server" (time @-> job) - -let () = - register - ~libraries:["conduit.mirage"; "vchan.xen"] - ~packages:["conduit"; "vchan"] - "vchan_server" [ main $ default_time ] diff --git a/tests/mirage/vchan/init-xenstore.sh b/tests/mirage/vchan/init-xenstore.sh deleted file mode 100755 index c5567479..00000000 --- a/tests/mirage/vchan/init-xenstore.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh -e - -echo Setting up a /conduit path in xenstore -xenstore-rm /conduit -xenstore-write /conduit "" -xenstore-chmod /conduit b0 diff --git a/tests/mirage/vchan/run.sh b/tests/mirage/vchan/run.sh deleted file mode 100755 index 9cad4db9..00000000 --- a/tests/mirage/vchan/run.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -sudo xl destroy vchan_server || true -sudo xl destroy vchan_client || true -sudo ./init-xenstore.sh -./build.sh diff --git a/tests/mirage/vchan/unikernel.ml b/tests/mirage/vchan/unikernel.ml deleted file mode 100644 index ac1fd577..00000000 --- a/tests/mirage/vchan/unikernel.ml +++ /dev/null @@ -1,71 +0,0 @@ -open Lwt.Infix -open Printf - -let conduit = Conduit_mirage.empty -let vchan = Conduit_mirage.vchan (module Vchan_xen) -let xs = Conduit_mirage.xs (module OS.Xs) - -module Server(Time : Mirage_types_lwt.TIME) = struct - - let server_src = Logs.Src.create "server" ~doc:"vchan server" - module Log = (val Logs.src_log server_src : Logs.LOG) - - let start _ = - Conduit_mirage.with_vchan conduit xs vchan "foo_server" >>= fun t -> - Log.info (fun f -> f "Server initialising"); - let callback flow = - Log.info (fun f -> f "Got a new flow!"); - let rec loop () = - Conduit_mirage.Flow.read flow - >>= fun res -> - match res with - | `Ok buf -> - Log.info (fun f -> f "Received: %s" @@ Cstruct.to_string buf); loop () - | `Eof -> - Log.info (fun f -> f "End of transmission!"); Lwt.return_unit - | `Error e -> - Log.warn (fun f -> f "Error reading the vchan flow!"); - Lwt.return_unit - in loop () - in - Conduit_mirage.listen t (`Vchan `Domain_socket) callback - -end - -module Client (Time : Mirage_types_lwt.TIME) = struct - - let client_src = Logs.Src.create "client" ~doc:"vchan client" - module Log = (val Logs.src_log client_src : Logs.LOG) - - let conduit = Conduit_mirage.empty - - let start _t = - Time.sleep 2.0 >>= fun () -> - Conduit_mirage.with_vchan conduit xs vchan "foo_client" >>= fun t -> - Log.info (fun f -> f "Connecting..."); - let client = match Vchan.Port.of_string "flibble" with - | `Ok port -> `Vchan (`Domain_socket ("foo_server", port)) - | `Error e -> failwith e - in - Conduit_mirage.connect t client >>= fun flow -> - Conduit_mirage.sexp_of_client client - |> Sexplib.Sexp.to_string_hum - |> sprintf "Endpoint: %s" - |> (fun s -> Log.info (fun f -> f "%s" s)); - - Log.info (fun f -> f "Client connected"); - let rec write num = - let buf = Io_page.(to_cstruct (get 1)) in - let s = sprintf "num is %d" num in - let len = String.length s in - Cstruct.blit_from_string s 0 buf 0 len; - let buf = Cstruct.sub buf 0 len in - Conduit_mirage.Flow.write flow buf - >>= function - |`Eof -> Log.info (fun f -> f "EOF"); Time.sleep 5. - |`Error _ -> Log.warn (fun f -> f "ERR"); Time.sleep 5. - |`Ok () -> Time.sleep 0.1 >>= fun () -> write (num+1) - in - write 0 - -end diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml new file mode 100644 index 00000000..ced9b30d --- /dev/null +++ b/tests/ping_pong.ml @@ -0,0 +1,225 @@ +open Rresult +open Lwt.Infix + +let () = Mirage_crypto_rng_unix.initialize () + +let () = Printexc.record_backtrace true + +let () = Ssl.init () + +let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Lwt.return err + +let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt + +let localhost = Domain_name.(host_exn (of_string_exn "localhost")) + +(* Server part *) + +let getline queue = + let exists ~predicate queue = + let pos = ref 0 and res = ref (-1) in + Ke.Rke.iter + (fun chr -> + if predicate chr then res := !pos ; + incr pos) + queue ; + if !res = -1 then None else Some !res in + let blit src src_off dst dst_off len = + Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in + match exists ~predicate:(( = ) '\n') queue with + | Some pos -> + let tmp = Bytes.create pos in + Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; + Ke.Rke.N.shift_exn queue (pos + 1) ; + Some (Bytes.unsafe_to_string tmp) + | None -> None + +let getline queue flow = + let tmp = Cstruct.create 0x1000 in + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len in + let rec go () = + match getline queue with + | Some line -> Lwt.return_ok (`Line line) + | None -> ( + Conduit_lwt.recv flow tmp >>? function + | `End_of_input -> Lwt.return_ok `Close + | `Input len -> + Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; + go ()) in + go () + +let pong = Cstruct.of_string "pong\n" + +let ping = Cstruct.of_string "ping\n" + +let transmission flow = + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let rec go () = + getline queue flow >>= function + | Ok `Close | Error _ -> Conduit_lwt.close flow + | Ok (`Line "ping") -> + Fmt.epr "[!] received ping.\n%!" ; + Conduit_lwt.send flow pong >>? fun _ -> go () + | Ok (`Line "pong") -> + Fmt.epr "[!] received pong.\n%!" ; + Conduit_lwt.send flow ping >>? fun _ -> go () + | Ok (`Line line) -> + Fmt.epr "[!] received %S.\n%!" line ; + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_lwt.close flow in + go () >>= function + | Error err -> failwith "%a" Conduit_lwt.pp_error err + | Ok () -> Lwt.return () + +let server : + type cfg master flow. + key:cfg Conduit_lwt.key -> + cfg -> + service:(master * flow) Conduit_lwt.Witness.service -> + unit Lwt_condition.t * unit Lwt.t = + fun ~key cfg ~service -> + Conduit_lwt_unix.serve_with_handler + ~handler:(fun protocol flow -> + transmission (Conduit_lwt_unix.abstract protocol flow)) + ~key ~service cfg + +(* Client part *) + +let client ?key ~resolvers domain_name responses = + Conduit_lwt.flow ?key resolvers domain_name >>? fun flow -> + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let rec go = function + | [] -> Conduit_lwt.close flow + | line :: rest -> ( + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + getline queue flow >>? function + | `Close -> Conduit_lwt.close flow + | `Line "pong" -> go rest + | `Line _ -> Conduit_lwt.close flow) in + go responses + +let client ?key ~resolvers filename = + let rec go acc ic = + match input_line ic with + | line -> go (line :: acc) ic + | exception End_of_file -> List.rev acc in + let ic = open_in filename in + let responses = go [] ic in + close_in ic ; + client ?key ~resolvers localhost responses >>= function + | Ok () -> Lwt.return_unit + | Error `Closed_by_peer -> Lwt.return_unit + | Error (#Conduit_lwt.error as err) -> + Fmt.epr "client: %a.\n%!" Conduit_lwt.pp_error err ; + Lwt.return_unit + +(* Composition *) + +let tls_endpoint, tls_protocol, tls_configuration, tls_service = + let open Conduit_lwt_unix_tls.TCP in + (endpoint, protocol, configuration, service) + +let ssl_endpoint, ssl_protocol, ssl_configuration, ssl_service = + let open Conduit_lwt_unix_ssl.TCP in + (endpoint, protocol, configuration, service) + +(* Resolution *) + +let resolve_ping_pong = Conduit_lwt_unix_tcp.resolv_conf ~port:4000 + +let resolve_tls_ping_pong = + let null ~host:_ _ = Ok None in + let config = Tls.Config.client ~authenticator:null () in + Conduit_lwt_unix_tls.TCP.resolv_conf ~port:8000 ~config + +let resolve_ssl_ping_pong = + let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in + Conduit_lwt_unix_ssl.TCP.resolv_conf ~port:6000 ~context ?verify:None + +let resolvers = + Conduit.empty + |> Conduit_lwt.register_resolver ~priority:20 + ~key:Conduit_lwt_unix_tcp.endpoint resolve_ping_pong + |> Conduit_lwt.register_resolver ~priority:10 ~key:tls_endpoint + resolve_tls_ping_pong + |> Conduit_lwt.register_resolver ~priority:10 ~key:ssl_endpoint + resolve_ssl_ping_pong + +(* Run *) + +let load_file filename = + let ic = open_in filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + really_input ic rs 0 ln ; + close_in ic ; + Cstruct.of_bytes rs + +let config cert key = + let cert = load_file cert in + let key = load_file key in + match + (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key) + with + | Ok certs, Ok (`RSA key) -> + Tls.Config.server ~certificates:(`Single (certs, key)) () + | _ -> Fmt.failwith "Invalid key or certificate" + +let run_with : + type edn cfg master flow. + ?key_edn:edn Conduit_lwt.key -> + key_cfg:cfg Conduit_lwt.key -> + cfg -> + service:(master * flow) Conduit_lwt.Witness.service -> + string list -> + unit = + fun ?key_edn ~key_cfg cfg ~service clients -> + let stop, server = server ~key:key_cfg cfg ~service in + let clients = List.map (client ?key:key_edn ~resolvers) clients in + let clients = + Lwt.join clients >>= fun () -> + Lwt_condition.broadcast stop () ; + Lwt.return_unit in + Lwt_main.run (Lwt.join [ server; clients ]) + +let run_with_tcp clients = + run_with ~key_cfg:Conduit_lwt_unix_tcp.configuration + { + Conduit_lwt_unix_tcp.sockaddr = + Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); + capacity = 40; + } + ~service:Conduit_lwt_unix_tcp.service clients + +let run_with_ssl cert key clients = + let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Server_context in + Ssl.use_certificate ctx cert key ; + run_with ~key_cfg:ssl_configuration + ( ctx, + { + Conduit_lwt_unix_tcp.sockaddr = + Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); + capacity = 40; + } ) + ~service:ssl_service clients + +let run_with_tls cert key clients = + let ctx = config cert key in + run_with ~key_edn:tls_endpoint ~key_cfg:tls_configuration + ( { + Conduit_lwt_unix_tcp.sockaddr = + Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); + capacity = 40; + }, + ctx ) + ~service:tls_service clients + +let () = + match Array.to_list Sys.argv with + | _ :: "--with-tls" :: cert :: key :: clients -> run_with_tls cert key clients + | _ :: "--with-ssl" :: cert :: key :: clients -> run_with_ssl cert key clients + | _ :: clients -> run_with_tcp clients + | _ -> Fmt.epr "%s [--with-tls|--with-ssl] filename...\n%!" Sys.argv.(0) diff --git a/tests/server.key b/tests/server.key new file mode 100644 index 00000000..a5fe9dd8 --- /dev/null +++ b/tests/server.key @@ -0,0 +1,52 @@ +-----BEGIN PRIVATE KEY----- +MIIJQgIBADANBgkqhkiG9w0BAQEFAASCCSwwggkoAgEAAoICAQDH0wujx/xJwPRC +uYbunbqb8gpIQT2UCgdEq8x1AFX1d0LJ2EESzNbMqGTkfnkHmBCsUFr16/sjEBR7 +lxgYpVe72t0lv3q/yfe3302Y8R2b5H7mQJL799b81Y3XCZPurr+mi55cKbz40bIg +nRIVWr3w/pVo84BTjz4o5PwUvmANx9P/Fj5PAgO2sC8h6j2CKSCJXnmA7eQs9B0l +DmHLji7iS7TsaUJD4TM3vtCcw9wzR01dpszBVaxDnc7ijDoCTCs6eNab0Hf4GkJv +GyFunHOIznXvmoFLelyJjnfww3TcRDNnYWE2erT5XG2tUy9fZyjdMPu0drGT21eh +vtPktpV8RqLtxd9Mmipip5WCWT2KDQmMdbSUEHYNaqTQ97mmQZAtjS9XUKH2oj2T +uYKFCoa+KcSJ+jBNOCmkzR5/wMQwQVk9QUtrWgYFkylvgqdHtuCb5thMyNZ7xS6Y +KRDD/kI+1XQbdL1d266wL756ytYjVApOm+klhB5SJZNlNiY+SE8UzypIdwg/rR1X +T8wBa8mUBJ14CyoNWBXrCXO3m7Tnf4ubJZjhl1EAQV01/dfjciqBHOMsOxCLdPr5 +Gep2WwQCbgYlDCFOp8owdntILsoVIBkmsM844ASOLuwuzxEcwZGfNrElBubh4Uj0 +YcptCFeFb3eW1NQ+r4/u5h1+qhxC8QIDAQABAoICAB9HrzPFM34MIXBsgG3L7RFK +U0e6Rrxs0XRzfD74fXw+XgsguhcKT7mbxqdqEOIacMm4jnSeqyJy+vHZ1iDNiS1T +9nhZQArTv95dq1T8sYjcvOyoQRoGUvYjK9/0lN6xJjkY9AIzWmyMztiCHfmPydn2 +0Easj3MFIlLefYN1xa2CkXIF9l0B0LkBXW9urpA4hepbCqQfGS/cSs+pL6/gowAz +n6++Tmw3zX+1dAyGMGsqhzbYzIabNaskAeW+07nWWJH/poCfopgI7EteMN6SyRcq +UpXeVs0M631w+t+KiTmNx4owWTpg/QFn8ZdHRUwm5uOxLkWyqtudY1tjduH/nuid +T8zZ+V8dYpWvAdSwURfoz4fOuuCAvwtTxyLhjhvWaioHNdDIuIiGMyv2cOea0OZ8 +mtF6pPXdThV9741WgzsUSCn7do93ebfMjqW54M2ztySGnbEPNQkQGuigtrCmZS1y +FHOkUKaHaS0vHPgUKCFLXihYr+n3+JS4Hr0F+0XieV9PFELasKvskCJCYXtfVc0E +EDxL0jzbaHAgWZ6JPclfa/dl4E3HlYOoBHj/cqCmGStu/Qz07JcAuE3EL94SaXpV +FN9tgntQRvbYAmW41qqkvPIr32WFGEuAKYVQfDnmZiRWfpu8dRAgNRc5gZvXYlXF +1WOH3wRpco44K784i4gBAoIBAQD1IM4WqFCD7DtBkPV08LN4MVablibPStoJF3qh +pXFwcCXBQpvAPi0oizaEVeENZy0+A6yYkU0UlEtUny238zZjq9MzgXl9ZpjYFLTE +CP0JIdJ+q614gvE8DSs1I+IS86HhWqCwcyAsHGEM6pwG9vb7/sQG+L9g4nYwYFBh +0jRlRHquFaMMZr5pNEz0+B0a5OW36yXDcRIaXvAu1WEZsAwh9hzXZIvadV+4vr// +ju95Imt0npAZ9X7E2LoPXz9+h+nkKiRPQwz1dHut9/xVmv6j1vO4opoldoNoBx0G +eYkxR7leCCdFotS4FnYifML7Pu82QtV47LhKTDsbTxptLa6BAoIBAQDQr9wdjfI2 +F1lkFWByEUsEjSJbT+ES9z7KElLzQzWT0FedNx6qrt3YIQ39SAnhtid0N7EzpTns +1hWe//MvDl9Qm6pk0FWs+0W/CZfSPmFS3iXEP37TmvoTQAAjoP09yIp01pXsFXfA +Zc1FD24Lzt4AeKVizPLHkK8/jNYT7Yg72GAs61/YydCWVLhYFtlKgDVgmnTqG6Gk +JHA90NjYM3SAT6ClTN98JUjO4qizghHTAbVIO+1ndiHkFGjmuCyl8nuKdAITYopk +jBPIW21OLqBrWahn8+P2hfE2gx1DGezITwUY8TOUFGZ2pesOMtr16N8VhKxEQnL+ +tKBJBdqWDDxxAoIBABZmkg7GAN2dZ+jc+2FdYbk5IQYE2bUVzQkJqT4+ZTh2Ny0L +DjqqM+xBlJDRXEiiRiMlqM8kcBvSVXP9O+tUgYLoP9u0GEsaZhtRARftDlqYSakj +vS2HIc5wEaPAjLdYplF2u7qEOsttKH1Kr0l/piBvLrDIaIzNBSn0k0PtNraOZHum +JIlMllf83I+CYP6FLmz5QzEyEwpv5JkTDNWRHfq4h/gzCwjCsyWp4NfU0xOJzrIQ +j3Cf257Xg2FGPgItH3WnWDwaD4Qayfai899K07xbN1iHG3kS9H08MS3XS29Cc7Eh +I52cfL3553/NUPAu1yNpRiLP1yOLBdfACdUyWIECggEBALVl2DjcdQktvKcxqbcd +bw8SuyWSRrvcrPireu03o6/L7wyaqA6HmBDRkr5ySxym4J619lNFMRe8c+jU5Qcn +QBTqau/c5ExL0rGfXhgD30dQEJYI925qjSwEetp9iwOUeT3cdU9UzdYw54A7TFX5 +SKIyPNin+/UawCrGeiOyWrRifh8trg/cRXMXS3JO0ixfS4agXDZPNG9guSwSiRtN +htwt2x80tiLMqgAjp675xhKbrn+Oj+taFVWTpCfBOhY5s8eC1XcSNef2lw+W4WmP +QCRwN+G8b5CPlz/iMqJsO5VWksC+kS4LmZFS4gJilFAjTx7+R1vCQwFB8v3ml73L +/xECggEAQkjyRh/IgJ3qMxfTT2CEeXm02EBY7sEaG/V1h2w+r8UC5imniYMefcns +R4vGY0v297iZTg+A3NBQW2Jw6u2mRUfMwaYfPaB0VytBF+/NwyB6ImDMEdR3is0n +S8xRYW4vHqQDsklP2wcrYcPa+MV+1KH2MpMDZRnwZ1zCfS3NH+kUFWrqnaEwXDJ6 +mF9fvE55hlU54GpOVt1PkIKhKv2Xl3QCqQclKX+9PXanw5C1PzocKHFEmdfVl1ZQ +cVuNb/KBApj5YUqpBqzBGi05KKvUPawSfoAo9s/q6c39s1WfQgMXYQ49k+3dNXsg +PYPA18b24ktXr5fHD0VgvdrbqvHJ7A== +-----END PRIVATE KEY----- diff --git a/tests/server.pem b/tests/server.pem new file mode 100644 index 00000000..f0d0c86d --- /dev/null +++ b/tests/server.pem @@ -0,0 +1,31 @@ +-----BEGIN CERTIFICATE----- +MIIFXTCCA0WgAwIBAgIJAKZsnNfIIm8KMA0GCSqGSIb3DQEBCwUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMjAwNTA0MjIwMDA2WhcNMjEwNTA0MjIwMDA2WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIIC +CgKCAgEAx9MLo8f8ScD0QrmG7p26m/IKSEE9lAoHRKvMdQBV9XdCydhBEszWzKhk +5H55B5gQrFBa9ev7IxAUe5cYGKVXu9rdJb96v8n3t99NmPEdm+R+5kCS+/fW/NWN +1wmT7q6/poueXCm8+NGyIJ0SFVq98P6VaPOAU48+KOT8FL5gDcfT/xY+TwIDtrAv +Ieo9gikgiV55gO3kLPQdJQ5hy44u4ku07GlCQ+EzN77QnMPcM0dNXabMwVWsQ53O +4ow6AkwrOnjWm9B3+BpCbxshbpxziM5175qBS3pciY538MN03EQzZ2FhNnq0+Vxt +rVMvX2co3TD7tHaxk9tXob7T5LaVfEai7cXfTJoqYqeVglk9ig0JjHW0lBB2DWqk +0Pe5pkGQLY0vV1Ch9qI9k7mChQqGvinEifowTTgppM0ef8DEMEFZPUFLa1oGBZMp +b4KnR7bgm+bYTMjWe8UumCkQw/5CPtV0G3S9XduusC++esrWI1QKTpvpJYQeUiWT +ZTYmPkhPFM8qSHcIP60dV0/MAWvJlASdeAsqDVgV6wlzt5u053+LmyWY4ZdRAEFd +Nf3X43IqgRzjLDsQi3T6+RnqdlsEAm4GJQwhTqfKMHZ7SC7KFSAZJrDPOOAEji7s +Ls8RHMGRnzaxJQbm4eFI9GHKbQhXhW93ltTUPq+P7uYdfqocQvECAwEAAaNQME4w +HQYDVR0OBBYEFFm3ApOQ1cvc0KGGp8m+/QxpVxMzMB8GA1UdIwQYMBaAFFm3ApOQ +1cvc0KGGp8m+/QxpVxMzMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQELBQADggIB +ALHpIO41UbbSDgG/TNWxVcDG15056vHJ2biCjw5fH+ztkwhydXdOtdTgNcGGXDqT +rxqE1KjpIcuPYwfN81lgzhZK2OSVjsq89G8TuVy5tiTtNkDRe+okbTIiSeLA4TOd +KjR3GZq4zFZiq8/cpbtjkIHltJrhn4Fmu4a8oXSkDypt+/9+zfReuMKN0Id/yNNv +QDtjGqRvASbwy2f0OpSRga9gwugbqP90SJKCBMJwtN8UgJu3ng+mz8hDPCNZr7DD +05UMA7HDllwEElhbasWdEoLE2WmBDD6mkbk+D6Ox9DmucskA15cidM5B2SF/DCJU ++OE/r0IwI+Ws7YsjVgqFkAflbQLYbDEBsXmgHyD2Z6hXwHbgXEoZ94ud2afzzPR6 +tJPgdMuaK0WzVxEX9Q2CvGaLfyX9ugIjqi6h2Y5CMOfwdGRP+q7/QSsm2wSmE1Kc +Qo1O7iC00DrEOE0/1BmIWMybMu81Z73wDNsMaL/pbKYQPEIEm2O91ssBNXRvmHi7 +05mBCLX/IbMjWVHwgtUbvBzuIB5dO81Iw+n2jRmLLM64krJkEfjXNVHWi+n5jlRu +IXkntxF0yvnLgr5CusDTm8oTwGSKpa5mLrtGtmce3n7hFAVE4KtkC+Tti7L8Sa0E +Vwjx0D4AcvTVI8z8h/wJu7lU4TQLiBPGQC9THcOLEXHO +-----END CERTIFICATE----- diff --git a/tests/test_async.ml b/tests/test_async.ml new file mode 100644 index 00000000..70aaff8d --- /dev/null +++ b/tests/test_async.ml @@ -0,0 +1,59 @@ +(* XXX(dinosaure): we serialize tests by ourselves! *) + +let pp_process_status ppf = function + | Unix.WEXITED n -> Format.fprintf ppf "(WEXITED %d)" n + | Unix.WSIGNALED n -> Format.fprintf ppf "(WSIGNALED %d)" n + | Unix.WSTOPPED n -> Format.fprintf ppf "(WSTOPPED %d)" n + +let res = ref true + +let exit_success = 0 + +let exit_failure = 1 + +let properly_exited = function Unix.WEXITED 0 -> true | _ -> false + +let () = + let pid = + Unix.create_process_env "./with_async.exe" + [| "./with_async.exe"; "client0"; "client1"; "client2" |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> with_async.exe: %a.\n%!" pp_process_status status ; + + let pid = + Unix.create_process_env "./with_async.exe" + [| + "./with_async.exe"; + "--with-ssl"; + "server.pem"; + "server.key"; + "client0"; + "client1"; + "client2"; + |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> with_async.exe --with-ssl: %a.\n%!" pp_process_status + status ; + + let pid = + Unix.create_process_env "./with_async.exe" + [| + "./with_async.exe"; + "--with-tls"; + "server.pem"; + "server.key"; + "client0"; + "client1"; + "client2"; + |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> with_async.exe --with-tls: %a.\n%!" pp_process_status + status ; + + if !res then exit exit_success else exit exit_failure diff --git a/tests/test_lwt.ml b/tests/test_lwt.ml new file mode 100644 index 00000000..c8bd28e6 --- /dev/null +++ b/tests/test_lwt.ml @@ -0,0 +1,57 @@ +(* XXX(dinosaure): we serialize tests by ourselves! *) + +let pp_process_status ppf = function + | Unix.WEXITED n -> Format.fprintf ppf "(WEXITED %d)" n + | Unix.WSIGNALED n -> Format.fprintf ppf "(WSIGNALED %d)" n + | Unix.WSTOPPED n -> Format.fprintf ppf "(WSTOPPED %d)" n + +let res = ref true + +let exit_success = 0 + +let exit_failure = 1 + +let properly_exited = function Unix.WEXITED 0 -> true | _ -> false + +let () = + let pid = + Unix.create_process_env "./ping_pong.exe" + [| "./ping_pong.exe"; "client0"; "client1"; "client2" |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> ping_pong.exe: %a.\n%!" pp_process_status status ; + + let pid = + Unix.create_process_env "./ping_pong.exe" + [| + "./ping_pong.exe"; + "--with-ssl"; + "server.pem"; + "server.key"; + "client0"; + "client1"; + "client2"; + |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> ping_pong.exe --with-ssl: %a.\n%!" pp_process_status status ; + + let pid = + Unix.create_process_env "./ping_pong.exe" + [| + "./ping_pong.exe"; + "--with-tls"; + "server.pem"; + "server.key"; + "client0"; + "client1"; + "client2"; + |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> ping_pong.exe --with-tls: %a.\n%!" pp_process_status status ; + + if !res then exit exit_success else exit exit_failure diff --git a/tests/unix/.gitignore b/tests/unix/.gitignore deleted file mode 100644 index edc345e6..00000000 --- a/tests/unix/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -server.conf -server.key -server.pem diff --git a/tests/unix/cdtest.ml b/tests/unix/cdtest.ml deleted file mode 100644 index c98365f4..00000000 --- a/tests/unix/cdtest.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* - * Copyright (c) 2016 Skylable Ltd. - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -*) - -open Lwt.Infix - -let port = - Random.self_init (); - 16_384 + Random.int 10_000 - -let config = `Crt_file_path "server.pem", `Key_file_path "server.key", `No_password, `Port port - -let rec repeat n f = - if n = 0 then Lwt.return_unit - else f () >>= fun () -> repeat (n-1) f - -let perform () = - let stop, do_stop = Lwt.wait () in - Conduit_lwt_unix.init ~src:"127.0.0.1" () >>= fun ctx -> - let _ = - Conduit_lwt_unix.serve ~stop ~ctx ~mode:(`TLS config) (fun _ ic oc -> - Lwt_io.read ic >>= fun _ -> Lwt_io.write oc "foo" >>= fun () -> Lwt_io.flush oc) - in - let sa = Unix.ADDR_INET (Unix.inet_addr_loopback, port) in - let wait, wake = Lwt.task () in - let active = ref 0 in - let cond = Lwt_condition.create () in - let client_test_wait timeout wait = - (* connect using low-level operations to check what happens if client closes connection - without calling ssl_shutdown (e.g. TCP connection is lost) *) - let s = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in - Lwt_unix.with_timeout timeout (fun () -> - Lwt.finalize (fun () -> - Lwt_unix.connect s sa >>= fun () -> - Lwt_ssl.ssl_connect s ctx >>= fun ss -> - incr active; - Lwt_condition.signal cond (); - wait) - (fun () -> Lwt_unix.close s)) - in - let client_test _ = client_test_wait 1. Lwt.return_unit in - let limit = 5 in - - Conduit_lwt_unix.set_max_active limit; - (* when clients = max_active no more clients are allowed and some get errors, - * use a higher timeout here so that all these connections are still active - * when doing the 2nd test below *) - let t = Array.init limit (fun _ -> client_test_wait 10. wait) |> Array.to_list |> Lwt.join in - Lwt.catch (fun () -> - (* wait for all 5 threads to connect *) - let rec wait_all_conn () = - Lwt_condition.wait cond >>= fun () -> - if !active < limit then wait_all_conn () - else Lwt.return_unit in - wait_all_conn () >>= fun () -> - print_endline "Waiting for error"; - (* use a lower timeout here, these should fail immediately *) - Array.init (2*limit) client_test |> Array.to_list |> Lwt.pick >>= fun () -> - prerr_endline "Expected errors, but got none"; - exit 2 - ) - (fun _exn -> - print_endline "Waking up connections"; - Lwt.wakeup wake (); - Lwt.catch (fun () -> t) (fun _ -> Lwt.return_unit) >>= fun () -> - print_endline "Opening more connections"; - (* clients can connect again, handled in batches of 5 *) - Array.init 10 client_test |> Array.to_list |> Lwt.join - ) >>= fun () -> - print_endline "Running single connection leak test"; - repeat 1024 client_test >>= fun () -> - Lwt.wakeup do_stop (); - Lwt.return_unit - -let () = - Lwt.async_exception_hook := ignore; - Sys.(set_signal sigpipe Signal_ignore); - Lwt_main.run (Lwt_unix.with_timeout 60. (fun () -> - Lwt_unix.handle_unix_error perform ())); - print_endline "OK" diff --git a/tests/unix/cdtest_tls.ml b/tests/unix/cdtest_tls.ml deleted file mode 100644 index a2281c67..00000000 --- a/tests/unix/cdtest_tls.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* - * Copyright (c) 2016 Skylable Ltd. - * Copyright (c) 2016 Vincent Bernardoff - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -*) - -open Lwt.Infix - -let port = - Random.self_init (); - 16_384 + Random.int 10_000 - -let config = `Crt_file_path "server.pem", `Key_file_path "server.key", `No_password, `Port port - -let rec repeat n f = - if n = 0 then Lwt.return_unit - else f () >>= fun () -> repeat (n-1) f - -let perform () = - let stop, do_stop = Lwt.wait () in - Conduit_lwt_unix.init ~src:"::1" () >>= fun ctx -> - let serve () = - Conduit_lwt_unix.serve ~stop ~ctx ~mode:(`TLS config) begin fun _flow ic oc -> - Lwt_log.notice "Server: Callback started." >>= fun () -> - Lwt_io.read ~count:5 ic >>= fun msg -> - Lwt_log.notice "Server: read hello." >>= fun () -> - Lwt_io.write oc "foo" - end - in - let client_test () = - (* connect using low-level operations to check what happens if client closes connection - without calling ssl_shutdown (e.g. TCP connection is lost) *) - let client = `TLS (`Hostname "", `IP Ipaddr.(V6 V6.localhost), `Port port) in - Conduit_lwt_unix.(connect ~ctx:default_ctx client) >>= fun (_flow, ic, oc) -> - Lwt_log.notice "Connected!" >>= fun () -> - Lwt_io.write oc "hello" >>= fun () -> - Lwt_log.notice "Written hello." >>= fun () -> - Lwt_io.read ic ~count:3 >>= fun msg -> - Lwt_log.notice "Got correct msg, disconnecting." >>= fun () -> - Lwt_io.close ic - in - Lwt.async serve; - Lwt_unix.sleep 1. >>= fun () -> - Lwt_log.notice_f "Server running on port %d" port >>= fun () -> - repeat 10 client_test >>= fun () -> - Lwt.wakeup do_stop (); - Lwt.return_unit - -let () = - Lwt.async_exception_hook := ignore; - Sys.(set_signal sigpipe Signal_ignore); - Lwt_main.run (Lwt_unix.handle_unix_error perform ()); - print_endline "OK" diff --git a/tests/unix/exit_test.ml b/tests/unix/exit_test.ml deleted file mode 100644 index 58b4be95..00000000 --- a/tests/unix/exit_test.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* - * Copyright (c) 2016 Vincent Bernardoff - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -*) - -open Lwt.Infix - -let perform () = - let stop, do_stop = Lwt.wait () in - Conduit_lwt_unix.init ~src:"::1" () >>= fun ctx -> - let serve () = - let callback _flow ic oc = - Lwt_io.read ~count:5 ic >>= fun msg -> - Lwt_io.write oc "foo" - in - Conduit_lwt_unix.serve ~stop ~ctx ~mode:(`TCP (`Port 8080)) callback - in - let handle = serve () in - Lwt.async (fun () -> (Lwt_unix.sleep 0.2 >|= Lwt.wakeup do_stop)); - handle - -let () = - Lwt.async_exception_hook := ignore; - let t_start = Unix.gettimeofday () in - Lwt_main.run (Lwt_unix.handle_unix_error perform ()); - let t_end = Unix.gettimeofday () in - if (t_end -. t_start > 0.15) then Printf.printf "OK %.3f\n" (t_end -. t_start) - else Printf.printf "FAILED %.3f (must be > 0.2)" (t_end -. t_start) diff --git a/tests/unix/gen.sh b/tests/unix/gen.sh deleted file mode 100755 index 82bd86ab..00000000 --- a/tests/unix/gen.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/sh -set -e -set -o nounset -cat >server.conf <>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Async.return err + +let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt + +let getline queue = + let exists ~predicate queue = + let pos = ref 0 and res = ref (-1) in + Ke.Rke.iter + (fun chr -> + if predicate chr then res := !pos ; + incr pos) + queue ; + if !res = -1 then None else Some !res in + let blit src src_off dst dst_off len = + Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in + match exists ~predicate:(( = ) '\n') queue with + | Some pos -> + let tmp = Bytes.create pos in + Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; + Ke.Rke.N.shift_exn queue (pos + 1) ; + Some (Bytes.unsafe_to_string tmp) + | None -> None + +let getline queue flow = + let tmp = Cstruct.create 0x1000 in + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len in + let rec go () = + match getline queue with + | Some line -> Async.return (Ok (`Line line)) + | None -> ( + Conduit_async.recv flow tmp >>? function + | `End_of_input -> Async.return (Ok `Close) + | `Input len -> + Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; + go ()) in + go () + +let pong = Cstruct.of_string "pong\n" + +let ping = Cstruct.of_string "ping\n" + +let transmission ~stop flow = + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.Char in + let rec go () = + let finish = Condition.wait stop >>= fun () -> Async.return (Ok `Done) in + let getline = getline queue flow in + Async.Deferred.any [ finish; getline ] >>= function + | Ok (`Done | `Close) | Error _ -> Conduit_async.close flow + | Ok (`Line "ping") -> + Format.eprintf "[!] received ping.\n%!" ; + Conduit_async.send flow pong >>? fun _ -> go () + | Ok (`Line "pong") -> + Format.eprintf "[!] received pong.\n%!" ; + Conduit_async.send flow ping >>? fun _ -> go () + | Ok (`Line line) -> + Format.eprintf "[!] received %S.\n%!" line ; + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_async.close flow in + go () >>= function + | Error err -> failwith "%a" Conduit_async.pp_error err + | Ok () -> Async.return () + +let server : + type edn master flow. + launched:unit Async.Condition.t -> + stop:unit Async.Condition.t -> + key:edn Conduit_async.key -> + edn -> + service:(master * flow) Conduit_async.Witness.service -> + unit Async.Deferred.t = + fun ~launched ~stop ~key edn ~service -> + let main () = + Conduit_async.impl_of_service ~key service |> Async.return + >>? fun (module Server) -> + let reword_error = R.reword_error (R.msgf "%a" Server.pp_error) in + Conduit_async.serve ~key edn ~service >>? fun (master, protocol) -> + Condition.signal launched () ; + + let rec go () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Closed in + let accept = + Server.accept master >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in + + Async.Deferred.any [ close; accept ] >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for + (transmission ~stop (Conduit_async.abstract protocol flow)) ; + Async.Scheduler.yield () >>= go + | Ok `Closed -> Server.close master + | Error _ as err -> Server.close master >>= fun _ -> Async.return err + in + go () >>| reword_error in + main () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Conduit_async.pp_error err + +let client ?key ~resolvers domain_name responses = + Conduit_async.flow ?key resolvers domain_name >>? fun flow -> + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let rec go = function + | [] -> Conduit_async.close flow + | line :: rest -> ( + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + getline queue flow >>? function + | `Close -> Conduit_async.close flow + | `Line "pong" -> go rest + | `Line _ -> Conduit_async.close flow) in + go responses + +let client ?key ~resolvers domain_name filename = + let rec go acc ic = + match Stdlib.input_line ic with + | line -> go (line :: acc) ic + | exception End_of_file -> List.rev acc in + let ic = Stdlib.open_in filename in + let responses = go [] ic in + Stdlib.close_in ic ; + client ?key ~resolvers domain_name responses >>= function + | Ok () -> Async.return () + | Error (#Conduit_async.error as err) -> + failwith "Client got an error: %a" Conduit_async.pp_error err + +let resolve_ping_pong = Conduit_async_tcp.resolv_conf ~port:5000 + +let resolve_ssl_ping_pong = + let context = + Conduit_async_ssl.context ~verify_modes:Ssl.Verify_mode.[ Verify_none ] () + in + Conduit_async_ssl.TCP.resolv_conf ~port:7000 ~context + +let resolve_tls_ping_pong = + let null ~host:_ _ = Ok None in + let config = Tls.Config.client ~authenticator:null () in + Conduit_async_tls.TCP.resolv_conf ~port:9000 ~config + +let resolvers = + Conduit.empty + |> Conduit_async.register_resolver ~priority:10 ~key:ssl_endpoint + resolve_ssl_ping_pong + |> Conduit_async.register_resolver ~priority:10 ~key:tls_endpoint + resolve_tls_ping_pong + |> Conduit_async.register_resolver ~priority:20 ~key:tcp_endpoint + resolve_ping_pong + +let localhost = Domain_name.(host_exn (of_string_exn "localhost")) + +let run_with : + type edn cfg master flow. + ?key_edn:edn Conduit_async.key -> + key_cfg:cfg Conduit_async.key -> + cfg -> + service:(master * flow) Conduit_async.Witness.service -> + string list -> + unit = + fun ?key_edn ~key_cfg cfg ~service clients -> + let launched = Condition.create () in + let stop = Condition.create () in + let server () = server ~launched ~stop ~key:key_cfg cfg ~service in + let clients = + Condition.wait launched >>= fun () -> + let clients = List.map (client ?key:key_edn ~resolvers localhost) clients in + Async.Deferred.all_unit clients >>= fun () -> + Condition.broadcast stop () ; + Async.return () in + Async.don't_wait_for + (Async.Deferred.all_unit [ server (); clients ] >>| fun () -> shutdown 0) ; + Core.never_returns (Scheduler.go ()) + +let run_with_tcp clients = + run_with ~key_cfg:tcp_configuration + (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 5000)) + ~service:tcp_service clients + +let run_with_ssl cert key clients = + let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in + run_with ~key_cfg:ssl_configuration + (ctx, Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 7000)) + ~service:ssl_service clients + +let load_file filename = + let open Stdlib in + let ic = open_in filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + really_input ic rs 0 ln ; + close_in ic ; + Cstruct.of_bytes rs + +let config cert key = + let cert = load_file cert in + let key = load_file key in + match + (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key) + with + | Ok certs, Ok (`RSA key) -> + Tls.Config.server ~certificates:(`Single (certs, key)) () + | _ -> Fmt.failwith "Invalid key or certificate" + +let run_with_tls cert key clients = + let ctx = config cert key in + run_with ~key_edn:tls_endpoint ~key_cfg:tls_configuration + (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 9000), ctx) + ~service:tls_service clients + +let () = + match Array.to_list Stdlib.Sys.argv with + | _ :: "--with-ssl" :: cert :: key :: clients -> run_with_ssl cert key clients + | _ :: "--with-tls" :: cert :: key :: clients -> run_with_tls cert key clients + | _ :: clients -> run_with_tcp clients + | [] -> assert false From 4cc2bcb8923f6ddf780989cade90c97301bbd72a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 20:48:46 +0200 Subject: [PATCH 012/140] Update OPAM files --- conduit-async.opam | 34 ++++++++++++++++-------------- conduit-lwt-unix.opam | 37 ++++++++++++++++---------------- conduit-lwt.opam | 29 ++++++++++++++----------- conduit-mirage.opam | 44 +++++++++++++++----------------------- conduit-tls.opam | 49 +++++++++++++++++++++++++++++++++++++++++++ conduit.opam | 33 +++++++++++++++-------------- 6 files changed, 136 insertions(+), 90 deletions(-) create mode 100644 conduit-tls.opam diff --git a/conduit-async.opam b/conduit-async.opam index b1442bea..483270a1 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -1,29 +1,31 @@ opam-version: "2.0" maintainer: "anil@recoil.org" authors: [ - "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" ] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library for Async" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} +] + depends: [ "ocaml" {>= "4.03.0"} "dune" "core" - "ppx_sexp_conv" {>="v0.9.0"} - "sexplib" - "conduit" {=version} - "async" {>= "v0.10.0"} - "ipaddr" {>= "3.0.0"} -] -depopts: ["async_ssl"] -conflicts: [ - "async_ssl" {< "v0.9.0"} + "conduit" + "async" {>= "v0.12.0"} + "async_ssl" + "conduit-tls" + "stdlib-shims" {with-test} ] -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] -] -dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for Async" diff --git a/conduit-lwt-unix.opam b/conduit-lwt-unix.opam index c104836f..7ab21e4a 100644 --- a/conduit-lwt-unix.opam +++ b/conduit-lwt-unix.opam @@ -1,31 +1,30 @@ opam-version: "2.0" maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" +authors:[ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" + "Romain Calascibetta" ] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A portable network connection establishment library using Lwt" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} +] + depends: [ "ocaml" {>= "4.07.0"} "dune" + "conduit-lwt" "base-unix" - "ppx_sexp_conv" {>="v0.12.0"} - "conduit-lwt" {=version} - "lwt" {>= "3.0.0"} - "uri" {>= "1.9.4"} - "ipaddr" {>= "4.0.0"} - "ipaddr-sexp" -] -depopts: ["tls" "lwt_ssl" "launchd"] -conflicts: [ - "tls" {< "0.11.0"} - "ssl" {< "0.5.9"} + "lwt_ssl" + "conduit-tls" ] -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] -] -dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for Lwt_unix" diff --git a/conduit-lwt.opam b/conduit-lwt.opam index 8482231f..b0066339 100644 --- a/conduit-lwt.opam +++ b/conduit-lwt.opam @@ -1,24 +1,29 @@ opam-version: "2.0" maintainer: "anil@recoil.org" authors: [ - "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" + "Romain Calascibetta" ] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" -depends: [ - "ocaml" {>= "4.03.0"} - "dune" - "base-unix" - "ppx_sexp_conv" {>="v0.12.0"} - "sexplib" - "conduit" {=version} - "lwt" {>= "3.0.0"} -] +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A portable network connection establishment library using Lwt" + build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ] -dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A portable network connection establishment library using Lwt" + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "conduit" + "cstruct" + "lwt" + "mirage-flow" +] diff --git a/conduit-mirage.opam b/conduit-mirage.opam index b4200b12..d9cd575e 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -1,39 +1,29 @@ opam-version: "2.0" maintainer: "anil@recoil.org" -authors: ["Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire"] +authors: [ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" +] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" -depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "ppx_sexp_conv" {>="v0.12.0"} - "sexplib" - "cstruct" {>= "3.0.0"} - "mirage-stack" {>= "2.0.0"} - "mirage-clock" {>= "3.0.0"} - "mirage-flow" {>= "2.0.0"} - "mirage-flow-combinators" {>= "2.0.0"} - "mirage-random" {>= "2.0.0"} - "mirage-time" {>= "2.0.0"} - "dns-client" {>= "4.5.0"} - "conduit-lwt" - "vchan" {>= "5.0.0"} - "xenstore" - "tls" {>= "0.11.0"} - "tls-mirage" {>= "0.11.0"} - "ipaddr" {>= "3.0.0"} - "ipaddr-sexp" -] -conflicts: [ - "mirage-conduit" -] +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library for MirageOS" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name] {with-test} ] -dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for MirageOS" + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "conduit-lwt" + "conduit-tls" + "tcpip" + "mirage-flow" +] + diff --git a/conduit-tls.opam b/conduit-tls.opam new file mode 100644 index 00000000..52822961 --- /dev/null +++ b/conduit-tls.opam @@ -0,0 +1,49 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" + "Romain Calascibetta" +] +license: "ISC" +tags: "org:mirage" +homepage: "https://github.com/mirage/ocaml-conduit" +doc: "https://mirage.github.io/ocaml-conduit/" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library" +description: """ +The `conduit` library takes care of establishing and listening for +TCP and SSL/TLS connections for the Lwt and Async libraries. + +The reason this library exists is to provide a degree of abstraction +from the precise SSL library used, since there are a variety of ways +to bind to a library (e.g. the C FFI, or the Ctypes library), as well +as well as which library is used (just OpenSSL for now). + +By default, OpenSSL is used as the preferred connection library, but +you can force the use of the pure OCaml TLS stack by setting the +environment variable `CONDUIT_TLS=native` when starting your program. + +The useful opam packages available that extend this library are: + +- `conduit`: the main `Conduit` module +- `conduit-lwt`: the portable Lwt implementation +- `conduit-lwt-unix`: the Lwt/Unix implementation +- `conduit-async` the Jane Street Async implementation +- `conduit-mirage`: the MirageOS compatible implementation +""" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "conduit" + "ke" + "tls" + "logs" + "bigstringaf" +] diff --git a/conduit.opam b/conduit.opam index aab1e9fe..48f683b7 100644 --- a/conduit.opam +++ b/conduit.opam @@ -1,28 +1,17 @@ opam-version: "2.0" maintainer: "anil@recoil.org" authors: [ - "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" + "Romain Calascibetta" ] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" doc: "https://mirage.github.io/ocaml-conduit/" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" -depends: [ - "ocaml" {>= "4.03.0"} - "dune" - "ppx_sexp_conv" {>="v0.12.0"} - "sexplib" - "astring" - "uri" - "logs" {>= "0.5.0"} - "ipaddr" {>= "4.0.0"} - "ipaddr-sexp" -] -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] -] dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" synopsis: "A network connection establishment library" description: """ @@ -46,3 +35,15 @@ The useful opam packages available that extend this library are: - `conduit-async` the Jane Street Async implementation - `conduit-mirage`: the MirageOS compatible implementation """ + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "domain-name" + "stdlib-shims" +] From 60ec59c5858e1635fe176295cbac77cc207a1be5 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 22 May 2020 13:13:27 +0200 Subject: [PATCH 013/140] TCP linger used by conduit-lwt-unix is bigger (io_buffer_size) --- lwt-unix/conduit_lwt_unix_tcp.ml | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index 9b48d118..f3ddcfd2 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -60,11 +60,13 @@ module Protocol = struct | `Transport_endpoint_is_not_connected -> pf ppf "Transport endpoint is not connected" + let io_buffer_size = 65536 + let flow sockaddr = let socket = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in - let linger = Bytes.create 0x1000 in + let linger = Bytes.create io_buffer_size in let rec go () = let process () = Lwt_unix.connect socket sockaddr >>= fun () -> @@ -97,33 +99,27 @@ module Protocol = struct (* | EINPROGRESS: TODO *) in go () - let ( >>? ) x f = - x >>= function Ok x -> f x | Error _ as err -> Lwt.return err - (* XXX(dinosaure): [recv] wants to fill [raw] as much as possible until it has reached [`End_of_file]. *) let rec recv ({ socket; closed; _ } as t) raw = if closed then Lwt.return_ok `End_of_input else - let process () = + let rec process filled raw = let max = Cstruct.len raw in Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) >>= fun len -> if len = 0 - then Lwt.return_ok `End_of_input + then Lwt.return_ok (if filled = 0 then `End_of_input else `Input filled) else ( Cstruct.blit_from_bytes t.linger 0 raw 0 len ; if len = Bytes.length t.linger && max > Bytes.length t.linger - then + then ( if Lwt_unix.readable t.socket - then - recv t (Cstruct.shift raw len) >>? function - | `End_of_input -> Lwt.return_ok (`Input len) - | `Input rest -> Lwt.return_ok (`Input (len + rest)) - else Lwt.return_ok (`Input len) - else Lwt.return_ok (`Input len)) in - Lwt.catch process @@ function + then process (filled + len) (Cstruct.shift raw len) + else Lwt.return_ok (if filled + len = 0 then `End_of_input else `Input (filled + len)) ) + else Lwt.return_ok (if filled + len = 0 then `End_of_input else `Input (filled + len)) ) in + Lwt.catch (fun () -> process 0 raw) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address From 8ccfc86bbee7b8bf17a4daff7d532082638d597c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 22 May 2020 13:14:04 +0200 Subject: [PATCH 014/140] Add interface helper for functoria/mirage about protocols impl. --- lwt/conduit_lwt.ml | 13 +++++++++++++ lwt/conduit_lwt.mli | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+) diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index 47eb8012..97d0dc67 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -51,3 +51,16 @@ let serve_with_handler : | Ok () -> Lwt.return_unit | Error err -> failwith "%a" Service.pp_error err) in (stop, main) + +module type CONDUIT = sig + type endpoint + type flow + type configuration + type master + + val endpoint : endpoint key + val protocol : flow Witness.protocol + + val configuration : configuration key + val service : (master * flow) Witness.service +end diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index e2a80bc1..0666c302 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -14,3 +14,35 @@ val serve_with_handler : service:('master * 'flow) Witness.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t + +(** Common interface to properly expose a protocol. + + If a protocol wants to be fully-compatible with [conduit], + it should expose such implementation which is an aggregate + of {i types witnesses}. + + At least, [endpoint], [configuration] and [service] must be + exposed to be usable by the end-user. Otherwise, the given + protocol can not be: + {ul + {- registered into {!resolvers}} + {- used as a service with {!serve_with_handler]/{!serve}}} + + [protocol] can be hidden - but must be registered with + {!register_protocol}. However, in such case, the end-user + will not be able to {i destruct} (with {!is}/{!Witness.equal_protocol}) + the given {i flow} to the underlying concrete value. +*) + +module type CONDUIT = sig + type endpoint + type flow + type configuration + type master + + val endpoint : endpoint key + val protocol : flow Witness.protocol + + val configuration : configuration key + val service : (master * flow) Witness.service +end From c5636a1fd71855c6692a0f2380ba2f7c4b10e0a9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 22 May 2020 13:17:01 +0200 Subject: [PATCH 015/140] Add helper to easily register a resolver in mirage --- conduit-mirage.opam | 1 + mirage/conduit_mirage.mli | 13 +++++++++++++ mirage/conduit_mirage_dns.ml | 15 +++++++++++++++ mirage/conduit_mirage_dns.mli | 11 +++++++++++ mirage/dune | 6 ++++++ 5 files changed, 46 insertions(+) create mode 100644 mirage/conduit_mirage_dns.ml create mode 100644 mirage/conduit_mirage_dns.mli diff --git a/conduit-mirage.opam b/conduit-mirage.opam index d9cd575e..d423a6fc 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -25,5 +25,6 @@ depends: [ "conduit-tls" "tcpip" "mirage-flow" + "dns-client" ] diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index e4047a7d..d7454401 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -17,3 +17,16 @@ val serve_with_handler : service:('master * 'flow) Witness.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t + +module type CONDUIT = sig + type endpoint + type flow + type configuration + type master + + val endpoint : endpoint key + val protocol : flow Witness.protocol + + val configuration : configuration key + val service : (master * flow) Witness.service +end diff --git a/mirage/conduit_mirage_dns.ml b/mirage/conduit_mirage_dns.ml new file mode 100644 index 00000000..d7130b1d --- /dev/null +++ b/mirage/conduit_mirage_dns.ml @@ -0,0 +1,15 @@ +open Conduit_mirage +open Lwt.Infix + +module Make + (R : Mirage_random.S) + (T : Mirage_time.S) + (C : Mirage_clock.MCLOCK) + (S : Mirage_stack.V4) = struct + include Dns_client_mirage.Make (R) (T) (C) (S) + + let resolv : t -> ?nameserver:Transport.ns_addr -> port:int -> (Ipaddr.V4.t * int) resolver = + fun t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function + | Ok domain_name -> Lwt.return_some (domain_name, port) + | Error _err -> Lwt.return_none +end diff --git a/mirage/conduit_mirage_dns.mli b/mirage/conduit_mirage_dns.mli new file mode 100644 index 00000000..00093669 --- /dev/null +++ b/mirage/conduit_mirage_dns.mli @@ -0,0 +1,11 @@ +open Conduit_mirage + +module Make + (R : Mirage_random.S) + (T : Mirage_time.S) + (C : Mirage_clock.MCLOCK) + (S : Mirage_stack.V4) : sig + include module type of Dns_client_mirage.Make (R) (T) (C) (S) + + val resolv : t -> ?nameserver:Transport.ns_addr -> port:int -> (Ipaddr.V4.t * int) resolver +end diff --git a/mirage/dune b/mirage/dune index 62bea036..84bdf52b 100644 --- a/mirage/dune +++ b/mirage/dune @@ -21,3 +21,9 @@ (public_name conduit-mirage.tcp) (modules conduit_mirage_tcp) (libraries logs mirage-stack bigstringaf ke tcpip.tcp conduit-mirage)) + +(library + (name conduit_mirage_dns) + (public_name conduit-mirage.dns) + (modules conduit_mirage_dns) + (libraries conduit-mirage dns-client.mirage)) From 142fd9dcf38f1031edbbd77b977b0ecea8a853f9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 26 May 2020 13:03:45 +0200 Subject: [PATCH 016/140] ocamlformat.0.14.2 pass --- .ocamlformat | 2 +- lwt-unix/conduit_lwt_unix_tcp.ml | 14 +++++++++++--- lwt/conduit_lwt.ml | 5 +++++ mirage/conduit_mirage.mli | 5 +++++ mirage/conduit_mirage_dns.ml | 16 +++++++++++----- mirage/conduit_mirage_dns.mli | 6 +++++- 6 files changed, 38 insertions(+), 10 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 71d5f8aa..d59e16ac 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.14.1 +version = 0.14.2 break-infix = fit-or-vertical parse-docstrings = true indicate-multiline-delimiters=no diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index f3ddcfd2..50495a27 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -114,11 +114,19 @@ module Protocol = struct else ( Cstruct.blit_from_bytes t.linger 0 raw 0 len ; if len = Bytes.length t.linger && max > Bytes.length t.linger - then ( + then if Lwt_unix.readable t.socket then process (filled + len) (Cstruct.shift raw len) - else Lwt.return_ok (if filled + len = 0 then `End_of_input else `Input (filled + len)) ) - else Lwt.return_ok (if filled + len = 0 then `End_of_input else `Input (filled + len)) ) in + else + Lwt.return_ok + (if filled + len = 0 + then `End_of_input + else `Input (filled + len)) + else + Lwt.return_ok + (if filled + len = 0 + then `End_of_input + else `Input (filled + len))) in Lwt.catch (fun () -> process 0 raw) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index 97d0dc67..043d548b 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -54,13 +54,18 @@ let serve_with_handler : module type CONDUIT = sig type endpoint + type flow + type configuration + type master val endpoint : endpoint key + val protocol : flow Witness.protocol val configuration : configuration key + val service : (master * flow) Witness.service end diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index d7454401..c95eabca 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -20,13 +20,18 @@ val serve_with_handler : module type CONDUIT = sig type endpoint + type flow + type configuration + type master val endpoint : endpoint key + val protocol : flow Witness.protocol val configuration : configuration key + val service : (master * flow) Witness.service end diff --git a/mirage/conduit_mirage_dns.ml b/mirage/conduit_mirage_dns.ml index d7130b1d..bf66d4b3 100644 --- a/mirage/conduit_mirage_dns.ml +++ b/mirage/conduit_mirage_dns.ml @@ -5,11 +5,17 @@ module Make (R : Mirage_random.S) (T : Mirage_time.S) (C : Mirage_clock.MCLOCK) - (S : Mirage_stack.V4) = struct + (S : Mirage_stack.V4) = +struct include Dns_client_mirage.Make (R) (T) (C) (S) - let resolv : t -> ?nameserver:Transport.ns_addr -> port:int -> (Ipaddr.V4.t * int) resolver = - fun t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function - | Ok domain_name -> Lwt.return_some (domain_name, port) - | Error _err -> Lwt.return_none + let resolv : + t -> + ?nameserver:Transport.ns_addr -> + port:int -> + (Ipaddr.V4.t * int) resolver = + fun t ?nameserver ~port domain_name -> + gethostbyname ?nameserver t domain_name >>= function + | Ok domain_name -> Lwt.return_some (domain_name, port) + | Error _err -> Lwt.return_none end diff --git a/mirage/conduit_mirage_dns.mli b/mirage/conduit_mirage_dns.mli index 00093669..cdebcf5a 100644 --- a/mirage/conduit_mirage_dns.mli +++ b/mirage/conduit_mirage_dns.mli @@ -7,5 +7,9 @@ module Make (S : Mirage_stack.V4) : sig include module type of Dns_client_mirage.Make (R) (T) (C) (S) - val resolv : t -> ?nameserver:Transport.ns_addr -> port:int -> (Ipaddr.V4.t * int) resolver + val resolv : + t -> + ?nameserver:Transport.ns_addr -> + port:int -> + (Ipaddr.V4.t * int) resolver end From 7c09a83dc4785095fdd25f3afe375fe768858311 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 13:52:21 +0200 Subject: [PATCH 017/140] Avoid to parse docstrings by ocamlformat --- .ocamlformat | 1 + 1 file changed, 1 insertion(+) diff --git a/.ocamlformat b/.ocamlformat index d59e16ac..3fa5ff9c 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -6,3 +6,4 @@ nested-match=align sequence-style=separator break-before-in=auto if-then-else=keyword-first +parse-docstrings=false From fc38b9f26f815c9fe81b76ad7ae146ba35bfceeb Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 13:52:42 +0200 Subject: [PATCH 018/140] Integration of @samoht's simplication into the core library - We split `conduit` into 2 parts: + A client part to connect/recv/send/close + A server part to make/accept/close - Deletion of the type witness value `'a key` The old design has 2 sets, a set of `'a key` and a set of `'a Witness.protocol`. The first represents the type of the required value to _initialize_ the connection. The second represents the type of the created `flow`. With such design, the end-user had to do the link by himself between `'a key` and `'a protocol` when he calls `register_protocol`. However, the user must keep the link by himself when he wants to extract the implementation (eg. `impl_of_protocol`). It appears that, from an usability point-of-view, a `'a protocol` has only one and uniq key. So this commit merges `'a key` and `'a protocol` into one and uniq type witness value `('edn, 'flow) protocol`. The commit does the same about service (with `'cfg`). - Expose extensible variant This commit de-abstracts `type flow` to `type flow = private ..` So we still must use `register` to extend `flow`, but we have the ability to _pattern-match_ on the type `flow` as long as the protocol implementer exposes `type Conduit.flow += T of t`. The protocol implementer can do that with the new function `Conduit.repr` - an example exists on `conduit-lwt-unix.tcp` and `conduit-lwt-unix.tls`. However, `Conduit.is` still exists to allow the deconstruction of the type `flow` with a given `('edn, 'flow) protocol`. - Rename `Conduit.flow` to `Conduit.connect` - `protocol` given by `Conduit.Service.serve` is wrapped into a GADT to hidden the _endpoint_ type. We still continue to be able to abstract the `'flow` given by `accept` but a step is added to abstract it to the type `Conduit.flow`. --- lib/conduit.ml | 721 +++++++++++++++++++++++------------------------- lib/conduit.mli | 672 +++++--------------------------------------- lib/sigs.ml | 6 +- 3 files changed, 427 insertions(+), 972 deletions(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index 2f0d79d1..040ef7d5 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -14,6 +14,10 @@ type _ resolver = } -> ('edn * 's) resolver +type ('a, 'b) value = Value : 'b -> ('a, 'b) value + +let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt + module Map = E1.Make (struct @@ -38,116 +42,110 @@ module type S = sig type scheduler - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s + module Client : sig + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s - type ('edn, 't, 'flow) service = - (module SERVICE - with type endpoint = 'edn - and type t = 't - and type flow = 'flow) + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - type ('edn, 'flow) protocol = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s + type flow = private .. - type flow + type ('edn, 'flow) protocol - val recv : - flow -> input -> (int Sigs.or_end_of_input, [> `Msg of string ]) result s + type error = [ `Msg of string | `Not_found ] - val send : flow -> output -> (int, [> `Msg of string ]) result s + val pp_error : error Fmt.t - val close : flow -> (unit, [> `Msg of string ]) result s + val recv : + flow -> input -> ([ `Input of int | `End_of_input ], [> error ]) result s - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + val send : flow -> output -> (int, [> error ]) result s - type 'edn key = ('edn * scheduler) Map.key + val close : flow -> (unit, [> error ]) result s - module Witness : sig - type 'flow protocol + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - type 't service + module type REPR = sig + type t - val equal_protocol : 'a protocol -> 'b protocol -> ('a, 'b) refl option - - val equal_service : 'a service -> 'b service -> ('a, 'b) refl option - end + type flow += T of t + end - val key : string -> 'edn key + val repr : + ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - val name_of_key : 'edn key -> string + val add : + ('edn, 'flow) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers - val register_service : - key:'edn key -> - service:('edn, 't, 'flow) service -> - protocol:'flow Witness.protocol -> - ('t * 'flow) Witness.service + val abstract : ('edn, 'v) protocol -> 'v -> flow - val register_protocol : - key:'edn key -> protocol:('edn, 'flow) protocol -> 'flow Witness.protocol + val connect : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s - val register_resolver : - key:'edn key -> ?priority:int -> 'edn resolver -> resolvers -> resolvers + val impl_of_protocol : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - type error = [ `Msg of string | `Not_found | `Unresolved | `Invalid_key ] + val impl_of_flow : + ('edn, 'flow) protocol -> (module FLOW with type flow = 'flow) - val pp_error : Format.formatter -> error -> unit + val is : flow -> ('edn, 'flow) protocol -> 'flow option + end - val abstract : 'flow Witness.protocol -> 'flow -> flow + module Service : sig + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s - val flow_of_endpoint : key:'edn key -> 'edn -> (flow, [> error ]) result s + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) - val flow_of_protocol : - key:'edn key -> - 'edn -> - protocol:'flow Witness.protocol -> - ('flow, [> error ]) result s + type 'flow protocol = + | Protocol : ('edn, 'flow) Client.protocol -> 'flow protocol - val flow : - resolvers -> - ?key:'edn key -> - ?protocol:'flow Witness.protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s + type ('cfg, 'v) service - val serve : - key:'edn key -> - 'edn -> - service:('t * 'flow) Witness.service -> - ('t * 'flow Witness.protocol, [> error ]) result s + val register : + service:('cfg, 't, 'flow) impl -> + protocol:('edn, 'flow) Client.protocol -> + ('cfg, 't * 'flow) service - val impl_of_service : - key:'edn key -> - ('t * 'flow) Witness.service -> - ( (module SERVICE - with type endpoint = 'edn - and type t = 't - and type flow = 'flow), - [> error ] ) - result + type error = [ `Msg of string ] - val impl_of_protocol : - key:'edn key -> - 'flow Witness.protocol -> - ( (module PROTOCOL with type endpoint = 'edn and type flow = 'flow), - [> error ] ) - result + val pp_error : error Fmt.t - val impl_of_flow : - 'flow Witness.protocol -> (module FLOW with type flow = 'flow) + val serve : + 'cfg -> + service:('cfg, 't * 'flow) service -> + ('t * 'flow protocol, [> error ]) result s - val is : flow -> 'flow Witness.protocol -> 'flow option + val impl : + ('cfg, 't * 'flow) service -> + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + end end module Make @@ -160,313 +158,290 @@ module Make and type +'a s = 'a Scheduler.t = struct module Bijection = Sigs.Higher (Scheduler) + type scheduler = Bijection.t + let inj = Bijection.inj let prj = Bijection.prj - type scheduler = Bijection.t - - type _ witness += Witness : scheduler witness - - let witness : scheduler witness = Witness + let return = Scheduler.return - type input = Input.t + let ( >>= ) x f = Scheduler.bind x f - type output = Output.t + let ( >>| ) x f = x >>= fun x -> return (f x) type +'a s = 'a Scheduler.t - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s - - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s - - type ('edn, 't, 'flow) service = - (module SERVICE - with type endpoint = 'edn - and type t = 't - and type flow = 'flow) - - type ('edn, 'flow) protocol = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s - - type 'edn key = ('edn * scheduler) Map.key - - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - - module B = struct - type 't t = Protocol : 'edn key * ('edn, 'flow) protocol -> 'flow t - end - - module Ptr = E0.Make (B) - - type flow = Ptr.t - - module A = struct - type 't t = - | Service : - 'edn key * ('edn, 't, 'flow) service * 'flow Ptr.s - -> ('t * 'flow) t - end - - module Svc = E0.Make (A) - - module Witness = struct - type 't service = 't Svc.s - - type 'flow protocol = 'flow Ptr.s - - let equal_protocol : - type a b. a protocol -> b protocol -> (a, b) refl option = - fun a b -> - match Ptr.equal a b with Some E0.Refl -> Some Refl | None -> None - - let equal_service : type a b. a service -> b service -> (a, b) refl option = - fun a b -> - match Svc.equal a b with Some E0.Refl -> Some Refl | None -> None - end - - let return = Scheduler.return + type _ witness += Witness : scheduler witness - let ( >>= ) x f = Scheduler.bind x f + let witness : scheduler witness = Witness - let ( >>| ) x f = x >>= fun x -> return (f x) + type input = Input.t - let ( >>? ) x f = - x >>= function Ok x -> f x | Error err -> return (Error err) - - let recv flow input = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.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 output = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.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 - Protocol.close flow >>| function - | Ok _ as v -> v - | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - - let key name = Map.Key.create name - - let name_of_key : type edn. edn key -> string = fun key -> Map.Key.info key - - let register_service : - type edn t flow. - key:edn key -> - service:(edn, t, flow) service -> - protocol:flow Witness.protocol -> - (t * flow) Witness.service = - fun ~key ~service ~protocol -> Svc.inj (Service (key, service, protocol)) - - let register_protocol : - type edn flow. - key:edn key -> protocol:(edn, flow) protocol -> flow Witness.protocol = - fun ~key ~protocol -> Ptr.inj (Protocol (key, protocol)) - - let ( <.> ) f g x = f (g x) - - let register_resolver : - type edn. - key:edn key -> ?priority:int -> edn resolver -> resolvers -> resolvers = - fun ~key ?(priority = 0) resolve -> - let resolve = inj <.> resolve in - Map.add key (Resolver { priority; resolve; witness }) - - type error = [ `Msg of string | `Not_found | `Unresolved | `Invalid_key ] - - let pf ppf fmt = Format.fprintf ppf fmt - - let pp_error ppf = function - | `Msg err -> pf ppf "%s" err - | `Not_found -> pf ppf "Not found" - | `Unresolved -> pf ppf "Unresolved" - | `Invalid_key -> pf ppf "Invalid key" - - let flow_of_endpoint : - type edn. key:edn key -> edn -> (flow, [> error ]) result s = - fun ~key edn -> - let rec go = function - | [] -> return (Error `Not_found) - | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: r -> - match Map.Key.(key == k) with - | None -> go r - | Some E1.Refl.Refl -> ( - Protocol.flow edn >>= function - | Ok flow -> return (Ok (ctor flow)) - | Error _err -> go r) in - go (Ptr.bindings ()) - - let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt - - let flow_of_protocol : - type edn flow. - key:edn key -> - edn -> - protocol:flow Witness.protocol -> - (flow, [> error ]) result s = - fun ~key edn ~protocol:(module P) -> - let (Protocol (k', (module Protocol))) = P.witness in - match Map.Key.(key == k') with - | None -> return (Error `Invalid_key) - | Some E1.Refl.Refl -> ( - Protocol.flow edn >>= function - | Ok flow -> return (Ok flow) - | Error err -> return (error_msgf "%a" Protocol.pp_error err)) - - type endpoint = Endpoint : 'edn key * 'edn -> endpoint - - module Refl = struct - type ('a, 'b) t = Refl : ('a, 'a) t - end + type output = Output.t - let scheduler : type s. s witness -> (s, scheduler) Refl.t option = function - | Witness -> Some Refl.Refl - | _ -> None - - let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = - fun m domain_name -> - let rec go acc = function - | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) - | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> - match scheduler witness with - | None -> go acc r - | Some Refl.Refl -> ( - resolve domain_name |> prj >>= function - | Some edn -> go (Endpoint (k, edn) :: acc) r - | None -> go acc r) in - let compare (Map.Value (_, Resolver { priority = pa; _ })) - (Map.Value (_, Resolver { priority = pb; _ })) = - (Stdlib.compare : int -> int -> int) pa pb in - go [] (List.sort compare (Map.bindings m)) - - let create : - resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = - fun m domain_name -> - resolve m domain_name >>= fun l -> - let rec go = function - | [] -> return (Error `Not_found) - | Endpoint (key, edn) :: r -> ( - flow_of_endpoint ~key edn >>= function - | Ok flow -> return (Ok flow) - | Error _err -> go r) in - go l - - let abstract : type v. v Witness.protocol -> v -> flow = - fun (module P) flow -> P.T flow - - let flow : - type edn f. - resolvers -> - ?key:edn key -> - ?protocol:f Witness.protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s = - fun m ?key ?protocol domain_name -> - match (key, protocol) with - | None, None -> create m domain_name - | Some key, None -> ( - match Map.find key m with - | None -> return (Error `Not_found) - | Some (Resolver { resolve; witness; _ }) -> + module Client = struct + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + type 'edn key = ('edn * scheduler) Map.key + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + + module F = struct + type _ t = + | Protocol : 'edn key * ('edn, 'flow) impl -> ('edn, 'flow) value t + end + + module Ptr = E0.Make (F) + + type flow = Ptr.t = private .. + + type ('edn, 'flow) protocol = ('edn, 'flow) value Ptr.s + + let recv flow input = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let (Value flow) = flow in + Protocol.recv flow input >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) + + let send flow output = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let (Value flow) = 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 + Protocol.close flow >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) + + let register : + type edn flow. protocol:(edn, flow) impl -> (edn, flow) protocol = + fun ~protocol -> + let key = Map.Key.create "" in + Ptr.inj (Protocol (key, protocol)) + + module type REPR = sig + type t + + type flow += T of 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 + + type t = x + end in + (module M) + + let ( <.> ) f g x = f (g x) + + let add : + type edn flow. + (edn, flow) protocol -> + ?priority:int -> + edn resolver -> + resolvers -> + resolvers = + fun (module Witness) ?(priority = 0) resolve -> + let (Protocol (key, _)) = Witness.witness in + let resolve = inj <.> resolve in + Map.add key (Resolver { priority; resolve; witness }) + + type error = [ `Msg of string | `Not_found ] + + let pf ppf fmt = Format.fprintf ppf fmt + + let pp_error ppf = function + | `Msg err -> pf ppf "%s" err + | `Not_found -> pf ppf "Not found" + + let flow_of_endpoint : + type edn. edn key -> edn -> (flow, [> error ]) result s = + fun key edn -> + let rec go = function + | [] -> return (Error `Not_found) + | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: 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))) + | Error _err -> go r) in + go (Ptr.bindings ()) + + let flow_of_protocol : + type edn flow. + (edn, flow) protocol -> edn -> (flow, [> error ]) result s = + fun (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) + + type endpoint = Endpoint : 'edn key * 'edn -> endpoint + + module Refl = struct + type ('a, 'b) t = Refl : ('a, 'a) t + end + + let scheduler : type s. s witness -> (s, scheduler) Refl.t option = function + | Witness -> Some Refl.Refl + | _ -> None + + let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = + fun m domain_name -> + let rec go acc = function + | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) + | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> match scheduler witness with - | None -> return (Error `Unresolved) + | None -> go acc r | Some Refl.Refl -> ( resolve domain_name |> prj >>= function - | Some edn -> flow_of_endpoint ~key edn - | None -> return (Error `Unresolved))) - | None, Some protocol -> - resolve m domain_name >>= fun l -> - let rec go = function - | [] -> return (Error `Not_found) - | Endpoint (key, edn) :: r -> ( - flow_of_protocol ~key edn ~protocol >>= function - | Ok flow -> - let module P = (val protocol) in - let (Protocol (_, (module Protocol))) = P.witness in - return (Ok (P.T flow)) - | Error _err -> go r) in - go l - | Some key, Some protocol -> - match Map.find key m with - | None -> return (Error `Not_found) - | Some (Resolver { resolve; witness; _ }) -> - match scheduler witness with - | None -> return (Error `Unresolved) - | Some Refl.Refl -> ( - resolve domain_name |> prj >>= function - | Some edn -> - flow_of_protocol ~key edn ~protocol >>? fun flow -> - let module P = (val protocol) in - let (Protocol (_, (module Protocol))) = P.witness in - return (Ok (P.T flow)) - | None -> return (Error `Unresolved)) - - let serve : - type edn t flow. - key:edn key -> - edn -> - service:(t * flow) Witness.service -> - (t * flow Witness.protocol, [> error ]) result s = - fun ~key edn ~service:(module S) -> - let (Service (k', (module Service), protocol)) = S.witness in - match Map.Key.(key == k') with - | None -> return (Error `Invalid_key) - | Some E1.Refl.Refl -> ( - Service.make edn >>= function - | Ok t -> return (Ok (t, protocol)) - | Error err -> return (error_msgf "%a" Service.pp_error err)) - - let impl_of_service : - type edn t flow. - key:edn key -> - (t * flow) Witness.service -> - ( (module SERVICE - with type endpoint = edn + | Some edn -> go (Endpoint (k, edn) :: acc) r + | None -> go acc r) in + let compare (Map.Value (_, Resolver { priority = pa; _ })) + (Map.Value (_, Resolver { priority = pb; _ })) = + (Stdlib.compare : int -> int -> int) pa pb in + go [] (List.sort compare (Map.bindings m)) + + let create : + resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = + fun m domain_name -> + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> ( + flow_of_endpoint key edn >>= function + | Ok flow -> return (Ok flow) + | Error _err -> go r) in + go l + + let abstract : type edn v. (edn, v) protocol -> v -> flow = + fun (module Witness) flow -> Witness.T (Value flow) + + let connect : + type edn v. + resolvers -> + ?protocol:(edn, v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s = + fun m ?protocol domain_name -> + match protocol with + | None -> create m domain_name + | Some (module Witness) -> + let (Protocol (key', _)) = Witness.witness in + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> + 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))) + | Error _err -> go r) in + go l + + let impl_of_protocol : + 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 + (module Protocol) + + let impl_of_flow : + type edn flow. + (edn, flow) protocol -> (module FLOW with type flow = flow) = + fun (module Witness) -> + let (Protocol (_, (module Protocol))) = Witness.witness in + (module Protocol) + + let is : 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 + end + + module Service = struct + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + + type 'flow protocol = + | Protocol : ('edn, 'flow) Client.protocol -> 'flow protocol + + module F = struct + type 't t = + | Service : + 'cfg key * ('cfg, 't, 'flow) impl * 'flow protocol + -> ('cfg, 't * 'flow) value t + end + + module Svc = E0.Make (F) + + type ('cfg, 'v) service = ('cfg, 'v) value Svc.s + + let register : + type edn cfg t flow. + service:(cfg, t, flow) impl -> + protocol:(edn, flow) Client.protocol -> + (cfg, t * flow) service = + fun ~service ~protocol -> + let cfg = Map.Key.create "" in + Svc.inj (Service (cfg, service, Protocol protocol)) + + type error = [ `Msg of string ] + + let pp_error ppf = function `Msg err -> Fmt.string ppf err + + let serve : + type cfg t flow. + cfg -> + service:(cfg, t * flow) service -> + (t * flow protocol, [> error ]) result s = + fun edn ~service:(module Witness) -> + let (Service (_, (module Service), protocol)) = Witness.witness in + Service.make edn >>= function + | Ok t -> return (Ok (t, protocol)) + | Error err -> return (error_msgf "%a" Service.pp_error err) + + let impl : + type cfg t flow. + (cfg, t * flow) service -> + (module SERVICE + with type configuration = cfg and type t = t - and type flow = flow), - [> error ] ) - result = - fun ~key (module S) -> - let (Service (k, (module Service), _)) = S.witness in - match Map.Key.(key == k) with - | Some E1.Refl.Refl -> Ok (module Service) - | None -> Error `Invalid_key - - let impl_of_protocol : - type edn flow. - key:edn key -> - flow Witness.protocol -> - ( (module PROTOCOL with type endpoint = edn and type flow = flow), - [> error ] ) - result = - fun ~key (module P) -> - let (Protocol (k, (module Protocol))) = P.witness in - match Map.Key.(key == k) with - | Some E1.Refl.Refl -> Ok (module Protocol) - | None -> Error `Invalid_key - - let impl_of_flow : - type flow. flow Witness.protocol -> (module FLOW with type flow = flow) = - fun (module P) -> - let (Protocol (_, (module Protocol))) = P.witness in - (module Protocol) - - let is : type v. flow -> v Witness.protocol -> v option = - fun flow witness -> Ptr.extract flow witness + and type flow = flow) = + fun (module S) -> + let (Service (_, (module Service), _)) = S.witness in + (module Service) + end end diff --git a/lib/conduit.mli b/lib/conduit.mli index 5471dd13..e5f0cb92 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -2,647 +2,127 @@ module Sigs = Sigs type ('a, 'b) refl = Refl : ('a, 'a) refl -(** [Conduit] is a little library which wants to give to the developer the - easiest way to compose protocols and only one way to make a {i Flow}. - Several words are used in this sentence and we need a clear definition of - them to fully understand the purpose of [Conduit]. - - {3 A Protocol.} - - A communication protocol is a system of rules that allows entities to - transmit information. In the case of [Conduit], this kind of information - must not be arbitrary. The protocol should only solve communication problems - such as {i routing}. - - When we talk about a protocol, it's only about a standard which is able to - transmit a {i payload}. Interpretation of the {i payload} is not done by the - {i protocol} but by the user of this library. - - For example, the Transmission Control Protocol (TCP) {b is} a protocol - according to [Conduit] because it is able to transmit {i payload} without - interpreting it. A counter example is the Simple Mail Transfer Protocol - (SMTP) which gives an interpretation of the {i payload} (such as [EHLO] - which is different to [QUIT]). - - This difference is important to unlock the ability to compose {i protocols}. - An other protocol according to [Conduit] is Transport Layer Security (TLS) - - which wants to solve privacy and data integrity. [Conduit] is able to - compose protocols together like [TCP ∘ TLS] to make a new protocol. From - this composition, the user is able to implement Secure Simple Mail Transfer - Protocol (SSMTP) or HyperText Transfer Protocol Secure (HTTPS) - both use - TCP and TLS. - - {3 A Flow.} - - To be able to do this composition, the protocol must respect an interface: - the [FLOW] interface. It defines an abstract type [t] and functions like - [recv] or [send]. These functions give to us the {i payload}. Rules to solve - communication problems are already processed internally. - - In other terms, from a given [FLOW], the user should not handle {i routing}, - privacy or data integrity (or some others problems). The user should only be - able to process the {i payload}. - - Finally, representation of a TCP protocol is a [FLOW]. VCHAN protocol or - User Datagram Protocol (UDP) can be represented by a [FLOW]. However, TLS is - not a flow but a layer on top of another protocol. Composition with it - should look like: - - {[ val with_tls : (module FLOW) -> (module FLOW) ]} - - From a given [FLOW], we {i wrap} it with TLS and return a new [FLOW]. Such a - composition exists also for WireGuard or Noise layers. [Conduit] wants to - solve this composition by a strict OCaml interface of the [FLOW]. - - {3 Resolution.} - - [Conduit] wants to solve one last problem, resolution of an {i endpoint}. - The goal is to make a [FLOW] from an {i endpoint} given by the developer. - - Definition of an endpoint can not fully exist where it depends on the - returned [FLOW]. For example, if we give to you a TCP flow, {i endpoint} - should be an IP and a {i port} where the given [FLOW] is {b already} - connected. - - However, we agree that the most general (by convention) description of the - {i endpoint} is the domain-name. By knowing this, we let the developer to - construct an {i endpoint} from a [\[ `host \] Domain_name.t]. - - At the end, [Conduit] should be able to construct an {i endpoint} from a - [\[ `host \] Domain_name.t]. Then, it tries to find a [SERVICE] according to - the given {i endpoint} and initializes a [FLOW]. - - The most abstract definition provided by [Conduit] is: - - {[ val flow : resolvers -> [ `host ] Domain_name.t -> flow ]} - - Where [resolvers] is a set of {i heterogeneous} constructors of {i - endpoints} given by the developer. The returned value [flow] is an - abstraction of an {b already} initialized communication protocol. From it, - the developer can {i extract} [send] and [recv] functions (as described into - {!A Protocol}). - - {3 Conclusion.} - - [Conduit] is a {i framework} which wants to give a few definitions to {b - restrict} developers of protocols to an interface [FLOW] and, by this way, - provide them with a set of tools to compose with others protocols and give - only one way to resolve an {i endpoint} (whatever its definition). - - [Conduit] does not make magic and all described processes previously are - explicit - composition, resolution, extraction. This last aspect wants to - solve a well-known problem of [Conduit] where nobody can fully understand - this framework. - - You can start to read the rest of the documentation. *) - -type 'a key - type resolvers -(** Type of a set of resolvers. - - This type is outside any implementation of [Conduit] to let others libraries - to depend only on the package [conduit]. Of course, at one point (specially - when they want to use [Conduit]), they must do a choice about which - implementation of [Conduit] they want - [Conduit_lwt] or [Conduit_unix]. *) val empty : resolvers +type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value + module type S = sig type input - (** The type of the {i input}. A flow is able to {i send} a {i payload}. The - type of the {i payload} is [input]. *) type output - (** The type of the {i output}. A flow is able to {i receive} a {i payload}. - The type of the {i payload} is [output]. *) - - (** {3 Input & Output.} - - Type of input can differ to type of output to have the ability to define - capabilities on them such as the {i read} capability or the {i write} - capability. A {i caml} example looks like: - - {[ - type input = bytes - - type output = string - ]} *) type +'a s - (** The type of {i scheduler}. [Conduit] is able to call some {i syscall} - which can be wrap in a {i monad} such as LWT or ASYNC. The core [Conduit] - library is abstracted over that. *) - - (** {3 Scheduling.} - - [Conduit] does not do the choice about LWT or ASYNC (or UNIX). However, it - should be able to call any {i syscall} (like [Unix.connect]) which can be - {i wrap} into a {i monad}. By this way, the core library is not - specialized to a specific {i backend}. - - However, this specialization is done as soon as we can. So, - [Conduit_unix], [Conduit_mirage] or [Conduit_caml] are different and can - not be used together into a same place. *) type scheduler - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s - - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s - - type ('edn, 't, 'flow) service = - (module SERVICE - with type endpoint = 'edn - and type t = 't - and type flow = 'flow) - - type ('edn, 'flow) protocol = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s - - type flow - (** A [flow] is an abstract value which contains your flow. As an abstracted - value, we can use it with few functions such as {!send}, {!recv} or - {!close}. If you are not aware about underlying implementation used, it - should be enough for you to only use it as is. - - {[ - type input = bytes - - type output = string + module Client : sig + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s - type +'a s = 'a + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s - let process (Flow (flow, (module Flow))) = - let buf = Bytes.create 0x1000 in - match Conduit.recv flow buf 0 0x1000 with - | Ok (`Data len) -> - let str = Bytes.sub_string buf 0 len in - ignore (Conduit.send flow str 0 len) - | _ -> failwith "Flow.recv" - ]} + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - The given flow can be more complex than a simple TCP flow for example. It - can be wrapped into a TLS layer. However the goal is to be able to - implement a protocol without such complexity. *) + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - (** {3 Usual operations on the {!flow}.} + type flow = private .. - Even if semantics of them is quite spontaneous ({!recv} can receive - something, {!send} can send something, {!close} closes the given [flow]), - the evil is into details. So they are only wrappers of associated {!recv}, - {!send} and {!close} functions of the underlying implementation of the - given [flow]. + type ('edn, 'flow) protocol - By that, precise behaviours of them depend on the associated - implementation. *) + type error = [ `Msg of string | `Not_found ] - val recv : - flow -> input -> (int Sigs.or_end_of_input, [> `Msg of string ]) result s + val pp_error : error Fmt.t - val send : flow -> output -> (int, [> `Msg of string ]) result s + val recv : + flow -> input -> ([ `Input of int | `End_of_input ], [> error ]) result s - val close : flow -> (unit, [> `Msg of string ]) result s + val send : flow -> output -> (int, [> error ]) result s - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - (** A [resolver] is an abstract function which resolves a given - [\[ `host \] Domain_name.t] to an {i endpoint}. At least, it can be - implemented as a DNS resolver such as: + val close : flow -> (unit, [> error ]) result s - {[ - type +'a s = 'a + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - let http_resolver : Unix.sockaddr resolver = - fun domain_name -> - match Unix.gethostbyname (Domain_name.to_string domain_name) with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) - else None - | _ -> None - ]} + module type REPR = sig + type t - Definition of {i endpoint} is free as long as a protocol can - initialize/connect a {!FLOW.flow} from it. In our example, a [Unix] TCP - service should exist with [Unix.connect]. *) + type flow += T of t + end - type nonrec 'edn key = ('edn * scheduler) key - (** To be able to {i plug} a {!resolver} to a {!service} or a {!protocol}, a - value ['edn key] exists. It represents, at the resolution step, - {!protocol} into an user-defined {!Map.t}. + val repr : + ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - Any construction of a {!service} or a {!protocol} give to us a ['edn key] - like a [Unix.sockaddr key] for example. The user has the ability to - construct then a restrained way to resolve a [\[ `host \] Domain_name.t]: - a set of {i heterogeneous} constructors of {i endpoint}. + val add : + ('edn, _) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers - Each constructor of {i endpoint} is bound with a ['edn key]. If one of - them is able to resolve the given domain-name, by the ['edn key], - [Conduit] is able to invoke the right {!protocol} to process the - initialization. + val abstract : (_, 'v) protocol -> 'v -> flow - {[ - val tcp_protocol : (Unix.sockaddr, Unix.file_descr) protocol + val connect : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s - val tcp_endpoint : Unix.sockaddr key + val impl_of_protocol : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - val http_resolver : Unix.sockaddr resolver (* on [*:80] *) + val impl_of_flow : + (_, 'flow) protocol -> (module FLOW with type flow = 'flow) - val debug_http_resolver : Unix.sockaddr resolver (* on [*:8080] *) + val is : flow -> (_, 'flow) protocol -> 'flow option + end - let map = - Map.empty - |> register_resolver ~key:tcp_endpoint ~priority:10 http_resolver - |> register_resolver ~key:tcp_endpoint ~priority:20 - debug_http_resolver - ]} *) + module Service : sig + module type SERVICE = Sigs.SERVICE with type +'a s = 'a s - module Witness : sig - type 'flow protocol + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) - type 't service + type 'flow protocol = + | Protocol : (_, 'flow) Client.protocol -> 'flow protocol - val equal_protocol : 'a protocol -> 'b protocol -> ('a, 'b) refl option + type ('cfg, 'v) service - val equal_service : 'a service -> 'b service -> ('a, 'b) refl option - end + val register : + service:('cfg, 't, 'flow) impl -> + protocol:(_, 'flow) Client.protocol -> + ('cfg, 't * 'flow) service - val key : string -> 'edn key - (** [key name] creates a new key. The returned value can be bound to a - {!service} with {!register_service} or a {!protocol} with - {!register_protocol}. - - The goal of the returned value is to plug a {!resolver} without any - knowledge of the the {!protocol}. + type error = [ `Msg of string ] - {[ - type input = bytes - - type output = string - - type +'a s = 'a - - module Conduit_tcp : sig - val key : Unix.sockaddr key - end = struct - let key : Unix.sockaddr key = key "sockaddr" + val pp_error : error Fmt.t - let protocol = register_protocol ~key ~protocol:(module TCP) - end - - let resolvers = - Map.empty - |> register_resolver ~key:Conduit_tcp.key http_resolver - |> register_resolver ~key:Conduit_tcp_tls.key https_resolver - - let mirage_io = Domain_name.(host_exn <.> of_string_exn) "mirage.io" + val serve : + 'cfg -> + service:('cfg, 't * 'flow) service -> + ('t * 'flow protocol, [> error ]) result s - let () = - match flow resolves mirage_io with - | Ok (flow, (module Flow)) -> ignore (Flow.send flow "Hello World!") - | Error err -> failwithf "%a" pp_error err - ]} - - More precisely a {!key} is associated with the given {!scheduler} of - [Conduit]. By this way, it's not possible to mis-use a key from an ASYNC - scheduler with [Conduit_lwt.flow] for example. *) - - val name_of_key : 'edn key -> string - - (** {3 Registration.} *) - - val register_service : - key:'edn key -> - service:('edn, 't, 'flow) service -> - protocol:'flow Witness.protocol -> - ('t * 'flow) Witness.service - (** [register_service ~key ~service ~protocol] registers implementation of a - {i service} which is able to make a {i flow} (an established transmission - between the service and an entity) according to the given definition - [protocol]. It binds [service] with [key] to be able to correctly - initialize the given service. - - A {!service} is not use with the resolution process because we assert that - the initialization of any service should be fully know. [key] unlocks only - the ability to let the user to define his type of {i endpoint}/{i - configuration} - at this stage, and only about {!service}, goal of [key] - differs from {!register_protocol}. - - {[ - module TCP_service : S with type configuration = Unix.sockaddr - and type t = Unix.file_descr - and type flow = TCP.t (* = Unix.file_descr *) - - let key : Unix.sockaddr = key "sockaddr" - let service : (Unix.file_descr * TCP.t) Witness.service = - register_service ~key ~service:(module TCP_service) ~protocol:TCP.protocol - ]} *) - - val register_protocol : - key:'edn key -> protocol:('edn, 'flow) protocol -> 'flow Witness.protocol - (** [register_protocol ~key ~protocol] registers implementation of a {i - protocol} and binds it with [key] - any resolver bound into a {!Map.t} - with this [key] will call (at least) [connect] given by [protocol]. - - [protocol] is an OCaml module which respects the interface {!F} (a - specialization of {!FLOW} according {!input}, {!output} and {!s}). - - The returned value is a {i light} representation of the given [protocol] - which can be use by the user for some others processes like the - composition. - - {[ - module TCP : F with type endpoint = Unix.sockaddr - and type t = Unix.file_descr - - let key : Unix.sockaddr key = key "sockaddr" - let protocol : Unix.file_descr Witness.protocol = - register_protocol ~key ~protocol:(module TCP) - ]} *) - - val register_resolver : - key:'edn key -> ?priority:int -> 'edn resolver -> resolvers -> resolvers - (** [register_resolver ~key ?priority resolver m] adds a new [resolver] into - [m]. [resolver] is bound to [key]. From a set of [key] which represent the - way to initialize a {!protocol}, we can bind a [resolver] into [m]. - - When the [resolver] is able to resolve the given domain-name, it will try - to initialize the transmission over the protocol bound to the shared - [key]. We try resolvers to a specific order (lower to higher). - - {[ - val resolver_on_my_private_network : Unix.sockaddr resolver - - val resolver_on_internet : Unix.sockaddr resolver - - let m = - Map.empty - |> register_resolver ~key:tcp_endpoint ~priority:10 - resolver_on_my_private_network - |> register_resolver ~key:tcp_endpoint ~priority:20 - resolver_on_internet - ]} *) - - type error = [ `Msg of string | `Not_found | `Invalid_key | `Unresolved ] - - val pp_error : Format.formatter -> error -> unit - - val abstract : 'flow Witness.protocol -> 'flow -> flow - (** [abstract protocol flow] constructs an abstracted value {!flow} from a - representation of the implementation of the protocol ([protocol]) and an - already initialized [flow]. *) - - val flow_of_endpoint : key:'edn key -> 'edn -> (flow, [> error ]) result s - (** [flow_of_endpoint ~key edn] creates a new abstracted flow from the given - endpoint ['edn]. Protocol used to initialize the transmission is (already) - registered with {!register_protocol} and [key]. - - User can register more than one protocol with the given [key]. In this - case, all of these protocols are extracted and they try to initialize the - transmission. The first which initializes the transmission is taken to - return the {!flow}. The order of protocols is undefined. - - {[ - let sockaddr : Unix.sockaddr = Conduit.key "sockaddr" - let tcp : Unix.file_descr Witness.protocol - let udp : Unix.file_descr Witness.protocol - - let mirage_io : Unix.sockaddr = match Unix.gethostbyname "mirage.io" with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Unix.ADDR_INET (h_addr_list.(0), 4242) - else failwith "Impossible to resolver mirage.io" - - let () = match flow_of_endpoint ~key:sockaddr mirage_io with - | Ok flow -> - ignore (Conduit.send flow "Hello World!") - | Error err -> failwithf "%a" pp_error err - ]} *) - - val flow_of_protocol : - key:'edn key -> - 'edn -> - protocol:'flow Witness.protocol -> - ('flow, [> error ]) result s - (** [flow_of_protocol ~key edn ~protocol] creates a new concrete ['flow] from - the given endpoint ['edn]. Protocol used to initialize the transmission is - (and only is) [protocol]. - - {[ - let sockaddr : Unix.sockaddr = Conduit.key "sockaddr" - let tcp : Unix.file_descr Witness.protocol - - let mirage_io : Unix.sockaddr = match Unix.gethostbyname "mirage.io" with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Unix.ADDR_INET (h_addr_list.(0), 4242) - else failwith "Impossible to resolver mirage.io" - - let () = match flow_of_protocol ~key:sockaddr ~protocol:tcp mirage_io with - | Ok fd -> - ignore (Unix.write fd "Hello World!" 0 12) - | Error err -> failwithf "%a" pp_error err - ]} *) - - (** {3 [Conduit] as a client.} *) - - val flow : - resolvers -> - ?key:'edn key -> - ?protocol:'flow Witness.protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s - (** [flow resolvers domain_name] tries to create a new abstracted according to - [resolvers]. Each resolver tries to resolve the given domain-name (they - are ordered by the given priority). Then, from a {i heterogeneous} set of - {i endpoints}, we try to initialize/establish a transmission. The first - which initializes the connection is taken to return the {!flow}. - - User can enforce to use a specific [key] and, by this way, a specific - resolver instead to call all of them (available into [resolvers]). - - User can enforce to use a specific [protocol], and by this way, enforce to - use a specific [key] (which is bound by [protocol]). - - {[ - let mirage_io = Domain_name.(host_exn <.> of_string_exn) "mirage.io" - - val resolver_on_my_private_network : Unix.sockaddr resolver - - val resolver_on_internet : Unix.sockaddr resolver - - val resolver_with_tls : Tls.Config.client -> Unix.sockaddr resolver - - let resolvers = - Map.empty - |> register_resolver ~key:tls_endpoint ~priority:0 - (resolver_with_tls tls_config) - |> register_resolver ~key:tcp_endpoint ~priority:10 - resolver_on_my_private_network - |> register_resolver ~key:tcp_endpoint ~priority:20 - resolver_on_internet - - let () = - match flow resolvers mirage_io with - | Ok (flow, (module Flow)) -> ignore (Flow.send flow "Hello World!") - | Error err -> failwithf "%a" pp_error err - ]} *) - - (** {3 [Conduit] as a server.} *) - - val serve : - key:'edn key -> - 'edn -> - service:('t * 'flow) Witness.service -> - ('t * 'flow Witness.protocol, [> error ]) result s - (** [serve ~key edn ~service] creates a new {i master} server with which {i - protocol} it can deliver according a configuration ['edn]. [serve] is more - restrictive than {!flow} when we assert that the initialization of a - service should be fully know. - - The initialization of the service returns a concrete type ['t] which - represents the service. It returns which protocol is used to transmit - information with entities. - - {[ - val sockaddr : Unix.sockaddr key - val tcp_service : (Unix.file_descr * TCP.t) Witness.service - - let () = - impl_of_service ~key:sockaddr tcp_service |> get_ok |> fun (module Server) -> - match serve ~key:sockaddr Unix.(ADDR_INET (inet_addr_any, 8080)) tcp_service with - | Ok (master, protocol) -> - let module Flow = impl_of_flow protocol in - let rec go () = match Server.accept t with - | Ok flow -> - ignore (Flow.send flow "Hello World") ; - Flow.close flow ; - go () - | Error err -> failwithf "%a" Server.pp_error err in - go () - ]} *) - - val impl_of_service : - key:'edn key -> - ('t * 'flow) Witness.service -> - ( (module SERVICE - with type endpoint = 'edn + val impl : + ('cfg, 't * 'flow) service -> + (module SERVICE + with type configuration = 'cfg and type t = 't - and type flow = 'flow), - [> error ] ) - result - (** [impl_of_service ~key svc] returns the full-defined implementation of a - service from a [key] and a witness of it [svc]. [key] and [svc] must be - associated with {!register_service}. Otherwise, we return an error. *) - - val impl_of_protocol : - key:'edn key -> - 'flow Witness.protocol -> - ( (module PROTOCOL with type endpoint = 'edn and type flow = 'flow), - [> error ] ) - result - (** [impl_of_protocol ~key protocol] returns the full-defined implementation - of a protocol from a [key] and a witness of it [protocol]. [key] and - [protocol] must be associated with {!register_protocol}. Otherwise, we - return an error. *) - - val impl_of_flow : - 'flow Witness.protocol -> (module FLOW with type flow = 'flow) - (** [impl_of_flow protocol] returns a not-full-defined implementation of a - protocol. Despite {!impl_of_protocol}, the returned implementation does - not allow to {i create} a new flow from it. It does the usual computation - {!recv}, {!send} and {!close}. *) - - val is : flow -> 'flow Witness.protocol -> 'flow option - (** [is flow protocol] tries to prove that the given flow {b comes from} - [protocol]. By this fact, you are able to directly use it with your - implementation. For example, TLS implementation comes with few accessors - such as [underlying] to fallback to the {i underlying} protocol used with - TLS. - - To be able to use this function, you must prove that [flow] comes from, at - least, the TLS protocol implementation: - - {[ - type socket = { ip : Ipaddr.V4.t; port : int; socket : Unix.socket } - - type tls - - val tcp_protocol : socket Conduit.Witness.protocol - - val tls_protocol : tls Conduit.Witness.protocol - - val underlying : tls -> Conduit.flow - - val dst : TCP.flow -> Ipaddr.V4.t * int - - let abstract_dst : flow -> (Ippaddr.V4.t * int) option = - fun flow -> - let dst_of_tcp flow = - match Conduit.is flow tcp_protocol with - | Some { ip; port; _ } -> Some (ip, port) - | None -> None in - match Conduit.is flow tls_protocol with - | Some with_tls -> dst_of_tcp (underlying with_tls) - | None -> None - ]}*) + and type flow = 'flow) + end end -(** {3 Composition.} - - [Conduit] does not do something magic as we said into the introduction. - Composition of protocols must be done by {i protocol} developer. [Conduit] - gives interfaces which can be help this composition - but {i the glue} - needed must be implemented. - - Considering TLS as a layer which can compose with an other protocol, the - implementation looks like: - - {[ - type input - type output - type +'a s - - type 'flow with_tls = - { flow : 'flow - ; tls : Tls.Engine.state } - - module With_tls - (Flow : Sigs.F with type input = input - and type output = output - and type +'a s = 'a s) - = struct - type flow = Flow.flow with_tls - type endpoint = Flow.endpoint * Tls.Config.client - - ... - end - - let with_tls - : type edn flow. - key:edn key - -> flow Witness.protocol - -> (edn * Tls.Config.client) key * flow with_tls Witness.protocol - = fun ~key protocol -> - match impl_of_protocol ~key protocol with - | Ok (module Flow) -> - let module M = With_tls(Flow) in - let k = key "with_tls" in - let p = register_protocol ~key:k ~protocol:(module M) in - k, p - | Error err -> failwithf "%a" pp_error err - ]} *) - module Make (Scheduler : Sigs.SCHEDULER) (Input : Sigs.SINGLETON) diff --git a/lib/sigs.ml b/lib/sigs.ml index 6458eb95..d4418808 100644 --- a/lib/sigs.ml +++ b/lib/sigs.ml @@ -74,7 +74,7 @@ module type PROTOCOL = sig type endpoint - val flow : endpoint -> (flow, error) result s + val connect : endpoint -> (flow, error) result s end module type SERVICE = sig @@ -86,9 +86,9 @@ module type SERVICE = sig type error - type endpoint + type configuration - val make : endpoint -> (t, error) result s + val make : configuration -> (t, error) result s val pp_error : error Fmt.t From 626c9b8b3c5984478d332f0cbe05d65376bff73b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:08:29 +0200 Subject: [PATCH 019/140] Update conduit-async with the new core --- async/conduit_async.ml | 65 ++++++++++++------------- async/conduit_async.mli | 7 ++- async/conduit_async_ssl.ml | 96 +++++++++++++++---------------------- async/conduit_async_ssl.mli | 28 +++++------ async/conduit_async_tcp.ml | 19 ++------ async/conduit_async_tcp.mli | 14 ++---- async/conduit_async_tls.ml | 5 +- async/conduit_async_tls.mli | 31 ++++++------ 8 files changed, 111 insertions(+), 154 deletions(-) diff --git a/async/conduit_async.ml b/async/conduit_async.ml index 8fb8d71f..5aa9e39f 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -8,61 +8,56 @@ end include Conduit.Make (Async_scheduler) (Cstruct) (Cstruct) -let invalid_arg fmt = Format.kasprintf invalid_arg fmt - let failwith fmt = Format.kasprintf failwith fmt let ( >>? ) x f = Async.Deferred.Result.bind x ~f let serve_with_handler : type cfg master flow. - handler:(flow Witness.protocol -> flow -> unit Async.Deferred.t) -> - key:cfg key -> - service:(master * flow) Witness.service -> + handler:(flow Service.protocol -> flow -> unit Async.Deferred.t) -> + service:(cfg, master * flow) Service.service -> cfg -> unit Async.Condition.t * unit Async.Deferred.t = - fun ~handler ~key ~service cfg -> + fun ~handler ~service cfg -> let open Async in let stop = Async.Condition.create () in - match impl_of_service ~key service with - | Error _ -> invalid_arg "Invalid key %s" (name_of_key key) - | Ok (module Service) -> - let main = - serve ~key cfg ~service >>= function - | Error err -> failwith "%a" pp_error err - | Ok (master, protocol) -> ( - let rec loop () = - let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in - let accept = - Service.accept master >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in + let module Svc = (val Service.impl service) in + let main = + Service.serve cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok (master, protocol) -> ( + let rec loop () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in + let accept = + Svc.accept master >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in - Async.Deferred.any [ close; accept ] >>= function - | Ok (`Flow flow) -> - Async.don't_wait_for (handler protocol flow) ; - Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok `Stop -> Service.close master - | Error err0 -> ( - Service.close master >>= function - | Ok () -> Async.return (Error err0) - | Error _err1 -> Async.return (Error err0)) in - loop () >>= function - | Ok () -> Async.return () - | Error err -> failwith "%a" Service.pp_error err) in - (stop, main) + Async.Deferred.any [ close; accept ] >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for (handler protocol flow) ; + Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Async.return (Error err0) + | Error _err1 -> Async.return (Error err0)) in + loop () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) let reader_and_writer_of_flow flow = let open Async in let recv flow writer = let tmp = Cstruct.create 0x1000 in let rec loop () = - recv flow tmp >>= function + Client.recv flow tmp >>= function | Ok (`Input len) -> Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop | Ok `End_of_input -> Pipe.close writer ; Async.return () - | Error err -> failwith "%a" pp_error err in + | Error err -> failwith "%a" Client.pp_error err in loop () in let send flow reader = let rec loop () = @@ -73,9 +68,9 @@ let reader_and_writer_of_flow flow = if Cstruct.len tmp = 0 then Async.return () else - send flow tmp >>= function + Client.send flow tmp >>= function | Ok shift -> go (Cstruct.shift tmp shift) - | Error err -> failwith "%a" pp_error err in + | Error err -> failwith "%a" Client.pp_error err in go (Cstruct.of_string v) >>= loop in loop () in let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in diff --git a/async/conduit_async.mli b/async/conduit_async.mli index ba82672e..cfe6c87b 100644 --- a/async/conduit_async.mli +++ b/async/conduit_async.mli @@ -10,11 +10,10 @@ include and type +'a s = 'a Async.Deferred.t val serve_with_handler : - handler:('flow Witness.protocol -> 'flow -> unit Async.Deferred.t) -> - key:'cfg key -> - service:('master * 'flow) Witness.service -> + handler:('flow Service.protocol -> 'flow -> unit Async.Deferred.t) -> + service:('cfg, 'master * 'flow) Service.service -> 'cfg -> unit Async.Condition.t * unit Async.Deferred.t val reader_and_writer_of_flow : - flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t + Client.flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index 27428ebc..4d491b87 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -78,7 +78,7 @@ type 'flow with_ssl = { } module Protocol (Protocol : sig - include Conduit_async.PROTOCOL + include Conduit_async.Client.PROTOCOL val reader : flow -> Reader.t @@ -103,7 +103,7 @@ struct | Core err -> Core.Error.pp ppf err | Protocol err -> Protocol.pp_error ppf err - let flow + let connect ( { version; options; @@ -119,7 +119,7 @@ struct verify; }, edn ) = - Protocol.flow edn >>| reword_error (fun err -> Protocol err) + Protocol.connect edn >>| reword_error (fun err -> Protocol err) >>? fun underlying -> let reader = Protocol.reader underlying in let writer = Protocol.writer underlying in @@ -175,32 +175,24 @@ end let protocol_with_ssl : type edn flow. - key:edn Conduit_async.key -> reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> - flow Conduit_async.Witness.protocol -> - (context * edn) Conduit_async.key - * flow with_ssl Conduit_async.Witness.protocol = - fun ~key ~reader ~writer protocol -> - match Conduit_async.impl_of_protocol ~key protocol with - | Ok (module F) -> - let module Flow = struct - include F - - let reader = reader - - let writer = writer - end in - let module M = Protocol (Flow) in - let k = - Conduit_async.key - (Format.asprintf "%s + ssl" (Conduit_async.name_of_key key)) in - let p = Conduit_async.register_protocol ~key:k ~protocol:(module M) in - (k, p) - | _ -> invalid_arg "Invalid key" + (edn, flow) Conduit_async.Client.protocol -> + (context * edn, flow with_ssl) Conduit_async.Client.protocol = + fun ~reader ~writer protocol -> + let module F = (val Conduit_async.Client.impl_of_protocol protocol) in + let module Flow = struct + include F + + let reader = reader + + let writer = writer + end in + let module M = Protocol (Flow) in + Conduit_async.Client.register ~protocol:(module M) module Make (Service : sig - include Conduit_async.SERVICE + include Conduit_async.Service.SERVICE val reader : flow -> Reader.t @@ -220,7 +212,7 @@ struct | Missing_crt_or_key -> Format.fprintf ppf "Missing crt of key values into context" - type endpoint = context * Service.endpoint + type configuration = context * Service.configuration type t = context * Service.t @@ -286,44 +278,34 @@ struct end let service_with_ssl : - type edn t flow. - key:edn Conduit_async.key -> - (t * flow) Conduit_async.Witness.service -> + type cfg edn t flow. + (cfg, t * flow) Conduit_async.Service.service -> reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> - flow with_ssl Conduit_async.Witness.protocol -> - (context * edn) Conduit_async.key - * ((context * t) * flow with_ssl) Conduit_async.Witness.service = - fun ~key service ~reader ~writer protocol -> - match Conduit_async.impl_of_service ~key service with - | Ok (module S) -> - let module Service = struct - include S - - let reader = reader - - let writer = writer - end in - let module M = Make (Service) in - let k = - Conduit_async.key - (Format.asprintf "%s + ssl" (Conduit_async.name_of_key key)) in - let s = - Conduit_async.register_service ~key:k ~service:(module M) ~protocol - in - (k, s) - | _ -> invalid_arg "Invalid key" + (edn, flow with_ssl) Conduit_async.Client.protocol -> + (context * cfg, (context * t) * flow with_ssl) Conduit_async.Service.service + = + fun service ~reader ~writer protocol -> + let module S = (val Conduit_async.Service.impl service) in + let module Service = struct + include S + + let reader = reader + + let writer = writer + end in + let module M = Make (Service) in + Conduit_async.Service.register ~service:(module M) ~protocol module TCP = struct open Conduit_async_tcp - let endpoint, protocol = - protocol_with_ssl ~key:endpoint ~reader:Protocol.reader - ~writer:Protocol.writer protocol + let protocol = + protocol_with_ssl ~reader:Protocol.reader ~writer:Protocol.writer protocol - let configuration, service = - service_with_ssl ~key:configuration service ~reader:Protocol.reader - ~writer:Protocol.writer protocol + let service = + service_with_ssl service ~reader:Protocol.reader ~writer:Protocol.writer + protocol let resolv_conf ~port ~context domain_name = resolv_conf ~port domain_name >>| function diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index 5ce30daf..6151d421 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -42,32 +42,28 @@ val context : context val protocol_with_ssl : - key:'edn Conduit_async.key -> reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> - 'flow Conduit_async.Witness.protocol -> - (context * 'edn) Conduit_async.key - * 'flow with_ssl Conduit_async.Witness.protocol + ('edn, 'flow) Client.protocol -> + (context * 'edn, 'flow with_ssl) Client.protocol val service_with_ssl : - key:'edn Conduit_async.key -> - ('t * 'flow) Conduit_async.Witness.service -> + ('cfg, 't * 'flow) Service.service -> reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> - 'flow with_ssl Conduit_async.Witness.protocol -> - (context * 'edn) Conduit_async.key - * ((context * 't) * 'flow with_ssl) Conduit_async.Witness.service + ('edn, 'flow with_ssl) Client.protocol -> + (context * 'cfg, (context * 't) * 'flow with_ssl) Service.service module TCP : sig open Conduit_async_tcp - val endpoint : (context * endpoint) key + val protocol : (context * endpoint, Protocol.flow with_ssl) Client.protocol - val protocol : Protocol.flow with_ssl Witness.protocol + val service : + ( context * Server.configuration, + (context * Server.t) * Protocol.flow with_ssl ) + Service.service - val configuration : (context * Conduit_async_tcp.configuration) key - - val service : ((context * Service.t) * Protocol.flow with_ssl) Witness.service - - val resolv_conf : port:int -> context:context -> (context * endpoint) resolver + val resolv_conf : + port:int -> context:context -> (context * endpoint) Client.resolver end diff --git a/async/conduit_async_tcp.ml b/async/conduit_async_tcp.ml index af63c50f..ea917667 100644 --- a/async/conduit_async_tcp.ml +++ b/async/conduit_async_tcp.ml @@ -34,7 +34,7 @@ module Protocol = struct let pp_error = Core.Error.pp - let flow edn = + let connect edn = let connect = function | Inet address -> Tcp.connect (Tcp.Where_to_connect.of_inet_address address) @@ -84,14 +84,11 @@ module Protocol = struct Writer.close writer >>= fun () -> Async.return (Ok ())) end -let endpoint = Conduit_async.key "tcp-endpoint" - -let protocol = - Conduit_async.register_protocol ~key:endpoint ~protocol:(module Protocol) +let protocol = Conduit_async.Client.register ~protocol:(module Protocol) type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration -module Service = struct +module Server = struct type +'a s = 'a Async.Deferred.t type flow = Protocol.flow @@ -107,8 +104,7 @@ module Service = struct (Printexc.to_string exn) | Socket_closed -> Format.fprintf ppf "Socket closed" - type endpoint = configuration = - | Listen : ('a, 'b) Tcp.Where_to_listen.t -> endpoint + type nonrec configuration = configuration type t = | Master : ([ `Passive ], ([< Socket.Address.t ] as 'a)) Socket.t * 'a -> t @@ -151,12 +147,7 @@ module Service = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end -let configuration = Conduit_async.key "tcp-configuration" - -let service = - Conduit_async.register_service ~key:configuration - ~service:(module Service) - ~protocol +let service = Conduit_async.Service.register ~service:(module Server) ~protocol let resolv_conf ~port domain_name = Monitor.try_with (fun () -> diff --git a/async/conduit_async_tcp.mli b/async/conduit_async_tcp.mli index 988de417..83804e21 100644 --- a/async/conduit_async_tcp.mli +++ b/async/conduit_async_tcp.mli @@ -4,7 +4,7 @@ open Conduit_async type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t module Protocol : sig - include Conduit_async.PROTOCOL + include Conduit_async.Client.PROTOCOL with type endpoint = endpoint val address : flow -> Socket.Address.t @@ -13,16 +13,12 @@ module Protocol : sig val writer : flow -> Writer.t end -val endpoint : endpoint key - -val protocol : Protocol.flow Witness.protocol +val protocol : (Protocol.endpoint, Protocol.flow) Client.protocol type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration -module Service : SERVICE with type endpoint = configuration - -val configuration : configuration key +module Server : Service.SERVICE with type configuration = configuration -val service : (Service.t * Protocol.flow) Witness.service +val service : (configuration, Server.t * Protocol.flow) Service.service -val resolv_conf : port:int -> endpoint resolver +val resolv_conf : port:int -> endpoint Client.resolver diff --git a/async/conduit_async_tls.ml b/async/conduit_async_tls.ml index 82faad9f..2e7f2a89 100644 --- a/async/conduit_async_tls.ml +++ b/async/conduit_async_tls.ml @@ -4,10 +4,9 @@ include Conduit_tls.Make (Conduit_async.Async_scheduler) (Conduit_async) module TCP = struct open Conduit_async_tcp - let endpoint, protocol = protocol_with_tls ~key:endpoint protocol + let protocol = protocol_with_tls protocol - let configuration, service = - service_with_tls ~key:configuration service protocol + let service = service_with_tls service protocol let resolv_conf ~port ~config domain_name = resolv_conf ~port domain_name >>| function diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index b45e146d..4a49ec55 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -7,34 +7,33 @@ val underlying : 'flow protocol_with_tls -> 'flow val handshake : 'flow protocol_with_tls -> bool val protocol_with_tls : - key:'edn key -> - 'flow Witness.protocol -> - ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + ('edn, 'flow) Client.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol type 'service service_with_tls val service_with_tls : - key:'edn key -> - ('t * 'flow) Witness.service -> - 'flow protocol_with_tls Witness.protocol -> - ('edn * Tls.Config.server) key - * ('t service_with_tls * 'flow protocol_with_tls) Witness.service + ('cfg, 't * 'flow) Service.service -> + ('edn, 'flow protocol_with_tls) Client.protocol -> + ( 'cfg * Tls.Config.server, + 't service_with_tls * 'flow protocol_with_tls ) + Service.service module TCP : sig open Conduit_async_tcp - val endpoint : (endpoint * Tls.Config.client) key - - val protocol : Protocol.flow protocol_with_tls Witness.protocol - - val configuration : (configuration * Tls.Config.server) key + val protocol : + ( endpoint * Tls.Config.client, + Protocol.flow protocol_with_tls ) + Client.protocol val service : - (Service.t service_with_tls * Protocol.flow protocol_with_tls) - Witness.service + ( configuration * Tls.Config.server, + Server.t service_with_tls * Protocol.flow protocol_with_tls ) + Service.service val resolv_conf : port:int -> config:Tls.Config.client -> - (endpoint * Tls.Config.client) resolver + (endpoint * Tls.Config.client) Client.resolver end From bb4ee909f2cbbfc113e2daa66b2f801202496e8d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:08:39 +0200 Subject: [PATCH 020/140] Update conduit-lwt with the new core --- lwt/conduit_lwt.ml | 67 +++++++++++++++++----------------------- lwt/conduit_lwt.mli | 14 ++++----- lwt/conduit_lwt_flow.ml | 16 +++++----- lwt/conduit_lwt_flow.mli | 2 +- 4 files changed, 44 insertions(+), 55 deletions(-) diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index 043d548b..806ec3a8 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -10,47 +10,40 @@ include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt -let invalid_arg fmt = Format.kasprintf invalid_arg fmt - let ( >>? ) = Lwt_result.bind let serve_with_handler : type cfg master flow. - handler:(flow Witness.protocol -> flow -> unit Lwt.t) -> - key:cfg key -> - service:(master * flow) Witness.service -> + handler:(flow Service.protocol -> flow -> unit Lwt.t) -> + service:(cfg, master * flow) Service.service -> cfg -> unit Lwt_condition.t * unit Lwt.t = - fun ~handler ~key ~service cfg -> + fun ~handler ~service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in - match impl_of_service ~key service with - | Error _ -> invalid_arg "Invalid key %s" (name_of_key key) - | Ok (module Service) -> - let main = - serve ~key cfg ~service >>= function - | Error err -> failwith "%a" pp_error err - | Ok (master, protocol) -> ( - let rec loop () = - let stop = - Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in - let accept = - Service.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) - in - - Lwt.pick [ stop; accept ] >>= function - | Ok (`Flow flow) -> - Lwt.async (fun () -> handler protocol flow) ; - Lwt.pause () >>= loop - | Ok `Stop -> Service.close master - | Error err0 -> ( - Service.close master >>= function - | Ok () -> Lwt.return_error err0 - | Error _err1 -> Lwt.return_error err0) in - loop () >>= function - | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" Service.pp_error err) in - (stop, main) + let module Svc = (val Service.impl service) in + let main = + Service.serve cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok (master, protocol) -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler protocol flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Lwt.return_error err0 + | Error _err1 -> Lwt.return_error err0) in + loop () >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) module type CONDUIT = sig type endpoint @@ -61,11 +54,7 @@ module type CONDUIT = sig type master - val endpoint : endpoint key - - val protocol : flow Witness.protocol - - val configuration : configuration key + val protocol : (endpoint, flow) Client.protocol - val service : (master * flow) Witness.service + val service : (configuration, master * flow) Service.service end diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index 0666c302..a9cab5f1 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -9,9 +9,8 @@ include and type +'a s = 'a Lwt.t val serve_with_handler : - handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> - key:'cfg key -> - service:('master * 'flow) Witness.service -> + handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> + service:('cfg, 'master * 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t @@ -36,13 +35,14 @@ val serve_with_handler : module type CONDUIT = sig type endpoint + type flow + type configuration + type master - val endpoint : endpoint key - val protocol : flow Witness.protocol + val protocol : (endpoint, flow) Client.protocol - val configuration : configuration key - val service : (master * flow) Witness.service + val service : (configuration, master * flow) Service.service end diff --git a/lwt/conduit_lwt_flow.ml b/lwt/conduit_lwt_flow.ml index d14261bd..ba9fba8a 100644 --- a/lwt/conduit_lwt_flow.ml +++ b/lwt/conduit_lwt_flow.ml @@ -1,20 +1,20 @@ open Lwt.Infix -type flow = Conduit_lwt.flow +type flow = Conduit_lwt.Client.flow -type error = Conduit_lwt.error +type error = Conduit_lwt.Client.error -type write_error = [ Mirage_flow.write_error | Conduit_lwt.error ] +type write_error = [ Mirage_flow.write_error | Conduit_lwt.Client.error ] -let pp_error = Conduit_lwt.pp_error +let pp_error = Conduit_lwt.Client.pp_error let pp_write_error ppf = function | #Mirage_flow.write_error as err -> Mirage_flow.pp_write_error ppf err - | #Conduit_lwt.error as err -> Conduit_lwt.pp_error ppf err + | #Conduit_lwt.Client.error as err -> Conduit_lwt.Client.pp_error ppf err let read flow = let raw = Cstruct.create 0x1000 in - Conduit_lwt.recv flow raw >>= function + Conduit_lwt.Client.recv flow raw >>= function | Ok `End_of_input -> Lwt.return_ok `Eof | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) | Error _ as err -> Lwt.return err @@ -24,7 +24,7 @@ let write flow raw = if Cstruct.len x = 0 then Lwt.return_ok () else - Conduit_lwt.send flow x >>= function + Conduit_lwt.Client.send flow x >>= function | Error _ as err -> Lwt.return err | Ok len -> go (Cstruct.shift x len) in go raw @@ -38,4 +38,4 @@ let writev flow cs = | Error _ as err -> Lwt.return err) in go cs -let close flow = Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit +let close flow = Conduit_lwt.Client.close flow >>= fun _ -> Lwt.return_unit diff --git a/lwt/conduit_lwt_flow.mli b/lwt/conduit_lwt_flow.mli index f9714023..4ca487ce 100644 --- a/lwt/conduit_lwt_flow.mli +++ b/lwt/conduit_lwt_flow.mli @@ -15,4 +15,4 @@ the POSIX interface and let the end-user to allocate by himself the input buffer. *) -include Mirage_flow.S with type flow = Conduit_lwt.flow +include Mirage_flow.S with type flow = Conduit_lwt.Client.flow From ca12602f925a95abadca45f5cbe39c2ff4cee527 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:08:51 +0200 Subject: [PATCH 021/140] Update conduit-lwt-unix with the new core --- lwt-unix/conduit_lwt_unix.ml | 12 ++--- lwt-unix/conduit_lwt_unix.mli | 16 +++--- lwt-unix/conduit_lwt_unix_ssl.ml | 82 +++++++++++-------------------- lwt-unix/conduit_lwt_unix_ssl.mli | 28 +++++------ lwt-unix/conduit_lwt_unix_tcp.ml | 18 +++---- lwt-unix/conduit_lwt_unix_tcp.mli | 19 ++++--- lwt-unix/conduit_lwt_unix_tls.ml | 7 +-- lwt-unix/conduit_lwt_unix_tls.mli | 32 ++++++------ 8 files changed, 94 insertions(+), 120 deletions(-) diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml index 882f9bb8..672ea584 100644 --- a/lwt-unix/conduit_lwt_unix.ml +++ b/lwt-unix/conduit_lwt_unix.ml @@ -8,9 +8,9 @@ let io_of_flow flow = let close () = if !ic_closed && !oc_closed then - close flow >>= function + Client.close flow >>= function | Ok () -> Lwt.return_unit - | Error err -> failf "%a" pp_error err + | Error err -> failf "%a" Client.pp_error err else Lwt.return_unit in let ic_close () = ic_closed := true ; @@ -20,15 +20,15 @@ let io_of_flow flow = close () in let recv buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - recv flow raw >>= function + Client.recv flow raw >>= function | Ok (`Input len) -> Lwt.return len | Ok `End_of_input -> Lwt.return 0 - | Error err -> failf "%a" pp_error err in + | Error err -> failf "%a" Client.pp_error err in let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in let send buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - send flow raw >>= function + Client.send flow raw >>= function | Ok len -> Lwt.return len - | Error err -> failf "%a" pp_error err in + | Error err -> failf "%a" Client.pp_error err in let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in (ic, oc) diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli index f6119a26..023e616a 100644 --- a/lwt-unix/conduit_lwt_unix.mli +++ b/lwt-unix/conduit_lwt_unix.mli @@ -6,17 +6,17 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type 'a key = ('a * Conduit_lwt.scheduler) Conduit.key - and type 'a Witness.protocol = 'a Conduit_lwt.Witness.protocol - and type 'a Witness.service = 'a Conduit_lwt.Witness.service - and type flow = Conduit_lwt.flow + and type ('edn, 'flow) Client.protocol = + ('edn, 'flow) Conduit_lwt.Client.protocol + and type ('cfg, 'v) Service.service = + ('cfg, 'v) Conduit_lwt.Service.service + and type Client.flow = Conduit_lwt.Client.flow val serve_with_handler : - handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> - key:'cfg key -> - service:('master * 'flow) Witness.service -> + handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> + service:('cfg, 'master * 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t val io_of_flow : - flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel + Client.flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml index 5842a7ac..bb05c5bb 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -5,8 +5,6 @@ let ( >>? ) x f = let reword_error f = function Ok _ as v -> v | Error err -> Error (f err) -let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt - type ('edn, 'flow) endpoint = { context : Ssl.context; endpoint : 'edn; @@ -27,7 +25,7 @@ let endpoint ~file_descr ~context ?verify endpoint = let pf = Format.fprintf -module Protocol (Flow : Conduit_lwt_unix.PROTOCOL) = struct +module Protocol (Flow : Conduit_lwt_unix.Client.PROTOCOL) = struct type input = Cstruct.t type output = Cstruct.t @@ -44,8 +42,9 @@ module Protocol (Flow : Conduit_lwt_unix.PROTOCOL) = struct type nonrec endpoint = (Flow.endpoint, Flow.flow) endpoint - let flow { context; endpoint; verify } = - Flow.flow endpoint >|= reword_error (fun err -> `Flow err) >>? fun flow -> + let connect { context; endpoint; verify } = + Flow.connect endpoint >|= reword_error (fun err -> `Flow err) + >>? fun flow -> verify context flow >>= function | Ok _ as v -> Lwt.return v | Error (`Verify _ as err) -> Lwt.return (Error err) @@ -67,34 +66,24 @@ end let protocol_with_ssl : type edn flow. - key:edn Conduit_lwt_unix.key -> - flow Conduit_lwt_unix.Witness.protocol -> - (edn, flow) endpoint Conduit_lwt_unix.key - * Lwt_ssl.socket Conduit_lwt_unix.Witness.protocol = - fun ~key protocol -> - match Conduit_lwt_unix.impl_of_protocol ~key protocol with - | Ok (module Flow) -> - let module M = Protocol (Flow) in - let k = - Conduit_lwt_unix.key - (Fmt.strf "%s + ssl" (Conduit_lwt_unix.name_of_key key)) in - let p = Conduit_lwt_unix.register_protocol ~key:k ~protocol:(module M) in - (k, p) - | Error _ -> - failwith "Invalid key %s with given protocol" - (Conduit_lwt_unix.name_of_key key) + (edn, flow) Conduit_lwt_unix.Client.protocol -> + ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol = + fun protocol -> + let module Flow = (val Conduit_lwt_unix.Client.impl_of_protocol protocol) in + let module M = Protocol (Flow) in + Conduit_lwt_unix.Client.register ~protocol:(module M) type 't master = { master : 't; context : Ssl.context } -module Service (Service : sig - include Conduit_lwt_unix.SERVICE +module Server (Service : sig + include Conduit_lwt_unix.Service.SERVICE val file_descr : flow -> Lwt_unix.file_descr end) = struct type +'a s = 'a Lwt.t - type endpoint = Ssl.context * Service.endpoint + type configuration = Ssl.context * Service.configuration type t = Service.t master @@ -122,31 +111,21 @@ struct end let service_with_ssl : - type edn t flow. - key:edn Conduit_lwt_unix.key -> - (t * flow) Conduit_lwt_unix.Witness.service -> + type cfg edn t flow. + (cfg, t * flow) Conduit_lwt_unix.Service.service -> file_descr:(flow -> Lwt_unix.file_descr) -> - Lwt_ssl.socket Conduit_lwt_unix.Witness.protocol -> - (Ssl.context * edn) Conduit_lwt_unix.key - * (t master * Lwt_ssl.socket) Conduit_lwt_unix.Witness.service = - fun ~key service ~file_descr protocol -> - match Conduit_lwt_unix.impl_of_service ~key service with - | Ok (module S) -> - let module M = Service (struct - include S - - let file_descr = file_descr - end) in - let k = - Conduit_lwt_unix.key - (Fmt.strf "%s + ssl" (Conduit_lwt_unix.name_of_key key)) in - let s = - Conduit_lwt_unix.register_service ~key:k ~service:(module M) ~protocol - in - (k, s) - | Error _ -> - failwith "Invalid key %s with given service" - (Conduit_lwt_unix.name_of_key key) + (edn, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol -> + ( Ssl.context * cfg, + t master * Lwt_ssl.socket ) + Conduit_lwt_unix.Service.service = + fun service ~file_descr protocol -> + let module S = (val Conduit_lwt_unix.Service.impl service) in + let module M = Server (struct + include S + + let file_descr = file_descr + end) in + Conduit_lwt_unix.Service.register ~service:(module M) ~protocol module TCP = struct let resolv_conf ~port ~context ?verify domain_name = @@ -162,9 +141,8 @@ module TCP = struct Protocol.flow -> (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t - let endpoint, protocol = protocol_with_ssl ~key:endpoint protocol + let protocol = protocol_with_ssl protocol - let configuration, service = - service_with_ssl ~key:configuration service ~file_descr:Protocol.file_descr - protocol + let service = + service_with_ssl service ~file_descr:Protocol.file_descr protocol end diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli index 69d6361b..ae64eda4 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -55,9 +55,8 @@ val endpoint : hostname} with your peer. *) val protocol_with_ssl : - key:'edn key -> - 'flow Witness.protocol -> - ('edn, 'flow) endpoint key * Lwt_ssl.socket Witness.protocol + ('edn, 'flow) Client.protocol -> + (('edn, 'flow) endpoint, Lwt_ssl.socket) Client.protocol (** [protocol_with_ssl ~key protocol] returns a representation of the given protocol with SSL. *) @@ -65,11 +64,10 @@ type 't master (** Type of the {i master} socket. *) val service_with_ssl : - key:'edn key -> - ('t * 'flow) Witness.service -> + ('cfg, 't * 'flow) Service.service -> file_descr:('flow -> Lwt_unix.file_descr) -> - Lwt_ssl.socket Witness.protocol -> - (Ssl.context * 'edn) key * ('t master * Lwt_ssl.socket) Witness.service + ('edn, Lwt_ssl.socket) Client.protocol -> + (Ssl.context * 'cfg, 't master * Lwt_ssl.socket) Service.service (** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a representation of the given service with SSL. The service deliver an SSL flow which must be described by a [Lwt_ssl.socket Witness.protocol] (eg. @@ -81,13 +79,15 @@ val service_with_ssl : module TCP : sig open Conduit_lwt_unix_tcp - val endpoint : (Lwt_unix.sockaddr, Protocol.flow) endpoint key + val protocol : + ( (Lwt_unix.sockaddr, Protocol.flow) endpoint, + Lwt_ssl.socket ) + Client.protocol - val protocol : Lwt_ssl.socket Witness.protocol - - val configuration : (Ssl.context * configuration) key - - val service : (Service.t master * Lwt_ssl.socket) Witness.service + val service : + ( Ssl.context * configuration, + Server.t master * Lwt_ssl.socket ) + Service.service type verify = Ssl.context -> @@ -98,5 +98,5 @@ module TCP : sig port:int -> context:Ssl.context -> ?verify:verify -> - (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver + (Lwt_unix.sockaddr, Protocol.flow) endpoint Client.resolver end diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index 50495a27..dd6c7252 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -62,7 +62,7 @@ module Protocol = struct let io_buffer_size = 65536 - let flow sockaddr = + let connect sockaddr = let socket = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in @@ -197,10 +197,10 @@ end type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } -module Service = struct +module Server = struct type +'a s = 'a Lwt.t - type endpoint = configuration = { + type nonrec configuration = configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int; } @@ -303,17 +303,11 @@ module Service = struct Lwt.return_ok () end -let endpoint = Conduit_lwt.key "tcp-endpoint" +let protocol = Conduit_lwt.Client.register ~protocol:(module Protocol) -let protocol = - Conduit_lwt.register_protocol ~key:endpoint ~protocol:(module Protocol) +include (val Conduit_lwt.Client.repr protocol) -let configuration = Conduit_lwt.key "tcp-configuration" - -let service = - Conduit_lwt.register_service ~key:configuration - ~service:(module Service) - ~protocol +let service = Conduit_lwt.Service.register ~service:(module Server) ~protocol let resolv_conf ~port domain_name = Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli index 1950179d..ae17bcf4 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.mli +++ b/lwt-unix/conduit_lwt_unix_tcp.mli @@ -19,7 +19,7 @@ open Conduit_lwt_unix module Protocol : sig include - PROTOCOL + Client.PROTOCOL with type endpoint = Lwt_unix.sockaddr and type error = [ `Closed_by_peer @@ -47,9 +47,9 @@ end type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } -module Service : - SERVICE - with type endpoint = configuration +module Server : + Service.SERVICE + with type configuration = configuration and type t = Lwt_unix.file_descr and type flow = Protocol.flow and type error = @@ -66,12 +66,11 @@ module Service : | `Protocol_error | `Firewall_rules_forbid_connection ] -val endpoint : Lwt_unix.sockaddr key +val protocol : (Lwt_unix.sockaddr, Protocol.flow) Client.protocol -val protocol : Protocol.flow Witness.protocol +type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value +type Conduit_lwt.Client.flow += T of t -val configuration : configuration key +val service : (configuration, Server.t * Protocol.flow) Service.service -val service : (Service.t * Protocol.flow) Witness.service - -val resolv_conf : port:int -> Lwt_unix.sockaddr resolver +val resolv_conf : port:int -> Lwt_unix.sockaddr Client.resolver diff --git a/lwt-unix/conduit_lwt_unix_tls.ml b/lwt-unix/conduit_lwt_unix_tls.ml index cad4d23a..5c004b4b 100644 --- a/lwt-unix/conduit_lwt_unix_tls.ml +++ b/lwt-unix/conduit_lwt_unix_tls.ml @@ -3,10 +3,11 @@ include Conduit_tls.Make (Conduit_lwt.Lwt_scheduler) (Conduit_lwt) module TCP = struct open Conduit_lwt_unix_tcp - let endpoint, protocol = protocol_with_tls ~key:endpoint protocol + let protocol = protocol_with_tls protocol - let configuration, service = - service_with_tls ~key:configuration service protocol + include (val Conduit_lwt.Client.repr protocol) + + let service = service_with_tls service protocol let resolv_conf ~port ~config domain_name = let open Lwt.Infix in diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt-unix/conduit_lwt_unix_tls.mli index c57d1b62..9db366ed 100644 --- a/lwt-unix/conduit_lwt_unix_tls.mli +++ b/lwt-unix/conduit_lwt_unix_tls.mli @@ -19,34 +19,36 @@ val handshake : 'flow protocol_with_tls -> bool it returns [false]. *) val protocol_with_tls : - key:'edn key -> - 'flow Witness.protocol -> - ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + ('edn, 'flow) Client.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol type 'service service_with_tls val service_with_tls : - key:'edn key -> - ('t * 'flow) Witness.service -> - 'flow protocol_with_tls Witness.protocol -> - ('edn * Tls.Config.server) key - * ('t service_with_tls * 'flow protocol_with_tls) Witness.service + ('cfg, 't * 'flow) Service.service -> + ('edn, 'flow protocol_with_tls) Client.protocol -> + ( 'cfg * Tls.Config.server, + 't service_with_tls * 'flow protocol_with_tls ) + Service.service module TCP : sig open Conduit_lwt_unix_tcp - val endpoint : (Lwt_unix.sockaddr * Tls.Config.client) key + val protocol : + ( Lwt_unix.sockaddr * Tls.Config.client, + Protocol.flow protocol_with_tls ) + Client.protocol - val protocol : Protocol.flow protocol_with_tls Witness.protocol - - val configuration : (configuration * Tls.Config.server) key + type t = (Lwt_unix.sockaddr * Tls.Config.client, Protocol.flow protocol_with_tls) Conduit.value + type Conduit_lwt.Client.flow += T of t val service : - (Service.t service_with_tls * Protocol.flow protocol_with_tls) - Witness.service + ( configuration * Tls.Config.server, + Server.t service_with_tls * Protocol.flow protocol_with_tls ) + Service.service val resolv_conf : port:int -> config:Tls.Config.client -> - (Lwt_unix.sockaddr * Tls.Config.client) resolver + (Lwt_unix.sockaddr * Tls.Config.client) Client.resolver end From 1fb8fc2e4ecf557b4d903118690a037b8f84f6a3 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:09:06 +0200 Subject: [PATCH 022/140] Update conduit-mirage with the new core --- mirage/conduit_mirage.mli | 22 +++++++++------------- mirage/conduit_mirage_dns.ml | 2 +- mirage/conduit_mirage_dns.mli | 2 +- mirage/conduit_mirage_flow.mli | 2 +- mirage/conduit_mirage_tcp.ml | 18 +++++------------- mirage/conduit_mirage_tcp.mli | 8 ++------ mirage/conduit_mirage_tls.mli | 15 +++++++-------- 7 files changed, 26 insertions(+), 43 deletions(-) diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index c95eabca..7bf64010 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -6,15 +6,15 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type 'a key = ('a * Conduit_lwt.scheduler) Conduit.key - and type 'a Witness.protocol = 'a Conduit_lwt.Witness.protocol - and type 'a Witness.service = 'a Conduit_lwt.Witness.service - and type flow = Conduit_lwt.flow + and type ('edn, 'flow) Client.protocol = + ('edn, 'flow) Conduit_lwt.Client.protocol + and type ('cfg, 'v) Service.service = + ('cfg, 'v) Conduit_lwt.Service.service + and type Client.flow = Conduit_lwt.Client.flow val serve_with_handler : - handler:('flow Witness.protocol -> 'flow -> unit Lwt.t) -> - key:'cfg key -> - service:('master * 'flow) Witness.service -> + handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> + service:('cfg, 'master * 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t @@ -27,11 +27,7 @@ module type CONDUIT = sig type master - val endpoint : endpoint key + val protocol : (endpoint, flow) Client.protocol - val protocol : flow Witness.protocol - - val configuration : configuration key - - val service : (master * flow) Witness.service + val service : (configuration, master * flow) Service.service end diff --git a/mirage/conduit_mirage_dns.ml b/mirage/conduit_mirage_dns.ml index bf66d4b3..35f95e91 100644 --- a/mirage/conduit_mirage_dns.ml +++ b/mirage/conduit_mirage_dns.ml @@ -13,7 +13,7 @@ struct t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) resolver = + (Ipaddr.V4.t * int) Client.resolver = fun t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function | Ok domain_name -> Lwt.return_some (domain_name, port) diff --git a/mirage/conduit_mirage_dns.mli b/mirage/conduit_mirage_dns.mli index cdebcf5a..42a224bb 100644 --- a/mirage/conduit_mirage_dns.mli +++ b/mirage/conduit_mirage_dns.mli @@ -11,5 +11,5 @@ module Make t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) resolver + (Ipaddr.V4.t * int) Client.resolver end diff --git a/mirage/conduit_mirage_flow.mli b/mirage/conduit_mirage_flow.mli index 1135b37d..03d1d177 100644 --- a/mirage/conduit_mirage_flow.mli +++ b/mirage/conduit_mirage_flow.mli @@ -15,4 +15,4 @@ the POSIX interface and let the end-user to allocate by himself the input buffer. *) -include Mirage_flow.S with type flow = Conduit_mirage.flow +include Mirage_flow.S with type flow = Conduit_mirage.Client.flow diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml index 06e4f6a9..b1e3fe68 100644 --- a/mirage/conduit_mirage_tcp.ml +++ b/mirage/conduit_mirage_tcp.ml @@ -75,7 +75,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct type nonrec endpoint = endpoint - let flow { stack; keepalive; nodelay; ip; port } = + let connect { stack; keepalive; nodelay; ip; port } = let tcpv4 = StackV4.tcpv4 stack in StackV4.TCPV4.create_connection tcpv4 ?keepalive (ip, port) >|= R.reword_error error @@ -199,10 +199,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct StackV4.TCPV4.close t.flow >>= fun () -> Lwt.return_ok ()) end - let endpoint : endpoint Conduit_mirage.key = Conduit_mirage.key "tcp-mirage" - - let protocol = - Conduit_mirage.register_protocol ~key:endpoint ~protocol:(module Protocol) + let protocol = Conduit_mirage.Client.register ~protocol:(module Protocol) type nonrec configuration = StackV4.t configuration @@ -215,7 +212,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct mutable closed : bool; } - module Service = struct + module Server = struct type +'a s = 'a Conduit_mirage.s type error = Connection_aborted @@ -226,7 +223,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct type flow = protocol - type endpoint = configuration + type nonrec configuration = configuration type t = service @@ -272,11 +269,6 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt.return (Ok ())) end - let configuration : configuration Conduit_mirage.key = - Conduit_mirage.key "tcp-mirage" - let service = - Conduit_mirage.register_service ~key:configuration - ~service:(module Service) - ~protocol + Conduit_mirage.Service.register ~service:(module Server) ~protocol end diff --git a/mirage/conduit_mirage_tcp.mli b/mirage/conduit_mirage_tcp.mli index a8b516c1..24ee8cd6 100644 --- a/mirage/conduit_mirage_tcp.mli +++ b/mirage/conduit_mirage_tcp.mli @@ -18,15 +18,11 @@ type 'stack configuration = { module Make (StackV4 : Mirage_stack.V4) : sig type protocol - val endpoint : (StackV4.t, Ipaddr.V4.t) endpoint key - - val protocol : protocol Witness.protocol + val protocol : ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Client.protocol val dst : protocol -> Ipaddr.V4.t * int type service - val configuration : StackV4.t configuration key - - val service : (service * protocol) Witness.service + val service : (StackV4.t configuration, service * protocol) Service.service end diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli index 40490369..8a42e474 100644 --- a/mirage/conduit_mirage_tls.mli +++ b/mirage/conduit_mirage_tls.mli @@ -7,15 +7,14 @@ val underlying : 'flow protocol_with_tls -> 'flow val handshake : 'flow protocol_with_tls -> bool val protocol_with_tls : - key:'edn key -> - 'flow Witness.protocol -> - ('edn * Tls.Config.client) key * 'flow protocol_with_tls Witness.protocol + ('edn, 'flow) Client.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol type 'service service_with_tls val service_with_tls : - key:'edn key -> - ('t * 'flow) Witness.service -> - 'flow protocol_with_tls Witness.protocol -> - ('edn * Tls.Config.server) key - * ('t service_with_tls * 'flow protocol_with_tls) Witness.service + ('cfg, 't * 'flow) Service.service -> + ('edn, 'flow protocol_with_tls) Client.protocol -> + ( 'cfg * Tls.Config.server, + 't service_with_tls * 'flow protocol_with_tls ) + Service.service From 66dbbc0824dbac17d4f3c157282c498a300897c1 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:09:20 +0200 Subject: [PATCH 023/140] Update conduit-tls with the new core --- tls/conduit_tls.ml | 49 ++++++++++++++++++--------------------------- tls/conduit_tls.mli | 16 +++++++-------- 2 files changed, 27 insertions(+), 38 deletions(-) diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index a4b8a90e..cded8828 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -193,8 +193,8 @@ struct in go tls raw0 - let flow (edn, config) = - Flow.flow edn >>| reword_error flow_error >>? fun flow -> + let connect (edn, config) = + Flow.connect edn >>| reword_error flow_error >>? fun flow -> let raw = Cstruct.create 0x1000 in let queue = Ke.create ~capacity:0x1000 Bigarray.Char in let tls, buf = Tls.Engine.client config in @@ -305,18 +305,13 @@ struct let protocol_with_tls : type edn flow. - key:edn Conduit.key -> - flow Conduit.Witness.protocol -> - (edn * Tls.Config.client) Conduit.key - * flow protocol_with_tls Conduit.Witness.protocol = - fun ~key protocol -> - match Conduit.impl_of_protocol ~key protocol with - | Ok (module Flow) -> - let module M = Make_protocol (Flow) in - let k = Conduit.key (Fmt.strf "%s + tls" (Conduit.name_of_key key)) in - let p = Conduit.register_protocol ~key:k ~protocol:(module M) in - (k, p) - | Error _ -> assert false + (edn, flow) Conduit.Client.protocol -> + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.Client.protocol + = + fun protocol -> + let module Protocol = (val Conduit.Client.impl_of_protocol protocol) in + let module M = Make_protocol (Protocol) in + Conduit.Client.register ~protocol:(module M) type 'service service_with_tls = { service : 'service; @@ -327,7 +322,7 @@ struct struct type +'a s = 'a Conduit.s - type endpoint = Service.endpoint * Tls.Config.server + type configuration = Service.configuration * Tls.Config.server type flow = Service.flow protocol_with_tls @@ -358,18 +353,14 @@ struct end let service_with_tls : - type edn t flow. - key:edn Conduit.key -> - (t * flow) Conduit.Witness.service -> - flow protocol_with_tls Conduit.Witness.protocol -> - (edn * Tls.Config.server) Conduit.key - * (t service_with_tls * flow protocol_with_tls) Conduit.Witness.service = - fun ~key service protocol -> - match Conduit.impl_of_service ~key service with - | Ok (module Service) -> - let module M = Make_server (Service) in - let k = Conduit.key (Fmt.strf "%s + tls" (Conduit.name_of_key key)) in - let s = Conduit.register_service ~key:k ~service:(module M) ~protocol in - (k, s) - | _ -> assert false + type cfg edn t flow. + (cfg, t * flow) Conduit.Service.service -> + (edn, flow protocol_with_tls) Conduit.Client.protocol -> + ( cfg * Tls.Config.server, + t service_with_tls * flow protocol_with_tls ) + Conduit.Service.service = + fun service protocol -> + let module Service = (val Conduit.Service.impl service) in + let module M = Make_server (Service) in + Conduit.Service.register ~service:(module M) ~protocol end diff --git a/tls/conduit_tls.mli b/tls/conduit_tls.mli index 7a23f4ad..f627fbb0 100644 --- a/tls/conduit_tls.mli +++ b/tls/conduit_tls.mli @@ -52,19 +52,17 @@ module Make (** [handshake flow] returns [true] if {i handshake} is processing. *) val protocol_with_tls : - key:'edn Conduit.key -> - 'flow Conduit.Witness.protocol -> - ('edn * Tls.Config.client) Conduit.key - * 'flow protocol_with_tls Conduit.Witness.protocol + ('edn, 'flow) Conduit.Client.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Conduit.Client.protocol (** From a given protocol [witness], it creates a new {i witness} of the protocol layered with TLS. *) type 'service service_with_tls val service_with_tls : - key:'edn Conduit.key -> - ('t * 'flow) Conduit.Witness.service -> - 'flow protocol_with_tls Conduit.Witness.protocol -> - ('edn * Tls.Config.server) Conduit.key - * ('t service_with_tls * 'flow protocol_with_tls) Conduit.Witness.service + ('cfg, 't * 'flow) Conduit.Service.service -> + ('edn, 'flow protocol_with_tls) Conduit.Client.protocol -> + ( 'cfg * Tls.Config.server, + 't service_with_tls * 'flow protocol_with_tls ) + Conduit.Service.service end From 44125b6b3da59376fd995b5263176221f57f3802 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 14:09:33 +0200 Subject: [PATCH 024/140] Update tests with the new core --- tests/ping_pong.ml | 81 +++++++++++++++++++-------------------- tests/with_async.ml | 93 +++++++++++++++++++++------------------------ 2 files changed, 83 insertions(+), 91 deletions(-) diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index ced9b30d..21ae590b 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -44,7 +44,7 @@ let getline queue flow = match getline queue with | Some line -> Lwt.return_ok (`Line line) | None -> ( - Conduit_lwt.recv flow tmp >>? function + Conduit_lwt_unix.Client.recv flow tmp >>? function | `End_of_input -> Lwt.return_ok `Close | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; @@ -59,49 +59,50 @@ let transmission flow = let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go () = getline queue flow >>= function - | Ok `Close | Error _ -> Conduit_lwt.close flow + | Ok `Close | Error _ -> Conduit_lwt.Client.close flow | Ok (`Line "ping") -> Fmt.epr "[!] received ping.\n%!" ; - Conduit_lwt.send flow pong >>? fun _ -> go () + Conduit_lwt.Client.send flow pong >>? fun _ -> go () | Ok (`Line "pong") -> Fmt.epr "[!] received pong.\n%!" ; - Conduit_lwt.send flow ping >>? fun _ -> go () + Conduit_lwt.Client.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Fmt.epr "[!] received %S.\n%!" line ; - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - Conduit_lwt.close flow in + Conduit_lwt.Client.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> Conduit_lwt.Client.close flow in go () >>= function - | Error err -> failwith "%a" Conduit_lwt.pp_error err + | Error err -> failwith "%a" Conduit_lwt.Client.pp_error err | Ok () -> Lwt.return () let server : type cfg master flow. - key:cfg Conduit_lwt.key -> cfg -> - service:(master * flow) Conduit_lwt.Witness.service -> + service:(cfg, master * flow) Conduit_lwt.Service.service -> unit Lwt_condition.t * unit Lwt.t = - fun ~key cfg ~service -> + fun cfg ~service -> Conduit_lwt_unix.serve_with_handler ~handler:(fun protocol flow -> - transmission (Conduit_lwt_unix.abstract protocol flow)) - ~key ~service cfg + let (Conduit_lwt_unix.Service.Protocol protocol) = protocol in + transmission (Conduit_lwt.Client.abstract protocol flow)) + ~service cfg (* Client part *) -let client ?key ~resolvers domain_name responses = - Conduit_lwt.flow ?key resolvers domain_name >>? fun flow -> +let client ~resolvers domain_name responses = + Conduit_lwt.Client.connect resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function - | [] -> Conduit_lwt.close flow + | [] -> Conduit_lwt.Client.close flow | line :: rest -> ( - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_lwt.Client.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> getline queue flow >>? function - | `Close -> Conduit_lwt.close flow + | `Close -> Conduit_lwt.Client.close flow | `Line "pong" -> go rest - | `Line _ -> Conduit_lwt.close flow) in + | `Line _ -> Conduit_lwt.Client.close flow) in go responses -let client ?key ~resolvers filename = +let client ~resolvers filename = let rec go acc ic = match input_line ic with | line -> go (line :: acc) ic @@ -109,22 +110,22 @@ let client ?key ~resolvers filename = let ic = open_in filename in let responses = go [] ic in close_in ic ; - client ?key ~resolvers localhost responses >>= function + client ~resolvers localhost responses >>= function | Ok () -> Lwt.return_unit | Error `Closed_by_peer -> Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Fmt.epr "client: %a.\n%!" Conduit_lwt.pp_error err ; + | Error (#Conduit_lwt.Client.error as err) -> + Fmt.epr "client: %a.\n%!" Conduit_lwt.Client.pp_error err ; Lwt.return_unit (* Composition *) -let tls_endpoint, tls_protocol, tls_configuration, tls_service = +let tls_protocol, tls_service = let open Conduit_lwt_unix_tls.TCP in - (endpoint, protocol, configuration, service) + (protocol, service) -let ssl_endpoint, ssl_protocol, ssl_configuration, ssl_service = +let ssl_protocol, ssl_service = let open Conduit_lwt_unix_ssl.TCP in - (endpoint, protocol, configuration, service) + (protocol, service) (* Resolution *) @@ -141,12 +142,10 @@ let resolve_ssl_ping_pong = let resolvers = Conduit.empty - |> Conduit_lwt.register_resolver ~priority:20 - ~key:Conduit_lwt_unix_tcp.endpoint resolve_ping_pong - |> Conduit_lwt.register_resolver ~priority:10 ~key:tls_endpoint - resolve_tls_ping_pong - |> Conduit_lwt.register_resolver ~priority:10 ~key:ssl_endpoint - resolve_ssl_ping_pong + |> Conduit_lwt.Client.add ~priority:20 Conduit_lwt_unix_tcp.protocol + resolve_ping_pong + |> Conduit_lwt.Client.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_lwt.Client.add ~priority:10 ssl_protocol resolve_ssl_ping_pong (* Run *) @@ -169,16 +168,14 @@ let config cert key = | _ -> Fmt.failwith "Invalid key or certificate" let run_with : - type edn cfg master flow. - ?key_edn:edn Conduit_lwt.key -> - key_cfg:cfg Conduit_lwt.key -> + type cfg master flow. cfg -> - service:(master * flow) Conduit_lwt.Witness.service -> + service:(cfg, master * flow) Conduit_lwt.Service.service -> string list -> unit = - fun ?key_edn ~key_cfg cfg ~service clients -> - let stop, server = server ~key:key_cfg cfg ~service in - let clients = List.map (client ?key:key_edn ~resolvers) clients in + fun cfg ~service clients -> + let stop, server = server cfg ~service in + let clients = List.map (client ~resolvers) clients in let clients = Lwt.join clients >>= fun () -> Lwt_condition.broadcast stop () ; @@ -186,7 +183,7 @@ let run_with : Lwt_main.run (Lwt.join [ server; clients ]) let run_with_tcp clients = - run_with ~key_cfg:Conduit_lwt_unix_tcp.configuration + run_with { Conduit_lwt_unix_tcp.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); @@ -197,7 +194,7 @@ let run_with_tcp clients = let run_with_ssl cert key clients = let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Server_context in Ssl.use_certificate ctx cert key ; - run_with ~key_cfg:ssl_configuration + run_with ( ctx, { Conduit_lwt_unix_tcp.sockaddr = @@ -208,7 +205,7 @@ let run_with_ssl cert key clients = let run_with_tls cert key clients = let ctx = config cert key in - run_with ~key_edn:tls_endpoint ~key_cfg:tls_configuration + run_with ( { Conduit_lwt_unix_tcp.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); diff --git a/tests/with_async.ml b/tests/with_async.ml index 2faba723..acb6fdd7 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -4,17 +4,17 @@ open Async_ssl let () = Mirage_crypto_rng_unix.initialize () -let tcp_endpoint, tcp_protocol, tcp_configuration, tcp_service = +let tcp_protocol, tcp_service = let open Conduit_async_tcp in - (endpoint, protocol, configuration, service) + (protocol, service) -let ssl_endpoint, ssl_protocol, ssl_configuration, ssl_service = +let ssl_protocol, ssl_service = let open Conduit_async_ssl.TCP in - (endpoint, protocol, configuration, service) + (protocol, service) -let tls_endpoint, tls_protocol, tls_configuration, tls_service = +let tls_protocol, tls_service = let open Conduit_async_tls.TCP in - (endpoint, protocol, configuration, service) + (protocol, service) let ( >>? ) x f = x >>= function Ok x -> f x | Error _ as err -> Async.return err @@ -49,7 +49,7 @@ let getline queue flow = match getline queue with | Some line -> Async.return (Ok (`Line line)) | None -> ( - Conduit_async.recv flow tmp >>? function + Conduit_async.Client.recv flow tmp >>? function | `End_of_input -> Async.return (Ok `Close) | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; @@ -66,35 +66,34 @@ let transmission ~stop flow = let finish = Condition.wait stop >>= fun () -> Async.return (Ok `Done) in let getline = getline queue flow in Async.Deferred.any [ finish; getline ] >>= function - | Ok (`Done | `Close) | Error _ -> Conduit_async.close flow + | Ok (`Done | `Close) | Error _ -> Conduit_async.Client.close flow | Ok (`Line "ping") -> Format.eprintf "[!] received ping.\n%!" ; - Conduit_async.send flow pong >>? fun _ -> go () + Conduit_async.Client.send flow pong >>? fun _ -> go () | Ok (`Line "pong") -> Format.eprintf "[!] received pong.\n%!" ; - Conduit_async.send flow ping >>? fun _ -> go () + Conduit_async.Client.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Format.eprintf "[!] received %S.\n%!" line ; - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - Conduit_async.close flow in + Conduit_async.Client.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> Conduit_async.Client.close flow in go () >>= function - | Error err -> failwith "%a" Conduit_async.pp_error err + | Error err -> failwith "%a" Conduit_async.Client.pp_error err | Ok () -> Async.return () let server : - type edn master flow. + type cfg master flow. launched:unit Async.Condition.t -> stop:unit Async.Condition.t -> - key:edn Conduit_async.key -> - edn -> - service:(master * flow) Conduit_async.Witness.service -> + cfg -> + service:(cfg, master * flow) Conduit_async.Service.service -> unit Async.Deferred.t = - fun ~launched ~stop ~key edn ~service -> + fun ~launched ~stop cfg ~service -> + let module Server = (val Conduit_async.Service.impl service) in let main () = - Conduit_async.impl_of_service ~key service |> Async.return - >>? fun (module Server) -> let reword_error = R.reword_error (R.msgf "%a" Server.pp_error) in - Conduit_async.serve ~key edn ~service >>? fun (master, protocol) -> + Conduit_async.Service.serve cfg ~service >>? fun (master, protocol) -> + let (Conduit_async.Service.Protocol protocol) = protocol in Condition.signal launched () ; let rec go () = @@ -106,7 +105,7 @@ let server : Async.Deferred.any [ close; accept ] >>= function | Ok (`Flow flow) -> Async.don't_wait_for - (transmission ~stop (Conduit_async.abstract protocol flow)) ; + (transmission ~stop (Conduit_async.Client.abstract protocol flow)) ; Async.Scheduler.yield () >>= go | Ok `Closed -> Server.close master | Error _ as err -> Server.close master >>= fun _ -> Async.return err @@ -114,22 +113,23 @@ let server : go () >>| reword_error in main () >>= function | Ok () -> Async.return () - | Error err -> failwith "%a" Conduit_async.pp_error err + | Error err -> failwith "%a" Conduit_async.Service.pp_error err -let client ?key ~resolvers domain_name responses = - Conduit_async.flow ?key resolvers domain_name >>? fun flow -> +let client ~resolvers domain_name responses = + Conduit_async.Client.connect resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function - | [] -> Conduit_async.close flow + | [] -> Conduit_async.Client.close flow | line :: rest -> ( - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_async.Client.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> getline queue flow >>? function - | `Close -> Conduit_async.close flow + | `Close -> Conduit_async.Client.close flow | `Line "pong" -> go rest - | `Line _ -> Conduit_async.close flow) in + | `Line _ -> Conduit_async.Client.close flow) in go responses -let client ?key ~resolvers domain_name filename = +let client ~resolvers domain_name filename = let rec go acc ic = match Stdlib.input_line ic with | line -> go (line :: acc) ic @@ -137,10 +137,10 @@ let client ?key ~resolvers domain_name filename = let ic = Stdlib.open_in filename in let responses = go [] ic in Stdlib.close_in ic ; - client ?key ~resolvers domain_name responses >>= function + client ~resolvers domain_name responses >>= function | Ok () -> Async.return () - | Error (#Conduit_async.error as err) -> - failwith "Client got an error: %a" Conduit_async.pp_error err + | Error (#Conduit_async.Client.error as err) -> + failwith "Client got an error: %a" Conduit_async.Client.pp_error err let resolve_ping_pong = Conduit_async_tcp.resolv_conf ~port:5000 @@ -157,30 +157,25 @@ let resolve_tls_ping_pong = let resolvers = Conduit.empty - |> Conduit_async.register_resolver ~priority:10 ~key:ssl_endpoint - resolve_ssl_ping_pong - |> Conduit_async.register_resolver ~priority:10 ~key:tls_endpoint - resolve_tls_ping_pong - |> Conduit_async.register_resolver ~priority:20 ~key:tcp_endpoint - resolve_ping_pong + |> Conduit_async.Client.add ~priority:10 ssl_protocol resolve_ssl_ping_pong + |> Conduit_async.Client.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_async.Client.add ~priority:20 tcp_protocol resolve_ping_pong let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : - type edn cfg master flow. - ?key_edn:edn Conduit_async.key -> - key_cfg:cfg Conduit_async.key -> + type cfg master flow. cfg -> - service:(master * flow) Conduit_async.Witness.service -> + service:(cfg, master * flow) Conduit_async.Service.service -> string list -> unit = - fun ?key_edn ~key_cfg cfg ~service clients -> + fun cfg ~service clients -> let launched = Condition.create () in let stop = Condition.create () in - let server () = server ~launched ~stop ~key:key_cfg cfg ~service in + let server () = server ~launched ~stop cfg ~service in let clients = Condition.wait launched >>= fun () -> - let clients = List.map (client ?key:key_edn ~resolvers localhost) clients in + let clients = List.map (client ~resolvers localhost) clients in Async.Deferred.all_unit clients >>= fun () -> Condition.broadcast stop () ; Async.return () in @@ -189,13 +184,13 @@ let run_with : Core.never_returns (Scheduler.go ()) let run_with_tcp clients = - run_with ~key_cfg:tcp_configuration + run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 5000)) ~service:tcp_service clients let run_with_ssl cert key clients = let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in - run_with ~key_cfg:ssl_configuration + run_with (ctx, Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 7000)) ~service:ssl_service clients @@ -220,7 +215,7 @@ let config cert key = let run_with_tls cert key clients = let ctx = config cert key in - run_with ~key_edn:tls_endpoint ~key_cfg:tls_configuration + run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 9000), ctx) ~service:tls_service clients From c84a6b45ecbe0b6846dd48d9619ab2c0df3220a2 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 16:04:56 +0200 Subject: [PATCH 025/140] ('a, 'b * 'c) service to ('a, 'b, 'c) service - And we remove the required protocol to register an new service --- async/conduit_async.ml | 8 +++--- async/conduit_async.mli | 4 +-- async/conduit_async_ssl.ml | 8 +++--- async/conduit_async_ssl.mli | 6 ++--- async/conduit_async_tcp.ml | 2 +- async/conduit_async_tcp.mli | 2 +- async/conduit_async_tls.mli | 6 ++--- lib/conduit.ml | 45 +++++++++++++------------------ lib/conduit.mli | 14 ++++------ lwt-unix/conduit_lwt_unix.mli | 8 +++--- lwt-unix/conduit_lwt_unix_ssl.ml | 8 +++--- lwt-unix/conduit_lwt_unix_ssl.mli | 6 ++--- lwt-unix/conduit_lwt_unix_tcp.ml | 2 +- lwt-unix/conduit_lwt_unix_tcp.mli | 2 +- lwt-unix/conduit_lwt_unix_tls.mli | 6 ++--- lwt/conduit_lwt.ml | 10 +++---- lwt/conduit_lwt.mli | 6 ++--- mirage/conduit_mirage.mli | 10 +++---- mirage/conduit_mirage_tcp.ml | 2 +- mirage/conduit_mirage_tcp.mli | 2 +- mirage/conduit_mirage_tls.mli | 4 +-- tests/ping_pong.ml | 18 ++++++++----- tests/with_async.ml | 18 ++++++++----- tls/conduit_tls.ml | 8 +++--- tls/conduit_tls.mli | 5 ++-- 25 files changed, 103 insertions(+), 107 deletions(-) diff --git a/async/conduit_async.ml b/async/conduit_async.ml index 5aa9e39f..d40f9a70 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -14,8 +14,8 @@ let ( >>? ) x f = Async.Deferred.Result.bind x ~f let serve_with_handler : type cfg master flow. - handler:(flow Service.protocol -> flow -> unit Async.Deferred.t) -> - service:(cfg, master * flow) Service.service -> + handler:(flow -> unit Async.Deferred.t) -> + service:(cfg, master, flow) Service.service -> cfg -> unit Async.Condition.t * unit Async.Deferred.t = fun ~handler ~service cfg -> @@ -25,7 +25,7 @@ let serve_with_handler : let main = Service.serve cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok (master, protocol) -> ( + | Ok master -> ( let rec loop () = let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in let accept = @@ -34,7 +34,7 @@ let serve_with_handler : Async.Deferred.any [ close; accept ] >>= function | Ok (`Flow flow) -> - Async.don't_wait_for (handler protocol flow) ; + Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () | Ok `Stop -> Svc.close master | Error err0 -> ( diff --git a/async/conduit_async.mli b/async/conduit_async.mli index cfe6c87b..10a0013b 100644 --- a/async/conduit_async.mli +++ b/async/conduit_async.mli @@ -10,8 +10,8 @@ include and type +'a s = 'a Async.Deferred.t val serve_with_handler : - handler:('flow Service.protocol -> 'flow -> unit Async.Deferred.t) -> - service:('cfg, 'master * 'flow) Service.service -> + handler:('flow -> unit Async.Deferred.t) -> + service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Async.Condition.t * unit Async.Deferred.t diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index 4d491b87..6648eaa0 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -279,13 +279,13 @@ end let service_with_ssl : type cfg edn t flow. - (cfg, t * flow) Conduit_async.Service.service -> + (cfg, t, flow) Conduit_async.Service.service -> reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> (edn, flow with_ssl) Conduit_async.Client.protocol -> - (context * cfg, (context * t) * flow with_ssl) Conduit_async.Service.service + (context * cfg, (context * t), flow with_ssl) Conduit_async.Service.service = - fun service ~reader ~writer protocol -> + fun service ~reader ~writer _ -> let module S = (val Conduit_async.Service.impl service) in let module Service = struct include S @@ -295,7 +295,7 @@ let service_with_ssl : let writer = writer end in let module M = Make (Service) in - Conduit_async.Service.register ~service:(module M) ~protocol + Conduit_async.Service.register ~service:(module M) module TCP = struct open Conduit_async_tcp diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index 6151d421..b3bd02df 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -48,11 +48,11 @@ val protocol_with_ssl : (context * 'edn, 'flow with_ssl) Client.protocol val service_with_ssl : - ('cfg, 't * 'flow) Service.service -> + ('cfg, 't, 'flow) Service.service -> reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> ('edn, 'flow with_ssl) Client.protocol -> - (context * 'cfg, (context * 't) * 'flow with_ssl) Service.service + (context * 'cfg, (context * 't), 'flow with_ssl) Service.service module TCP : sig open Conduit_async_tcp @@ -61,7 +61,7 @@ module TCP : sig val service : ( context * Server.configuration, - (context * Server.t) * Protocol.flow with_ssl ) + (context * Server.t), Protocol.flow with_ssl ) Service.service val resolv_conf : diff --git a/async/conduit_async_tcp.ml b/async/conduit_async_tcp.ml index ea917667..aedf0664 100644 --- a/async/conduit_async_tcp.ml +++ b/async/conduit_async_tcp.ml @@ -147,7 +147,7 @@ module Server = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end -let service = Conduit_async.Service.register ~service:(module Server) ~protocol +let service = Conduit_async.Service.register ~service:(module Server) let resolv_conf ~port domain_name = Monitor.try_with (fun () -> diff --git a/async/conduit_async_tcp.mli b/async/conduit_async_tcp.mli index 83804e21..52e09e53 100644 --- a/async/conduit_async_tcp.mli +++ b/async/conduit_async_tcp.mli @@ -19,6 +19,6 @@ type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration module Server : Service.SERVICE with type configuration = configuration -val service : (configuration, Server.t * Protocol.flow) Service.service +val service : (configuration, Server.t, Protocol.flow) Service.service val resolv_conf : port:int -> endpoint Client.resolver diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index 4a49ec55..e86e0227 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -13,10 +13,10 @@ val protocol_with_tls : type 'service service_with_tls val service_with_tls : - ('cfg, 't * 'flow) Service.service -> + ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls * 'flow protocol_with_tls ) + 't service_with_tls, 'flow protocol_with_tls ) Service.service module TCP : sig @@ -29,7 +29,7 @@ module TCP : sig val service : ( configuration * Tls.Config.server, - Server.t service_with_tls * Protocol.flow protocol_with_tls ) + Server.t service_with_tls, Protocol.flow protocol_with_tls ) Service.service val resolv_conf : diff --git a/lib/conduit.ml b/lib/conduit.ml index 040ef7d5..3a24b3d0 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -15,6 +15,7 @@ type _ resolver = -> ('edn * 's) resolver type ('a, 'b) value = Value : 'b -> ('a, 'b) value +type ('a, 'b, 'c) thd = Thd : 'b -> ('a, 'b, 'c) thd [@@warning "-37"] let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt @@ -120,15 +121,11 @@ module type S = sig and type t = 't and type flow = 'flow) - type 'flow protocol = - | Protocol : ('edn, 'flow) Client.protocol -> 'flow protocol - - type ('cfg, 'v) service + type ('cfg, 't, 'flow) service val register : service:('cfg, 't, 'flow) impl -> - protocol:('edn, 'flow) Client.protocol -> - ('cfg, 't * 'flow) service + ('cfg, 't, 'flow) service type error = [ `Msg of string ] @@ -136,11 +133,11 @@ module type S = sig val serve : 'cfg -> - service:('cfg, 't * 'flow) service -> - ('t * 'flow protocol, [> error ]) result s + service:('cfg, 't, 'flow) service -> + ('t, [> error ]) result s val impl : - ('cfg, 't * 'flow) service -> + ('cfg, 't, 'flow) service -> (module SERVICE with type configuration = 'cfg and type t = 't @@ -395,28 +392,24 @@ module Make and type t = 't and type flow = 'flow) - type 'flow protocol = - | Protocol : ('edn, 'flow) Client.protocol -> 'flow protocol - module F = struct type 't t = | Service : - 'cfg key * ('cfg, 't, 'flow) impl * 'flow protocol - -> ('cfg, 't * 'flow) value t + 'cfg key * ('cfg, 't, 'flow) impl + -> ('cfg, 't, 'flow) thd t end module Svc = E0.Make (F) - type ('cfg, 'v) service = ('cfg, 'v) value Svc.s + type ('cfg, 't, 'flow) service = ('cfg, 't, 'flow) thd Svc.s let register : - type edn cfg t flow. + type cfg t flow. service:(cfg, t, flow) impl -> - protocol:(edn, flow) Client.protocol -> - (cfg, t * flow) service = - fun ~service ~protocol -> + (cfg, t, flow) service = + fun ~service -> let cfg = Map.Key.create "" in - Svc.inj (Service (cfg, service, Protocol protocol)) + Svc.inj (Service (cfg, service)) type error = [ `Msg of string ] @@ -425,23 +418,23 @@ module Make let serve : type cfg t flow. cfg -> - service:(cfg, t * flow) service -> - (t * flow protocol, [> error ]) result s = + service:(cfg, t, flow) service -> + (t, [> error ]) result s = fun edn ~service:(module Witness) -> - let (Service (_, (module Service), protocol)) = Witness.witness in + let (Service (_, (module Service))) = Witness.witness in Service.make edn >>= function - | Ok t -> return (Ok (t, protocol)) + | Ok t -> return (Ok t) | Error err -> return (error_msgf "%a" Service.pp_error err) let impl : type cfg t flow. - (cfg, t * flow) service -> + (cfg, t, flow) service -> (module SERVICE with type configuration = cfg and type t = t and type flow = flow) = fun (module S) -> - let (Service (_, (module Service), _)) = S.witness in + let (Service (_, (module Service))) = S.witness in (module Service) end end diff --git a/lib/conduit.mli b/lib/conduit.mli index e5f0cb92..3066bf10 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -95,15 +95,11 @@ module type S = sig and type t = 't and type flow = 'flow) - type 'flow protocol = - | Protocol : (_, 'flow) Client.protocol -> 'flow protocol - - type ('cfg, 'v) service + type ('cfg, 't, 'flow) service val register : service:('cfg, 't, 'flow) impl -> - protocol:(_, 'flow) Client.protocol -> - ('cfg, 't * 'flow) service + ('cfg, 't, 'flow) service type error = [ `Msg of string ] @@ -111,11 +107,11 @@ module type S = sig val serve : 'cfg -> - service:('cfg, 't * 'flow) service -> - ('t * 'flow protocol, [> error ]) result s + service:('cfg, 't, 'flow) service -> + ('t, [> error ]) result s val impl : - ('cfg, 't * 'flow) service -> + ('cfg, 't, 'flow) service -> (module SERVICE with type configuration = 'cfg and type t = 't diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli index 023e616a..d8904fe0 100644 --- a/lwt-unix/conduit_lwt_unix.mli +++ b/lwt-unix/conduit_lwt_unix.mli @@ -8,13 +8,13 @@ include and type scheduler = Conduit_lwt.scheduler and type ('edn, 'flow) Client.protocol = ('edn, 'flow) Conduit_lwt.Client.protocol - and type ('cfg, 'v) Service.service = - ('cfg, 'v) Conduit_lwt.Service.service + and type ('cfg, 't, 'flow) Service.service = + ('cfg, 't, 'flow) Conduit_lwt.Service.service and type Client.flow = Conduit_lwt.Client.flow val serve_with_handler : - handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> - service:('cfg, 'master * 'flow) Service.service -> + handler:('flow -> unit Lwt.t) -> + service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml index bb05c5bb..ecae6c5c 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -112,20 +112,20 @@ end let service_with_ssl : type cfg edn t flow. - (cfg, t * flow) Conduit_lwt_unix.Service.service -> + (cfg, t, flow) Conduit_lwt_unix.Service.service -> file_descr:(flow -> Lwt_unix.file_descr) -> (edn, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol -> ( Ssl.context * cfg, - t master * Lwt_ssl.socket ) + t master, Lwt_ssl.socket ) Conduit_lwt_unix.Service.service = - fun service ~file_descr protocol -> + fun service ~file_descr _ -> let module S = (val Conduit_lwt_unix.Service.impl service) in let module M = Server (struct include S let file_descr = file_descr end) in - Conduit_lwt_unix.Service.register ~service:(module M) ~protocol + Conduit_lwt_unix.Service.register ~service:(module M) module TCP = struct let resolv_conf ~port ~context ?verify domain_name = diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli index ae64eda4..e670e868 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -64,10 +64,10 @@ type 't master (** Type of the {i master} socket. *) val service_with_ssl : - ('cfg, 't * 'flow) Service.service -> + ('cfg, 't, 'flow) Service.service -> file_descr:('flow -> Lwt_unix.file_descr) -> ('edn, Lwt_ssl.socket) Client.protocol -> - (Ssl.context * 'cfg, 't master * Lwt_ssl.socket) Service.service + (Ssl.context * 'cfg, 't master, Lwt_ssl.socket) Service.service (** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a representation of the given service with SSL. The service deliver an SSL flow which must be described by a [Lwt_ssl.socket Witness.protocol] (eg. @@ -86,7 +86,7 @@ module TCP : sig val service : ( Ssl.context * configuration, - Server.t master * Lwt_ssl.socket ) + Server.t master, Lwt_ssl.socket ) Service.service type verify = diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index dd6c7252..5ebdccb8 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -307,7 +307,7 @@ let protocol = Conduit_lwt.Client.register ~protocol:(module Protocol) include (val Conduit_lwt.Client.repr protocol) -let service = Conduit_lwt.Service.register ~service:(module Server) ~protocol +let service = Conduit_lwt.Service.register ~service:(module Server) let resolv_conf ~port domain_name = Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli index ae17bcf4..172c2d77 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.mli +++ b/lwt-unix/conduit_lwt_unix_tcp.mli @@ -71,6 +71,6 @@ val protocol : (Lwt_unix.sockaddr, Protocol.flow) Client.protocol type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value type Conduit_lwt.Client.flow += T of t -val service : (configuration, Server.t * Protocol.flow) Service.service +val service : (configuration, Server.t, Protocol.flow) Service.service val resolv_conf : port:int -> Lwt_unix.sockaddr Client.resolver diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt-unix/conduit_lwt_unix_tls.mli index 9db366ed..f72f24e6 100644 --- a/lwt-unix/conduit_lwt_unix_tls.mli +++ b/lwt-unix/conduit_lwt_unix_tls.mli @@ -25,10 +25,10 @@ val protocol_with_tls : type 'service service_with_tls val service_with_tls : - ('cfg, 't * 'flow) Service.service -> + ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls * 'flow protocol_with_tls ) + 't service_with_tls, 'flow protocol_with_tls ) Service.service module TCP : sig @@ -44,7 +44,7 @@ module TCP : sig val service : ( configuration * Tls.Config.server, - Server.t service_with_tls * Protocol.flow protocol_with_tls ) + Server.t service_with_tls, Protocol.flow protocol_with_tls ) Service.service val resolv_conf : diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index 806ec3a8..dc134914 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -14,8 +14,8 @@ let ( >>? ) = Lwt_result.bind let serve_with_handler : type cfg master flow. - handler:(flow Service.protocol -> flow -> unit Lwt.t) -> - service:(cfg, master * flow) Service.service -> + handler:(flow -> unit Lwt.t) -> + service:(cfg, master, flow) Service.service -> cfg -> unit Lwt_condition.t * unit Lwt.t = fun ~handler ~service cfg -> @@ -25,7 +25,7 @@ let serve_with_handler : let main = Service.serve cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok (master, protocol) -> ( + | Ok master -> ( let rec loop () = let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = @@ -33,7 +33,7 @@ let serve_with_handler : Lwt.pick [ stop; accept ] >>= function | Ok (`Flow flow) -> - Lwt.async (fun () -> handler protocol flow) ; + Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop | Ok `Stop -> Svc.close master | Error err0 -> ( @@ -56,5 +56,5 @@ module type CONDUIT = sig val protocol : (endpoint, flow) Client.protocol - val service : (configuration, master * flow) Service.service + val service : (configuration, master, flow) Service.service end diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index a9cab5f1..7b451af3 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -9,8 +9,8 @@ include and type +'a s = 'a Lwt.t val serve_with_handler : - handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> - service:('cfg, 'master * 'flow) Service.service -> + handler:('flow -> unit Lwt.t) -> + service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t @@ -44,5 +44,5 @@ module type CONDUIT = sig val protocol : (endpoint, flow) Client.protocol - val service : (configuration, master * flow) Service.service + val service : (configuration, master, flow) Service.service end diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 7bf64010..0c7f2c4a 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -8,13 +8,13 @@ include and type scheduler = Conduit_lwt.scheduler and type ('edn, 'flow) Client.protocol = ('edn, 'flow) Conduit_lwt.Client.protocol - and type ('cfg, 'v) Service.service = - ('cfg, 'v) Conduit_lwt.Service.service + and type ('cfg, 't, 'flow) Service.service = + ('cfg, 't, 'flow) Conduit_lwt.Service.service and type Client.flow = Conduit_lwt.Client.flow val serve_with_handler : - handler:('flow Service.protocol -> 'flow -> unit Lwt.t) -> - service:('cfg, 'master * 'flow) Service.service -> + handler:('flow -> unit Lwt.t) -> + service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t @@ -29,5 +29,5 @@ module type CONDUIT = sig val protocol : (endpoint, flow) Client.protocol - val service : (configuration, master * flow) Service.service + val service : (configuration, master, flow) Service.service end diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml index b1e3fe68..8906ae83 100644 --- a/mirage/conduit_mirage_tcp.ml +++ b/mirage/conduit_mirage_tcp.ml @@ -270,5 +270,5 @@ module Make (StackV4 : Mirage_stack.V4) = struct end let service = - Conduit_mirage.Service.register ~service:(module Server) ~protocol + Conduit_mirage.Service.register ~service:(module Server) end diff --git a/mirage/conduit_mirage_tcp.mli b/mirage/conduit_mirage_tcp.mli index 24ee8cd6..9fa874dc 100644 --- a/mirage/conduit_mirage_tcp.mli +++ b/mirage/conduit_mirage_tcp.mli @@ -24,5 +24,5 @@ module Make (StackV4 : Mirage_stack.V4) : sig type service - val service : (StackV4.t configuration, service * protocol) Service.service + val service : (StackV4.t configuration, service, protocol) Service.service end diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli index 8a42e474..b4448439 100644 --- a/mirage/conduit_mirage_tls.mli +++ b/mirage/conduit_mirage_tls.mli @@ -13,8 +13,8 @@ val protocol_with_tls : type 'service service_with_tls val service_with_tls : - ('cfg, 't * 'flow) Service.service -> + ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls * 'flow protocol_with_tls ) + 't service_with_tls, 'flow protocol_with_tls ) Service.service diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 21ae590b..f308ca23 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -77,12 +77,12 @@ let transmission flow = let server : type cfg master flow. cfg -> - service:(cfg, master * flow) Conduit_lwt.Service.service -> + protocol:(_, flow) Conduit_lwt.Client.protocol -> + service:(cfg, master, flow) Conduit_lwt.Service.service -> unit Lwt_condition.t * unit Lwt.t = - fun cfg ~service -> + fun cfg ~protocol ~service -> Conduit_lwt_unix.serve_with_handler - ~handler:(fun protocol flow -> - let (Conduit_lwt_unix.Service.Protocol protocol) = protocol in + ~handler:(fun flow -> transmission (Conduit_lwt.Client.abstract protocol flow)) ~service cfg @@ -170,11 +170,12 @@ let config cert key = let run_with : type cfg master flow. cfg -> - service:(cfg, master * flow) Conduit_lwt.Service.service -> + protocol:(_, flow) Conduit_lwt.Client.protocol -> + service:(cfg, master, flow) Conduit_lwt.Service.service -> string list -> unit = - fun cfg ~service clients -> - let stop, server = server cfg ~service in + fun cfg ~protocol ~service clients -> + let stop, server = server cfg ~protocol ~service in let clients = List.map (client ~resolvers) clients in let clients = Lwt.join clients >>= fun () -> @@ -189,6 +190,7 @@ let run_with_tcp clients = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); capacity = 40; } + ~protocol:Conduit_lwt_unix_tcp.protocol ~service:Conduit_lwt_unix_tcp.service clients let run_with_ssl cert key clients = @@ -201,6 +203,7 @@ let run_with_ssl cert key clients = Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); capacity = 40; } ) + ~protocol:ssl_protocol ~service:ssl_service clients let run_with_tls cert key clients = @@ -212,6 +215,7 @@ let run_with_tls cert key clients = capacity = 40; }, ctx ) + ~protocol:tls_protocol ~service:tls_service clients let () = diff --git a/tests/with_async.ml b/tests/with_async.ml index acb6fdd7..e678eaa0 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -86,14 +86,14 @@ let server : launched:unit Async.Condition.t -> stop:unit Async.Condition.t -> cfg -> - service:(cfg, master * flow) Conduit_async.Service.service -> + protocol:(_, flow) Conduit_async.Client.protocol -> + service:(cfg, master, flow) Conduit_async.Service.service -> unit Async.Deferred.t = - fun ~launched ~stop cfg ~service -> + fun ~launched ~stop cfg ~protocol ~service -> let module Server = (val Conduit_async.Service.impl service) in let main () = let reword_error = R.reword_error (R.msgf "%a" Server.pp_error) in - Conduit_async.Service.serve cfg ~service >>? fun (master, protocol) -> - let (Conduit_async.Service.Protocol protocol) = protocol in + Conduit_async.Service.serve cfg ~service >>? fun master -> Condition.signal launched () ; let rec go () = @@ -166,13 +166,14 @@ let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : type cfg master flow. cfg -> - service:(cfg, master * flow) Conduit_async.Service.service -> + protocol:(_, flow) Conduit_async.Client.protocol -> + service:(cfg, master, flow) Conduit_async.Service.service -> string list -> unit = - fun cfg ~service clients -> + fun cfg ~protocol ~service clients -> let launched = Condition.create () in let stop = Condition.create () in - let server () = server ~launched ~stop cfg ~service in + let server () = server ~launched ~stop cfg ~protocol ~service in let clients = Condition.wait launched >>= fun () -> let clients = List.map (client ~resolvers localhost) clients in @@ -186,12 +187,14 @@ let run_with : let run_with_tcp clients = run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 5000)) + ~protocol:tcp_protocol ~service:tcp_service clients let run_with_ssl cert key clients = let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in run_with (ctx, Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 7000)) + ~protocol:ssl_protocol ~service:ssl_service clients let load_file filename = @@ -217,6 +220,7 @@ let run_with_tls cert key clients = let ctx = config cert key in run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 9000), ctx) + ~protocol:tls_protocol ~service:tls_service clients let () = diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index cded8828..db4bcf53 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -354,13 +354,13 @@ struct let service_with_tls : type cfg edn t flow. - (cfg, t * flow) Conduit.Service.service -> + (cfg, t, flow) Conduit.Service.service -> (edn, flow protocol_with_tls) Conduit.Client.protocol -> ( cfg * Tls.Config.server, - t service_with_tls * flow protocol_with_tls ) + t service_with_tls, flow protocol_with_tls ) Conduit.Service.service = - fun service protocol -> + fun service _ -> let module Service = (val Conduit.Service.impl service) in let module M = Make_server (Service) in - Conduit.Service.register ~service:(module M) ~protocol + Conduit.Service.register ~service:(module M) end diff --git a/tls/conduit_tls.mli b/tls/conduit_tls.mli index f627fbb0..03b1b049 100644 --- a/tls/conduit_tls.mli +++ b/tls/conduit_tls.mli @@ -60,9 +60,8 @@ module Make type 'service service_with_tls val service_with_tls : - ('cfg, 't * 'flow) Conduit.Service.service -> + ('cfg, 't, 'flow) Conduit.Service.service -> ('edn, 'flow protocol_with_tls) Conduit.Client.protocol -> - ( 'cfg * Tls.Config.server, - 't service_with_tls * 'flow protocol_with_tls ) + ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) Conduit.Service.service end From 8b412baeccbf8f8fe89302dab5bb3da2159edbb1 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 16:07:41 +0200 Subject: [PATCH 026/140] ocamlformat pass --- async/conduit_async_ssl.ml | 3 +-- async/conduit_async_ssl.mli | 5 +++-- async/conduit_async_tls.mli | 6 ++++-- lib/conduit.ml | 21 ++++++--------------- lib/conduit.mli | 8 ++------ lwt-unix/conduit_lwt_unix_ssl.ml | 3 ++- lwt-unix/conduit_lwt_unix_ssl.mli | 3 ++- lwt-unix/conduit_lwt_unix_tcp.mli | 1 + lwt-unix/conduit_lwt_unix_tls.mli | 12 +++++++++--- mirage/conduit_mirage_tcp.ml | 3 +-- mirage/conduit_mirage_tls.mli | 3 ++- tests/ping_pong.ml | 6 ++---- tests/with_async.ml | 9 +++------ tls/conduit_tls.ml | 3 ++- tls/conduit_tls.mli | 4 +++- 15 files changed, 43 insertions(+), 47 deletions(-) diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index 6648eaa0..79f35c11 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -283,8 +283,7 @@ let service_with_ssl : reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> (edn, flow with_ssl) Conduit_async.Client.protocol -> - (context * cfg, (context * t), flow with_ssl) Conduit_async.Service.service - = + (context * cfg, context * t, flow with_ssl) Conduit_async.Service.service = fun service ~reader ~writer _ -> let module S = (val Conduit_async.Service.impl service) in let module Service = struct diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index b3bd02df..f3b188d8 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -52,7 +52,7 @@ val service_with_ssl : reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> ('edn, 'flow with_ssl) Client.protocol -> - (context * 'cfg, (context * 't), 'flow with_ssl) Service.service + (context * 'cfg, context * 't, 'flow with_ssl) Service.service module TCP : sig open Conduit_async_tcp @@ -61,7 +61,8 @@ module TCP : sig val service : ( context * Server.configuration, - (context * Server.t), Protocol.flow with_ssl ) + context * Server.t, + Protocol.flow with_ssl ) Service.service val resolv_conf : diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index e86e0227..2ba10bdd 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -16,7 +16,8 @@ val service_with_tls : ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls, 'flow protocol_with_tls ) + 't service_with_tls, + 'flow protocol_with_tls ) Service.service module TCP : sig @@ -29,7 +30,8 @@ module TCP : sig val service : ( configuration * Tls.Config.server, - Server.t service_with_tls, Protocol.flow protocol_with_tls ) + Server.t service_with_tls, + Protocol.flow protocol_with_tls ) Service.service val resolv_conf : diff --git a/lib/conduit.ml b/lib/conduit.ml index 3a24b3d0..40cdee68 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -15,6 +15,7 @@ type _ resolver = -> ('edn * 's) resolver type ('a, 'b) value = Value : 'b -> ('a, 'b) value + type ('a, 'b, 'c) thd = Thd : 'b -> ('a, 'b, 'c) thd [@@warning "-37"] let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt @@ -123,18 +124,14 @@ module type S = sig type ('cfg, 't, 'flow) service - val register : - service:('cfg, 't, 'flow) impl -> - ('cfg, 't, 'flow) service + val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service type error = [ `Msg of string ] val pp_error : error Fmt.t val serve : - 'cfg -> - service:('cfg, 't, 'flow) service -> - ('t, [> error ]) result s + 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s val impl : ('cfg, 't, 'flow) service -> @@ -394,9 +391,7 @@ module Make module F = struct type 't t = - | Service : - 'cfg key * ('cfg, 't, 'flow) impl - -> ('cfg, 't, 'flow) thd t + | Service : 'cfg key * ('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) thd t end module Svc = E0.Make (F) @@ -404,9 +399,7 @@ module Make type ('cfg, 't, 'flow) service = ('cfg, 't, 'flow) thd Svc.s let register : - type cfg t flow. - service:(cfg, t, flow) impl -> - (cfg, t, flow) service = + type cfg t flow. service:(cfg, t, flow) impl -> (cfg, t, flow) service = fun ~service -> let cfg = Map.Key.create "" in Svc.inj (Service (cfg, service)) @@ -417,9 +410,7 @@ module Make let serve : type cfg t flow. - cfg -> - service:(cfg, t, flow) service -> - (t, [> error ]) result s = + cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result s = fun edn ~service:(module Witness) -> let (Service (_, (module Service))) = Witness.witness in Service.make edn >>= function diff --git a/lib/conduit.mli b/lib/conduit.mli index 3066bf10..a0192b1a 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -97,18 +97,14 @@ module type S = sig type ('cfg, 't, 'flow) service - val register : - service:('cfg, 't, 'flow) impl -> - ('cfg, 't, 'flow) service + val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service type error = [ `Msg of string ] val pp_error : error Fmt.t val serve : - 'cfg -> - service:('cfg, 't, 'flow) service -> - ('t, [> error ]) result s + 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s val impl : ('cfg, 't, 'flow) service -> diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml index ecae6c5c..290eb429 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -116,7 +116,8 @@ let service_with_ssl : file_descr:(flow -> Lwt_unix.file_descr) -> (edn, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol -> ( Ssl.context * cfg, - t master, Lwt_ssl.socket ) + t master, + Lwt_ssl.socket ) Conduit_lwt_unix.Service.service = fun service ~file_descr _ -> let module S = (val Conduit_lwt_unix.Service.impl service) in diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli index e670e868..9c926d7d 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -86,7 +86,8 @@ module TCP : sig val service : ( Ssl.context * configuration, - Server.t master, Lwt_ssl.socket ) + Server.t master, + Lwt_ssl.socket ) Service.service type verify = diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli index 172c2d77..dcca5dd0 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.mli +++ b/lwt-unix/conduit_lwt_unix_tcp.mli @@ -69,6 +69,7 @@ module Server : val protocol : (Lwt_unix.sockaddr, Protocol.flow) Client.protocol type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value + type Conduit_lwt.Client.flow += T of t val service : (configuration, Server.t, Protocol.flow) Service.service diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt-unix/conduit_lwt_unix_tls.mli index f72f24e6..e83a72ac 100644 --- a/lwt-unix/conduit_lwt_unix_tls.mli +++ b/lwt-unix/conduit_lwt_unix_tls.mli @@ -28,7 +28,8 @@ val service_with_tls : ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls, 'flow protocol_with_tls ) + 't service_with_tls, + 'flow protocol_with_tls ) Service.service module TCP : sig @@ -39,12 +40,17 @@ module TCP : sig Protocol.flow protocol_with_tls ) Client.protocol - type t = (Lwt_unix.sockaddr * Tls.Config.client, Protocol.flow protocol_with_tls) Conduit.value + type t = + ( Lwt_unix.sockaddr * Tls.Config.client, + Protocol.flow protocol_with_tls ) + Conduit.value + type Conduit_lwt.Client.flow += T of t val service : ( configuration * Tls.Config.server, - Server.t service_with_tls, Protocol.flow protocol_with_tls ) + Server.t service_with_tls, + Protocol.flow protocol_with_tls ) Service.service val resolv_conf : diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml index 8906ae83..314d7d25 100644 --- a/mirage/conduit_mirage_tcp.ml +++ b/mirage/conduit_mirage_tcp.ml @@ -269,6 +269,5 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt.return (Ok ())) end - let service = - Conduit_mirage.Service.register ~service:(module Server) + let service = Conduit_mirage.Service.register ~service:(module Server) end diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli index b4448439..837a16c4 100644 --- a/mirage/conduit_mirage_tls.mli +++ b/mirage/conduit_mirage_tls.mli @@ -16,5 +16,6 @@ val service_with_tls : ('cfg, 't, 'flow) Service.service -> ('edn, 'flow protocol_with_tls) Client.protocol -> ( 'cfg * Tls.Config.server, - 't service_with_tls, 'flow protocol_with_tls ) + 't service_with_tls, + 'flow protocol_with_tls ) Service.service diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index f308ca23..483b5f5d 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -203,8 +203,7 @@ let run_with_ssl cert key clients = Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); capacity = 40; } ) - ~protocol:ssl_protocol - ~service:ssl_service clients + ~protocol:ssl_protocol ~service:ssl_service clients let run_with_tls cert key clients = let ctx = config cert key in @@ -215,8 +214,7 @@ let run_with_tls cert key clients = capacity = 40; }, ctx ) - ~protocol:tls_protocol - ~service:tls_service clients + ~protocol:tls_protocol ~service:tls_service clients let () = match Array.to_list Sys.argv with diff --git a/tests/with_async.ml b/tests/with_async.ml index e678eaa0..473138e6 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -187,15 +187,13 @@ let run_with : let run_with_tcp clients = run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 5000)) - ~protocol:tcp_protocol - ~service:tcp_service clients + ~protocol:tcp_protocol ~service:tcp_service clients let run_with_ssl cert key clients = let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in run_with (ctx, Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 7000)) - ~protocol:ssl_protocol - ~service:ssl_service clients + ~protocol:ssl_protocol ~service:ssl_service clients let load_file filename = let open Stdlib in @@ -220,8 +218,7 @@ let run_with_tls cert key clients = let ctx = config cert key in run_with (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 9000), ctx) - ~protocol:tls_protocol - ~service:tls_service clients + ~protocol:tls_protocol ~service:tls_service clients let () = match Array.to_list Stdlib.Sys.argv with diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index db4bcf53..d89018b6 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -357,7 +357,8 @@ struct (cfg, t, flow) Conduit.Service.service -> (edn, flow protocol_with_tls) Conduit.Client.protocol -> ( cfg * Tls.Config.server, - t service_with_tls, flow protocol_with_tls ) + t service_with_tls, + flow protocol_with_tls ) Conduit.Service.service = fun service _ -> let module Service = (val Conduit.Service.impl service) in diff --git a/tls/conduit_tls.mli b/tls/conduit_tls.mli index 03b1b049..5802619e 100644 --- a/tls/conduit_tls.mli +++ b/tls/conduit_tls.mli @@ -62,6 +62,8 @@ module Make val service_with_tls : ('cfg, 't, 'flow) Conduit.Service.service -> ('edn, 'flow protocol_with_tls) Conduit.Client.protocol -> - ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) + ( 'cfg * Tls.Config.server, + 't service_with_tls, + 'flow protocol_with_tls ) Conduit.Service.service end From bd3af382bf4ab1f289e80ccd547d7ff180710a1d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 18:33:54 +0200 Subject: [PATCH 027/140] Rename End_of_input to End_of_flow --- async/conduit_async.ml | 2 +- async/conduit_async_ssl.ml | 2 +- async/conduit_async_tcp.ml | 2 +- lib/conduit.ml | 2 +- lib/conduit.mli | 2 +- lib/sigs.ml | 4 ++-- lwt-unix/conduit_lwt_unix.ml | 2 +- lwt-unix/conduit_lwt_unix_ssl.ml | 2 +- lwt-unix/conduit_lwt_unix_tcp.ml | 8 ++++---- lwt/conduit_lwt_flow.ml | 2 +- mirage/conduit_mirage_tcp.ml | 6 +++--- tests/ping_pong.ml | 2 +- tests/with_async.ml | 2 +- tls/conduit_tls.ml | 10 +++++----- 14 files changed, 24 insertions(+), 24 deletions(-) diff --git a/async/conduit_async.ml b/async/conduit_async.ml index d40f9a70..be09c4c4 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -54,7 +54,7 @@ let reader_and_writer_of_flow flow = Client.recv flow tmp >>= function | Ok (`Input len) -> Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop - | Ok `End_of_input -> + | Ok `End_of_flow -> Pipe.close writer ; Async.return () | Error err -> failwith "%a" Client.pp_error err in diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index 79f35c11..b7ba9f2d 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -161,7 +161,7 @@ struct let recv { reader; _ } raw = Reader.read_bigsubstring reader (of_cstruct raw) >>= function - | `Eof -> Async.return (Ok `End_of_input) + | `Eof -> Async.return (Ok `End_of_flow) | `Ok n -> Async.return (Ok (`Input n)) let send { writer; _ } raw = diff --git a/async/conduit_async_tcp.ml b/async/conduit_async_tcp.ml index aedf0664..b786b15f 100644 --- a/async/conduit_async_tcp.ml +++ b/async/conduit_async_tcp.ml @@ -65,7 +65,7 @@ module Protocol = struct | Ok (`Ok n) -> Async.return (Ok (`Input n)) | Ok `Eof -> ( Fd.ready_to (Socket.fd socket) `Read >>= function - | `Bad_fd | `Closed -> Async.return (Ok `End_of_input) + | `Bad_fd | `Closed -> Async.return (Ok `End_of_flow) | `Ready -> Scheduler.yield () >>= fun () -> recv flow raw) let send (Socket { writer; _ }) raw = diff --git a/lib/conduit.ml b/lib/conduit.ml index 40cdee68..0a534892 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -71,7 +71,7 @@ module type S = sig val pp_error : error Fmt.t val recv : - flow -> input -> ([ `Input of int | `End_of_input ], [> error ]) result s + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s val send : flow -> output -> (int, [> error ]) result s diff --git a/lib/conduit.mli b/lib/conduit.mli index a0192b1a..4e6d1bef 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -44,7 +44,7 @@ module type S = sig val pp_error : error Fmt.t val recv : - flow -> input -> ([ `Input of int | `End_of_input ], [> error ]) result s + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s val send : flow -> output -> (int, [> error ]) result s diff --git a/lib/sigs.ml b/lib/sigs.ml index d4418808..cf80d20e 100644 --- a/lib/sigs.ml +++ b/lib/sigs.ml @@ -2,7 +2,7 @@ type kind = UDP | TCP type description = { name : string; port : int; kind : kind } -type 'x or_end_of_input = [ `End_of_input | `Input of 'x ] +type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] module type FUNCTOR = sig type 'a t @@ -62,7 +62,7 @@ module type FLOW = sig val pp_error : error Fmt.t - val recv : flow -> input -> (int or_end_of_input, error) result s + val recv : flow -> input -> (int or_end_of_flow, error) result s val send : flow -> output -> (int, error) result s diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml index 672ea584..c1fb67fc 100644 --- a/lwt-unix/conduit_lwt_unix.ml +++ b/lwt-unix/conduit_lwt_unix.ml @@ -22,7 +22,7 @@ let io_of_flow flow = let raw = Cstruct.of_bigarray buf ~off ~len in Client.recv flow raw >>= function | Ok (`Input len) -> Lwt.return len - | Ok `End_of_input -> Lwt.return 0 + | Ok `End_of_flow -> Lwt.return 0 | Error err -> failf "%a" Client.pp_error err in let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in let send buf off len = diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml index 290eb429..d297bf85 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -52,7 +52,7 @@ module Protocol (Flow : Conduit_lwt_unix.Client.PROTOCOL) = struct let recv socket raw = let { Cstruct.buffer; off; len } = raw in Lwt_ssl.read_bytes socket buffer off len >>= function - | 0 -> Lwt.return_ok `End_of_input + | 0 -> Lwt.return_ok `End_of_flow | len -> Lwt.return_ok (`Input len) let send socket raw = diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index 5ebdccb8..f0e4b4da 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -103,14 +103,14 @@ module Protocol = struct it has reached [`End_of_file]. *) let rec recv ({ socket; closed; _ } as t) raw = if closed - then Lwt.return_ok `End_of_input + then Lwt.return_ok `End_of_flow else let rec process filled raw = let max = Cstruct.len raw in Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) >>= fun len -> if len = 0 - then Lwt.return_ok (if filled = 0 then `End_of_input else `Input filled) + then Lwt.return_ok (if filled = 0 then `End_of_flow else `Input filled) else ( Cstruct.blit_from_bytes t.linger 0 raw 0 len ; if len = Bytes.length t.linger && max > Bytes.length t.linger @@ -120,12 +120,12 @@ module Protocol = struct else Lwt.return_ok (if filled + len = 0 - then `End_of_input + then `End_of_flow else `Input (filled + len)) else Lwt.return_ok (if filled + len = 0 - then `End_of_input + then `End_of_flow else `Input (filled + len))) in Lwt.catch (fun () -> process 0 raw) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw diff --git a/lwt/conduit_lwt_flow.ml b/lwt/conduit_lwt_flow.ml index ba9fba8a..207aa405 100644 --- a/lwt/conduit_lwt_flow.ml +++ b/lwt/conduit_lwt_flow.ml @@ -15,7 +15,7 @@ let pp_write_error ppf = function let read flow = let raw = Cstruct.create 0x1000 in Conduit_lwt.Client.recv flow raw >>= function - | Ok `End_of_input -> Lwt.return_ok `Eof + | Ok `End_of_flow -> Lwt.return_ok `Eof | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) | Error _ as err -> Lwt.return err diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml index 314d7d25..42188d3a 100644 --- a/mirage/conduit_mirage_tcp.ml +++ b/mirage/conduit_mirage_tcp.ml @@ -112,7 +112,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct | Ok `Eof -> t.closed <- true ; Log.debug (fun m -> m "<- End of input.") ; - Lwt.return (Ok `End_of_input) + Lwt.return (Ok `End_of_flow) | Ok (`Data buf) -> Log.debug (fun m -> m "<- Got %d byte(s)." (Cstruct.len buf)) ; (* XXX(dinosaure): [telnet] send '\004' (End Of Transmission) to ask @@ -122,7 +122,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct then ( StackV4.TCPV4.close t.flow >>= fun () -> Log.debug (fun m -> m "<- End of input (end of transmission)") ; - Lwt.return (Ok `End_of_input)) + Lwt.return (Ok `End_of_flow)) else let max_buf = Cstruct.len buf in let max_raw = Cstruct.len raw in @@ -140,7 +140,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct if len = max_buf - max_raw then Lwt.return (Ok (`Input max_raw)) else Lwt.return (Error Input_too_large))) - else Lwt.return_ok `End_of_input + else Lwt.return_ok `End_of_flow | lst -> let rec go consumed raw = function | [] -> diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 483b5f5d..a6d5df91 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -45,7 +45,7 @@ let getline queue flow = | Some line -> Lwt.return_ok (`Line line) | None -> ( Conduit_lwt_unix.Client.recv flow tmp >>? function - | `End_of_input -> Lwt.return_ok `Close + | `End_of_flow -> Lwt.return_ok `Close | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; go ()) in diff --git a/tests/with_async.ml b/tests/with_async.ml index 473138e6..11d7a02c 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -50,7 +50,7 @@ let getline queue flow = | Some line -> Async.return (Ok (`Line line)) | None -> ( Conduit_async.Client.recv flow tmp >>? function - | `End_of_input -> Async.return (Ok `Close) + | `End_of_flow -> Async.return (Ok `Close) | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; go ()) in diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index d89018b6..28cc89dc 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -159,7 +159,7 @@ struct then ( Log.debug (fun m -> m "<- Read the TLS flow") ; Flow.recv flow raw0 >>| reword_error flow_error >>? function - | `End_of_input -> + | `End_of_flow -> Log.warn (fun m -> m "Got EOF from underlying connection while \ @@ -219,15 +219,15 @@ struct match t.tls with | None -> Log.debug (fun m -> m "<~ Connection is close.") ; - return (Ok `End_of_input) + return (Ok `End_of_flow) | Some tls -> ( Log.debug (fun m -> m "<- Read the TLS flow.") ; Flow.recv t.flow t.raw >>| reword_error flow_error >>? function - | `End_of_input -> + | `End_of_flow -> Log.warn (fun m -> m "<- Connection closed by underlying protocol.") ; t.tls <- None ; - return (Ok `End_of_input) + return (Ok `End_of_flow) | `Input len -> let handle = if Tls.Engine.handshake_in_progress tls @@ -264,7 +264,7 @@ struct | None -> return (Ok (Cstruct.lenv raw))) | Some tls -> ( Flow.recv t.flow t.raw >>| reword_error flow_error >>? function - | `End_of_input -> + | `End_of_flow -> Log.warn (fun m -> m "[-] Underlying flow already closed.") ; t.tls <- None ; return (Error `Closed_by_peer) From 1e89348483c6aedd5e6959c12c8dfd1e8d0ce35a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 18:41:34 +0200 Subject: [PATCH 028/140] Add Conduit.Service.{accept,close} --- lib/conduit.ml | 24 ++++++++++++++++++++++++ lib/conduit.mli | 6 ++++++ 2 files changed, 30 insertions(+) diff --git a/lib/conduit.ml b/lib/conduit.ml index 0a534892..6c20f2c0 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -133,6 +133,12 @@ module type S = sig val serve : 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s + val accept : + service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result s + + val close : + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result s + val impl : ('cfg, 't, 'flow) service -> (module SERVICE @@ -417,6 +423,24 @@ module Make | Ok t -> return (Ok t) | Error err -> return (error_msgf "%a" Service.pp_error err) + let accept : + type cfg t flow. + service:(cfg, t, flow) service -> t -> (flow, [> error ]) result s = + fun ~service:(module Witness) t -> + let (Service (_, (module Service))) = Witness.witness in + Service.accept t >>= function + | Ok flow -> return (Ok flow) + | Error err -> return (error_msgf "%a" Service.pp_error err) + + let close : + type cfg t flow. + service:(cfg, t, flow) service -> t -> (unit, [> error ]) result s = + fun ~service:(module Witness) t -> + let (Service (_, (module Service))) = Witness.witness in + Service.close t >>= function + | Ok () -> return (Ok ()) + | Error err -> return (error_msgf "%a" Service.pp_error err) + let impl : type cfg t flow. (cfg, t, flow) service -> diff --git a/lib/conduit.mli b/lib/conduit.mli index 4e6d1bef..915fd96d 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -106,6 +106,12 @@ module type S = sig val serve : 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s + val accept : + service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result s + + val close : + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result s + val impl : ('cfg, 't, 'flow) service -> (module SERVICE From 036a62d9d043b1f020af4806c94825646b361802 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 4 Jun 2020 18:41:42 +0200 Subject: [PATCH 029/140] ocamlformat pass --- lwt-unix/conduit_lwt_unix_tcp.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index f0e4b4da..7bb1382f 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -124,9 +124,8 @@ module Protocol = struct else `Input (filled + len)) else Lwt.return_ok - (if filled + len = 0 - then `End_of_flow - else `Input (filled + len))) in + (if filled + len = 0 then `End_of_flow else `Input (filled + len))) + in Lwt.catch (fun () -> process 0 raw) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw From aeaadfbcf62ef778e4c158ed3113397f1a659a2e Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 8 Jun 2020 12:32:11 +0200 Subject: [PATCH 030/140] Remove prefix module name Client and add documentation --- async/conduit_async.ml | 8 +- async/conduit_async.mli | 2 +- async/conduit_async_ssl.ml | 12 +- async/conduit_async_ssl.mli | 10 +- async/conduit_async_tcp.ml | 2 +- async/conduit_async_tcp.mli | 6 +- async/conduit_async_tls.mli | 10 +- lib/conduit.ml | 458 ++++++++++++++---------------- lib/conduit.mli | 302 +++++++++++++++----- lwt-unix/conduit_lwt_unix.ml | 12 +- lwt-unix/conduit_lwt_unix.mli | 8 +- lwt-unix/conduit_lwt_unix_ssl.ml | 12 +- lwt-unix/conduit_lwt_unix_ssl.mli | 10 +- lwt-unix/conduit_lwt_unix_tcp.ml | 4 +- lwt-unix/conduit_lwt_unix_tcp.mli | 8 +- lwt-unix/conduit_lwt_unix_tls.ml | 2 +- lwt-unix/conduit_lwt_unix_tls.mli | 12 +- lwt/conduit_lwt.ml | 2 +- lwt/conduit_lwt.mli | 2 +- lwt/conduit_lwt_flow.ml | 16 +- lwt/conduit_lwt_flow.mli | 2 +- mirage/conduit_mirage.mli | 8 +- mirage/conduit_mirage_dns.ml | 2 +- mirage/conduit_mirage_dns.mli | 2 +- mirage/conduit_mirage_flow.mli | 2 +- mirage/conduit_mirage_tcp.ml | 2 +- mirage/conduit_mirage_tcp.mli | 2 +- mirage/conduit_mirage_tls.mli | 6 +- tests/ping_pong.ml | 42 +-- tests/with_async.ml | 40 +-- tls/conduit_tls.ml | 10 +- tls/conduit_tls.mli | 6 +- 32 files changed, 587 insertions(+), 435 deletions(-) diff --git a/async/conduit_async.ml b/async/conduit_async.ml index be09c4c4..a3b22de1 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -51,13 +51,13 @@ let reader_and_writer_of_flow flow = let recv flow writer = let tmp = Cstruct.create 0x1000 in let rec loop () = - Client.recv flow tmp >>= function + recv flow tmp >>= function | Ok (`Input len) -> Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop | Ok `End_of_flow -> Pipe.close writer ; Async.return () - | Error err -> failwith "%a" Client.pp_error err in + | Error err -> failwith "%a" pp_error err in loop () in let send flow reader = let rec loop () = @@ -68,9 +68,9 @@ let reader_and_writer_of_flow flow = if Cstruct.len tmp = 0 then Async.return () else - Client.send flow tmp >>= function + send flow tmp >>= function | Ok shift -> go (Cstruct.shift tmp shift) - | Error err -> failwith "%a" Client.pp_error err in + | Error err -> failwith "%a" pp_error err in go (Cstruct.of_string v) >>= loop in loop () in let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in diff --git a/async/conduit_async.mli b/async/conduit_async.mli index 10a0013b..dd6b6896 100644 --- a/async/conduit_async.mli +++ b/async/conduit_async.mli @@ -16,4 +16,4 @@ val serve_with_handler : unit Async.Condition.t * unit Async.Deferred.t val reader_and_writer_of_flow : - Client.flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t + flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index b7ba9f2d..170589fb 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -78,7 +78,7 @@ type 'flow with_ssl = { } module Protocol (Protocol : sig - include Conduit_async.Client.PROTOCOL + include Conduit_async.PROTOCOL val reader : flow -> Reader.t @@ -177,10 +177,10 @@ let protocol_with_ssl : type edn flow. reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> - (edn, flow) Conduit_async.Client.protocol -> - (context * edn, flow with_ssl) Conduit_async.Client.protocol = + (edn, flow) Conduit_async.protocol -> + (context * edn, flow with_ssl) Conduit_async.protocol = fun ~reader ~writer protocol -> - let module F = (val Conduit_async.Client.impl_of_protocol protocol) in + let module F = (val Conduit_async.impl protocol) in let module Flow = struct include F @@ -189,7 +189,7 @@ let protocol_with_ssl : let writer = writer end in let module M = Protocol (Flow) in - Conduit_async.Client.register ~protocol:(module M) + Conduit_async.register ~protocol:(module M) module Make (Service : sig include Conduit_async.Service.SERVICE @@ -282,7 +282,7 @@ let service_with_ssl : (cfg, t, flow) Conduit_async.Service.service -> reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> - (edn, flow with_ssl) Conduit_async.Client.protocol -> + (edn, flow with_ssl) Conduit_async.protocol -> (context * cfg, context * t, flow with_ssl) Conduit_async.Service.service = fun service ~reader ~writer _ -> let module S = (val Conduit_async.Service.impl service) in diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index f3b188d8..2305e752 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -44,20 +44,20 @@ val context : val protocol_with_ssl : reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> - ('edn, 'flow) Client.protocol -> - (context * 'edn, 'flow with_ssl) Client.protocol + ('edn, 'flow) protocol -> + (context * 'edn, 'flow with_ssl) protocol val service_with_ssl : ('cfg, 't, 'flow) Service.service -> reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> - ('edn, 'flow with_ssl) Client.protocol -> + ('edn, 'flow with_ssl) protocol -> (context * 'cfg, context * 't, 'flow with_ssl) Service.service module TCP : sig open Conduit_async_tcp - val protocol : (context * endpoint, Protocol.flow with_ssl) Client.protocol + val protocol : (context * endpoint, Protocol.flow with_ssl) protocol val service : ( context * Server.configuration, @@ -66,5 +66,5 @@ module TCP : sig Service.service val resolv_conf : - port:int -> context:context -> (context * endpoint) Client.resolver + port:int -> context:context -> (context * endpoint) resolver end diff --git a/async/conduit_async_tcp.ml b/async/conduit_async_tcp.ml index b786b15f..f4d53b70 100644 --- a/async/conduit_async_tcp.ml +++ b/async/conduit_async_tcp.ml @@ -84,7 +84,7 @@ module Protocol = struct Writer.close writer >>= fun () -> Async.return (Ok ())) end -let protocol = Conduit_async.Client.register ~protocol:(module Protocol) +let protocol = Conduit_async.register ~protocol:(module Protocol) type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration diff --git a/async/conduit_async_tcp.mli b/async/conduit_async_tcp.mli index 52e09e53..9712bb9a 100644 --- a/async/conduit_async_tcp.mli +++ b/async/conduit_async_tcp.mli @@ -4,7 +4,7 @@ open Conduit_async type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t module Protocol : sig - include Conduit_async.Client.PROTOCOL with type endpoint = endpoint + include Conduit_async.PROTOCOL with type endpoint = endpoint val address : flow -> Socket.Address.t @@ -13,7 +13,7 @@ module Protocol : sig val writer : flow -> Writer.t end -val protocol : (Protocol.endpoint, Protocol.flow) Client.protocol +val protocol : (Protocol.endpoint, Protocol.flow) protocol type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration @@ -21,4 +21,4 @@ module Server : Service.SERVICE with type configuration = configuration val service : (configuration, Server.t, Protocol.flow) Service.service -val resolv_conf : port:int -> endpoint Client.resolver +val resolv_conf : port:int -> endpoint resolver diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index 2ba10bdd..6026401c 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -7,14 +7,14 @@ val underlying : 'flow protocol_with_tls -> 'flow val handshake : 'flow protocol_with_tls -> bool val protocol_with_tls : - ('edn, 'flow) Client.protocol -> - ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol + ('edn, 'flow) protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol type 'service service_with_tls val service_with_tls : ('cfg, 't, 'flow) Service.service -> - ('edn, 'flow protocol_with_tls) Client.protocol -> + ('edn, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) @@ -26,7 +26,7 @@ module TCP : sig val protocol : ( endpoint * Tls.Config.client, Protocol.flow protocol_with_tls ) - Client.protocol + protocol val service : ( configuration * Tls.Config.server, @@ -37,5 +37,5 @@ module TCP : sig val resolv_conf : port:int -> config:Tls.Config.client -> - (endpoint * Tls.Config.client) Client.resolver + (endpoint * Tls.Config.client) resolver end diff --git a/lib/conduit.ml b/lib/conduit.ml index 6c20f2c0..a95301dd 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -31,8 +31,6 @@ module Map = type resolvers = Map.t -type 'a key = 'a Map.key - let empty = Map.empty module type S = sig @@ -44,74 +42,69 @@ module type S = sig type scheduler - module Client : sig - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - type flow = private .. + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - type ('edn, 'flow) protocol + type flow = private .. - type error = [ `Msg of string | `Not_found ] + type ('edn, 'flow) protocol - val pp_error : error Fmt.t + type error = [ `Msg of string | `Not_found ] - val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s + val pp_error : error Fmt.t - val send : flow -> output -> (int, [> error ]) result s + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s - val close : flow -> (unit, [> error ]) result s + val send : flow -> output -> (int, [> error ]) result s - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol + val close : flow -> (unit, [> error ]) result s - module type REPR = sig - type t + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - type flow += T of t - end + module type REPR = sig + type t - val repr : - ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + type flow += T of t + end - val add : - ('edn, 'flow) protocol -> - ?priority:int -> - 'edn resolver -> - resolvers -> - resolvers + val repr : + ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - val abstract : ('edn, 'v) protocol -> 'v -> flow + val add : + ('edn, 'flow) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers - val connect : - resolvers -> - ?protocol:('edn, 'v) protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s + val abstract : ('edn, 'v) protocol -> 'v -> flow - val impl_of_protocol : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + val connect : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s - val impl_of_flow : - ('edn, 'flow) protocol -> (module FLOW with type flow = 'flow) + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - val is : flow -> ('edn, 'flow) protocol -> 'flow option - end + val is : flow -> ('edn, 'flow) protocol -> 'flow option module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s @@ -180,212 +173,203 @@ module Make type output = Output.t - module Client = struct - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - type 'edn key = ('edn * scheduler) Map.key + type 'edn key = ('edn * scheduler) Map.key - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - module F = struct - type _ t = - | Protocol : 'edn key * ('edn, 'flow) impl -> ('edn, 'flow) value t - end + module F = struct + type _ t = + | Protocol : 'edn key * ('edn, 'flow) impl -> ('edn, 'flow) value t + end - module Ptr = E0.Make (F) + module Ptr = E0.Make (F) - type flow = Ptr.t = private .. + type flow = Ptr.t = private .. - type ('edn, 'flow) protocol = ('edn, 'flow) value Ptr.s + type ('edn, 'flow) protocol = ('edn, 'flow) value Ptr.s - let recv flow input = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in - let (Value flow) = flow in - Protocol.recv flow input >>| function - | Ok _ as v -> v - | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) + let recv flow input = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let (Value flow) = flow in + Protocol.recv flow input >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let send flow output = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in - let (Value flow) = flow in - Protocol.send flow output >>| function - | Ok _ as v -> v - | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) + let send flow output = + let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let (Value flow) = 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 - Protocol.close flow >>| 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 + Protocol.close flow >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let register : - type edn flow. protocol:(edn, flow) impl -> (edn, flow) protocol = - fun ~protocol -> - let key = Map.Key.create "" in - Ptr.inj (Protocol (key, protocol)) + let register : + type edn flow. protocol:(edn, flow) impl -> (edn, flow) protocol = + fun ~protocol -> + let key = Map.Key.create "" in + Ptr.inj (Protocol (key, protocol)) - module type REPR = sig - type t + module type REPR = sig + type t - type flow += T of t - end + type flow += T of 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 - - type t = x - end in - (module M) - - let ( <.> ) f g x = f (g x) - - let add : - type edn flow. - (edn, flow) protocol -> - ?priority:int -> - edn resolver -> - resolvers -> - resolvers = - fun (module Witness) ?(priority = 0) resolve -> - let (Protocol (key, _)) = Witness.witness in - let resolve = inj <.> resolve in - Map.add key (Resolver { priority; resolve; witness }) - - type error = [ `Msg of string | `Not_found ] - - let pf ppf fmt = Format.fprintf ppf fmt - - let pp_error ppf = function - | `Msg err -> pf ppf "%s" err - | `Not_found -> pf ppf "Not found" - - let flow_of_endpoint : - type edn. edn key -> edn -> (flow, [> error ]) result s = - fun key edn -> - let rec go = function - | [] -> return (Error `Not_found) - | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: 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))) - | Error _err -> go r) in - go (Ptr.bindings ()) - - let flow_of_protocol : - type edn flow. - (edn, flow) protocol -> edn -> (flow, [> error ]) result s = - fun (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) + 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 - type endpoint = Endpoint : 'edn key * 'edn -> endpoint + type t = x + end in + (module M) - module Refl = struct - type ('a, 'b) t = Refl : ('a, 'a) t - end + let ( <.> ) f g x = f (g x) - let scheduler : type s. s witness -> (s, scheduler) Refl.t option = function - | Witness -> Some Refl.Refl - | _ -> None - - let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = - fun m domain_name -> - let rec go acc = function - | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) - | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> - match scheduler witness with - | None -> go acc r - | Some Refl.Refl -> ( - resolve domain_name |> prj >>= function - | Some edn -> go (Endpoint (k, edn) :: acc) r - | None -> go acc r) in - let compare (Map.Value (_, Resolver { priority = pa; _ })) - (Map.Value (_, Resolver { priority = pb; _ })) = - (Stdlib.compare : int -> int -> int) pa pb in - go [] (List.sort compare (Map.bindings m)) - - let create : - resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = - fun m domain_name -> - resolve m domain_name >>= fun l -> - let rec go = function - | [] -> return (Error `Not_found) - | Endpoint (key, edn) :: r -> ( - flow_of_endpoint key edn >>= function - | Ok flow -> return (Ok flow) - | Error _err -> go r) in - go l - - let abstract : type edn v. (edn, v) protocol -> v -> flow = - fun (module Witness) flow -> Witness.T (Value flow) - - let connect : - type edn v. - resolvers -> - ?protocol:(edn, v) protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s = - fun m ?protocol domain_name -> - match protocol with - | None -> create m domain_name - | Some (module Witness) -> - let (Protocol (key', _)) = Witness.witness in - resolve m domain_name >>= fun l -> - let rec go = function - | [] -> return (Error `Not_found) - | Endpoint (key, edn) :: r -> - 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))) - | Error _err -> go r) in - go l - - let impl_of_protocol : - 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 - (module Protocol) - - let impl_of_flow : - type edn flow. - (edn, flow) protocol -> (module FLOW with type flow = flow) = - fun (module Witness) -> - let (Protocol (_, (module Protocol))) = Witness.witness in - (module Protocol) - - let is : 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 + let add : + type edn flow. + (edn, flow) protocol -> + ?priority:int -> + edn resolver -> + resolvers -> + resolvers = + fun (module Witness) ?(priority = 0) resolve -> + let (Protocol (key, _)) = Witness.witness in + let resolve = inj <.> resolve in + Map.add key (Resolver { priority; resolve; witness }) + + type error = [ `Msg of string | `Not_found ] + + let pf ppf fmt = Format.fprintf ppf fmt + + let pp_error ppf = function + | `Msg err -> pf ppf "%s" err + | `Not_found -> pf ppf "Not found" + + let flow_of_endpoint : + type edn. edn key -> edn -> (flow, [> error ]) result s = + fun key edn -> + let rec go = function + | [] -> return (Error `Not_found) + | Ptr.Key (Protocol (k, (module Protocol)), ctor) :: 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))) + | Error _err -> go r) in + go (Ptr.bindings ()) + + let flow_of_protocol : + type edn flow. + (edn, flow) protocol -> edn -> (flow, [> error ]) result s = + fun (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) + + type endpoint = Endpoint : 'edn key * 'edn -> endpoint + + module Refl = struct + type ('a, 'b) t = Refl : ('a, 'a) t end + let scheduler : type s. s witness -> (s, scheduler) Refl.t option = function + | Witness -> Some Refl.Refl + | _ -> None + + let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = + fun m domain_name -> + let rec go acc = function + | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) + | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> + match scheduler witness with + | None -> go acc r + | Some Refl.Refl -> ( + resolve domain_name |> prj >>= function + | Some edn -> go (Endpoint (k, edn) :: acc) r + | None -> go acc r) in + let compare (Map.Value (_, Resolver { priority = pa; _ })) + (Map.Value (_, Resolver { priority = pb; _ })) = + (Stdlib.compare : int -> int -> int) pa pb in + go [] (List.sort compare (Map.bindings m)) + + let create : + resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = + fun m domain_name -> + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> ( + flow_of_endpoint key edn >>= function + | Ok flow -> return (Ok flow) + | Error _err -> go r) in + go l + + let abstract : type edn v. (edn, v) protocol -> v -> flow = + fun (module Witness) flow -> Witness.T (Value flow) + + let connect : + type edn v. + resolvers -> + ?protocol:(edn, v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s = + fun m ?protocol domain_name -> + match protocol with + | None -> create m domain_name + | Some (module Witness) -> + let (Protocol (key', _)) = Witness.witness in + resolve m domain_name >>= fun l -> + let rec go = function + | [] -> return (Error `Not_found) + | Endpoint (key, edn) :: r -> + 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))) + | Error _err -> go r) in + go l + + 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 + (module Protocol) + + let is : 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 + module Service = struct module type SERVICE = Sigs.SERVICE with type +'a s = 'a s diff --git a/lib/conduit.mli b/lib/conduit.mli index 915fd96d..6fa25f8b 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -17,75 +17,243 @@ module type S = sig type scheduler - module Client : sig - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s - - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - - type flow = private .. - - type ('edn, 'flow) protocol - - type error = [ `Msg of string | `Not_found ] - - val pp_error : error Fmt.t - - val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s - - val send : flow -> output -> (int, [> error ]) result s - - val close : flow -> (unit, [> error ]) result s - - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - - module type REPR = sig - type t - - type flow += T of t - end - - val repr : - ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - - val add : - ('edn, _) protocol -> - ?priority:int -> - 'edn resolver -> - resolvers -> - resolvers - - val abstract : (_, 'v) protocol -> 'v -> flow - - val connect : - resolvers -> - ?protocol:('edn, 'v) protocol -> - [ `host ] Domain_name.t -> - (flow, [> error ]) result s - - val impl_of_protocol : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - val impl_of_flow : - (_, 'flow) protocol -> (module FLOW with type flow = 'flow) - - val is : flow -> (_, 'flow) protocol -> 'flow option + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + (** A flow is a system that allows entities to transmit {i payloads}. These + entities do not have to care about the underlying transport mechanism. + flows simply deal with routing and delivering of these payloads. That + abstraction allows these protocols to compose. + + For example, the Transmission Control Protocol (TCP) is representable as a + flow, because it is able to encapsulate some {i payloads} without + interpreting it. A counter-example is the Simple Mail Transfer Protocol + (SMTP) which needs an interpretation of its {i payloads}: tokens such as + [EHLO] or [QUIT] have a direct incidence over the life-cycle of the + connection. + + An other protocol representable as a flow is the Transport Layer Security + (TLS), as it deals only with privacy and data integrity. [Conduit] is able + to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level + protocols can be built in top of these abstract flows: for instance, Secure + Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure + (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these + can be abstracted to work over any flow implementations. *) + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + (** A protocol is a {!FLOW} plus [connect]. *) + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** The type to represent a module {!PROTOCOL}. *) + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + (** The type for resolver functions, which resolve domain names to endpoints. + For instance, the DNS resolver function is: + + {[ + let http_resolver : Unix.sockaddr resolver = + fun domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) + else None + | exception _ -> None + ]} + *) + + type flow = private .. + (** The type for generic flows. {!PROTOCOL} implementations are extending (via + {!register}) this type. It allows users to extract the underlying flow + 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))) -> ... + | _ -> ... (* use flow functions for the default case *) + ]} + *) + + type ('edn, 'flow) protocol + (** The type for client protocols. ['edn] is the type for endpoint parameters. + ['flow] is the type for underlying flows. + + Endpoints allow users to create flows by either connecting directly to a + remote server or by resolving domain names (with {!connect}). *) + + type error = [ `Msg of string | `Not_found ] + + val pp_error : error Fmt.t + + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s + (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been + received from the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, [> error ]) result s + (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, [> error ]) result s + (** [close flow] closes [flow]. Subsequent calls to {!recv} will return + [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) + + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol + (** [register ~protocol] is the protocol using the implementation [protocol]. + [protocol] must provide a [connect] function to allow client flows to be + created. + + For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow + endpoints, while [Unix.file_descr] would be used for the flow transport. + + {[ + module Conduit_tcp : sig + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + end + ]} + + Client endpoints can of course be more complex, for instance to hold TLS + credentials, and [Conduit] allows all these kinds of flow to be used + transparently: + + {[ + module Conduit_tcp_tls : sig + val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TLS) + ]} + + As a protocol implementer, you must {i register} your implementation and + expose the {i witness} of it. Then, users will be able to use it. *) + + module type REPR = sig + type t + + 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: + + {[ + module Conduit_tcp : sig + type t = (Unix.sockaddr, Unix.file_descr) Conduit.value + type Conduit.flow += T of t + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + include (val (Conduit.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) -> ... + | _ -> ... + ]} + *) + + val add : + ('edn, _) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers + (** [add protocol ?priority resolver resolvers] adds a new resolver function + [resolver] to [resolvers]. + + When the [resolver] is able to resolve the given domain name, it will try + to connect to the specified client endpoint. Resolvers are iterated in + priority order (lower to higher). + + {[ + let http_resolver = ... + let https_resolver = ... (* deal with client-side certificates here. *) + + let resolvers = + empty + |> add Conduit_tcp.t http_resolver + |> add Conduit_tcp_tls.t https_resolver ~priority:10 + |> add Conduit_tcp_ssl.t https_resolver ~priority:20 + ]} *) + + val abstract : (_, 'v) protocol -> 'v -> flow + (** [abstract protocol concrete_flow] abstracts the given [flow] into the + {!flow} type from a given [protocol]. It permits to use [Conduit] with a + concrete value created by the user. + + {[ + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let flow = Conduit.abstract Conduit_tcp.t socket in + Conduit.send flow "Hello World!" + ]} + *) + + val connect : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result s + (** [connect resolvers domain_name] is the flow created by connecting to the + domain name [domain_name], using the resolvers [resolvers]. Each resolver + tries to resolve the given domain-name (they are ordered by the given + priority). The first which connects successfully wins. + + The resolver result is a flow connect to that winning endpoint. + + {[ + let mirage_io = domain_name_exn "mirage.io" + + val resolver_on_my_private_network : Unix.sockaddr resolver + val resolver_on_internet : Unix.sockaddr resolver + val resolver_with_tls : (Unix.sockaddr * Tls.Config.client) resolver + + let resolvers = + empty + |> add tls ~priority:0 resolver_with_tls + |> add tcp ~priority:10 resolver_on_my_private_network + |> add tcp ~priority:20 resolver_on_internet + + let () = Conduit.connect resolvers mirage_io >>? function + | TCP.T (Conduit.Value 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!" + ]} + *) + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** [impl protocol] is [protocol]'s implementation. *) + + val is : flow -> (_, 'flow) protocol -> 'flow option + (** [is flow protocol] tries to {i destruct} the given [flow] to the concrete + type described by the given [protocol]. + + {[ + match Conduit.is flow Conduit_tcp.t with + | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) + | None -> None + ]} + *) + module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml index c1fb67fc..c4bb2264 100644 --- a/lwt-unix/conduit_lwt_unix.ml +++ b/lwt-unix/conduit_lwt_unix.ml @@ -8,9 +8,9 @@ let io_of_flow flow = let close () = if !ic_closed && !oc_closed then - Client.close flow >>= function + close flow >>= function | Ok () -> Lwt.return_unit - | Error err -> failf "%a" Client.pp_error err + | Error err -> failf "%a" pp_error err else Lwt.return_unit in let ic_close () = ic_closed := true ; @@ -20,15 +20,15 @@ let io_of_flow flow = close () in let recv buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - Client.recv flow raw >>= function + recv flow raw >>= function | Ok (`Input len) -> Lwt.return len | Ok `End_of_flow -> Lwt.return 0 - | Error err -> failf "%a" Client.pp_error err in + | Error err -> failf "%a" pp_error err in let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in let send buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - Client.send flow raw >>= function + send flow raw >>= function | Ok len -> Lwt.return len - | Error err -> failf "%a" Client.pp_error err in + | Error err -> failf "%a" pp_error err in let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in (ic, oc) diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli index d8904fe0..c6c8a531 100644 --- a/lwt-unix/conduit_lwt_unix.mli +++ b/lwt-unix/conduit_lwt_unix.mli @@ -6,11 +6,11 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) Client.protocol = - ('edn, 'flow) Conduit_lwt.Client.protocol + and type ('edn, 'flow) protocol = + ('edn, 'flow) Conduit_lwt.protocol and type ('cfg, 't, 'flow) Service.service = ('cfg, 't, 'flow) Conduit_lwt.Service.service - and type Client.flow = Conduit_lwt.Client.flow + and type flow = Conduit_lwt.flow val serve_with_handler : handler:('flow -> unit Lwt.t) -> @@ -19,4 +19,4 @@ val serve_with_handler : unit Lwt_condition.t * unit Lwt.t val io_of_flow : - Client.flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel + flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt-unix/conduit_lwt_unix_ssl.ml index d297bf85..2eb7bbe8 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt-unix/conduit_lwt_unix_ssl.ml @@ -25,7 +25,7 @@ let endpoint ~file_descr ~context ?verify endpoint = let pf = Format.fprintf -module Protocol (Flow : Conduit_lwt_unix.Client.PROTOCOL) = struct +module Protocol (Flow : Conduit_lwt_unix.PROTOCOL) = struct type input = Cstruct.t type output = Cstruct.t @@ -66,12 +66,12 @@ end let protocol_with_ssl : type edn flow. - (edn, flow) Conduit_lwt_unix.Client.protocol -> - ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol = + (edn, flow) Conduit_lwt_unix.protocol -> + ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt_unix.protocol = fun protocol -> - let module Flow = (val Conduit_lwt_unix.Client.impl_of_protocol protocol) in + let module Flow = (val Conduit_lwt_unix.impl protocol) in let module M = Protocol (Flow) in - Conduit_lwt_unix.Client.register ~protocol:(module M) + Conduit_lwt_unix.register ~protocol:(module M) type 't master = { master : 't; context : Ssl.context } @@ -114,7 +114,7 @@ let service_with_ssl : type cfg edn t flow. (cfg, t, flow) Conduit_lwt_unix.Service.service -> file_descr:(flow -> Lwt_unix.file_descr) -> - (edn, Lwt_ssl.socket) Conduit_lwt_unix.Client.protocol -> + (edn, Lwt_ssl.socket) Conduit_lwt_unix.protocol -> ( Ssl.context * cfg, t master, Lwt_ssl.socket ) diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli index 9c926d7d..52dbb313 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -55,8 +55,8 @@ val endpoint : hostname} with your peer. *) val protocol_with_ssl : - ('edn, 'flow) Client.protocol -> - (('edn, 'flow) endpoint, Lwt_ssl.socket) Client.protocol + ('edn, 'flow) protocol -> + (('edn, 'flow) endpoint, Lwt_ssl.socket) protocol (** [protocol_with_ssl ~key protocol] returns a representation of the given protocol with SSL. *) @@ -66,7 +66,7 @@ type 't master val service_with_ssl : ('cfg, 't, 'flow) Service.service -> file_descr:('flow -> Lwt_unix.file_descr) -> - ('edn, Lwt_ssl.socket) Client.protocol -> + ('edn, Lwt_ssl.socket) protocol -> (Ssl.context * 'cfg, 't master, Lwt_ssl.socket) Service.service (** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a representation of the given service with SSL. The service deliver an SSL @@ -82,7 +82,7 @@ module TCP : sig val protocol : ( (Lwt_unix.sockaddr, Protocol.flow) endpoint, Lwt_ssl.socket ) - Client.protocol + protocol val service : ( Ssl.context * configuration, @@ -99,5 +99,5 @@ module TCP : sig port:int -> context:Ssl.context -> ?verify:verify -> - (Lwt_unix.sockaddr, Protocol.flow) endpoint Client.resolver + (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver end diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt-unix/conduit_lwt_unix_tcp.ml index 7bb1382f..4336121a 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt-unix/conduit_lwt_unix_tcp.ml @@ -302,9 +302,9 @@ module Server = struct Lwt.return_ok () end -let protocol = Conduit_lwt.Client.register ~protocol:(module Protocol) +let protocol = Conduit_lwt.register ~protocol:(module Protocol) -include (val Conduit_lwt.Client.repr protocol) +include (val Conduit_lwt.repr protocol) let service = Conduit_lwt.Service.register ~service:(module Server) diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli index dcca5dd0..81626f16 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.mli +++ b/lwt-unix/conduit_lwt_unix_tcp.mli @@ -19,7 +19,7 @@ open Conduit_lwt_unix module Protocol : sig include - Client.PROTOCOL + PROTOCOL with type endpoint = Lwt_unix.sockaddr and type error = [ `Closed_by_peer @@ -66,12 +66,12 @@ module Server : | `Protocol_error | `Firewall_rules_forbid_connection ] -val protocol : (Lwt_unix.sockaddr, Protocol.flow) Client.protocol +val protocol : (Lwt_unix.sockaddr, Protocol.flow) protocol type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value -type Conduit_lwt.Client.flow += T of t +type Conduit_lwt.flow += T of t val service : (configuration, Server.t, Protocol.flow) Service.service -val resolv_conf : port:int -> Lwt_unix.sockaddr Client.resolver +val resolv_conf : port:int -> Lwt_unix.sockaddr resolver diff --git a/lwt-unix/conduit_lwt_unix_tls.ml b/lwt-unix/conduit_lwt_unix_tls.ml index 5c004b4b..440e269b 100644 --- a/lwt-unix/conduit_lwt_unix_tls.ml +++ b/lwt-unix/conduit_lwt_unix_tls.ml @@ -5,7 +5,7 @@ module TCP = struct let protocol = protocol_with_tls protocol - include (val Conduit_lwt.Client.repr protocol) + include (val Conduit_lwt.repr protocol) let service = service_with_tls service protocol diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt-unix/conduit_lwt_unix_tls.mli index e83a72ac..9b2fc178 100644 --- a/lwt-unix/conduit_lwt_unix_tls.mli +++ b/lwt-unix/conduit_lwt_unix_tls.mli @@ -19,14 +19,14 @@ val handshake : 'flow protocol_with_tls -> bool it returns [false]. *) val protocol_with_tls : - ('edn, 'flow) Client.protocol -> - ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol + ('edn, 'flow) protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol type 'service service_with_tls val service_with_tls : ('cfg, 't, 'flow) Service.service -> - ('edn, 'flow protocol_with_tls) Client.protocol -> + ('edn, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) @@ -38,14 +38,14 @@ module TCP : sig val protocol : ( Lwt_unix.sockaddr * Tls.Config.client, Protocol.flow protocol_with_tls ) - Client.protocol + protocol type t = ( Lwt_unix.sockaddr * Tls.Config.client, Protocol.flow protocol_with_tls ) Conduit.value - type Conduit_lwt.Client.flow += T of t + type Conduit_lwt.flow += T of t val service : ( configuration * Tls.Config.server, @@ -56,5 +56,5 @@ module TCP : sig val resolv_conf : port:int -> config:Tls.Config.client -> - (Lwt_unix.sockaddr * Tls.Config.client) Client.resolver + (Lwt_unix.sockaddr * Tls.Config.client) resolver end diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index dc134914..9b023570 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -54,7 +54,7 @@ module type CONDUIT = sig type master - val protocol : (endpoint, flow) Client.protocol + val protocol : (endpoint, flow) protocol val service : (configuration, master, flow) Service.service end diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index 7b451af3..739a9a83 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -42,7 +42,7 @@ module type CONDUIT = sig type master - val protocol : (endpoint, flow) Client.protocol + val protocol : (endpoint, flow) protocol val service : (configuration, master, flow) Service.service end diff --git a/lwt/conduit_lwt_flow.ml b/lwt/conduit_lwt_flow.ml index 207aa405..7ef5eee4 100644 --- a/lwt/conduit_lwt_flow.ml +++ b/lwt/conduit_lwt_flow.ml @@ -1,20 +1,20 @@ open Lwt.Infix -type flow = Conduit_lwt.Client.flow +type flow = Conduit_lwt.flow -type error = Conduit_lwt.Client.error +type error = Conduit_lwt.error -type write_error = [ Mirage_flow.write_error | Conduit_lwt.Client.error ] +type write_error = [ Mirage_flow.write_error | Conduit_lwt.error ] -let pp_error = Conduit_lwt.Client.pp_error +let pp_error = Conduit_lwt.pp_error let pp_write_error ppf = function | #Mirage_flow.write_error as err -> Mirage_flow.pp_write_error ppf err - | #Conduit_lwt.Client.error as err -> Conduit_lwt.Client.pp_error ppf err + | #Conduit_lwt.error as err -> Conduit_lwt.pp_error ppf err let read flow = let raw = Cstruct.create 0x1000 in - Conduit_lwt.Client.recv flow raw >>= function + Conduit_lwt.recv flow raw >>= function | Ok `End_of_flow -> Lwt.return_ok `Eof | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) | Error _ as err -> Lwt.return err @@ -24,7 +24,7 @@ let write flow raw = if Cstruct.len x = 0 then Lwt.return_ok () else - Conduit_lwt.Client.send flow x >>= function + Conduit_lwt.send flow x >>= function | Error _ as err -> Lwt.return err | Ok len -> go (Cstruct.shift x len) in go raw @@ -38,4 +38,4 @@ let writev flow cs = | Error _ as err -> Lwt.return err) in go cs -let close flow = Conduit_lwt.Client.close flow >>= fun _ -> Lwt.return_unit +let close flow = Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit diff --git a/lwt/conduit_lwt_flow.mli b/lwt/conduit_lwt_flow.mli index 4ca487ce..f9714023 100644 --- a/lwt/conduit_lwt_flow.mli +++ b/lwt/conduit_lwt_flow.mli @@ -15,4 +15,4 @@ the POSIX interface and let the end-user to allocate by himself the input buffer. *) -include Mirage_flow.S with type flow = Conduit_lwt.Client.flow +include Mirage_flow.S with type flow = Conduit_lwt.flow diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 0c7f2c4a..f5e560ed 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -6,11 +6,11 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) Client.protocol = - ('edn, 'flow) Conduit_lwt.Client.protocol + and type ('edn, 'flow) protocol = + ('edn, 'flow) Conduit_lwt.protocol and type ('cfg, 't, 'flow) Service.service = ('cfg, 't, 'flow) Conduit_lwt.Service.service - and type Client.flow = Conduit_lwt.Client.flow + and type flow = Conduit_lwt.flow val serve_with_handler : handler:('flow -> unit Lwt.t) -> @@ -27,7 +27,7 @@ module type CONDUIT = sig type master - val protocol : (endpoint, flow) Client.protocol + val protocol : (endpoint, flow) protocol val service : (configuration, master, flow) Service.service end diff --git a/mirage/conduit_mirage_dns.ml b/mirage/conduit_mirage_dns.ml index 35f95e91..bf66d4b3 100644 --- a/mirage/conduit_mirage_dns.ml +++ b/mirage/conduit_mirage_dns.ml @@ -13,7 +13,7 @@ struct t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) Client.resolver = + (Ipaddr.V4.t * int) resolver = fun t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function | Ok domain_name -> Lwt.return_some (domain_name, port) diff --git a/mirage/conduit_mirage_dns.mli b/mirage/conduit_mirage_dns.mli index 42a224bb..cdebcf5a 100644 --- a/mirage/conduit_mirage_dns.mli +++ b/mirage/conduit_mirage_dns.mli @@ -11,5 +11,5 @@ module Make t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) Client.resolver + (Ipaddr.V4.t * int) resolver end diff --git a/mirage/conduit_mirage_flow.mli b/mirage/conduit_mirage_flow.mli index 03d1d177..1135b37d 100644 --- a/mirage/conduit_mirage_flow.mli +++ b/mirage/conduit_mirage_flow.mli @@ -15,4 +15,4 @@ the POSIX interface and let the end-user to allocate by himself the input buffer. *) -include Mirage_flow.S with type flow = Conduit_mirage.Client.flow +include Mirage_flow.S with type flow = Conduit_mirage.flow diff --git a/mirage/conduit_mirage_tcp.ml b/mirage/conduit_mirage_tcp.ml index 42188d3a..700adf1c 100644 --- a/mirage/conduit_mirage_tcp.ml +++ b/mirage/conduit_mirage_tcp.ml @@ -199,7 +199,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct StackV4.TCPV4.close t.flow >>= fun () -> Lwt.return_ok ()) end - let protocol = Conduit_mirage.Client.register ~protocol:(module Protocol) + let protocol = Conduit_mirage.register ~protocol:(module Protocol) type nonrec configuration = StackV4.t configuration diff --git a/mirage/conduit_mirage_tcp.mli b/mirage/conduit_mirage_tcp.mli index 9fa874dc..d2acb348 100644 --- a/mirage/conduit_mirage_tcp.mli +++ b/mirage/conduit_mirage_tcp.mli @@ -18,7 +18,7 @@ type 'stack configuration = { module Make (StackV4 : Mirage_stack.V4) : sig type protocol - val protocol : ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Client.protocol + val protocol : ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Conduit_mirage.protocol val dst : protocol -> Ipaddr.V4.t * int diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli index 837a16c4..d9f41be4 100644 --- a/mirage/conduit_mirage_tls.mli +++ b/mirage/conduit_mirage_tls.mli @@ -7,14 +7,14 @@ val underlying : 'flow protocol_with_tls -> 'flow val handshake : 'flow protocol_with_tls -> bool val protocol_with_tls : - ('edn, 'flow) Client.protocol -> - ('edn * Tls.Config.client, 'flow protocol_with_tls) Client.protocol + ('edn, 'flow) protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol type 'service service_with_tls val service_with_tls : ('cfg, 't, 'flow) Service.service -> - ('edn, 'flow protocol_with_tls) Client.protocol -> + ('edn, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index a6d5df91..9e890f2b 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -44,7 +44,7 @@ let getline queue flow = match getline queue with | Some line -> Lwt.return_ok (`Line line) | None -> ( - Conduit_lwt_unix.Client.recv flow tmp >>? function + Conduit_lwt_unix.recv flow tmp >>? function | `End_of_flow -> Lwt.return_ok `Close | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; @@ -59,47 +59,47 @@ let transmission flow = let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go () = getline queue flow >>= function - | Ok `Close | Error _ -> Conduit_lwt.Client.close flow + | Ok `Close | Error _ -> Conduit_lwt.close flow | Ok (`Line "ping") -> Fmt.epr "[!] received ping.\n%!" ; - Conduit_lwt.Client.send flow pong >>? fun _ -> go () + Conduit_lwt.send flow pong >>? fun _ -> go () | Ok (`Line "pong") -> Fmt.epr "[!] received pong.\n%!" ; - Conduit_lwt.Client.send flow ping >>? fun _ -> go () + Conduit_lwt.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Fmt.epr "[!] received %S.\n%!" line ; - Conduit_lwt.Client.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> Conduit_lwt.Client.close flow in + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> Conduit_lwt.close flow in go () >>= function - | Error err -> failwith "%a" Conduit_lwt.Client.pp_error err + | Error err -> failwith "%a" Conduit_lwt.pp_error err | Ok () -> Lwt.return () let server : type cfg master flow. cfg -> - protocol:(_, flow) Conduit_lwt.Client.protocol -> + protocol:(_, flow) Conduit_lwt.protocol -> service:(cfg, master, flow) Conduit_lwt.Service.service -> unit Lwt_condition.t * unit Lwt.t = fun cfg ~protocol ~service -> Conduit_lwt_unix.serve_with_handler ~handler:(fun flow -> - transmission (Conduit_lwt.Client.abstract protocol flow)) + transmission (Conduit_lwt.abstract protocol flow)) ~service cfg -(* Client part *) +(* part *) let client ~resolvers domain_name responses = - Conduit_lwt.Client.connect resolvers domain_name >>? fun flow -> + Conduit_lwt.connect resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function - | [] -> Conduit_lwt.Client.close flow + | [] -> Conduit_lwt.close flow | line :: rest -> ( - Conduit_lwt.Client.send flow (Cstruct.of_string (line ^ "\n")) + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> getline queue flow >>? function - | `Close -> Conduit_lwt.Client.close flow + | `Close -> Conduit_lwt.close flow | `Line "pong" -> go rest - | `Line _ -> Conduit_lwt.Client.close flow) in + | `Line _ -> Conduit_lwt.close flow) in go responses let client ~resolvers filename = @@ -113,8 +113,8 @@ let client ~resolvers filename = client ~resolvers localhost responses >>= function | Ok () -> Lwt.return_unit | Error `Closed_by_peer -> Lwt.return_unit - | Error (#Conduit_lwt.Client.error as err) -> - Fmt.epr "client: %a.\n%!" Conduit_lwt.Client.pp_error err ; + | Error (#Conduit_lwt.error as err) -> + Fmt.epr "client: %a.\n%!" Conduit_lwt.pp_error err ; Lwt.return_unit (* Composition *) @@ -142,10 +142,10 @@ let resolve_ssl_ping_pong = let resolvers = Conduit.empty - |> Conduit_lwt.Client.add ~priority:20 Conduit_lwt_unix_tcp.protocol + |> Conduit_lwt.add ~priority:20 Conduit_lwt_unix_tcp.protocol resolve_ping_pong - |> Conduit_lwt.Client.add ~priority:10 tls_protocol resolve_tls_ping_pong - |> Conduit_lwt.Client.add ~priority:10 ssl_protocol resolve_ssl_ping_pong + |> Conduit_lwt.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_lwt.add ~priority:10 ssl_protocol resolve_ssl_ping_pong (* Run *) @@ -170,7 +170,7 @@ let config cert key = let run_with : type cfg master flow. cfg -> - protocol:(_, flow) Conduit_lwt.Client.protocol -> + protocol:(_, flow) Conduit_lwt.protocol -> service:(cfg, master, flow) Conduit_lwt.Service.service -> string list -> unit = diff --git a/tests/with_async.ml b/tests/with_async.ml index 11d7a02c..b4a50951 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -49,7 +49,7 @@ let getline queue flow = match getline queue with | Some line -> Async.return (Ok (`Line line)) | None -> ( - Conduit_async.Client.recv flow tmp >>? function + Conduit_async.recv flow tmp >>? function | `End_of_flow -> Async.return (Ok `Close) | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; @@ -66,19 +66,19 @@ let transmission ~stop flow = let finish = Condition.wait stop >>= fun () -> Async.return (Ok `Done) in let getline = getline queue flow in Async.Deferred.any [ finish; getline ] >>= function - | Ok (`Done | `Close) | Error _ -> Conduit_async.Client.close flow + | Ok (`Done | `Close) | Error _ -> Conduit_async.close flow | Ok (`Line "ping") -> Format.eprintf "[!] received ping.\n%!" ; - Conduit_async.Client.send flow pong >>? fun _ -> go () + Conduit_async.send flow pong >>? fun _ -> go () | Ok (`Line "pong") -> Format.eprintf "[!] received pong.\n%!" ; - Conduit_async.Client.send flow ping >>? fun _ -> go () + Conduit_async.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Format.eprintf "[!] received %S.\n%!" line ; - Conduit_async.Client.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> Conduit_async.Client.close flow in + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) + >>? fun _ -> Conduit_async.close flow in go () >>= function - | Error err -> failwith "%a" Conduit_async.Client.pp_error err + | Error err -> failwith "%a" Conduit_async.pp_error err | Ok () -> Async.return () let server : @@ -86,7 +86,7 @@ let server : launched:unit Async.Condition.t -> stop:unit Async.Condition.t -> cfg -> - protocol:(_, flow) Conduit_async.Client.protocol -> + protocol:(_, flow) Conduit_async.protocol -> service:(cfg, master, flow) Conduit_async.Service.service -> unit Async.Deferred.t = fun ~launched ~stop cfg ~protocol ~service -> @@ -105,7 +105,7 @@ let server : Async.Deferred.any [ close; accept ] >>= function | Ok (`Flow flow) -> Async.don't_wait_for - (transmission ~stop (Conduit_async.Client.abstract protocol flow)) ; + (transmission ~stop (Conduit_async.abstract protocol flow)) ; Async.Scheduler.yield () >>= go | Ok `Closed -> Server.close master | Error _ as err -> Server.close master >>= fun _ -> Async.return err @@ -116,17 +116,17 @@ let server : | Error err -> failwith "%a" Conduit_async.Service.pp_error err let client ~resolvers domain_name responses = - Conduit_async.Client.connect resolvers domain_name >>? fun flow -> + Conduit_async.connect resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function - | [] -> Conduit_async.Client.close flow + | [] -> Conduit_async.close flow | line :: rest -> ( - Conduit_async.Client.send flow (Cstruct.of_string (line ^ "\n")) + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> getline queue flow >>? function - | `Close -> Conduit_async.Client.close flow + | `Close -> Conduit_async.close flow | `Line "pong" -> go rest - | `Line _ -> Conduit_async.Client.close flow) in + | `Line _ -> Conduit_async.close flow) in go responses let client ~resolvers domain_name filename = @@ -139,8 +139,8 @@ let client ~resolvers domain_name filename = Stdlib.close_in ic ; client ~resolvers domain_name responses >>= function | Ok () -> Async.return () - | Error (#Conduit_async.Client.error as err) -> - failwith "Client got an error: %a" Conduit_async.Client.pp_error err + | Error (#Conduit_async.error as err) -> + failwith "got an error: %a" Conduit_async.pp_error err let resolve_ping_pong = Conduit_async_tcp.resolv_conf ~port:5000 @@ -157,16 +157,16 @@ let resolve_tls_ping_pong = let resolvers = Conduit.empty - |> Conduit_async.Client.add ~priority:10 ssl_protocol resolve_ssl_ping_pong - |> Conduit_async.Client.add ~priority:10 tls_protocol resolve_tls_ping_pong - |> Conduit_async.Client.add ~priority:20 tcp_protocol resolve_ping_pong + |> Conduit_async.add ~priority:10 ssl_protocol resolve_ssl_ping_pong + |> Conduit_async.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_async.add ~priority:20 tcp_protocol resolve_ping_pong let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : type cfg master flow. cfg -> - protocol:(_, flow) Conduit_async.Client.protocol -> + protocol:(_, flow) Conduit_async.protocol -> service:(cfg, master, flow) Conduit_async.Service.service -> string list -> unit = diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index 28cc89dc..4ad16859 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -305,13 +305,13 @@ struct let protocol_with_tls : type edn flow. - (edn, flow) Conduit.Client.protocol -> - (edn * Tls.Config.client, flow protocol_with_tls) Conduit.Client.protocol + (edn, flow) Conduit.protocol -> + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol = fun protocol -> - let module Protocol = (val Conduit.Client.impl_of_protocol protocol) in + let module Protocol = (val Conduit.impl protocol) in let module M = Make_protocol (Protocol) in - Conduit.Client.register ~protocol:(module M) + Conduit.register ~protocol:(module M) type 'service service_with_tls = { service : 'service; @@ -355,7 +355,7 @@ struct let service_with_tls : type cfg edn t flow. (cfg, t, flow) Conduit.Service.service -> - (edn, flow protocol_with_tls) Conduit.Client.protocol -> + (edn, flow protocol_with_tls) Conduit.protocol -> ( cfg * Tls.Config.server, t service_with_tls, flow protocol_with_tls ) diff --git a/tls/conduit_tls.mli b/tls/conduit_tls.mli index 5802619e..26bcf570 100644 --- a/tls/conduit_tls.mli +++ b/tls/conduit_tls.mli @@ -52,8 +52,8 @@ module Make (** [handshake flow] returns [true] if {i handshake} is processing. *) val protocol_with_tls : - ('edn, 'flow) Conduit.Client.protocol -> - ('edn * Tls.Config.client, 'flow protocol_with_tls) Conduit.Client.protocol + ('edn, 'flow) Conduit.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Conduit.protocol (** From a given protocol [witness], it creates a new {i witness} of the protocol layered with TLS. *) @@ -61,7 +61,7 @@ module Make val service_with_tls : ('cfg, 't, 'flow) Conduit.Service.service -> - ('edn, 'flow protocol_with_tls) Conduit.Client.protocol -> + ('edn, 'flow protocol_with_tls) Conduit.protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) From 1c36d327ff9d30846b4d840cb4f03762b261432d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 8 Jun 2020 12:44:52 +0200 Subject: [PATCH 031/140] Re-order documentation and ocamlformat pass --- async/conduit_async_ssl.mli | 3 +- async/conduit_async_tls.mli | 4 +- lib/conduit.ml | 65 ++++++------ lib/conduit.mli | 167 +++++++++++++++--------------- lwt-unix/conduit_lwt_unix.mli | 3 +- lwt-unix/conduit_lwt_unix_ssl.mli | 7 +- mirage/conduit_mirage.mli | 3 +- mirage/conduit_mirage_tcp.mli | 3 +- tests/ping_pong.ml | 10 +- tests/with_async.ml | 7 +- tls/conduit_tls.ml | 3 +- 11 files changed, 134 insertions(+), 141 deletions(-) diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index 2305e752..51ce74f0 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -65,6 +65,5 @@ module TCP : sig Protocol.flow with_ssl ) Service.service - val resolv_conf : - port:int -> context:context -> (context * endpoint) resolver + val resolv_conf : port:int -> context:context -> (context * endpoint) resolver end diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index 6026401c..0c33b918 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -24,9 +24,7 @@ module TCP : sig open Conduit_async_tcp val protocol : - ( endpoint * Tls.Config.client, - Protocol.flow protocol_with_tls ) - protocol + (endpoint * Tls.Config.client, Protocol.flow protocol_with_tls) protocol val service : ( configuration * Tls.Config.server, diff --git a/lib/conduit.ml b/lib/conduit.ml index a95301dd..aa4c0e42 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -42,27 +42,8 @@ module type S = sig type scheduler - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a s = 'a s - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s - - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - type flow = private .. - type ('edn, 'flow) protocol - type error = [ `Msg of string | `Not_found ] val pp_error : error Fmt.t @@ -74,6 +55,23 @@ module type S = sig val close : flow -> (unit, [> error ]) result s + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a s = 'a s + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + type ('edn, 'flow) protocol + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol module type REPR = sig @@ -82,8 +80,17 @@ module type S = sig type flow += T of t end - val repr : - ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + + val abstract : ('edn, 'v) protocol -> 'v -> flow + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + val is : flow -> ('edn, 'flow) protocol -> 'flow option + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s val add : ('edn, 'flow) protocol -> @@ -92,20 +99,12 @@ module type S = sig resolvers -> resolvers - val abstract : ('edn, 'v) protocol -> 'v -> flow - val connect : resolvers -> ?protocol:('edn, 'v) protocol -> [ `host ] Domain_name.t -> (flow, [> error ]) result s - val impl : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - val is : flow -> ('edn, 'flow) protocol -> 'flow option - module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s @@ -269,8 +268,8 @@ module Make | `Msg err -> pf ppf "%s" err | `Not_found -> pf ppf "Not found" - let flow_of_endpoint : - type edn. edn key -> edn -> (flow, [> error ]) result s = + let flow_of_endpoint : type edn. edn key -> edn -> (flow, [> error ]) result s + = fun key edn -> let rec go = function | [] -> return (Error `Not_found) @@ -284,8 +283,8 @@ module Make go (Ptr.bindings ()) let flow_of_protocol : - type edn flow. - (edn, flow) protocol -> edn -> (flow, [> error ]) result s = + type edn flow. (edn, flow) protocol -> edn -> (flow, [> error ]) result s + = fun (module Witness) edn -> let (Protocol (_, (module Protocol))) = Witness.witness in Protocol.connect edn >>= function diff --git a/lib/conduit.mli b/lib/conduit.mli index 6fa25f8b..b285834b 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -17,11 +17,40 @@ module type S = sig type scheduler - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a s = 'a s + (** {2:client Client-side Conduits.} *) + + type flow = private .. + (** The type for generic flows. {!PROTOCOL} implementations are extending (via + {!register}) this type. It allows users to extract the underlying flow + 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))) -> ... + | _ -> ... (* use flow functions for the default case *) + ]} + *) + + type error = [ `Msg of string | `Not_found ] + + val pp_error : error Fmt.t + + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s + (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been + received from the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, [> error ]) result s + (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, [> error ]) result s + (** [close flow] closes [flow]. Subsequent calls to {!recv} will return + [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) + + (** {2:registration Protocol registration.} *) + (** A flow is a system that allows entities to transmit {i payloads}. These entities do not have to care about the underlying transport mechanism. flows simply deal with routing and delivering of these payloads. That @@ -41,46 +70,23 @@ module type S = sig Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these can be abstracted to work over any flow implementations. *) + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a s = 'a s + (** A protocol is a {!FLOW} plus [connect]. *) module type PROTOCOL = Sigs.PROTOCOL with type input = input and type output = output and type +'a s = 'a s - (** A protocol is a {!FLOW} plus [connect]. *) type ('edn, 'flow) impl = (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) (** The type to represent a module {!PROTOCOL}. *) - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s - (** The type for resolver functions, which resolve domain names to endpoints. - For instance, the DNS resolver function is: - - {[ - let http_resolver : Unix.sockaddr resolver = - fun domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) - else None - | exception _ -> None - ]} - *) - - type flow = private .. - (** The type for generic flows. {!PROTOCOL} implementations are extending (via - {!register}) this type. It allows users to extract the underlying flow - 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))) -> ... - | _ -> ... (* use flow functions for the default case *) - ]} - *) - type ('edn, 'flow) protocol (** The type for client protocols. ['edn] is the type for endpoint parameters. ['flow] is the type for underlying flows. @@ -88,23 +94,6 @@ module type S = sig Endpoints allow users to create flows by either connecting directly to a remote server or by resolving domain names (with {!connect}). *) - type error = [ `Msg of string | `Not_found ] - - val pp_error : error Fmt.t - - val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s - (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been - received from the flow [flow] and copied in [input]. *) - - val send : flow -> output -> (int, [> error ]) result s - (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been - sent over the flow [flow]. *) - - val close : flow -> (unit, [> error ]) result s - (** [close flow] closes [flow]. Subsequent calls to {!recv} will return - [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol (** [register ~protocol] is the protocol using the implementation [protocol]. [protocol] must provide a [connect] function to allow client flows to be @@ -141,8 +130,7 @@ module type S = sig type flow += T of t end - val repr : - ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + 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: @@ -168,6 +156,51 @@ module type S = sig ]} *) + val abstract : (_, 'v) protocol -> 'v -> flow + (** [abstract protocol concrete_flow] abstracts the given [flow] into the + {!flow} type from a given [protocol]. It permits to use [Conduit] with a + concrete value created by the user. + + {[ + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let flow = Conduit.abstract Conduit_tcp.t socket in + Conduit.send flow "Hello World!" + ]} + *) + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** [impl protocol] is [protocol]'s implementation. *) + + val is : flow -> (_, 'flow) protocol -> 'flow option + (** [is flow protocol] tries to {i destruct} the given [flow] to the concrete + type described by the given [protocol]. + + {[ + match Conduit.is flow Conduit_tcp.t with + | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) + | None -> None + ]} + *) + + (** {2:resolution Domain name resolvers.} *) + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + (** The type for resolver functions, which resolve domain names to endpoints. + For instance, the DNS resolver function is: + + {[ + let http_resolver : Unix.sockaddr resolver = + fun domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) + else None + | exception _ -> None + ]} + *) + val add : ('edn, _) protocol -> ?priority:int -> @@ -192,18 +225,6 @@ module type S = sig |> add Conduit_tcp_ssl.t https_resolver ~priority:20 ]} *) - val abstract : (_, 'v) protocol -> 'v -> flow - (** [abstract protocol concrete_flow] abstracts the given [flow] into the - {!flow} type from a given [protocol]. It permits to use [Conduit] with a - concrete value created by the user. - - {[ - let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let flow = Conduit.abstract Conduit_tcp.t socket in - Conduit.send flow "Hello World!" - ]} - *) - val connect : resolvers -> ?protocol:('edn, 'v) protocol -> @@ -238,22 +259,6 @@ module type S = sig ]} *) - val impl : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - (** [impl protocol] is [protocol]'s implementation. *) - - val is : flow -> (_, 'flow) protocol -> 'flow option - (** [is flow protocol] tries to {i destruct} the given [flow] to the concrete - type described by the given [protocol]. - - {[ - match Conduit.is flow Conduit_tcp.t with - | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) - | None -> None - ]} - *) - module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli index c6c8a531..78ca7acd 100644 --- a/lwt-unix/conduit_lwt_unix.mli +++ b/lwt-unix/conduit_lwt_unix.mli @@ -6,8 +6,7 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) protocol = - ('edn, 'flow) Conduit_lwt.protocol + and type ('edn, 'flow) protocol = ('edn, 'flow) Conduit_lwt.protocol and type ('cfg, 't, 'flow) Service.service = ('cfg, 't, 'flow) Conduit_lwt.Service.service and type flow = Conduit_lwt.flow diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt-unix/conduit_lwt_unix_ssl.mli index 52dbb313..87b07f7c 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt-unix/conduit_lwt_unix_ssl.mli @@ -55,8 +55,7 @@ val endpoint : hostname} with your peer. *) val protocol_with_ssl : - ('edn, 'flow) protocol -> - (('edn, 'flow) endpoint, Lwt_ssl.socket) protocol + ('edn, 'flow) protocol -> (('edn, 'flow) endpoint, Lwt_ssl.socket) protocol (** [protocol_with_ssl ~key protocol] returns a representation of the given protocol with SSL. *) @@ -80,9 +79,7 @@ module TCP : sig open Conduit_lwt_unix_tcp val protocol : - ( (Lwt_unix.sockaddr, Protocol.flow) endpoint, - Lwt_ssl.socket ) - protocol + ((Lwt_unix.sockaddr, Protocol.flow) endpoint, Lwt_ssl.socket) protocol val service : ( Ssl.context * configuration, diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index f5e560ed..40076926 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -6,8 +6,7 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) protocol = - ('edn, 'flow) Conduit_lwt.protocol + and type ('edn, 'flow) protocol = ('edn, 'flow) Conduit_lwt.protocol and type ('cfg, 't, 'flow) Service.service = ('cfg, 't, 'flow) Conduit_lwt.Service.service and type flow = Conduit_lwt.flow diff --git a/mirage/conduit_mirage_tcp.mli b/mirage/conduit_mirage_tcp.mli index d2acb348..2a4a2bb7 100644 --- a/mirage/conduit_mirage_tcp.mli +++ b/mirage/conduit_mirage_tcp.mli @@ -18,7 +18,8 @@ type 'stack configuration = { module Make (StackV4 : Mirage_stack.V4) : sig type protocol - val protocol : ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Conduit_mirage.protocol + val protocol : + ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Conduit_mirage.protocol val dst : protocol -> Ipaddr.V4.t * int diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 9e890f2b..db35cfaf 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -68,8 +68,8 @@ let transmission flow = Conduit_lwt.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Fmt.epr "[!] received %S.\n%!" line ; - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> Conduit_lwt.close flow in + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_lwt.close flow in go () >>= function | Error err -> failwith "%a" Conduit_lwt.pp_error err | Ok () -> Lwt.return () @@ -82,8 +82,7 @@ let server : unit Lwt_condition.t * unit Lwt.t = fun cfg ~protocol ~service -> Conduit_lwt_unix.serve_with_handler - ~handler:(fun flow -> - transmission (Conduit_lwt.abstract protocol flow)) + ~handler:(fun flow -> transmission (Conduit_lwt.abstract protocol flow)) ~service cfg (* part *) @@ -94,8 +93,7 @@ let client ~resolvers domain_name responses = let rec go = function | [] -> Conduit_lwt.close flow | line :: rest -> ( - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> getline queue flow >>? function | `Close -> Conduit_lwt.close flow | `Line "pong" -> go rest diff --git a/tests/with_async.ml b/tests/with_async.ml index b4a50951..8ea58120 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -75,8 +75,8 @@ let transmission ~stop flow = Conduit_async.send flow ping >>? fun _ -> go () | Ok (`Line line) -> Format.eprintf "[!] received %S.\n%!" line ; - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> Conduit_async.close flow in + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_async.close flow in go () >>= function | Error err -> failwith "%a" Conduit_async.pp_error err | Ok () -> Async.return () @@ -121,8 +121,7 @@ let client ~resolvers domain_name responses = let rec go = function | [] -> Conduit_async.close flow | line :: rest -> ( - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) - >>? fun _ -> + Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> getline queue flow >>? function | `Close -> Conduit_async.close flow | `Line "pong" -> go rest diff --git a/tls/conduit_tls.ml b/tls/conduit_tls.ml index 4ad16859..a75db5e5 100644 --- a/tls/conduit_tls.ml +++ b/tls/conduit_tls.ml @@ -306,8 +306,7 @@ struct let protocol_with_tls : type edn flow. (edn, flow) Conduit.protocol -> - (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol - = + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol = fun protocol -> let module Protocol = (val Conduit.impl protocol) in let module M = Make_protocol (Protocol) in From 8e75c7433dbfa88454e7dc86e03be0404eeb39a4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 8 Jun 2020 13:10:16 +0200 Subject: [PATCH 032/140] Fix error about internal thd type and add a comment about it --- lib/conduit.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index aa4c0e42..3cbce295 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -16,7 +16,13 @@ type _ resolver = type ('a, 'b) value = Value : 'b -> ('a, 'b) value -type ('a, 'b, 'c) thd = Thd : 'b -> ('a, 'b, 'c) thd [@@warning "-37"] +[@@@warning "-37"] +type ('a, 'b, 'c) thd = Thd : 'b -> ('a, 'b, 'c) thd +(** XXX(dinosaure): we must define [(_, _, _) thd] to be able to keep some + existential types (eg. ['cfg] and ['flow] when we use [('cfg, 't, 'flow) + service]) but still to use only on (eg. ['t]). + + We add [warning "-37"] to be able to compile the project. *) let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt From 54015063c8ee2a67a1bcaf1cb012444da5142c5d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 13:27:49 +0200 Subject: [PATCH 033/140] Add documentation --- lib/conduit.ml | 6 ++++-- lib/conduit.mli | 32 +++++++++++++++++++++++++++++ lib/sigs.ml | 54 ++++++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 85 insertions(+), 7 deletions(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index 3cbce295..1c844164 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -17,8 +17,10 @@ type _ resolver = type ('a, 'b) value = Value : 'b -> ('a, 'b) value [@@@warning "-37"] -type ('a, 'b, 'c) thd = Thd : 'b -> ('a, 'b, 'c) thd -(** XXX(dinosaure): we must define [(_, _, _) thd] to be able to keep some + +type ('a, 'b, 'c) thd = + | Thd : 'b -> ('a, 'b, 'c) thd + (** XXX(dinosaure): we must define [(_, _, _) thd] to be able to keep some existential types (eg. ['cfg] and ['flow] when we use [('cfg, 't, 'flow) service]) but still to use only on (eg. ['t]). diff --git a/lib/conduit.mli b/lib/conduit.mli index b285834b..71d8f0b6 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -3,19 +3,25 @@ module Sigs = Sigs type ('a, 'b) refl = Refl : ('a, 'a) refl type resolvers +(** Type for resolvers map. *) val empty : resolvers +(** [empty] is an empty {!resolvers} map. *) type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value module type S = sig type input + (** The type for payload inputs. *) type output + (** The type for payload outputs. *) type +'a s + (** The type for I/O effects. *) type scheduler + (** The type of I/O monads. *) (** {2:client Client-side Conduits.} *) @@ -259,6 +265,8 @@ module type S = sig ]} *) + (** {2:service Server-side conduits.} *) + module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s @@ -269,8 +277,26 @@ module type S = sig and type flow = 'flow) type ('cfg, 't, 'flow) service + (** The type for services, e.g. service-side protocols. ['cfg] is the type + for configuration, ['t] is the type for state states. ['flow] is the type + for underlying flows. *) val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service + (** [register ~service] is the service using the implementation [service]. + [service] must define [make] and [accept] function to be able to create + server-side flows. + + For instance: + + {[ + module TCP : SERVICE with type configuration = Unix.sockaddr + and type t = Unix.file_descr + and type flow = Unix.file_descr + + let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = + Service.register ~service:(module TCP) + ]} + *) type error = [ `Msg of string ] @@ -278,12 +304,17 @@ module type S = sig val serve : 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s + (** [serve cfg ~service] initialises the service with the configuration + [cfg]. *) val accept : service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result s + (** [accept service t] waits for a connection on the service [t]. The result + is a {i flow} connected to the client. *) val close : service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result s + (** [close ~service t] releases the resources associated to the server [t]. *) val impl : ('cfg, 't, 'flow) service -> @@ -291,6 +322,7 @@ module type S = sig with type configuration = 'cfg and type t = 't and type flow = 'flow) + (** [impl service] is [service]'s underlying implementation. *) end end diff --git a/lib/sigs.ml b/lib/sigs.ml index cf80d20e..fa78b7d3 100644 --- a/lib/sigs.ml +++ b/lib/sigs.ml @@ -1,7 +1,3 @@ -type kind = UDP | TCP - -type description = { name : string; port : int; kind : kind } - type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] module type FUNCTOR = sig @@ -50,23 +46,71 @@ module type SCHEDULER = sig end module type FLOW = sig + (** [FLOW] is the signature for flow clients. + + A [flow] is an abstract value over which I/O functions such as {!send}, + {!recv} and {!close} can be used. + + {[ + type input = bytes and output = string + type +'a s = 'a + + let process flow = + let buf = Bytes.create 0x1000 in + match Flow.recv flow buf with + | Ok (`Input len) -> + let str = Bytes.sub_string buf 0 len in + ignore (Flow.send flow str) + | _ -> failwith "Flow.recv" + ]} + + The given flow can be more complex than a simple TCP flow for example. It + can be wrapped into a TLS layer. However, the goal is to be able to implement + a protocol without such complexity. + *) + type +'a s type flow - type error + (** {3 Input & Output.} + + Depending on the I/O model, the type for inputs and outputs can differ ; + for instance they could allow users the ability to define capabilities on + them such as {i read} or {i write} capabilities. + + However, in most of the current [Conduit] backends: + + {[ + type input = Cstruct.t + type output = Cstruct.t + ]} + *) type input and output + (** {3 Errors.} *) + + type error + (** The type for errors. *) + val pp_error : error Fmt.t + (** [pp_error] is the pretty-printer for {!error}. *) val recv : flow -> input -> (int or_end_of_flow, error) result s + (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from + the flow [flow] and copied in [input]. *) val send : flow -> output -> (int, error) result s + (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been + sent over the flow [flow]. *) val close : flow -> (unit, error) result s + (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will + return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an + [Error]. *) end module type PROTOCOL = sig From 96a93992c05bb9e94241a4cc34ec6fd025c3d3f6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 16:39:17 +0200 Subject: [PATCH 034/140] Rename connect to resolve and provide Conduit.connect as a simple call to underlying Protocol.connect --- lib/conduit.ml | 25 +++++++++++++++++++++++-- lib/conduit.mli | 8 +++++--- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index 1c844164..34a8c538 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -16,6 +16,12 @@ type _ resolver = type ('a, 'b) value = Value : 'b -> ('a, 'b) value +let reword_error f = function + | Ok x -> Ok x + | Error err -> Error (f err) + +let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt + [@@@warning "-37"] type ('a, 'b, 'c) thd = @@ -107,12 +113,14 @@ module type S = sig resolvers -> resolvers - val connect : + val resolve : resolvers -> ?protocol:('edn, 'v) protocol -> [ `host ] Domain_name.t -> (flow, [> error ]) result s + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result s + module Service : sig module type SERVICE = Sigs.SERVICE with type +'a s = 'a s @@ -170,6 +178,10 @@ module Make let ( >>| ) x f = x >>= fun x -> return (f x) + let ( >>? ) x f = x >>= function + | Ok x -> f x + | Error err -> return (Error err) + type +'a s = 'a Scheduler.t type _ witness += Witness : scheduler witness @@ -340,7 +352,7 @@ module Make let abstract : type edn v. (edn, v) protocol -> v -> flow = fun (module Witness) flow -> Witness.T (Value flow) - let connect : + let resolve : type edn v. resolvers -> ?protocol:(edn, v) protocol -> @@ -363,6 +375,15 @@ module Make | Error _err -> go r) in go l + let connect : + type edn v. + edn -> (edn, v) protocol -> (flow, [> error ]) result s = + fun edn (module Witness) -> + let (Protocol (_, (module Protocol))) = Witness.witness in + Protocol.connect edn + >>| reword_error (msgf "%a" Protocol.pp_error) + >>? fun flow -> return (Ok (Witness.T (Value flow))) + let impl : type edn flow. (edn, flow) protocol -> diff --git a/lib/conduit.mli b/lib/conduit.mli index 71d8f0b6..68cf9958 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -231,12 +231,12 @@ module type S = sig |> add Conduit_tcp_ssl.t https_resolver ~priority:20 ]} *) - val connect : + val resolve : resolvers -> ?protocol:('edn, 'v) protocol -> [ `host ] Domain_name.t -> (flow, [> error ]) result s - (** [connect resolvers domain_name] is the flow created by connecting to the + (** [resolve resolvers domain_name] is the flow created by connecting to the domain name [domain_name], using the resolvers [resolvers]. Each resolver tries to resolve the given domain-name (they are ordered by the given priority). The first which connects successfully wins. @@ -256,7 +256,7 @@ module type S = sig |> add tcp ~priority:10 resolver_on_my_private_network |> add tcp ~priority:20 resolver_on_internet - let () = Conduit.connect resolvers mirage_io >>? function + let () = Conduit.resolve resolvers mirage_io >>? function | TCP.T (Conduit.Value file_descr) as flow -> let peer = Unix.getpeername file_descr in ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) @@ -265,6 +265,8 @@ module type S = sig ]} *) + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result s + (** {2:service Server-side conduits.} *) module Service : sig From 3a16024769aa374e020f550d34969d03440dcf32 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 16:39:40 +0200 Subject: [PATCH 035/140] Fallback API update to tests --- tests/dune | 9 +++++++++ tests/ping_pong.ml | 2 +- tests/with_async.ml | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/tests/dune b/tests/dune index 93b5e7c9..e12daf9c 100644 --- a/tests/dune +++ b/tests/dune @@ -50,3 +50,12 @@ client2) (action (run %{test}))) + +(executable + (name flow) + (modules flow) + (libraries alcotest rresult conduit)) + +(rule + (alias runtest) + (action (run ./flow.exe))) \ No newline at end of file diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index db35cfaf..1967a390 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -88,7 +88,7 @@ let server : (* part *) let client ~resolvers domain_name responses = - Conduit_lwt.connect resolvers domain_name >>? fun flow -> + Conduit_lwt.resolve resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function | [] -> Conduit_lwt.close flow diff --git a/tests/with_async.ml b/tests/with_async.ml index 8ea58120..d7df7b02 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -116,7 +116,7 @@ let server : | Error err -> failwith "%a" Conduit_async.Service.pp_error err let client ~resolvers domain_name responses = - Conduit_async.connect resolvers domain_name >>? fun flow -> + Conduit_async.resolve resolvers domain_name >>? fun flow -> let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go = function | [] -> Conduit_async.close flow From 6748a1d5d78350e3e8a4bded6e8f6a1dac1b3727 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 16:39:54 +0200 Subject: [PATCH 036/140] Fallback mirage-flow tests into conduit --- tests/flow.ml | 219 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 219 insertions(+) create mode 100644 tests/flow.ml diff --git a/tests/flow.ml b/tests/flow.ml new file mode 100644 index 00000000..f3b4feaa --- /dev/null +++ b/tests/flow.ml @@ -0,0 +1,219 @@ +module Unix_scheduler = struct + type +'a t = 'a + + let bind x f = f x + let return x = x +end + +module Conduit = Conduit.Make(Unix_scheduler)(Bytes)(String) + +let recv = + let pp ppf = function + | `Input len -> Fmt.pf ppf "@[<1>(`Input@ %d)@]" len + | `End_of_flow -> Fmt.string ppf "`End_of_flow" in + let equal a b = match a, b with + | `Input a, `Input b -> a = b + | `End_of_flow, `End_of_flow -> true + | _ -> false in + Alcotest.testable pp equal + +let send = Alcotest.int + +let error = + let pp ppf = function + | #Rresult.R.msg as v -> Rresult.R.pp_msg ppf v + | `Not_found -> Fmt.string ppf "`Not_found" in + let equal a b = match a, b with + | `Msg a, `Msg b -> a = b + | `Not_found, `Not_found -> true + | _ -> false in + Alcotest.testable pp equal + +module Memory_flow0 = struct + type input = bytes and output = string + type +'a s = 'a + + type flow = + { mutable i : string + ; o : bytes + ; mutable p : int + ; mutable c : bool } + + type endpoint = (string * bytes) + type error = [ `Closed ] + + let closed_by_peer = "Closed by peer" + let pp_error ppf = function + | `Closed -> Fmt.string ppf closed_by_peer + + let connect (i, o) = Ok { i; o; p= 0; c= false; } + + let recv flow buf = + let len = min (String.length flow.i) (Bytes.length buf) in + if len = 0 then ( flow.c <- true ; Ok `End_of_flow ) + else + ( Bytes.blit_string flow.i 0 buf 0 len + ; flow.i <- String.sub flow.i len (String.length flow.i - len) + ; Ok (`Input len) ) + + let send flow str = + if flow.c then Error `Closed + else + ( let len = min (Bytes.length flow.o - flow.p) (String.length str) in + Bytes.blit_string str 0 flow.o flow.p len + ; flow.p <- flow.p + len + ; Ok len ) + + let close flow = flow.c <- true ; Ok () +end + +let memory0 = Conduit.register ~protocol:(module Memory_flow0) + +let test_input_string = + Alcotest.test_case "input string" `Quick @@ fun () -> + let open Rresult in + let flow = Conduit.connect ("Hello World!", Bytes.empty) memory0 in + Alcotest.(check bool) "connect" (R.is_ok flow) true ; + let flow = R.get_ok flow in + let buf0 = Bytes.create 12 in + let buf1 = Bytes.create 12 in + let res0 = Conduit.recv flow buf0 in + let res1 = Conduit.recv flow buf1 in + let res2 = Conduit.send flow "Hello World!" in + Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 12)) ; + Alcotest.(check string) "buf0" (Bytes.to_string buf0) "Hello World!" ; + Alcotest.(check (result recv error)) "res1" res1 (Ok `End_of_flow) ; + Alcotest.(check (result send error)) "res2" res2 (Error (`Msg Memory_flow0.closed_by_peer)) ; +;; + +let test_output_string = + Alcotest.test_case "output string" `Quick @@ fun () -> + let open Rresult in + let buf = Bytes.create 12 in + let flow = Conduit.connect ("", buf) memory0 in + Alcotest.(check bool) "connect" (R.is_ok flow) true ; + let flow = R.get_ok flow in + let res0 = Conduit.send flow "Hell" in + let res1 = Conduit.send flow "o Wo" in + let res2 = Conduit.send flow "rld!" in + let res3 = Conduit.send flow "?!?!" in + let res4 = Conduit.recv flow Bytes.empty in + Alcotest.(check (result send error)) "res0" res0 (Ok 4) ; + Alcotest.(check (result send error)) "res1" res1 (Ok 4) ; + Alcotest.(check (result send error)) "res2" res2 (Ok 4) ; + Alcotest.(check (result send error)) "res3" res3 (Ok 0) ; + Alcotest.(check (result recv error)) "res4" res4 (Ok `End_of_flow) ; + Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!" ; +;; + +module Memory_flow1 = struct + type input = bytes and output = string + type +'a s = 'a + + type flow = + { mutable i : string list + ; o : bytes list + ; mutable p : int + ; mutable c : bool } + + type endpoint = (string list * bytes list) + type error = [ `Closed ] + + let closed_by_peer = "Closed by peer" + let pp_error ppf = function + | `Closed -> Fmt.string ppf closed_by_peer + + let connect (i, o) = Ok { i; o; p= 0; c= false; } + + let rec shift n = function + | [] -> [] + | x :: r -> + if String.length x <= n + then shift (n - String.length x) r + else String.sub x n (String.length x - n) :: r + + let recv flow buf = + let max = Bytes.length buf in + let acc = ref 0 in + List.iter (fun x -> + if !acc < max + then ( let len = min (max - !acc) (String.length x) in + Bytes.blit_string x 0 buf !acc len + ; acc := !acc + len)) + flow.i ; + flow.i <- shift !acc flow.i ; + if !acc = 0 then ( flow.c <- true ; Ok `End_of_flow ) + else Ok (`Input !acc) + + let ( <.> ) f g = fun x -> f (g x) + + let send flow str = + if flow.c then Error `Closed + else + let top = String.length str in + let pos = ref flow.p in + let acc = ref 0 in + List.iter (fun x -> + if !acc < top && !pos - Bytes.length x < 0 + then ( let len = max 0 (Bytes.length x + (!pos + !acc)) in + let len = min (top - !acc) len in + Bytes.blit_string str !acc x (!pos + !acc) len + ; acc := !acc + len ) ; + pos := !pos - Bytes.length x) + flow.o ; + flow.p <- flow.p + !acc ; + if flow.p = List.fold_right (( + ) <.> Bytes.length) flow.o 0 + then flow.c <- true ; + Ok !acc + + let close flow = flow.c <- true ; Ok () +end + +let memory1 = Conduit.register ~protocol:(module Memory_flow1) + +let test_input_strings = + Alcotest.test_case "input strings" `Quick @@ fun () -> + let open Rresult in + let flow = Conduit.connect ([ ""; "123"; "45"; "6789"; "0" ], [ Bytes.empty ]) memory1 in + Alcotest.(check bool) "connect" (R.is_ok flow) true ; + let flow = R.get_ok flow in + let buf0 = Bytes.create 5 in + let buf1 = Bytes.create 5 in + let res0 = Conduit.recv flow buf0 in + let res1 = Conduit.recv flow buf1 in + let res2 = Conduit.recv flow Bytes.empty in + let res3 = Conduit.recv flow Bytes.empty in + let res4 = Conduit.send flow "" in + Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 5)) ; + Alcotest.(check (result recv error)) "res1" res1 (Ok (`Input 5)) ; + Alcotest.(check string) "buf0" (Bytes.to_string buf0) "12345" ; + Alcotest.(check string) "buf1" (Bytes.to_string buf1) "67890" ; + Alcotest.(check (result recv error)) "res2" res2 (Ok `End_of_flow) ; + Alcotest.(check (result recv error)) "res3" res3 (Ok `End_of_flow) ; + Alcotest.(check (result send error)) "res4" res4 (Error (`Msg Memory_flow1.closed_by_peer)) ; +;; + +let test_output_strings = + Alcotest.test_case "output strings" `Quick @@ fun () -> + let open Rresult in + let bufs = [ Bytes.create 4; Bytes.empty; Bytes.create 2; Bytes.create 6 ] in + let flow = Conduit.connect ([], bufs) memory1 in + Alcotest.(check bool) "connect" (R.is_ok flow) true ; + let flow = R.get_ok flow in + let res0 = Conduit.send flow "Hello" in + let res1 = Conduit.send flow " " in + let res2 = Conduit.send flow "World!" in + let res3 = Conduit.send flow "?!?!" in + Alcotest.(check (result send error)) "res0" res0 (Ok 5) ; + Alcotest.(check (result send error)) "res1" res1 (Ok 1) ; + Alcotest.(check (result send error)) "res2" res2 (Ok 6) ; + Alcotest.(check (result send error)) "res3" res3 (Error (`Msg Memory_flow1.closed_by_peer)) ; + Alcotest.(check string) "bufs" (String.concat "" (List.map Bytes.to_string bufs)) "Hello World!" ; +;; + +let () = + Alcotest.run "flow" + [ "memory", [ test_input_string + ; test_output_string + ; test_input_strings + ; test_output_strings ] ] From 9143e28802265e583b818ccee1cb48dc4e0f1d9c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 16:40:23 +0200 Subject: [PATCH 037/140] ocamlformat pass --- lib/conduit.ml | 15 ++--- tests/dune | 3 +- tests/flow.ml | 169 ++++++++++++++++++++++++++++++------------------- 3 files changed, 112 insertions(+), 75 deletions(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index 34a8c538..1e376710 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -16,9 +16,7 @@ type _ resolver = type ('a, 'b) value = Value : 'b -> ('a, 'b) value -let reword_error f = function - | Ok x -> Ok x - | Error err -> Error (f err) +let reword_error f = function Ok x -> Ok x | Error err -> Error (f err) let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt @@ -178,9 +176,8 @@ module Make let ( >>| ) x f = x >>= fun x -> return (f x) - let ( >>? ) x f = x >>= function - | Ok x -> f x - | Error err -> return (Error err) + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> return (Error err) type +'a s = 'a Scheduler.t @@ -376,12 +373,10 @@ module Make go l let connect : - type edn v. - edn -> (edn, v) protocol -> (flow, [> error ]) result s = + type edn v. edn -> (edn, v) protocol -> (flow, [> error ]) result s = fun edn (module Witness) -> let (Protocol (_, (module Protocol))) = Witness.witness in - Protocol.connect edn - >>| reword_error (msgf "%a" Protocol.pp_error) + Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) >>? fun flow -> return (Ok (Witness.T (Value flow))) let impl : diff --git a/tests/dune b/tests/dune index e12daf9c..a7955319 100644 --- a/tests/dune +++ b/tests/dune @@ -58,4 +58,5 @@ (rule (alias runtest) - (action (run ./flow.exe))) \ No newline at end of file + (action + (run ./flow.exe))) diff --git a/tests/flow.ml b/tests/flow.ml index f3b4feaa..bdb526d1 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -2,16 +2,18 @@ module Unix_scheduler = struct type +'a t = 'a let bind x f = f x + let return x = x end -module Conduit = Conduit.Make(Unix_scheduler)(Bytes)(String) +module Conduit = Conduit.Make (Unix_scheduler) (Bytes) (String) let recv = let pp ppf = function | `Input len -> Fmt.pf ppf "@[<1>(`Input@ %d)@]" len | `End_of_flow -> Fmt.string ppf "`End_of_flow" in - let equal a b = match a, b with + let equal a b = + match (a, b) with | `Input a, `Input b -> a = b | `End_of_flow, `End_of_flow -> true | _ -> false in @@ -23,48 +25,60 @@ let error = let pp ppf = function | #Rresult.R.msg as v -> Rresult.R.pp_msg ppf v | `Not_found -> Fmt.string ppf "`Not_found" in - let equal a b = match a, b with + let equal a b = + match (a, b) with | `Msg a, `Msg b -> a = b | `Not_found, `Not_found -> true | _ -> false in Alcotest.testable pp equal module Memory_flow0 = struct - type input = bytes and output = string + type input = bytes + + and output = string + type +'a s = 'a - type flow = - { mutable i : string - ; o : bytes - ; mutable p : int - ; mutable c : bool } + type flow = { + mutable i : string; + o : bytes; + mutable p : int; + mutable c : bool; + } + + type endpoint = string * bytes - type endpoint = (string * bytes) type error = [ `Closed ] let closed_by_peer = "Closed by peer" - let pp_error ppf = function - | `Closed -> Fmt.string ppf closed_by_peer - let connect (i, o) = Ok { i; o; p= 0; c= false; } + let pp_error ppf = function `Closed -> Fmt.string ppf closed_by_peer + + let connect (i, o) = Ok { i; o; p = 0; c = false } let recv flow buf = let len = min (String.length flow.i) (Bytes.length buf) in - if len = 0 then ( flow.c <- true ; Ok `End_of_flow ) - else - ( Bytes.blit_string flow.i 0 buf 0 len - ; flow.i <- String.sub flow.i len (String.length flow.i - len) - ; Ok (`Input len) ) + if len = 0 + then ( + flow.c <- true ; + Ok `End_of_flow) + else ( + Bytes.blit_string flow.i 0 buf 0 len ; + flow.i <- String.sub flow.i len (String.length flow.i - len) ; + Ok (`Input len)) let send flow str = - if flow.c then Error `Closed + if flow.c + then Error `Closed else - ( let len = min (Bytes.length flow.o - flow.p) (String.length str) in - Bytes.blit_string str 0 flow.o flow.p len - ; flow.p <- flow.p + len - ; Ok len ) + let len = min (Bytes.length flow.o - flow.p) (String.length str) in + Bytes.blit_string str 0 flow.o flow.p len ; + flow.p <- flow.p + len ; + Ok len - let close flow = flow.c <- true ; Ok () + let close flow = + flow.c <- true ; + Ok () end let memory0 = Conduit.register ~protocol:(module Memory_flow0) @@ -83,8 +97,9 @@ let test_input_string = Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 12)) ; Alcotest.(check string) "buf0" (Bytes.to_string buf0) "Hello World!" ; Alcotest.(check (result recv error)) "res1" res1 (Ok `End_of_flow) ; - Alcotest.(check (result send error)) "res2" res2 (Error (`Msg Memory_flow0.closed_by_peer)) ; -;; + Alcotest.(check (result send error)) + "res2" res2 + (Error (`Msg Memory_flow0.closed_by_peer)) let test_output_string = Alcotest.test_case "output string" `Quick @@ fun () -> @@ -103,62 +118,74 @@ let test_output_string = Alcotest.(check (result send error)) "res2" res2 (Ok 4) ; Alcotest.(check (result send error)) "res3" res3 (Ok 0) ; Alcotest.(check (result recv error)) "res4" res4 (Ok `End_of_flow) ; - Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!" ; -;; + Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!" module Memory_flow1 = struct - type input = bytes and output = string + type input = bytes + + and output = string + type +'a s = 'a - type flow = - { mutable i : string list - ; o : bytes list - ; mutable p : int - ; mutable c : bool } + type flow = { + mutable i : string list; + o : bytes list; + mutable p : int; + mutable c : bool; + } + + type endpoint = string list * bytes list - type endpoint = (string list * bytes list) type error = [ `Closed ] let closed_by_peer = "Closed by peer" - let pp_error ppf = function - | `Closed -> Fmt.string ppf closed_by_peer - let connect (i, o) = Ok { i; o; p= 0; c= false; } + let pp_error ppf = function `Closed -> Fmt.string ppf closed_by_peer + + let connect (i, o) = Ok { i; o; p = 0; c = false } let rec shift n = function | [] -> [] | x :: r -> - if String.length x <= n - then shift (n - String.length x) r - else String.sub x n (String.length x - n) :: r + if String.length x <= n + then shift (n - String.length x) r + else String.sub x n (String.length x - n) :: r let recv flow buf = let max = Bytes.length buf in let acc = ref 0 in - List.iter (fun x -> + List.iter + (fun x -> if !acc < max - then ( let len = min (max - !acc) (String.length x) in - Bytes.blit_string x 0 buf !acc len - ; acc := !acc + len)) + then ( + let len = min (max - !acc) (String.length x) in + Bytes.blit_string x 0 buf !acc len ; + acc := !acc + len)) flow.i ; flow.i <- shift !acc flow.i ; - if !acc = 0 then ( flow.c <- true ; Ok `End_of_flow ) + if !acc = 0 + then ( + flow.c <- true ; + Ok `End_of_flow) else Ok (`Input !acc) - let ( <.> ) f g = fun x -> f (g x) + let ( <.> ) f g x = f (g x) let send flow str = - if flow.c then Error `Closed + if flow.c + then Error `Closed else let top = String.length str in let pos = ref flow.p in let acc = ref 0 in - List.iter (fun x -> + List.iter + (fun x -> if !acc < top && !pos - Bytes.length x < 0 - then ( let len = max 0 (Bytes.length x + (!pos + !acc)) in - let len = min (top - !acc) len in - Bytes.blit_string str !acc x (!pos + !acc) len - ; acc := !acc + len ) ; + then ( + let len = max 0 (Bytes.length x + (!pos + !acc)) in + let len = min (top - !acc) len in + Bytes.blit_string str !acc x (!pos + !acc) len ; + acc := !acc + len) ; pos := !pos - Bytes.length x) flow.o ; flow.p <- flow.p + !acc ; @@ -166,7 +193,9 @@ module Memory_flow1 = struct then flow.c <- true ; Ok !acc - let close flow = flow.c <- true ; Ok () + let close flow = + flow.c <- true ; + Ok () end let memory1 = Conduit.register ~protocol:(module Memory_flow1) @@ -174,7 +203,9 @@ let memory1 = Conduit.register ~protocol:(module Memory_flow1) let test_input_strings = Alcotest.test_case "input strings" `Quick @@ fun () -> let open Rresult in - let flow = Conduit.connect ([ ""; "123"; "45"; "6789"; "0" ], [ Bytes.empty ]) memory1 in + let flow = + Conduit.connect ([ ""; "123"; "45"; "6789"; "0" ], [ Bytes.empty ]) memory1 + in Alcotest.(check bool) "connect" (R.is_ok flow) true ; let flow = R.get_ok flow in let buf0 = Bytes.create 5 in @@ -190,8 +221,9 @@ let test_input_strings = Alcotest.(check string) "buf1" (Bytes.to_string buf1) "67890" ; Alcotest.(check (result recv error)) "res2" res2 (Ok `End_of_flow) ; Alcotest.(check (result recv error)) "res3" res3 (Ok `End_of_flow) ; - Alcotest.(check (result send error)) "res4" res4 (Error (`Msg Memory_flow1.closed_by_peer)) ; -;; + Alcotest.(check (result send error)) + "res4" res4 + (Error (`Msg Memory_flow1.closed_by_peer)) let test_output_strings = Alcotest.test_case "output strings" `Quick @@ fun () -> @@ -207,13 +239,22 @@ let test_output_strings = Alcotest.(check (result send error)) "res0" res0 (Ok 5) ; Alcotest.(check (result send error)) "res1" res1 (Ok 1) ; Alcotest.(check (result send error)) "res2" res2 (Ok 6) ; - Alcotest.(check (result send error)) "res3" res3 (Error (`Msg Memory_flow1.closed_by_peer)) ; - Alcotest.(check string) "bufs" (String.concat "" (List.map Bytes.to_string bufs)) "Hello World!" ; -;; + Alcotest.(check (result send error)) + "res3" res3 + (Error (`Msg Memory_flow1.closed_by_peer)) ; + Alcotest.(check string) + "bufs" + (String.concat "" (List.map Bytes.to_string bufs)) + "Hello World!" let () = Alcotest.run "flow" - [ "memory", [ test_input_string - ; test_output_string - ; test_input_strings - ; test_output_strings ] ] + [ + ( "memory", + [ + test_input_string; + test_output_string; + test_input_strings; + test_output_strings; + ] ); + ] From 94b2b97d8c9b5b1c8eb45c4134f5e154da82de72 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 17:14:24 +0200 Subject: [PATCH 038/140] Add tests about resolvers --- lib/conduit.ml | 18 ++++- lib/conduit.mli | 2 + tests/dune | 10 +++ tests/resolvers.ml | 166 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 193 insertions(+), 3 deletions(-) create mode 100644 tests/resolvers.ml diff --git a/lib/conduit.ml b/lib/conduit.ml index 1e376710..f892ed80 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -8,7 +8,7 @@ type _ witness = .. type _ resolver = | Resolver : { - priority : int; + priority : int option; resolve : [ `host ] Domain_name.t -> ('edn option, 's) Sigs.app; witness : 's witness; } @@ -104,6 +104,8 @@ module type S = sig type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + val empty : resolvers + val add : ('edn, 'flow) protocol -> ?priority:int -> @@ -265,6 +267,8 @@ module Make let ( <.> ) f g x = f (g x) + let empty = empty + let add : type edn flow. (edn, flow) protocol -> @@ -272,7 +276,7 @@ module Make edn resolver -> resolvers -> resolvers = - fun (module Witness) ?(priority = 0) resolve -> + fun (module Witness) ?priority resolve -> let (Protocol (key, _)) = Witness.witness in let resolve = inj <.> resolve in Map.add key (Resolver { priority; resolve; witness }) @@ -318,6 +322,10 @@ module Make | Witness -> Some Refl.Refl | _ -> None + let inf = -1 + + and sup = 1 + let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = fun m domain_name -> let rec go acc = function @@ -331,7 +339,11 @@ module Make | None -> go acc r) in let compare (Map.Value (_, Resolver { priority = pa; _ })) (Map.Value (_, Resolver { priority = pb; _ })) = - (Stdlib.compare : int -> int -> int) pa pb in + match (pa, pb) with + | Some a, Some b -> (Stdlib.compare : int -> int -> int) a b + | None, Some _ -> sup + | Some _, None -> inf + | None, None -> 0 in go [] (List.sort compare (Map.bindings m)) let create : diff --git a/lib/conduit.mli b/lib/conduit.mli index 68cf9958..c6b8d992 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -207,6 +207,8 @@ module type S = sig ]} *) + val empty : resolvers + val add : ('edn, _) protocol -> ?priority:int -> diff --git a/tests/dune b/tests/dune index a7955319..8712367e 100644 --- a/tests/dune +++ b/tests/dune @@ -60,3 +60,13 @@ (alias runtest) (action (run ./flow.exe))) + +(executable + (name resolvers) + (modules resolvers) + (libraries alcotest rresult conduit)) + +(rule + (alias runtest) + (action + (run ./resolvers.exe))) diff --git a/tests/resolvers.ml b/tests/resolvers.ml new file mode 100644 index 00000000..5286891d --- /dev/null +++ b/tests/resolvers.ml @@ -0,0 +1,166 @@ +module Unix_scheduler = struct + type +'a t = 'a + + let bind x f = f x + + let return x = x +end + +module Conduit = Conduit.Make (Unix_scheduler) (Bytes) (String) + +module Dummy (Edn : sig + type t +end) = +struct + type input = bytes + + and output = string + + type +'a s = 'a + + type endpoint = Edn.t + + type flow = unit + + type error = | + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let connect _ = Ok () + + let recv _ _ = Ok `End_of_flow + + let send _ _ = Ok 0 + + let close _ = Ok () +end + +module Dummy_int = Dummy (struct + type t = int +end) + +module Dummy_string = Dummy (struct + type t = string +end) + +module Dummy_unit = Dummy (struct + type t = unit +end) + +let dummy_int = Conduit.register ~protocol:(module Dummy_int) + +let dummy_string = Conduit.register ~protocol:(module Dummy_string) + +let dummy_unit = Conduit.register ~protocol:(module Dummy_unit) + +let ( <.> ) f g x = f (g x) + +let localhost = Domain_name.(host_exn <.> of_string_exn) "localhost" + +let all_resolvers = + Alcotest.test_case "all resolvers" `Quick @@ fun () -> + let int_called = ref true in + let int _ = Some 0 in + + let string_called = ref true in + let string _ = Some "Hello World!" in + + let unit_called = ref true in + let unit _ = Some () in + + let resolvers = + Conduit.empty + |> Conduit.add dummy_int int + |> Conduit.add dummy_string string + |> Conduit.add dummy_unit unit in + let _ = Conduit.resolve resolvers localhost in + Alcotest.(check bool) "call int" !int_called true ; + Alcotest.(check bool) "call string" !string_called true ; + Alcotest.(check bool) "call unit" !unit_called true + +let priorities = + Alcotest.test_case "priorities" `Quick @@ fun () -> + let count = ref 0 in + + let int_called = ref None in + let int _ = + int_called := Some !count ; + incr count ; + Some 0 in + + let string_called = ref None in + let string _ = + string_called := Some !count ; + incr count ; + Some "Hello World!" in + + let unit_called = ref None in + let unit _ = + unit_called := Some !count ; + incr count ; + Some () in + + let resolvers = + Conduit.empty + |> Conduit.add ~priority:0 dummy_int int + |> Conduit.add ~priority:10 dummy_string string + |> Conduit.add dummy_unit unit in + let _ = Conduit.resolve resolvers localhost in + Alcotest.(check (option int)) "call int" !int_called (Some 0) ; + Alcotest.(check (option int)) "call string" !string_called (Some 1) ; + Alcotest.(check (option int)) "call unit" !unit_called (Some 2) ; + + int_called := None ; + string_called := None ; + unit_called := None ; + count := 0 ; + + let resolvers = + Conduit.empty + |> Conduit.add dummy_int int + |> Conduit.add ~priority:0 dummy_string string + |> Conduit.add dummy_unit unit in + let _ = Conduit.resolve resolvers localhost in + Alcotest.(check (option int)) "call int" !int_called (Some 2) ; + Alcotest.(check (option int)) "call string" !string_called (Some 0) ; + Alcotest.(check (option int)) "call unit" !unit_called (Some 1) ; + + int_called := None ; + string_called := None ; + unit_called := None ; + count := 0 ; + + let resolvers = + Conduit.empty + |> Conduit.add dummy_int int + |> Conduit.add dummy_string string + |> Conduit.add dummy_unit unit in + let _ = Conduit.resolve resolvers localhost in + Alcotest.(check (option int)) "call int" !int_called (Some 2) ; + Alcotest.(check (option int)) "call string" !string_called (Some 1) ; + Alcotest.(check (option int)) "call unit" !unit_called (Some 0) + +let only_one = + Alcotest.test_case "only one" `Quick @@ fun () -> + let int_called = ref true in + let int _ = Some 0 in + + let string_called = ref true in + let string _ = Some "Hello World!" in + + let unit_called = ref true in + let unit _ = Some () in + + let resolvers = + Conduit.empty + |> Conduit.add dummy_int int + |> Conduit.add dummy_string string + |> Conduit.add dummy_unit unit in + let _ = Conduit.resolve resolvers ~protocol:dummy_string localhost in + Alcotest.(check bool) "call int" !int_called true ; + Alcotest.(check bool) "call string" !string_called true ; + Alcotest.(check bool) "call unit" !unit_called true + +let () = + Alcotest.run "resolvers" + [ ("resolve", [ all_resolvers; priorities; only_one ]) ] From 5843ee9bd0bf84d57e278c63162ec65ca344691f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 9 Jun 2020 17:15:50 +0200 Subject: [PATCH 039/140] Add alcotest as a dependency to test core library --- conduit.opam | 1 + tests/dune | 2 ++ 2 files changed, 3 insertions(+) diff --git a/conduit.opam b/conduit.opam index 48f683b7..ec0b1703 100644 --- a/conduit.opam +++ b/conduit.opam @@ -46,4 +46,5 @@ depends: [ "dune" "domain-name" "stdlib-shims" + "alcotest" {with-test} ] diff --git a/tests/dune b/tests/dune index 8712367e..9e7eb6fd 100644 --- a/tests/dune +++ b/tests/dune @@ -58,6 +58,7 @@ (rule (alias runtest) + (package conduit) (action (run ./flow.exe))) @@ -68,5 +69,6 @@ (rule (alias runtest) + (package conduit) (action (run ./resolvers.exe))) From 44a3ce5caf7b4da56b9f84bcceb7516e53de1235 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 16 Jun 2020 13:50:30 +0200 Subject: [PATCH 040/140] Functorize tests over LWT and ASYNC --- tests/common.ml | 137 +++++++++++++++++++++++++++++++++++++++ tests/dune | 15 +++-- tests/ping_pong.ml | 112 ++------------------------------ tests/with_async.ml | 152 +++++++------------------------------------- 4 files changed, 175 insertions(+), 241 deletions(-) create mode 100644 tests/common.ml diff --git a/tests/common.ml b/tests/common.ml new file mode 100644 index 00000000..bdb56257 --- /dev/null +++ b/tests/common.ml @@ -0,0 +1,137 @@ +module type S = sig + include Conduit.S + + type 'a condition + + val serve_with_handler : + handler:('flow -> unit s) -> + service:('cfg, 'master, 'flow) Service.service -> + 'cfg -> + unit condition * unit s +end + +module type CONDITION = sig + type 'a t +end + +let ( <.> ) f g x = f (g x) + +module Make + (Scheduler : Conduit.Sigs.SCHEDULER) + (Condition : CONDITION) + (Conduit : S + with type +'a s = 'a Scheduler.t + and type 'a condition = 'a Condition.t + and type input = Cstruct.t + and type output = Cstruct.t) = +struct + let return = Scheduler.return + + let ( >>= ) = Scheduler.bind + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> Scheduler.return (Error err) + + let localhost = Domain_name.(host_exn <.> of_string_exn) "localhost" + + (* Server part *) + + let getline queue = + let exists ~predicate queue = + let pos = ref 0 and res = ref (-1) in + Ke.Rke.iter + (fun chr -> + if predicate chr then res := !pos ; + incr pos) + queue ; + if !res = -1 then None else Some !res in + let blit src src_off dst dst_off len = + Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in + match exists ~predicate:(( = ) '\n') queue with + | Some pos -> + let tmp = Bytes.create pos in + Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; + Ke.Rke.N.shift_exn queue (pos + 1) ; + Some (Bytes.unsafe_to_string tmp) + | None -> None + + let getline queue flow = + let tmp = Cstruct.create 0x1000 in + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len in + let rec go () = + match getline queue with + | Some line -> Scheduler.return (Ok (`Line line)) + | None -> ( + Conduit.recv flow tmp >>? function + | `End_of_flow -> Scheduler.return (Ok `Close) + | `Input len -> + Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; + go ()) in + go () + + let pong = Cstruct.of_string "pong\n" + + let ping = Cstruct.of_string "ping\n" + + let transmission flow = + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let rec go () = + getline queue flow >>= function + | Ok `Close | Error _ -> Conduit.close flow + | Ok (`Line "ping") -> + Fmt.epr "[!] received ping.\n%!" ; + Conduit.send flow pong >>? fun _ -> go () + | Ok (`Line "pong") -> + Fmt.epr "[!] received pong.\n%!" ; + Conduit.send flow ping >>? fun _ -> go () + | Ok (`Line line) -> + Fmt.epr "[!] received %S.\n%!" line ; + Conduit.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit.close flow in + go () >>= function + | Error err -> Fmt.failwith "%a" Conduit.pp_error err + | Ok () -> return () + + let server : + type cfg master flow. + cfg -> + protocol:(_, flow) Conduit.protocol -> + service:(cfg, master, flow) Conduit.Service.service -> + unit Condition.t * unit Scheduler.t = + fun cfg ~protocol ~service -> + Conduit.serve_with_handler + ~handler:(fun flow -> transmission (Conduit.abstract protocol flow)) + ~service cfg + + (* part *) + + let client ~resolvers domain_name responses = + Conduit.resolve resolvers domain_name >>? fun flow -> + let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let rec go = function + | [] -> Conduit.close flow + | line :: rest -> ( + Conduit.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + getline queue flow >>? function + | `Close -> Conduit.close flow + | `Line "pong" -> go rest + | `Line _ -> Conduit.close flow) in + go responses + + let client ~resolvers filename = + let rec go acc ic = + match input_line ic with + | line -> go (line :: acc) ic + | exception End_of_file -> List.rev acc in + let ic = open_in filename in + let responses = go [] ic in + close_in ic ; + client ~resolvers localhost responses >>= function + | Ok () -> Scheduler.return () + | Error `Closed_by_peer -> Scheduler.return () + | Error (#Conduit.error as err) -> + Fmt.epr "client: %a.\n%!" Conduit.pp_error err ; + Scheduler.return () +end diff --git a/tests/dune b/tests/dune index 9e7eb6fd..05a0413d 100644 --- a/tests/dune +++ b/tests/dune @@ -1,16 +1,19 @@ +(library + (name common) + (modules common) + (libraries bigarray cstruct stdlib-shims bigstringaf ke fmt rresult conduit)) + (executable (name ping_pong) (modules ping_pong) - (libraries bigstringaf ke fmt rresult fmt.tty logs.fmt - mirage-crypto-rng.unix conduit-lwt-unix.tcp conduit-lwt-unix.tls - conduit-lwt-unix.ssl)) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix + conduit-lwt-unix.tcp conduit-lwt-unix.tls conduit-lwt-unix.ssl)) (executable (name with_async) (modules with_async) - (libraries stdlib-shims bigstringaf ke fmt rresult fmt.tty logs.fmt - mirage-crypto-rng.unix conduit-async.tcp conduit-async.tls - conduit-async.ssl)) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async.tcp + conduit-async.tls conduit-async.ssl)) (executable (name test_lwt) diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 1967a390..8928ce9b 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -1,5 +1,4 @@ open Rresult -open Lwt.Infix let () = Mirage_crypto_rng_unix.initialize () @@ -7,113 +6,14 @@ let () = Printexc.record_backtrace true let () = Ssl.init () -let ( >>? ) x f = - x >>= function Ok x -> f x | Error _ as err -> Lwt.return err - let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt -let localhost = Domain_name.(host_exn (of_string_exn "localhost")) - -(* Server part *) - -let getline queue = - let exists ~predicate queue = - let pos = ref 0 and res = ref (-1) in - Ke.Rke.iter - (fun chr -> - if predicate chr then res := !pos ; - incr pos) - queue ; - if !res = -1 then None else Some !res in - let blit src src_off dst dst_off len = - Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in - match exists ~predicate:(( = ) '\n') queue with - | Some pos -> - let tmp = Bytes.create pos in - Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; - Ke.Rke.N.shift_exn queue (pos + 1) ; - Some (Bytes.unsafe_to_string tmp) - | None -> None - -let getline queue flow = - let tmp = Cstruct.create 0x1000 in - let blit src src_off dst dst_off len = - let src = Cstruct.to_bigarray src in - Bigstringaf.blit src ~src_off dst ~dst_off ~len in - let rec go () = - match getline queue with - | Some line -> Lwt.return_ok (`Line line) - | None -> ( - Conduit_lwt_unix.recv flow tmp >>? function - | `End_of_flow -> Lwt.return_ok `Close - | `Input len -> - Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; - go ()) in - go () - -let pong = Cstruct.of_string "pong\n" - -let ping = Cstruct.of_string "ping\n" - -let transmission flow = - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in - let rec go () = - getline queue flow >>= function - | Ok `Close | Error _ -> Conduit_lwt.close flow - | Ok (`Line "ping") -> - Fmt.epr "[!] received ping.\n%!" ; - Conduit_lwt.send flow pong >>? fun _ -> go () - | Ok (`Line "pong") -> - Fmt.epr "[!] received pong.\n%!" ; - Conduit_lwt.send flow ping >>? fun _ -> go () - | Ok (`Line line) -> - Fmt.epr "[!] received %S.\n%!" line ; - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - Conduit_lwt.close flow in - go () >>= function - | Error err -> failwith "%a" Conduit_lwt.pp_error err - | Ok () -> Lwt.return () - -let server : - type cfg master flow. - cfg -> - protocol:(_, flow) Conduit_lwt.protocol -> - service:(cfg, master, flow) Conduit_lwt.Service.service -> - unit Lwt_condition.t * unit Lwt.t = - fun cfg ~protocol ~service -> - Conduit_lwt_unix.serve_with_handler - ~handler:(fun flow -> transmission (Conduit_lwt.abstract protocol flow)) - ~service cfg - -(* part *) - -let client ~resolvers domain_name responses = - Conduit_lwt.resolve resolvers domain_name >>? fun flow -> - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in - let rec go = function - | [] -> Conduit_lwt.close flow - | line :: rest -> ( - Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - getline queue flow >>? function - | `Close -> Conduit_lwt.close flow - | `Line "pong" -> go rest - | `Line _ -> Conduit_lwt.close flow) in - go responses - -let client ~resolvers filename = - let rec go acc ic = - match input_line ic with - | line -> go (line :: acc) ic - | exception End_of_file -> List.rev acc in - let ic = open_in filename in - let responses = go [] ic in - close_in ic ; - client ~resolvers localhost responses >>= function - | Ok () -> Lwt.return_unit - | Error `Closed_by_peer -> Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Fmt.epr "client: %a.\n%!" Conduit_lwt.pp_error err ; - Lwt.return_unit +include Common.Make (Lwt) (Lwt_condition) + (struct + type 'a condition = 'a Lwt_condition.t + + include Conduit_lwt + end) (* Composition *) diff --git a/tests/with_async.ml b/tests/with_async.ml index d7df7b02..f46dbd27 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -4,6 +4,21 @@ open Async_ssl let () = Mirage_crypto_rng_unix.initialize () +include Common.Make + (struct + type +'a t = 'a Async.Deferred.t + + let bind x f = Async.Deferred.bind x ~f + + let return = Async.Deferred.return + end) + (Async.Condition) + (struct + type 'a condition = 'a Async.Condition.t + + include Conduit_async + end) + let tcp_protocol, tcp_service = let open Conduit_async_tcp in (protocol, service) @@ -16,131 +31,8 @@ let tls_protocol, tls_service = let open Conduit_async_tls.TCP in (protocol, service) -let ( >>? ) x f = - x >>= function Ok x -> f x | Error _ as err -> Async.return err - let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt -let getline queue = - let exists ~predicate queue = - let pos = ref 0 and res = ref (-1) in - Ke.Rke.iter - (fun chr -> - if predicate chr then res := !pos ; - incr pos) - queue ; - if !res = -1 then None else Some !res in - let blit src src_off dst dst_off len = - Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in - match exists ~predicate:(( = ) '\n') queue with - | Some pos -> - let tmp = Bytes.create pos in - Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; - Ke.Rke.N.shift_exn queue (pos + 1) ; - Some (Bytes.unsafe_to_string tmp) - | None -> None - -let getline queue flow = - let tmp = Cstruct.create 0x1000 in - let blit src src_off dst dst_off len = - let src = Cstruct.to_bigarray src in - Bigstringaf.blit src ~src_off dst ~dst_off ~len in - let rec go () = - match getline queue with - | Some line -> Async.return (Ok (`Line line)) - | None -> ( - Conduit_async.recv flow tmp >>? function - | `End_of_flow -> Async.return (Ok `Close) - | `Input len -> - Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; - go ()) in - go () - -let pong = Cstruct.of_string "pong\n" - -let ping = Cstruct.of_string "ping\n" - -let transmission ~stop flow = - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.Char in - let rec go () = - let finish = Condition.wait stop >>= fun () -> Async.return (Ok `Done) in - let getline = getline queue flow in - Async.Deferred.any [ finish; getline ] >>= function - | Ok (`Done | `Close) | Error _ -> Conduit_async.close flow - | Ok (`Line "ping") -> - Format.eprintf "[!] received ping.\n%!" ; - Conduit_async.send flow pong >>? fun _ -> go () - | Ok (`Line "pong") -> - Format.eprintf "[!] received pong.\n%!" ; - Conduit_async.send flow ping >>? fun _ -> go () - | Ok (`Line line) -> - Format.eprintf "[!] received %S.\n%!" line ; - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - Conduit_async.close flow in - go () >>= function - | Error err -> failwith "%a" Conduit_async.pp_error err - | Ok () -> Async.return () - -let server : - type cfg master flow. - launched:unit Async.Condition.t -> - stop:unit Async.Condition.t -> - cfg -> - protocol:(_, flow) Conduit_async.protocol -> - service:(cfg, master, flow) Conduit_async.Service.service -> - unit Async.Deferred.t = - fun ~launched ~stop cfg ~protocol ~service -> - let module Server = (val Conduit_async.Service.impl service) in - let main () = - let reword_error = R.reword_error (R.msgf "%a" Server.pp_error) in - Conduit_async.Service.serve cfg ~service >>? fun master -> - Condition.signal launched () ; - - let rec go () = - let close = Async.Condition.wait stop >>| fun () -> Ok `Closed in - let accept = - Server.accept master >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in - - Async.Deferred.any [ close; accept ] >>= function - | Ok (`Flow flow) -> - Async.don't_wait_for - (transmission ~stop (Conduit_async.abstract protocol flow)) ; - Async.Scheduler.yield () >>= go - | Ok `Closed -> Server.close master - | Error _ as err -> Server.close master >>= fun _ -> Async.return err - in - go () >>| reword_error in - main () >>= function - | Ok () -> Async.return () - | Error err -> failwith "%a" Conduit_async.Service.pp_error err - -let client ~resolvers domain_name responses = - Conduit_async.resolve resolvers domain_name >>? fun flow -> - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in - let rec go = function - | [] -> Conduit_async.close flow - | line :: rest -> ( - Conduit_async.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> - getline queue flow >>? function - | `Close -> Conduit_async.close flow - | `Line "pong" -> go rest - | `Line _ -> Conduit_async.close flow) in - go responses - -let client ~resolvers domain_name filename = - let rec go acc ic = - match Stdlib.input_line ic with - | line -> go (line :: acc) ic - | exception End_of_file -> List.rev acc in - let ic = Stdlib.open_in filename in - let responses = go [] ic in - Stdlib.close_in ic ; - client ~resolvers domain_name responses >>= function - | Ok () -> Async.return () - | Error (#Conduit_async.error as err) -> - failwith "got an error: %a" Conduit_async.pp_error err - let resolve_ping_pong = Conduit_async_tcp.resolv_conf ~port:5000 let resolve_ssl_ping_pong = @@ -170,17 +62,19 @@ let run_with : string list -> unit = fun cfg ~protocol ~service clients -> - let launched = Condition.create () in - let stop = Condition.create () in - let server () = server ~launched ~stop cfg ~protocol ~service in + let stop, server = server (* ~launched ~stop *) cfg ~protocol ~service in let clients = - Condition.wait launched >>= fun () -> - let clients = List.map (client ~resolvers localhost) clients in + Async.after Core.Time.Span.(of_sec 0.5) >>= fun () -> + (* XXX(dinosaure): [async] tries to go further and fibers + * can be launched before the initialization of the server. + * We waiting a bit to ensure that the server is launched + * before clients. *) + let clients = List.map (client ~resolvers) clients in Async.Deferred.all_unit clients >>= fun () -> Condition.broadcast stop () ; Async.return () in Async.don't_wait_for - (Async.Deferred.all_unit [ server (); clients ] >>| fun () -> shutdown 0) ; + (Async.Deferred.all_unit [ server; clients ] >>| fun () -> shutdown 0) ; Core.never_returns (Scheduler.go ()) let run_with_tcp clients = From 775cbf58cad437920083e71981eba3084764bdb0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sat, 20 Jun 2020 13:54:59 +0200 Subject: [PATCH 041/140] Delete conduit-lwt-unix and provide conduit-lwt-{ssl,tls} with lwt.unix --- async/conduit_async.mli | 27 +++++ conduit-lwt-ssl.opam | 28 +++++ conduit-lwt-unix.opam => conduit-lwt-tls.opam | 2 - conduit-lwt.opam | 6 +- lib/conduit.mli | 1 + lwt-unix/conduit_lwt_unix.ml | 34 ------ lwt-unix/conduit_lwt_unix.mli | 21 ---- lwt-unix/conduit_lwt_unix_tcp.mli | 77 ------------- lwt-unix/dune | 23 ---- lwt/conduit_lwt.ml | 62 +---------- lwt/conduit_lwt.mli | 105 +++++++++++++++--- .../conduit_lwt_ssl.ml | 31 +++--- .../conduit_lwt_ssl.mli | 4 +- .../conduit_lwt_tls.ml | 2 +- .../conduit_lwt_tls.mli | 4 +- lwt/dune | 16 ++- lwt/internal.ml | 60 ++++++++++ .../conduit_lwt_unix_tcp.ml => lwt/tCP.ml | 6 +- mirage/conduit_mirage.ml | 62 ++++++++++- mirage/conduit_mirage.mli | 5 - mirage/conduit_mirage_flow.ml | 1 - mirage/conduit_mirage_flow.mli | 18 --- mirage/conduit_mirage_tls.ml | 1 - mirage/conduit_mirage_tls.mli | 21 ---- mirage/dune | 14 +-- tests/dune | 6 +- tests/ping_pong.ml | 25 ++--- 27 files changed, 322 insertions(+), 340 deletions(-) create mode 100644 conduit-lwt-ssl.opam rename conduit-lwt-unix.opam => conduit-lwt-tls.opam (96%) delete mode 100644 lwt-unix/conduit_lwt_unix.ml delete mode 100644 lwt-unix/conduit_lwt_unix.mli delete mode 100644 lwt-unix/conduit_lwt_unix_tcp.mli delete mode 100644 lwt-unix/dune rename lwt-unix/conduit_lwt_unix_ssl.ml => lwt/conduit_lwt_ssl.ml (81%) rename lwt-unix/conduit_lwt_unix_ssl.mli => lwt/conduit_lwt_ssl.mli (98%) rename lwt-unix/conduit_lwt_unix_tls.ml => lwt/conduit_lwt_tls.ml (93%) rename lwt-unix/conduit_lwt_unix_tls.mli => lwt/conduit_lwt_tls.mli (96%) create mode 100644 lwt/internal.ml rename lwt-unix/conduit_lwt_unix_tcp.ml => lwt/tCP.ml (98%) delete mode 100644 mirage/conduit_mirage_flow.ml delete mode 100644 mirage/conduit_mirage_flow.mli delete mode 100644 mirage/conduit_mirage_tls.ml delete mode 100644 mirage/conduit_mirage_tls.mli diff --git a/async/conduit_async.mli b/async/conduit_async.mli index dd6b6896..d4a49006 100644 --- a/async/conduit_async.mli +++ b/async/conduit_async.mli @@ -17,3 +17,30 @@ val serve_with_handler : val reader_and_writer_of_flow : flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t + +module TCP : sig + type endpoint = + | Inet of Socket.Address.Inet.t + | Unix of Socket.Address.Unix.t + + module Protocol : sig + include PROTOCOL with type endpoint = endpoint + + val address : flow -> Socket.Address.t + + val reader : flow -> Reader.t + + val writer : flow -> Writer.t + end + + val protocol : (Protocol.endpoint, Protocol.flow) protocol + + type configuration = + | Listen : ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration + + module Server : Service.SERVICE with type configuration = configuration + + val service : (configuration, Server.t, Protocol.flow) Service.service + + val resolv_conf : port:int -> endpoint resolver +end diff --git a/conduit-lwt-ssl.opam b/conduit-lwt-ssl.opam new file mode 100644 index 00000000..618bef10 --- /dev/null +++ b/conduit-lwt-ssl.opam @@ -0,0 +1,28 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors:[ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" + "Romain Calascibetta" +] +license: "ISC" +tags: "org:mirage" +homepage: "https://github.com/mirage/ocaml-conduit" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A portable network connection establishment library using Lwt" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "conduit-lwt" + "lwt_ssl" +] diff --git a/conduit-lwt-unix.opam b/conduit-lwt-tls.opam similarity index 96% rename from conduit-lwt-unix.opam rename to conduit-lwt-tls.opam index 7ab21e4a..7566c892 100644 --- a/conduit-lwt-unix.opam +++ b/conduit-lwt-tls.opam @@ -24,7 +24,5 @@ depends: [ "ocaml" {>= "4.07.0"} "dune" "conduit-lwt" - "base-unix" - "lwt_ssl" "conduit-tls" ] diff --git a/conduit-lwt.opam b/conduit-lwt.opam index b0066339..574ec5bb 100644 --- a/conduit-lwt.opam +++ b/conduit-lwt.opam @@ -1,6 +1,6 @@ opam-version: "2.0" maintainer: "anil@recoil.org" -authors: [ +authors:[ "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" @@ -17,13 +17,13 @@ synopsis: "A portable network connection establishment library using Lwt" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} ] depends: [ "ocaml" {>= "4.07.0"} "dune" "conduit" - "cstruct" "lwt" - "mirage-flow" + "base-unix" ] diff --git a/lib/conduit.mli b/lib/conduit.mli index c6b8d992..b5b601ea 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -125,6 +125,7 @@ module type S = sig val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol end = struct let t = register ~protocol:(module TLS) + end ]} As a protocol implementer, you must {i register} your implementation and diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml deleted file mode 100644 index c4bb2264..00000000 --- a/lwt-unix/conduit_lwt_unix.ml +++ /dev/null @@ -1,34 +0,0 @@ -include Conduit_lwt - -let failf fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt - -let io_of_flow flow = - let open Lwt.Infix in - let ic_closed = ref false and oc_closed = ref false in - let close () = - if !ic_closed && !oc_closed - then - close flow >>= function - | Ok () -> Lwt.return_unit - | Error err -> failf "%a" pp_error err - else Lwt.return_unit in - let ic_close () = - ic_closed := true ; - close () in - let oc_close () = - oc_closed := true ; - close () in - let recv buf off len = - let raw = Cstruct.of_bigarray buf ~off ~len in - recv flow raw >>= function - | Ok (`Input len) -> Lwt.return len - | Ok `End_of_flow -> Lwt.return 0 - | Error err -> failf "%a" pp_error err in - let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in - let send buf off len = - let raw = Cstruct.of_bigarray buf ~off ~len in - send flow raw >>= function - | Ok len -> Lwt.return len - | Error err -> failf "%a" pp_error err in - let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in - (ic, oc) diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli deleted file mode 100644 index 78ca7acd..00000000 --- a/lwt-unix/conduit_lwt_unix.mli +++ /dev/null @@ -1,21 +0,0 @@ -module Lwt_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t - -include - Conduit.S - with type input = Cstruct.t - and type output = Cstruct.t - and type +'a s = 'a Lwt.t - and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) protocol = ('edn, 'flow) Conduit_lwt.protocol - and type ('cfg, 't, 'flow) Service.service = - ('cfg, 't, 'flow) Conduit_lwt.Service.service - and type flow = Conduit_lwt.flow - -val serve_with_handler : - handler:('flow -> unit Lwt.t) -> - service:('cfg, 'master, 'flow) Service.service -> - 'cfg -> - unit Lwt_condition.t * unit Lwt.t - -val io_of_flow : - flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel diff --git a/lwt-unix/conduit_lwt_unix_tcp.mli b/lwt-unix/conduit_lwt_unix_tcp.mli deleted file mode 100644 index 81626f16..00000000 --- a/lwt-unix/conduit_lwt_unix_tcp.mli +++ /dev/null @@ -1,77 +0,0 @@ -(** Implementation of TCP protocol using [Lwt_unix]. *) - -(** Implementation of TCP protocol as a client. - - Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. - This is a description of what they currently do. - - {b NOTE}: [recv] wants to fill the given buffer as much as possible until it - has reached {i end-of-input}. In other words, [recv] can do a multiple call - to [Lwt_unix.recv] to fill the given buffer. - - {b NOTE}: [send] tries to send as much as it can the given buffer. However, - if internal call of [Lwt_unix.send] returns something smaller than what we - requested, we stop the process and return how many byte(s) we sended. In - other word, [send] can do a multiple call to [Lwt_unix.send] until we fully - sended what we wanted. *) - -open Conduit_lwt_unix - -module Protocol : sig - include - PROTOCOL - with type endpoint = Lwt_unix.sockaddr - and type error = - [ `Closed_by_peer - | `Operation_not_permitted - | `Address_already_in_use of Unix.sockaddr - | `Cannot_assign_requested_address of Unix.sockaddr - | `Address_family_not_supported_by_protocol of Unix.sockaddr - | `Operation_already_in_progress - | `Bad_address - | `Network_is_unreachable - | `Connection_timed_out - | `Connection_refused - | `Transport_endpoint_is_not_connected ] - - val file_descr : flow -> Lwt_unix.file_descr - (** [file_descr] returns the underlying [Lwt_unix.file_descr] used to - communicate over TCP. *) - - val peer : flow -> Unix.sockaddr - (** [peer flow] retunrs the address of the peer connected to the given [flow]. *) - - val sock : flow -> Unix.sockaddr - (** [sock flow] returns the current addres to which the socket is bound. *) -end - -type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } - -module Server : - Service.SERVICE - with type configuration = configuration - and type t = Lwt_unix.file_descr - and type flow = Protocol.flow - and type error = - [ `Address_is_protected of Unix.sockaddr - | `Operation_not_permitted of Unix.sockaddr - | `Address_already_in_use of Unix.sockaddr - | `Address_is_not_valid of Unix.sockaddr - | `Cannot_assign_requested_address of Unix.sockaddr - | `Bad_address - | `Too_many_symbolic_links of Unix.sockaddr - | `Name_too_long of Unix.sockaddr - | `Operation_not_supported - | `Limit_reached - | `Protocol_error - | `Firewall_rules_forbid_connection ] - -val protocol : (Lwt_unix.sockaddr, Protocol.flow) protocol - -type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value - -type Conduit_lwt.flow += T of t - -val service : (configuration, Server.t, Protocol.flow) Service.service - -val resolv_conf : port:int -> Lwt_unix.sockaddr resolver diff --git a/lwt-unix/dune b/lwt-unix/dune deleted file mode 100644 index 11984328..00000000 --- a/lwt-unix/dune +++ /dev/null @@ -1,23 +0,0 @@ -(library - (name conduit_lwt_unix) - (public_name conduit-lwt-unix) - (modules conduit_lwt_unix) - (libraries conduit-lwt lwt.unix)) - -(library - (name conduit_lwt_unix_tcp) - (public_name conduit-lwt-unix.tcp) - (modules conduit_lwt_unix_tcp) - (libraries conduit-lwt-unix)) - -(library - (name conduit_lwt_unix_tls) - (public_name conduit-lwt-unix.tls) - (modules conduit_lwt_unix_tls) - (libraries conduit-lwt-unix conduit-lwt-unix.tcp conduit-tls)) - -(library - (name conduit_lwt_unix_ssl) - (public_name conduit-lwt-unix.ssl) - (modules conduit_lwt_unix_ssl) - (libraries conduit-lwt-unix conduit-lwt-unix.tcp lwt_ssl)) diff --git a/lwt/conduit_lwt.ml b/lwt/conduit_lwt.ml index 9b023570..4d947097 100644 --- a/lwt/conduit_lwt.ml +++ b/lwt/conduit_lwt.ml @@ -1,60 +1,2 @@ -module Lwt_scheduler = struct - type +'a t = 'a Lwt.t - - let bind x f = Lwt.bind x f - - let return x = Lwt.return x -end - -include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) - -let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt - -let ( >>? ) = Lwt_result.bind - -let serve_with_handler : - type cfg master flow. - handler:(flow -> unit Lwt.t) -> - service:(cfg, master, flow) Service.service -> - cfg -> - unit Lwt_condition.t * unit Lwt.t = - fun ~handler ~service cfg -> - let open Lwt.Infix in - let stop = Lwt_condition.create () in - let module Svc = (val Service.impl service) in - let main = - Service.serve cfg ~service >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( - let rec loop () = - let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in - let accept = - Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in - - Lwt.pick [ stop; accept ] >>= function - | Ok (`Flow flow) -> - Lwt.async (fun () -> handler flow) ; - Lwt.pause () >>= loop - | Ok `Stop -> Svc.close master - | Error err0 -> ( - Svc.close master >>= function - | Ok () -> Lwt.return_error err0 - | Error _err1 -> Lwt.return_error err0) in - loop () >>= function - | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" Svc.pp_error err) in - (stop, main) - -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type master - - val protocol : (endpoint, flow) protocol - - val service : (configuration, master, flow) Service.service -end +include Internal +module TCP = TCP diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index 739a9a83..0a3b9ba9 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -1,5 +1,3 @@ -(** Conduit with LWT. *) - module Lwt_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t include @@ -13,24 +11,27 @@ val serve_with_handler : service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t +(** [serve_with_handler ~handler ~service cfg] creates an usual infinite [service] + loop from the given configuration ['cfg]. It returns the {i promise} to launch + the loop and a condition variable to stop the loop. + + {[ + let stop, loop = serve_with_handle + ~handler ~service:TCP.service cfg in + Lwt.both + (Lwt_unix.sleep 10. >>= fun () -> + Lwt_condition.broadcast stop () ; + Lwt.return ()) + loop + ]} + + In your example, we want to launch a server only for 10 seconds. *) (** Common interface to properly expose a protocol. If a protocol wants to be fully-compatible with [conduit], it should expose such implementation which is an aggregate of {i types witnesses}. - - At least, [endpoint], [configuration] and [service] must be - exposed to be usable by the end-user. Otherwise, the given - protocol can not be: - {ul - {- registered into {!resolvers}} - {- used as a service with {!serve_with_handler]/{!serve}}} - - [protocol] can be hidden - but must be registered with - {!register_protocol}. However, in such case, the end-user - will not be able to {i destruct} (with {!is}/{!Witness.equal_protocol}) - the given {i flow} to the underlying concrete value. *) module type CONDUIT = sig @@ -46,3 +47,79 @@ module type CONDUIT = sig val service : (configuration, master, flow) Service.service end + +module TCP : sig + (** Implementation of TCP protocol as a client. + + Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. + This is a description of what they currently do. + + {b NOTE}: [recv] wants to fill the given buffer as much as possible until it + has reached {i end-of-input}. In other words, [recv] can do a multiple call + to [Lwt_unix.recv] to fill the given buffer. + + {b NOTE}: [send] tries to send as much as it can the given buffer. However, + if internal call of [Lwt_unix.send] returns something smaller than what we + requested, we stop the process and return how many byte(s) we sended. In + other word, [send] can do a multiple call to [Lwt_unix.send] until we fully + sended what we wanted. *) + + module Protocol : sig + include + PROTOCOL + with type endpoint = Lwt_unix.sockaddr + and type error = + [ `Closed_by_peer + | `Operation_not_permitted + | `Address_already_in_use of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Address_family_not_supported_by_protocol of Unix.sockaddr + | `Operation_already_in_progress + | `Bad_address + | `Network_is_unreachable + | `Connection_timed_out + | `Connection_refused + | `Transport_endpoint_is_not_connected ] + + val file_descr : flow -> Lwt_unix.file_descr + (** [file_descr] returns the underlying [Lwt_unix.file_descr] used to + communicate over TCP. *) + + val peer : flow -> Unix.sockaddr + (** [peer flow] retunrs the address of the peer connected to the given [flow]. *) + + val sock : flow -> Unix.sockaddr + (** [sock flow] returns the current addres to which the socket is bound. *) + end + + type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } + + module Server : + Service.SERVICE + with type configuration = configuration + and type t = Lwt_unix.file_descr + and type flow = Protocol.flow + and type error = + [ `Address_is_protected of Unix.sockaddr + | `Operation_not_permitted of Unix.sockaddr + | `Address_already_in_use of Unix.sockaddr + | `Address_is_not_valid of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Bad_address + | `Too_many_symbolic_links of Unix.sockaddr + | `Name_too_long of Unix.sockaddr + | `Operation_not_supported + | `Limit_reached + | `Protocol_error + | `Firewall_rules_forbid_connection ] + + val protocol : (Lwt_unix.sockaddr, Protocol.flow) protocol + + type t = (Lwt_unix.sockaddr, Protocol.flow) Conduit.value + + type flow += T of t + + val service : (configuration, Server.t, Protocol.flow) Service.service + + val resolv_conf : port:int -> Lwt_unix.sockaddr resolver +end diff --git a/lwt-unix/conduit_lwt_unix_ssl.ml b/lwt/conduit_lwt_ssl.ml similarity index 81% rename from lwt-unix/conduit_lwt_unix_ssl.ml rename to lwt/conduit_lwt_ssl.ml index 2eb7bbe8..9aa052d0 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.ml +++ b/lwt/conduit_lwt_ssl.ml @@ -25,7 +25,7 @@ let endpoint ~file_descr ~context ?verify endpoint = let pf = Format.fprintf -module Protocol (Flow : Conduit_lwt_unix.PROTOCOL) = struct +module Protocol (Flow : Conduit_lwt.PROTOCOL) = struct type input = Cstruct.t type output = Cstruct.t @@ -66,17 +66,17 @@ end let protocol_with_ssl : type edn flow. - (edn, flow) Conduit_lwt_unix.protocol -> - ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt_unix.protocol = + (edn, flow) Conduit_lwt.protocol -> + ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt.protocol = fun protocol -> - let module Flow = (val Conduit_lwt_unix.impl protocol) in + let module Flow = (val Conduit_lwt.impl protocol) in let module M = Protocol (Flow) in - Conduit_lwt_unix.register ~protocol:(module M) + Conduit_lwt.register ~protocol:(module M) type 't master = { master : 't; context : Ssl.context } module Server (Service : sig - include Conduit_lwt_unix.Service.SERVICE + include Conduit_lwt.Service.SERVICE val file_descr : flow -> Lwt_unix.file_descr end) = @@ -112,30 +112,27 @@ end let service_with_ssl : type cfg edn t flow. - (cfg, t, flow) Conduit_lwt_unix.Service.service -> + (cfg, t, flow) Conduit_lwt.Service.service -> file_descr:(flow -> Lwt_unix.file_descr) -> - (edn, Lwt_ssl.socket) Conduit_lwt_unix.protocol -> - ( Ssl.context * cfg, - t master, - Lwt_ssl.socket ) - Conduit_lwt_unix.Service.service = + (edn, Lwt_ssl.socket) Conduit_lwt.protocol -> + (Ssl.context * cfg, t master, Lwt_ssl.socket) Conduit_lwt.Service.service = fun service ~file_descr _ -> - let module S = (val Conduit_lwt_unix.Service.impl service) in + let module S = (val Conduit_lwt.Service.impl service) in let module M = Server (struct include S let file_descr = file_descr end) in - Conduit_lwt_unix.Service.register ~service:(module M) + Conduit_lwt.Service.register ~service:(module M) module TCP = struct let resolv_conf ~port ~context ?verify domain_name = - let file_descr = Conduit_lwt_unix_tcp.Protocol.file_descr in - Conduit_lwt_unix_tcp.resolv_conf ~port domain_name >|= function + let file_descr = Conduit_lwt.TCP.Protocol.file_descr in + Conduit_lwt.TCP.resolv_conf ~port domain_name >|= function | Some edn -> Some (endpoint ~context ~file_descr ?verify edn) | None -> None - open Conduit_lwt_unix_tcp + open Conduit_lwt.TCP type verify = Ssl.context -> diff --git a/lwt-unix/conduit_lwt_unix_ssl.mli b/lwt/conduit_lwt_ssl.mli similarity index 98% rename from lwt-unix/conduit_lwt_unix_ssl.mli rename to lwt/conduit_lwt_ssl.mli index 87b07f7c..ced936ae 100644 --- a/lwt-unix/conduit_lwt_unix_ssl.mli +++ b/lwt/conduit_lwt_ssl.mli @@ -27,7 +27,7 @@ [connect] call). So, nothing was exchanged between you and your peer at this time - even the handshake. *) -open Conduit_lwt_unix +open Conduit_lwt type ('edn, 'flow) endpoint = { context : Ssl.context; @@ -76,7 +76,7 @@ val service_with_ssl : service a [Lwt_unix.file_descr] needed to create a [Lwt_ssl.socket]. *) module TCP : sig - open Conduit_lwt_unix_tcp + open Conduit_lwt.TCP val protocol : ((Lwt_unix.sockaddr, Protocol.flow) endpoint, Lwt_ssl.socket) protocol diff --git a/lwt-unix/conduit_lwt_unix_tls.ml b/lwt/conduit_lwt_tls.ml similarity index 93% rename from lwt-unix/conduit_lwt_unix_tls.ml rename to lwt/conduit_lwt_tls.ml index 440e269b..cb17a000 100644 --- a/lwt-unix/conduit_lwt_unix_tls.ml +++ b/lwt/conduit_lwt_tls.ml @@ -1,7 +1,7 @@ include Conduit_tls.Make (Conduit_lwt.Lwt_scheduler) (Conduit_lwt) module TCP = struct - open Conduit_lwt_unix_tcp + open Conduit_lwt.TCP let protocol = protocol_with_tls protocol diff --git a/lwt-unix/conduit_lwt_unix_tls.mli b/lwt/conduit_lwt_tls.mli similarity index 96% rename from lwt-unix/conduit_lwt_unix_tls.mli rename to lwt/conduit_lwt_tls.mli index 9b2fc178..5439a338 100644 --- a/lwt-unix/conduit_lwt_unix_tls.mli +++ b/lwt/conduit_lwt_tls.mli @@ -7,7 +7,7 @@ For more details about behaviours, you should look into [conduit-tls]. *) -open Conduit_lwt_unix +open Conduit_lwt type 'flow protocol_with_tls @@ -33,7 +33,7 @@ val service_with_tls : Service.service module TCP : sig - open Conduit_lwt_unix_tcp + open Conduit_lwt.TCP val protocol : ( Lwt_unix.sockaddr * Tls.Config.client, diff --git a/lwt/dune b/lwt/dune index c170d8cc..08ecde8b 100644 --- a/lwt/dune +++ b/lwt/dune @@ -1,8 +1,20 @@ (library (name conduit_lwt) (public_name conduit-lwt) - (modules conduit_lwt) - (libraries cstruct lwt conduit)) + (modules conduit_lwt internal tCP) + (libraries cstruct lwt lwt.unix conduit)) + +(library + (name conduit_lwt_ssl) + (public_name conduit-lwt-ssl) + (modules conduit_lwt_ssl) + (libraries conduit-lwt lwt_ssl)) + +(library + (name conduit_lwt_tls) + (public_name conduit-lwt-tls) + (modules conduit_lwt_tls) + (libraries conduit-lwt conduit-tls)) (library (name conduit_lwt_flow) diff --git a/lwt/internal.ml b/lwt/internal.ml new file mode 100644 index 00000000..9b023570 --- /dev/null +++ b/lwt/internal.ml @@ -0,0 +1,60 @@ +module Lwt_scheduler = struct + type +'a t = 'a Lwt.t + + let bind x f = Lwt.bind x f + + let return x = Lwt.return x +end + +include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let ( >>? ) = Lwt_result.bind + +let serve_with_handler : + type cfg master flow. + handler:(flow -> unit Lwt.t) -> + service:(cfg, master, flow) Service.service -> + cfg -> + unit Lwt_condition.t * unit Lwt.t = + fun ~handler ~service cfg -> + let open Lwt.Infix in + let stop = Lwt_condition.create () in + let module Svc = (val Service.impl service) in + let main = + Service.serve cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok master -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Lwt.return_error err0 + | Error _err1 -> Lwt.return_error err0) in + loop () >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) + +module type CONDUIT = sig + type endpoint + + type flow + + type configuration + + type master + + val protocol : (endpoint, flow) protocol + + val service : (configuration, master, flow) Service.service +end diff --git a/lwt-unix/conduit_lwt_unix_tcp.ml b/lwt/tCP.ml similarity index 98% rename from lwt-unix/conduit_lwt_unix_tcp.ml rename to lwt/tCP.ml index 4336121a..8b7328f9 100644 --- a/lwt-unix/conduit_lwt_unix_tcp.ml +++ b/lwt/tCP.ml @@ -302,11 +302,11 @@ module Server = struct Lwt.return_ok () end -let protocol = Conduit_lwt.register ~protocol:(module Protocol) +let protocol = Internal.register ~protocol:(module Protocol) -include (val Conduit_lwt.repr protocol) +include (val Internal.repr protocol) -let service = Conduit_lwt.Service.register ~service:(module Server) +let service = Internal.Service.register ~service:(module Server) let resolv_conf ~port domain_name = Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function diff --git a/mirage/conduit_mirage.ml b/mirage/conduit_mirage.ml index 468754f3..e451f5c7 100644 --- a/mirage/conduit_mirage.ml +++ b/mirage/conduit_mirage.ml @@ -1,2 +1,60 @@ -module Mirage_scheduler = Conduit_lwt.Lwt_scheduler -include Conduit_lwt +module Mirage_scheduler = struct + type +'a t = 'a Lwt.t + + let bind x f = Lwt.bind x f + + let return x = Lwt.return x +end + +include Conduit.Make (Mirage_scheduler) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let ( >>? ) = Lwt_result.bind + +let serve_with_handler : + type cfg master flow. + handler:(flow -> unit Lwt.t) -> + service:(cfg, master, flow) Service.service -> + cfg -> + unit Lwt_condition.t * unit Lwt.t = + fun ~handler ~service cfg -> + let open Lwt.Infix in + let stop = Lwt_condition.create () in + let module Svc = (val Service.impl service) in + let main = + Service.serve cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok master -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Lwt.return_error err0 + | Error _err1 -> Lwt.return_error err0) in + loop () >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) + +module type CONDUIT = sig + type endpoint + + type flow + + type configuration + + type master + + val protocol : (endpoint, flow) protocol + + val service : (configuration, master, flow) Service.service +end diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 40076926..e5d804f4 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -5,11 +5,6 @@ include with type input = Cstruct.t and type output = Cstruct.t and type +'a s = 'a Lwt.t - and type scheduler = Conduit_lwt.scheduler - and type ('edn, 'flow) protocol = ('edn, 'flow) Conduit_lwt.protocol - and type ('cfg, 't, 'flow) Service.service = - ('cfg, 't, 'flow) Conduit_lwt.Service.service - and type flow = Conduit_lwt.flow val serve_with_handler : handler:('flow -> unit Lwt.t) -> diff --git a/mirage/conduit_mirage_flow.ml b/mirage/conduit_mirage_flow.ml deleted file mode 100644 index 65ff904a..00000000 --- a/mirage/conduit_mirage_flow.ml +++ /dev/null @@ -1 +0,0 @@ -include Conduit_lwt_flow diff --git a/mirage/conduit_mirage_flow.mli b/mirage/conduit_mirage_flow.mli deleted file mode 100644 index 1135b37d..00000000 --- a/mirage/conduit_mirage_flow.mli +++ /dev/null @@ -1,18 +0,0 @@ -(** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. - This module is deprecated when the current implementation of [read] has - another behaviour: - - [conduit] provides: - - {[ val read : flow -> Cstruct.t -> (int or_eoi, error) result Lwt.t ]} - - where [mirage-flow] expects: - - {[ val read : flow -> (Cstruct.t or_eoi, error) result Lwt.t ]} - - This current implementation allocates an {b arbitrary} 4096 bytes buffer to - fit under the [mirage-flow] interface. [conduit] did the choice to follow - the POSIX interface and let the end-user to allocate by himself the input - buffer. *) - -include Mirage_flow.S with type flow = Conduit_mirage.flow diff --git a/mirage/conduit_mirage_tls.ml b/mirage/conduit_mirage_tls.ml deleted file mode 100644 index 1c676d73..00000000 --- a/mirage/conduit_mirage_tls.ml +++ /dev/null @@ -1 +0,0 @@ -include Conduit_tls.Make (Conduit_mirage.Mirage_scheduler) (Conduit_mirage) diff --git a/mirage/conduit_mirage_tls.mli b/mirage/conduit_mirage_tls.mli deleted file mode 100644 index d9f41be4..00000000 --- a/mirage/conduit_mirage_tls.mli +++ /dev/null @@ -1,21 +0,0 @@ -open Conduit_mirage - -type 'flow protocol_with_tls - -val underlying : 'flow protocol_with_tls -> 'flow - -val handshake : 'flow protocol_with_tls -> bool - -val protocol_with_tls : - ('edn, 'flow) protocol -> - ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol - -type 'service service_with_tls - -val service_with_tls : - ('cfg, 't, 'flow) Service.service -> - ('edn, 'flow protocol_with_tls) protocol -> - ( 'cfg * Tls.Config.server, - 't service_with_tls, - 'flow protocol_with_tls ) - Service.service diff --git a/mirage/dune b/mirage/dune index 84bdf52b..75abaf27 100644 --- a/mirage/dune +++ b/mirage/dune @@ -2,19 +2,7 @@ (name conduit_mirage) (public_name conduit-mirage) (modules conduit_mirage) - (libraries conduit conduit-lwt)) - -(library - (name conduit_mirage_tls) - (public_name conduit-mirage.tls) - (modules conduit_mirage_tls) - (libraries conduit-mirage conduit-tls)) - -(library - (name conduit_mirage_flow) - (public_name conduit-mirage.flow) - (modules conduit_mirage_flow) - (libraries conduit-mirage conduit-lwt.flow)) + (libraries cstruct conduit lwt)) (library (name conduit_mirage_tcp) diff --git a/tests/dune b/tests/dune index 05a0413d..11d42bd3 100644 --- a/tests/dune +++ b/tests/dune @@ -6,8 +6,8 @@ (executable (name ping_pong) (modules ping_pong) - (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix - conduit-lwt-unix.tcp conduit-lwt-unix.tls conduit-lwt-unix.ssl)) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-lwt + conduit-lwt-tls conduit-lwt-ssl)) (executable (name with_async) @@ -22,7 +22,7 @@ (rule (alias runtest) - (package conduit-lwt-unix) + (package conduit-lwt) (deps (:test test_lwt.exe) ping_pong.exe diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 8928ce9b..26c80571 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -18,30 +18,29 @@ include Common.Make (Lwt) (Lwt_condition) (* Composition *) let tls_protocol, tls_service = - let open Conduit_lwt_unix_tls.TCP in + let open Conduit_lwt_tls.TCP in (protocol, service) let ssl_protocol, ssl_service = - let open Conduit_lwt_unix_ssl.TCP in + let open Conduit_lwt_ssl.TCP in (protocol, service) (* Resolution *) -let resolve_ping_pong = Conduit_lwt_unix_tcp.resolv_conf ~port:4000 +let resolve_ping_pong = Conduit_lwt.TCP.resolv_conf ~port:4000 let resolve_tls_ping_pong = let null ~host:_ _ = Ok None in let config = Tls.Config.client ~authenticator:null () in - Conduit_lwt_unix_tls.TCP.resolv_conf ~port:8000 ~config + Conduit_lwt_tls.TCP.resolv_conf ~port:8000 ~config let resolve_ssl_ping_pong = let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in - Conduit_lwt_unix_ssl.TCP.resolv_conf ~port:6000 ~context ?verify:None + Conduit_lwt_ssl.TCP.resolv_conf ~port:6000 ~context ?verify:None let resolvers = Conduit.empty - |> Conduit_lwt.add ~priority:20 Conduit_lwt_unix_tcp.protocol - resolve_ping_pong + |> Conduit_lwt.add ~priority:20 Conduit_lwt.TCP.protocol resolve_ping_pong |> Conduit_lwt.add ~priority:10 tls_protocol resolve_tls_ping_pong |> Conduit_lwt.add ~priority:10 ssl_protocol resolve_ssl_ping_pong @@ -84,12 +83,10 @@ let run_with : let run_with_tcp clients = run_with { - Conduit_lwt_unix_tcp.sockaddr = - Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); capacity = 40; } - ~protocol:Conduit_lwt_unix_tcp.protocol - ~service:Conduit_lwt_unix_tcp.service clients + ~protocol:Conduit_lwt.TCP.protocol ~service:Conduit_lwt.TCP.service clients let run_with_ssl cert key clients = let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Server_context in @@ -97,8 +94,7 @@ let run_with_ssl cert key clients = run_with ( ctx, { - Conduit_lwt_unix_tcp.sockaddr = - Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); capacity = 40; } ) ~protocol:ssl_protocol ~service:ssl_service clients @@ -107,8 +103,7 @@ let run_with_tls cert key clients = let ctx = config cert key in run_with ( { - Conduit_lwt_unix_tcp.sockaddr = - Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); capacity = 40; }, ctx ) From aa9966a0cae550b74ab95bf9634d8507f7892f8d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 22 Jun 2020 11:07:05 +0200 Subject: [PATCH 042/140] Create new package conduit-async-{tls,ssl} and integrate conduit-async.tcp into conduit-async --- async/conduit_async.ml | 82 +------------------------- async/conduit_async.mli | 2 + async/conduit_async_ssl.ml | 2 +- async/conduit_async_ssl.mli | 2 +- async/conduit_async_tcp.mli | 24 -------- async/conduit_async_tls.ml | 2 +- async/conduit_async_tls.mli | 2 +- async/dune | 16 ++--- async/internal.ml | 80 +++++++++++++++++++++++++ async/{conduit_async_tcp.ml => tCP.ml} | 4 +- conduit-async-ssl.opam | 31 ++++++++++ conduit-async-tls.opam | 31 ++++++++++ conduit-mirage.opam | 4 +- tests/dune | 4 +- tests/with_async.ml | 10 ++-- 15 files changed, 165 insertions(+), 131 deletions(-) delete mode 100644 async/conduit_async_tcp.mli create mode 100644 async/internal.ml rename async/{conduit_async_tcp.ml => tCP.ml} (97%) create mode 100644 conduit-async-ssl.opam create mode 100644 conduit-async-tls.opam diff --git a/async/conduit_async.ml b/async/conduit_async.ml index a3b22de1..4d947097 100644 --- a/async/conduit_async.ml +++ b/async/conduit_async.ml @@ -1,80 +1,2 @@ -module Async_scheduler = struct - type +'a t = 'a Async.Deferred.t - - let bind x f = Async.Deferred.bind x ~f - - let return x = Async.Deferred.return x -end - -include Conduit.Make (Async_scheduler) (Cstruct) (Cstruct) - -let failwith fmt = Format.kasprintf failwith fmt - -let ( >>? ) x f = Async.Deferred.Result.bind x ~f - -let serve_with_handler : - type cfg master flow. - handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, master, flow) Service.service -> - cfg -> - unit Async.Condition.t * unit Async.Deferred.t = - fun ~handler ~service cfg -> - let open Async in - let stop = Async.Condition.create () in - let module Svc = (val Service.impl service) in - let main = - Service.serve cfg ~service >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( - let rec loop () = - let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in - let accept = - Svc.accept master >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in - - Async.Deferred.any [ close; accept ] >>= function - | Ok (`Flow flow) -> - Async.don't_wait_for (handler flow) ; - Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok `Stop -> Svc.close master - | Error err0 -> ( - Svc.close master >>= function - | Ok () -> Async.return (Error err0) - | Error _err1 -> Async.return (Error err0)) in - loop () >>= function - | Ok () -> Async.return () - | Error err -> failwith "%a" Svc.pp_error err) in - (stop, main) - -let reader_and_writer_of_flow flow = - let open Async in - let recv flow writer = - let tmp = Cstruct.create 0x1000 in - let rec loop () = - recv flow tmp >>= function - | Ok (`Input len) -> - Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop - | Ok `End_of_flow -> - Pipe.close writer ; - Async.return () - | Error err -> failwith "%a" pp_error err in - loop () in - let send flow reader = - let rec loop () = - Pipe.read reader >>= function - | `Eof -> Async.return () - | `Ok v -> - let rec go tmp = - if Cstruct.len tmp = 0 - then Async.return () - else - send flow tmp >>= function - | Ok shift -> go (Cstruct.shift tmp shift) - | Error err -> failwith "%a" pp_error err in - go (Cstruct.of_string v) >>= loop in - loop () in - let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in - let pwriter = Pipe.create_writer (send flow) in - Reader.of_pipe (Core.Info.of_string "reader") preader >>= fun reader -> - Writer.of_pipe (Core.Info.of_string "writer") pwriter >>= fun (writer, _) -> - Async.return (reader, writer) +include Internal +module TCP = TCP diff --git a/async/conduit_async.mli b/async/conduit_async.mli index d4a49006..12487f9e 100644 --- a/async/conduit_async.mli +++ b/async/conduit_async.mli @@ -1,5 +1,7 @@ (** Conduit with Async. *) +open Async_unix + module Async_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Async.Deferred.t diff --git a/async/conduit_async_ssl.ml b/async/conduit_async_ssl.ml index 170589fb..2612e9c0 100644 --- a/async/conduit_async_ssl.ml +++ b/async/conduit_async_ssl.ml @@ -297,7 +297,7 @@ let service_with_ssl : Conduit_async.Service.register ~service:(module M) module TCP = struct - open Conduit_async_tcp + open Conduit_async.TCP let protocol = protocol_with_ssl ~reader:Protocol.reader ~writer:Protocol.writer protocol diff --git a/async/conduit_async_ssl.mli b/async/conduit_async_ssl.mli index 51ce74f0..e1ac0962 100644 --- a/async/conduit_async_ssl.mli +++ b/async/conduit_async_ssl.mli @@ -55,7 +55,7 @@ val service_with_ssl : (context * 'cfg, context * 't, 'flow with_ssl) Service.service module TCP : sig - open Conduit_async_tcp + open Conduit_async.TCP val protocol : (context * endpoint, Protocol.flow with_ssl) protocol diff --git a/async/conduit_async_tcp.mli b/async/conduit_async_tcp.mli deleted file mode 100644 index 9712bb9a..00000000 --- a/async/conduit_async_tcp.mli +++ /dev/null @@ -1,24 +0,0 @@ -open Async -open Conduit_async - -type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t - -module Protocol : sig - include Conduit_async.PROTOCOL with type endpoint = endpoint - - val address : flow -> Socket.Address.t - - val reader : flow -> Reader.t - - val writer : flow -> Writer.t -end - -val protocol : (Protocol.endpoint, Protocol.flow) protocol - -type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration - -module Server : Service.SERVICE with type configuration = configuration - -val service : (configuration, Server.t, Protocol.flow) Service.service - -val resolv_conf : port:int -> endpoint resolver diff --git a/async/conduit_async_tls.ml b/async/conduit_async_tls.ml index 2e7f2a89..ac3aca37 100644 --- a/async/conduit_async_tls.ml +++ b/async/conduit_async_tls.ml @@ -2,7 +2,7 @@ open Async include Conduit_tls.Make (Conduit_async.Async_scheduler) (Conduit_async) module TCP = struct - open Conduit_async_tcp + open Conduit_async.TCP let protocol = protocol_with_tls protocol diff --git a/async/conduit_async_tls.mli b/async/conduit_async_tls.mli index 0c33b918..daaf20aa 100644 --- a/async/conduit_async_tls.mli +++ b/async/conduit_async_tls.mli @@ -21,7 +21,7 @@ val service_with_tls : Service.service module TCP : sig - open Conduit_async_tcp + open Conduit_async.TCP val protocol : (endpoint * Tls.Config.client, Protocol.flow protocol_with_tls) protocol diff --git a/async/dune b/async/dune index 01bb5cf6..75512b5e 100644 --- a/async/dune +++ b/async/dune @@ -1,23 +1,17 @@ (library (name conduit_async) (public_name conduit-async) - (modules conduit_async) + (modules conduit_async internal tCP) (libraries cstruct async conduit)) -(library - (name conduit_async_tcp) - (public_name conduit-async.tcp) - (modules conduit_async_tcp) - (libraries async_unix conduit-async)) - (library (name conduit_async_tls) - (public_name conduit-async.tls) + (public_name conduit-async-tls) (modules conduit_async_tls) - (libraries conduit-tls conduit-async conduit-async.tcp)) + (libraries conduit-tls conduit-async)) (library (name conduit_async_ssl) - (public_name conduit-async.ssl) + (public_name conduit-async-ssl) (modules conduit_async_ssl) - (libraries core async_ssl conduit-async conduit-async.tcp)) + (libraries core async_ssl conduit-async)) diff --git a/async/internal.ml b/async/internal.ml new file mode 100644 index 00000000..a3b22de1 --- /dev/null +++ b/async/internal.ml @@ -0,0 +1,80 @@ +module Async_scheduler = struct + type +'a t = 'a Async.Deferred.t + + let bind x f = Async.Deferred.bind x ~f + + let return x = Async.Deferred.return x +end + +include Conduit.Make (Async_scheduler) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf failwith fmt + +let ( >>? ) x f = Async.Deferred.Result.bind x ~f + +let serve_with_handler : + type cfg master flow. + handler:(flow -> unit Async.Deferred.t) -> + service:(cfg, master, flow) Service.service -> + cfg -> + unit Async.Condition.t * unit Async.Deferred.t = + fun ~handler ~service cfg -> + let open Async in + let stop = Async.Condition.create () in + let module Svc = (val Service.impl service) in + let main = + Service.serve cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok master -> ( + let rec loop () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in + let accept = + Svc.accept master >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in + + Async.Deferred.any [ close; accept ] >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for (handler flow) ; + Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Async.return (Error err0) + | Error _err1 -> Async.return (Error err0)) in + loop () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) + +let reader_and_writer_of_flow flow = + let open Async in + let recv flow writer = + let tmp = Cstruct.create 0x1000 in + let rec loop () = + recv flow tmp >>= function + | Ok (`Input len) -> + Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop + | Ok `End_of_flow -> + Pipe.close writer ; + Async.return () + | Error err -> failwith "%a" pp_error err in + loop () in + let send flow reader = + let rec loop () = + Pipe.read reader >>= function + | `Eof -> Async.return () + | `Ok v -> + let rec go tmp = + if Cstruct.len tmp = 0 + then Async.return () + else + send flow tmp >>= function + | Ok shift -> go (Cstruct.shift tmp shift) + | Error err -> failwith "%a" pp_error err in + go (Cstruct.of_string v) >>= loop in + loop () in + let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in + let pwriter = Pipe.create_writer (send flow) in + Reader.of_pipe (Core.Info.of_string "reader") preader >>= fun reader -> + Writer.of_pipe (Core.Info.of_string "writer") pwriter >>= fun (writer, _) -> + Async.return (reader, writer) diff --git a/async/conduit_async_tcp.ml b/async/tCP.ml similarity index 97% rename from async/conduit_async_tcp.ml rename to async/tCP.ml index f4d53b70..7ee605d2 100644 --- a/async/conduit_async_tcp.ml +++ b/async/tCP.ml @@ -84,7 +84,7 @@ module Protocol = struct Writer.close writer >>= fun () -> Async.return (Ok ())) end -let protocol = Conduit_async.register ~protocol:(module Protocol) +let protocol = Internal.register ~protocol:(module Protocol) type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration @@ -147,7 +147,7 @@ module Server = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end -let service = Conduit_async.Service.register ~service:(module Server) +let service = Internal.Service.register ~service:(module Server) let resolv_conf ~port domain_name = Monitor.try_with (fun () -> diff --git a/conduit-async-ssl.opam b/conduit-async-ssl.opam new file mode 100644 index 00000000..483270a1 --- /dev/null +++ b/conduit-async-ssl.opam @@ -0,0 +1,31 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" +] +license: "ISC" +tags: "org:mirage" +homepage: "https://github.com/mirage/ocaml-conduit" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library for Async" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" + "core" + "conduit" + "async" {>= "v0.12.0"} + "async_ssl" + "conduit-tls" + "stdlib-shims" {with-test} +] diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam new file mode 100644 index 00000000..483270a1 --- /dev/null +++ b/conduit-async-tls.opam @@ -0,0 +1,31 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" +] +license: "ISC" +tags: "org:mirage" +homepage: "https://github.com/mirage/ocaml-conduit" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library for Async" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-j1"] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" + "core" + "conduit" + "async" {>= "v0.12.0"} + "async_ssl" + "conduit-tls" + "stdlib-shims" {with-test} +] diff --git a/conduit-mirage.opam b/conduit-mirage.opam index d423a6fc..99705f42 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -21,10 +21,8 @@ build: [ depends: [ "ocaml" {>= "4.07.0"} "dune" - "conduit-lwt" - "conduit-tls" + "conduit" "tcpip" "mirage-flow" "dns-client" ] - diff --git a/tests/dune b/tests/dune index 11d42bd3..ee0c00c7 100644 --- a/tests/dune +++ b/tests/dune @@ -12,8 +12,8 @@ (executable (name with_async) (modules with_async) - (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async.tcp - conduit-async.tls conduit-async.ssl)) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async + conduit-async-tls conduit-async-ssl)) (executable (name test_lwt) diff --git a/tests/with_async.ml b/tests/with_async.ml index f46dbd27..07374cc6 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -20,7 +20,7 @@ include Common.Make end) let tcp_protocol, tcp_service = - let open Conduit_async_tcp in + let open Conduit_async.TCP in (protocol, service) let ssl_protocol, ssl_service = @@ -33,7 +33,7 @@ let tls_protocol, tls_service = let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt -let resolve_ping_pong = Conduit_async_tcp.resolv_conf ~port:5000 +let resolve_ping_pong = Conduit_async.TCP.resolv_conf ~port:5000 let resolve_ssl_ping_pong = let context = @@ -79,13 +79,13 @@ let run_with : let run_with_tcp clients = run_with - (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 5000)) + (Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 5000)) ~protocol:tcp_protocol ~service:tcp_service clients let run_with_ssl cert key clients = let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in run_with - (ctx, Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 7000)) + (ctx, Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 7000)) ~protocol:ssl_protocol ~service:ssl_service clients let load_file filename = @@ -110,7 +110,7 @@ let config cert key = let run_with_tls cert key clients = let ctx = config cert key in run_with - (Conduit_async_tcp.Listen (Tcp.Where_to_listen.of_port 9000), ctx) + (Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 9000), ctx) ~protocol:tls_protocol ~service:tls_service clients let () = From 7367a0b7884161dd5059f43285ea245cf52c9147 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 22 Jun 2020 11:07:55 +0200 Subject: [PATCH 043/140] Update GitHub Action with the new layout of conduit --- .github/workflows/test.yml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 480b0c39..f832859e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -21,25 +21,28 @@ jobs: run: | opam pin add -n conduit.dev . opam pin add -n conduit-lwt.dev . - opam pin add -n conduit-lwt-unix.dev . opam pin add -n conduit-async.dev . opam pin add -n conduit-mirage.dev . opam pin add -n conduit-tls.dev . - opam depext -y conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-async conduit-mirage - opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-async conduit-mirage + opam pin add -n conduit-async-tls.dev . + opam pin add -n conduit-async-ssl.dev . + opam pin add -n conduit-lwt-tls.dev . + opam pin add -n conduit-lwt-ssl.dev . + opam depext -y conduit conduit-tls conduit-lwt conduit-async conduit-mirage + opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-lwt-ssl conduit-async conduit-async-tls conduit-async-ssl conduit-mirage - name: Deps (Windows) if: runner.os == 'Windows' run: | opam pin add -n conduit.dev . opam pin add -n conduit-lwt.dev . - opam pin add -n conduit-lwt-unix.dev . opam pin add -n conduit-mirage.dev . opam pin add -n conduit-tls.dev . - opam depext -y conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-mirage - opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-unix conduit-mirage + opam pin add -n conduit-lwt-tls.dev . + opam depext -y conduit conduit-tls conduit-lwt conduit-mirage + opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-mirage - name: Build (Windows) if: runner.os == 'Windows' - run: opam exec -- dune build -p conduit,conduit-tls,conduit-lwt,conduit-lwt-unix,conduit-mirage + run: opam exec -- dune build -p conduit,conduit-tls,conduit-lwt,conduit-mirage - name: Build if: runner.os != 'Windows' run: opam exec -- dune build From cfa382190056a964b8d93fae88cc99d56a0c68e4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 22 Jun 2020 17:12:01 +0200 Subject: [PATCH 044/140] Optmize the core of conduit to have a smaller overhead about projection --- bench/cost.ml | 141 +++++++++++++++++++++++++++++++++++++++++ bench/dune | 6 ++ bench/rdtsc.c | 37 +++++++++++ lib/conduit.ml | 44 ++++++++++--- lib/conduit.mli | 55 +++++++++++++--- lib/e0.ml | 125 +++++++++++++++++++++++++++++++++---- lib/index.mld | 162 ++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 542 insertions(+), 28 deletions(-) create mode 100644 bench/cost.ml create mode 100644 bench/dune create mode 100644 bench/rdtsc.c create mode 100644 lib/index.mld diff --git a/bench/cost.ml b/bench/cost.ml new file mode 100644 index 00000000..d76873dd --- /dev/null +++ b/bench/cost.ml @@ -0,0 +1,141 @@ +external tick : unit -> (int64[@unboxed]) = "none" "get_tick" [@@noalloc] + +module None = struct + type +'a t = 'a + + let bind x f = f x + + let return x = x +end + +module Tuyau = Conduit.Make (None) (Bytes) (String) + +let t1 = ref 0L + +module Fake_protocol0 = struct + type input = bytes + + and output = string + + and +'a s = 'a + + type endpoint = Unix.file_descr + + type flow = Unix.file_descr + + type error = | + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let connect x = Ok x + + let recv _ _ = Ok `End_of_flow + + let send fd v = + t1 := tick () ; + let _ = Unix.write_substring fd v 0 (String.length v) in + Ok 0 + + let close _ = Ok () +end + +module Fake_protocol1 = struct + type input = bytes + + and output = string + + and +'a s = 'a + + type endpoint = Unix.file_descr + + type flow = Unix.file_descr + + type error = | + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let connect x = Ok x + + let recv _ _ = Ok `End_of_flow + + let send _ _ = assert false + + let close _ = Ok () +end + +module Fake_protocol2 = struct + type input = bytes + + and output = string + + and +'a s = 'a + + type endpoint = Unix.file_descr + + type flow = Unix.file_descr + + type error = | + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let connect x = Ok x + + let recv _ _ = Ok `End_of_flow + + let send _ _ = assert false + + let close _ = Ok () +end + +let fake0 = Tuyau.register ~protocol:(module Fake_protocol0) + +let fake1 = Tuyau.register ~protocol:(module Fake_protocol1) + +let fake2 = Tuyau.register ~protocol:(module Fake_protocol2) + +let hello_world = "Hello World!\n" + +let fully_abstr () = + let open Rresult in + Tuyau.connect Unix.stderr fake0 >>= fun flow -> + let t0 = tick () in + Tuyau.send flow hello_world >>= fun _len -> + let t3 = Int64.sub (tick ()) !t1 in + let t2 = tick () in + Tuyau.send flow hello_world >>= fun _len -> + R.ok (Int64.sub !t1 t0, t3, Int64.sub !t1 t2) + +let abstr () = + let open Rresult in + let module Protocol = (val Tuyau.impl fake0) in + Tuyau.connect Unix.stderr fake0 >>= fun flow -> + let (Tuyau.Flow (flow, (module Flow))) = Tuyau.flow flow in + let t0 = tick () in + Flow.send flow hello_world |> R.reword_error (R.msgf "%a" Flow.pp_error) + >>= fun _len -> + let t3 = Int64.sub (tick ()) !t1 in + let t2 = tick () in + Flow.send flow hello_world |> R.reword_error (R.msgf "%a" Flow.pp_error) + >>= fun _len -> R.ok (Int64.sub !t1 t0, t3, Int64.sub !t1 t2) + +let concrete () = + let t0 = tick () in + let _ = + Unix.write_substring Unix.stderr hello_world 0 (String.length hello_world) + in + let t1 = tick () in + Ok (Int64.sub t1 t0) + +let () = + let _ = + Unix.write_substring Unix.stderr hello_world 0 (String.length hello_world) + in + let[@warning "-8"] (Ok ts) = concrete () in + t1 := 0L ; + let[@warning "-8"] (Ok (ts0, ts1, ts2)) = fully_abstr () in + t1 := 0L ; + let[@warning "-8"] (Ok (tsa, tsb, tsc)) = abstr () in + t1 := 0L ; + Fmt.pr "fully-abstr:\t%Ldns, %Ldns, %Ldns.\n%!" ts0 ts1 ts2 ; + Fmt.pr "abstr:\t\t%Ldns, %Ldns, %Ldns.\n%!" tsa tsb tsc ; + Fmt.pr "concrete:\t%Ldns.\n%!" ts diff --git a/bench/dune b/bench/dune new file mode 100644 index 00000000..19246a85 --- /dev/null +++ b/bench/dune @@ -0,0 +1,6 @@ +(executable + (name cost) + (libraries conduit unix rresult fmt) + (foreign_stubs + (language c) + (names rdtsc))) diff --git a/bench/rdtsc.c b/bench/rdtsc.c new file mode 100644 index 00000000..fdc7db5f --- /dev/null +++ b/bench/rdtsc.c @@ -0,0 +1,37 @@ +#include +#include + +#include +#include +#include +#include + +#ifndef __unused +#define __unused(x) x __attribute((unused)) +#endif +#define __unit() value __unused(unit) + +uint64_t +get_tick(__unit ()) +{ + struct timespec ts; + + clock_gettime(CLOCK_MONOTONIC, &ts); + + return ((uint64_t) ts.tv_sec + * (uint64_t) 1000000000LL + + (uint64_t) ts.tv_nsec); +} + +/* + +uint64_t +get_tick(__unit ()) +{ + unsigned hi, lo; + __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); + + return (((unsigned long long) lo) | (((unsigned long long) hi) << 32)); +} + +*/ diff --git a/lib/conduit.ml b/lib/conduit.ml index f892ed80..46d645b4 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -25,10 +25,10 @@ let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt type ('a, 'b, 'c) thd = | Thd : 'b -> ('a, 'b, 'c) thd (** XXX(dinosaure): we must define [(_, _, _) thd] to be able to keep some - existential types (eg. ['cfg] and ['flow] when we use [('cfg, 't, 'flow) - service]) but still to use only on (eg. ['t]). + existential types (eg. ['cfg] and ['flow] when we use [('cfg, 't, 'flow) + service]) but still to use only on (eg. ['t]). - We add [warning "-37"] to be able to compile the project. *) + We add [warning "-37"] to be able to compile the project. *) let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt @@ -94,7 +94,9 @@ module type S = sig val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - val abstract : ('edn, 'v) protocol -> 'v -> flow + type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + + val flow : flow -> pack val impl : ('edn, 'flow) protocol -> @@ -102,6 +104,8 @@ module type S = sig val is : flow -> ('edn, 'flow) protocol -> 'flow option + val abstract : ('edn, 'v) protocol -> 'v -> flow + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s val empty : resolvers @@ -221,15 +225,32 @@ module Make type ('edn, 'flow) protocol = ('edn, 'flow) value Ptr.s + (* XXX(dinosaure): note about performance, [Ptr.prj] can cost where + * it's a lookup into the global [hashtbl] (created by [Ptr]). However, + * the usual pattern of [Conduit] is multiple calls of [send]/[recv] with + * the same [flow]. + * + * Implementation of internal [hashtbl] memoize such case. We have different + * overheads: + * - about [recv]/[send], it's around ~500ns (first call), ~125ns (subsequent calls) + * - about [flow] & [Flow.recv]/[Flow.send], it's aroung ~75ns + * + * However, keep in your mind that: + * - the internal [hashtbl] should be small (smaller than 16 elements) + * - performance is intrinsic with [caml_hash] + *) + let recv flow input = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = + Ptr.prj flow in let (Value flow) = flow in Protocol.recv flow input >>| function | Ok _ as v -> v | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let send flow output = - let (Ptr.Value (flow, Protocol (_, (module Protocol)))) = Ptr.prj flow in + let send (flow : Ptr.t) output = + let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = + Ptr.prj flow in let (Value flow) = flow in Protocol.send flow output >>| function | Ok _ as v -> v @@ -391,6 +412,15 @@ module Make Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) >>? fun flow -> return (Ok (Witness.T (Value flow))) + type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + + let flow : flow -> pack = + 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 impl : type edn flow. (edn, flow) protocol -> diff --git a/lib/conduit.mli b/lib/conduit.mli index b5b601ea..dd4ea6ee 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -23,7 +23,7 @@ module type S = sig type scheduler (** The type of I/O monads. *) - (** {2:client Client-side Conduits.} *) + (** {2:client Client-side conduits.} *) type flow = private .. (** The type for generic flows. {!PROTOCOL} implementations are extending (via @@ -131,6 +131,32 @@ module type S = sig As a protocol implementer, you must {i register} your implementation and expose the {i witness} of it. Then, users will be able to use it. *) + (** {2 Injection and Extraction.} + + The goal of [Conduit] is to provide: + {ul + {- A way to manipulate a fully-abstract [flow].} + {- A way to manipulate a concrete and well-know [flow].}} + + [Conduit] provides several mechanisms to be able to manipulate our abstract + type {!flow} and destruct it to a concrete value such as a [Unix.file_descr]. + [Conduit] can assert one assumption: from a given abstracted [flow], it exists + one and only one {!FLOW} implementation. + + As [Conduit] determines this implementation, the user can determine the used + implementation when he wants to {!send} or {!recv} datas. + + So [Conduit] uses or extracts uniqely the implementation registered before + with {!register} and no layer can tweak or update this assertion. + + {!repr}, {!flow}, {!impl} and {!is} can extracts in differents ways the + abstracted {!flow}: + {ul + {- with the {i pattern-matching}} + {- with {i first-class module}} + {- with the function {!is}}} + *) + module type REPR = sig type t @@ -163,15 +189,16 @@ module type S = sig ]} *) - val abstract : (_, 'v) protocol -> 'v -> flow - (** [abstract protocol concrete_flow] abstracts the given [flow] into the - {!flow} type from a given [protocol]. It permits to use [Conduit] with a - concrete value created by the user. + type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + + val flow : flow -> pack + (** [flow flow] projects the module implementation associated to the given + abstract [flow] such as: {[ - let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let flow = Conduit.abstract Conduit_tcp.t socket in - Conduit.send flow "Hello World!" + Conduit.connect edn >>= fun flow -> + let Conduit.Flow (flow, (module Flow)) = Conduit.flow flow in + Flow.send flow "Hello World!" ]} *) @@ -191,6 +218,18 @@ module type S = sig ]} *) + val abstract : (_, 'v) protocol -> 'v -> flow + (** [abstract protocol concrete_flow] abstracts the given [flow] into the + {!flow} type from a given [protocol]. It permits to use [Conduit] with a + concrete value created by the user. + + {[ + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let flow = Conduit.abstract Conduit_tcp.t socket in + Conduit.send flow "Hello World!" + ]} + *) + (** {2:resolution Domain name resolvers.} *) type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s diff --git a/lib/e0.ml b/lib/e0.ml index a974be10..eaf3b41b 100644 --- a/lib/e0.ml +++ b/lib/e0.ml @@ -1,7 +1,82 @@ -(* (c) Frédéric Bour *) +(* (c) Frédéric Bour + * (c) Romain Calascibetta *) type ('a, 'b) refl = Refl : ('a, 'a) refl +module Tbl = struct + (* XXX(dinosaure): [Tbl] is a small re-implementation + * of [Hashtbl] where [find_all] is needed by [prj]. To + * avoid an allocation of an intermediate list, we directly + * use the underlying linked-list to do the projection. + * + * This implementation wants to be: + * - deterministic (seed = 0) + * - fast + * + * Memoization is done by [last_k]/[last_v] where the common use + * of [Conduit] is a loop with multiple calls of [send]/[recv] + * with the same [flow] value. + *) + + type 'v t = { + mutable size : int; + mutable data : 'v lst array; + mutable last_k : int; + mutable last_v : 'v; + } + + and 'v lst = Empty | Cons of { key : int; data : 'v; mutable next : 'v lst } + + let rec power_2_above x n = + if x >= n + then x + else if x * 2 > Sys.max_array_length + then x + else power_2_above (x * 2) n + + let create ~epsilon size = + let size = power_2_above 16 size in + { size = 0; data = Array.make size Empty; last_k = 0; last_v = epsilon } + + external caml_hash : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] + + let hash v = caml_hash 10 100 0 v + + let resize t = + let old_data = t.data in + let old_size = Array.length old_data in + let new_size = old_size * 2 in + if new_size < Sys.max_array_length + then ( + let new_data = Array.make new_size Empty in + let new_data_tail = Array.make new_size Empty in + t.data <- new_data ; + let rec insert = function + | Empty -> () + | Cons { key; next; _ } as cell -> + let new_idx = hash key land (new_size - 1) in + (match new_data_tail.(new_idx) with + | Empty -> new_data.(new_idx) <- cell + | Cons tail -> tail.next <- cell) ; + new_data_tail.(new_idx) <- cell ; + insert next in + for i = 0 to old_size - 1 do + insert old_data.(i) + done ; + for i = 0 to new_size - 1 do + match new_data_tail.(i) with + | Empty -> () + | Cons tail -> tail.next <- Empty + done) + + let add t key data = + let i = hash key land (Array.length t.data - 1) in + let v = Cons { key; data; next = t.data.(i) } in + t.data.(i) <- v ; + t.size <- t.size + 1 ; + if t.size > Array.length t.data lsl 1 then resize t +end + module Make (Key : Sigs.FUNCTOR) = struct type t = .. @@ -29,9 +104,11 @@ module Make (Key : Sigs.FUNCTOR) = struct let module B = (val b : S with type x = b) in match A.Id with B.Id -> Some Refl | _ -> None - let handlers = Hashtbl.create 16 + let epsilon _ = raise_notrace Not_found - let witnesses = Hashtbl.create 16 + let handlers = Tbl.create ~epsilon 16 + + let witnesses = Hashtbl.create ~random:false 16 module Injection (X : sig type t @@ -46,13 +123,17 @@ module Make (Key : Sigs.FUNCTOR) = struct let witness = X.witness + let key = Key (witness, fun x -> T x) + + let value x = Value (x, witness) + + let handler = function T x -> value x | _ -> raise_notrace Not_found + let () = let[@warning "-3"] uid = Stdlib.Obj.extension_id [%extension_constructor T] in - Hashtbl.add handlers uid (function - | T x -> Value (x, witness) - | _ -> raise Not_found) ; - Hashtbl.add witnesses uid (Key (witness, fun x -> T x)) + Tbl.add handlers uid handler ; + Hashtbl.add witnesses uid key end let inj (type a) (k : a Key.t) : a s = @@ -62,13 +143,31 @@ module Make (Key : Sigs.FUNCTOR) = struct let witness = k end)) + (* XXX(dinosaure): we ensure that a value [t : t] must have an implementation + * availble into [handlers]. By this way, + * [let[@warning "-8"] Tbl.Cons _ = lst in] is safe where we must find an + * implementation. + *) + + let rec iter t uid lst = + let[@warning "-8"] (Tbl.Cons { key = k; data = f; next = r; _ }) = lst in + try + if uid <> k then raise_notrace Not_found ; + handlers.Tbl.last_v <- f ; + f t + with _ -> (iter [@tailcall]) t uid r + let prj (t : t) = - let rec go = function - | [] -> assert false (* totality *) - | f :: r -> try f t with Not_found -> go r in - go - (Hashtbl.find_all handlers - Stdlib.Obj.((extension_id (extension_constructor t) [@warning "-3"]))) + let arr = handlers.Tbl.data in + let uid = + Stdlib.Obj.((extension_id (extension_constructor t) [@warning "-3"])) + in + if handlers.Tbl.last_k == uid + then handlers.Tbl.last_v t + else + let res = iter t uid arr.(Tbl.hash uid land (Array.length arr - 1)) in + handlers.Tbl.last_k <- uid ; + res let extract (t : t) (type a) ((module S) : a s) : a option = match t with S.T x -> Some x | _ -> None diff --git a/lib/index.mld b/lib/index.mld new file mode 100644 index 00000000..20dc4422 --- /dev/null +++ b/lib/index.mld @@ -0,0 +1,162 @@ +{1 Conduit - an abstraction of protocols.} + +Conduit is a little library to be able to abtract the protocol used to +communicate with a peer. + +{2 Implement a protocol.} + +A Conduit's protocol can be defined as: + +{[ +module type S = sig + type flow + type endpoint + + type error + + val pp_error : error Fmt.t + + val connect : endpoint -> (flow, error) result + val send : flow -> string -> (int, error) result + val recv : flow -> bytes -> (int, error) result + val close : flow -> (unit, error) result +end +]} + +This definition is pretty-close to the [Unix] module: + +{[ +module TCP = struct + type flow = Unix.file_descr + type endpoint = Unix.sockaddr + + type error = (Unix.error * string * string) + + let pp_error (error, call, _) = + Fmt.pf ppf "%s: %s" call (Unix.error_message error) + + let connect sockaddr = + try let socket = Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in + Unix.connect socket sockaddr ; Ok socket + with Unix.Unix_error (err, call, args) -> Error (err, call, args) + + let send socket str = + try + let rec go off len = + let len' = Unix.write_substring socket str off len in + if len' < len then go (off + len') (len - len') in + go 0 (String.length str) ; Ok (String.length str) + with Unix.Unix_error (err, call, args) -> Error (err, call, args) + + let recv socket buf = + try + let len = Unix.read socket 0 (Bytes.length buf) in + if len = 0 then Ok `End_of_flow else Ok (`Input len) + with Unix.Unix_error (err, call, args) -> Error (err, call, args) + + let close socket = + try Unix.close socket ; Ok () + with Unix.Unix_error (err, call, args) -> Error (err, call, args) +]} + +This is an example of how to implement the TCP protocol according the Conduit's +interface {!PROTOCOL}. We concretely define the flow as an [Unix.file_descr] and +the endpoint (the value required to create the flow) as an [Unix.sockaddr]. + +Now, the protocol must be registered into [Conduit] with: + +{[ +let tcp = Conduit.register ~protocol:(module TCP) +]} + +The registration gives to us a {i type-witness} which is a small representation +of our protocol. This value {b must} be exposed to the user: + +{[ +val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol +]} + +As you can see, the value keeps the type of your [endpoint] and the type of your +[flow]. This value is the uniq link to your implementation [TCP]. + +{2 Use a Conduit's protocol.} + +Now, the implementation of our protocol is reachable at any point of your code +with Conduit. The library provides mainly 2 ways to start a transmission: + +{[ +let loopback = Unix.ADDR_INET Unix.inet_addr_loopback + +let socket : Unix.file_descr = Conduit.connect loopback My_protocol.tcp +]} + +It's the usual way when you want to start a TCP transmission. However, in some +cases, you want to start {i "a transmission"} regardless the kind of the +transmission. Conduit provides a {i resolution} mechanism which is able to start +any kind of protocols. + +{3 Resolution.} + +We consider [[ `host ] Domain_name.t] as the most general concrete type to +represent a peer. From it, we can extract the [Unix.sockaddr] such as: + +{[ +let http_resolv domain_name = + match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Some (Unix.INET_ADDR (h_addr_list.(0), 80)) + | _ -> None + | exception _ -> None +]} + +But we can extract (or decide to bind) something else such as a set of TLS +certificates. More generally, the value returned by your resolution is free as +long as a Conduit's protocol can use it to initialise a transmission. + +Then, Conduit defines a [resolvers] which can contains your function such as +[http_resolv] and let the user to bind them to a specific protocol. For example, +we can bind our [http_resolv] with our TCP protocol: + +{[ +let my_resolvers = Conduit.add My_protocol.tcp http_resolv Conduit.empty +]} + +Finally, we can use this value to start {i "a transmission"}: + +{[ +let google = Domain_name.(host_exn (of_string_exn "google.com")) + +let flow : Conduit.flow = Conduit.resolve my_resolvers google +]} + +You can denote that we finally return a {!Conduit.flow} value which is an +abstract type instead to return a concrete [Unix.file_descr] value as before. +From it, you still able to use [send]/[recv] functions with: + +{[ +let hello (flow : Conduit.flow) = + Conduit.send flow "Hello World!" +]} + +But the flow can be an usual TCP transmission or something more complex like a +TLS connection. But all of this complexity is hidden by the abstract type. + +More generally, in some context, it's useful to be abstract over the protocol +used to communicate with a peer. Specially when you have several ways to +communicate with your peer. An example is Git which can communicate with: + +{ul +{- TCP with a [git://] URL.} +{- SSH with a [git@] endpoint.} +{- HTTP with a [http://] URL.} +{- HTTPS with a [https://] URL.}} + +However contents of the transmission is pretty the same betweem all of these +ways. Instead to duplicate the process to communicate with our peer, it could be +better to use one and a full abstract [flow] and be less-aware about the +underlying protocol used - or, at least, shift this responsability to the final +user. + +An other case is about MirageOS which does not assert that the TCP/IP stack - +and the TCP protocol - is available into your unikernel. Of course, the protocol +can exists but it can be replaced by something else. \ No newline at end of file From d4549a2475d7654094f5b8a78034554a53bcd7ef Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Jun 2020 18:50:51 +0200 Subject: [PATCH 045/140] conduit-lwt-unix: require tls 0.12.2+ --- conduit-lwt-unix.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conduit-lwt-unix.opam b/conduit-lwt-unix.opam index c104836f..b7a131de 100644 --- a/conduit-lwt-unix.opam +++ b/conduit-lwt-unix.opam @@ -20,7 +20,7 @@ depends: [ ] depopts: ["tls" "lwt_ssl" "launchd"] conflicts: [ - "tls" {< "0.11.0"} + "tls" {< "0.12.2"} "ssl" {< "0.5.9"} ] build: [ From 3f6438249a5832c6da2a810db56f4ff9cef16f5a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 24 Jun 2020 11:01:14 +0200 Subject: [PATCH 046/140] Add a proper benchmark --- bench/README.md | 44 ++++++++++++++ bench/benchmark.ml | 53 ++++++++++++++++ bench/cost.ml | 76 ++++++++++------------- bench/linear_algebra.ml | 131 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 259 insertions(+), 45 deletions(-) create mode 100644 bench/README.md create mode 100644 bench/benchmark.ml create mode 100644 bench/linear_algebra.ml diff --git a/bench/README.md b/bench/README.md new file mode 100644 index 00000000..94415525 --- /dev/null +++ b/bench/README.md @@ -0,0 +1,44 @@ +## Cost - a little benchmark about injection/projection + +When the user does: +```ocaml +Conduit.connect edn protocol >>= fun flow -> +Conduit.send flow str +``` + +Internally, `conduit` uses an `Hashtbl.t` to get the +protocol implementation. You can see it into [lib/e0.ml]. + +If performances matters, the user can get the protocol +implementation one time with `Conduit.flow`: +```ocaml +Conduit.connect edn protocol >>= fun flow -> +let Conduit.Flow (flow, (module Flow)) = Conduit.flow flow in +Flow.send flow str +``` + +To ensure a small overhead between the first case and the +second case, `conduit` provides a little benchmark to see +the difference: +```sh +$ dune exec bench/cost.exe +with Conduit: 252.20ns (r²: 0.99). +without Conduit: 215.03ns (r²: 0.99). +Overhead: 37.17ns. +``` + +And check that: +- the overhead is stable regardless the number of protocol + implementations available into the global `Hashtbl.t` +- the overhead is small enough not to have performance + regression + +### A use-pattern + +To be fast about projection of the protocol implementation, +`conduit` tweak a bit the implementation of the `Hashtbl.t` +and it proposes a memoization of the last call of `Ptr.prj`. + +If you call several times `Conduit.send`/`Conduit.recv` with +the same flow value, we directly load the protocol +implementation kept into a extra mutable field of the `Hashtbl.t`. diff --git a/bench/benchmark.ml b/bench/benchmark.ml new file mode 100644 index 00000000..ef11a92b --- /dev/null +++ b/bench/benchmark.ml @@ -0,0 +1,53 @@ +external tick : unit -> (int64[@unboxed]) = "none" "get_tick" [@@noalloc] + +type t = V : (unit -> 'a) -> t + +let stabilize_garbage_collector () = + let rec go limit last_heap_live_words = + if limit <= 0 + then failwith "Unable to stabilize the number of live words in the heap" ; + Gc.compact () ; + let stat = Gc.stat () in + if stat.Gc.live_words <> last_heap_live_words + then go (pred limit) stat.Gc.live_words in + go 10 0 + +let runnable f i = + for _ = 1 to i do + ignore @@ Sys.opaque_identity (f ()) + done + [@@inline] + +let samples = 1000 + +let run t = + let idx = ref 0 in + let run = ref 0 in + let (V fn) = t in + + let m = Array.create_float (samples * 2) in + + stabilize_garbage_collector () ; + + while !idx < samples do + let current_run = !run in + let current_idx = !idx in + + let time_0 = tick () in + + runnable fn current_run ; + + let time_1 = tick () in + + m.((current_idx * 2) + 0) <- float_of_int current_run ; + m.((current_idx * 2) + 1) <- Int64.to_float (Int64.sub time_1 time_0) ; + + let next = + (max : int -> int -> int) + (int_of_float (float_of_int current_run *. 1.01)) + (succ current_run) in + run := next ; + incr idx + done ; + + Array.init samples (fun i -> [| m.((i * 2) + 0); m.((i * 2) + 1) |]) diff --git a/bench/cost.ml b/bench/cost.ml index d76873dd..e17c174f 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -10,8 +10,6 @@ end module Tuyau = Conduit.Make (None) (Bytes) (String) -let t1 = ref 0L - module Fake_protocol0 = struct type input = bytes @@ -31,9 +29,10 @@ module Fake_protocol0 = struct let recv _ _ = Ok `End_of_flow - let send fd v = - t1 := tick () ; - let _ = Unix.write_substring fd v 0 (String.length v) in + let send _ _ = + for _ = 0 to 500 do + () + done ; Ok 0 let close _ = Ok () @@ -95,47 +94,34 @@ let fake2 = Tuyau.register ~protocol:(module Fake_protocol2) let hello_world = "Hello World!\n" -let fully_abstr () = - let open Rresult in - Tuyau.connect Unix.stderr fake0 >>= fun flow -> - let t0 = tick () in - Tuyau.send flow hello_world >>= fun _len -> - let t3 = Int64.sub (tick ()) !t1 in - let t2 = tick () in - Tuyau.send flow hello_world >>= fun _len -> - R.ok (Int64.sub !t1 t0, t3, Int64.sub !t1 t2) - -let abstr () = +let fn_fully_abstr flow = Benchmark.V (fun () -> Tuyau.send flow hello_world) + +let fn_abstr (Tuyau.Flow (flow, (module Flow))) = + Benchmark.V (fun () -> Flow.send flow hello_world) + +let run () = let open Rresult in - let module Protocol = (val Tuyau.impl fake0) in Tuyau.connect Unix.stderr fake0 >>= fun flow -> - let (Tuyau.Flow (flow, (module Flow))) = Tuyau.flow flow in - let t0 = tick () in - Flow.send flow hello_world |> R.reword_error (R.msgf "%a" Flow.pp_error) - >>= fun _len -> - let t3 = Int64.sub (tick ()) !t1 in - let t2 = tick () in - Flow.send flow hello_world |> R.reword_error (R.msgf "%a" Flow.pp_error) - >>= fun _len -> R.ok (Int64.sub !t1 t0, t3, Int64.sub !t1 t2) - -let concrete () = - let t0 = tick () in - let _ = - Unix.write_substring Unix.stderr hello_world 0 (String.length hello_world) - in - let t1 = tick () in - Ok (Int64.sub t1 t0) + Tuyau.send flow hello_world >>= fun _ -> + let samples0 = Benchmark.run (fn_fully_abstr flow) in + let samples1 = Benchmark.run (fn_abstr (Tuyau.flow flow)) in + + match + ( Linear_algebra.ols (fun m -> m.(1)) [| (fun m -> m.(0)) |] samples0, + Linear_algebra.ols (fun m -> m.(1)) [| (fun m -> m.(0)) |] samples1 ) + with + | Ok (estimate0, r0), Ok (estimate1, r1) -> + Fmt.pr "with Conduit:\t\t%fns (r²: %f).\n%!" estimate0.(0) r0 ; + Fmt.pr "without Conduit:\t%fns (r²: %f).\n%!" estimate1.(0) r1 ; + if r0 >= 0.99 && r1 >= 0.99 + then Fmt.pr "Overhead:\t\t%fns.\n%!" (estimate0.(0) -. estimate1.(0)) + else Fmt.epr "Bad regression coefficients!\n%!" ; + Ok () + | Error err, _ -> Error err + | _, Error err -> Error err let () = - let _ = - Unix.write_substring Unix.stderr hello_world 0 (String.length hello_world) - in - let[@warning "-8"] (Ok ts) = concrete () in - t1 := 0L ; - let[@warning "-8"] (Ok (ts0, ts1, ts2)) = fully_abstr () in - t1 := 0L ; - let[@warning "-8"] (Ok (tsa, tsb, tsc)) = abstr () in - t1 := 0L ; - Fmt.pr "fully-abstr:\t%Ldns, %Ldns, %Ldns.\n%!" ts0 ts1 ts2 ; - Fmt.pr "abstr:\t\t%Ldns, %Ldns, %Ldns.\n%!" tsa tsb tsc ; - Fmt.pr "concrete:\t%Ldns.\n%!" ts + match run () with + | Ok v -> v + | Error (`Msg err) -> Fmt.epr "%s: %s.\n%!" Sys.argv.(0) err + | Error `Not_found -> assert false diff --git a/bench/linear_algebra.ml b/bench/linear_algebra.ml new file mode 100644 index 00000000..b1bdc86f --- /dev/null +++ b/bench/linear_algebra.ml @@ -0,0 +1,131 @@ +(* Code under Apache License 2.0 - Jane Street Group, LLC *) + +let col_norm a column = + let acc = ref 0. in + for i = 0 to Array.length a - 1 do + let entry = a.(i).(column) in + acc := !acc +. (entry *. entry) + done ; + sqrt !acc + +let col_inner_prod t j1 j2 = + let acc = ref 0. in + for i = 0 to Array.length t - 1 do + acc := !acc +. (t.(i).(j1) *. t.(i).(j2)) + done ; + !acc + +let qr_in_place a = + let m = Array.length a in + if m = 0 + then ([||], [||]) + else + let n = Array.length a.(0) in + let r = Array.make_matrix n n 0. in + for j = 0 to n - 1 do + let alpha = col_norm a j in + r.(j).(j) <- alpha ; + let one_over_alpha = 1. /. alpha in + for i = 0 to m - 1 do + a.(i).(j) <- a.(i).(j) *. one_over_alpha + done ; + for j2 = j + 1 to n - 1 do + let c = col_inner_prod a j j2 in + r.(j).(j2) <- c ; + for i = 0 to m - 1 do + a.(i).(j2) <- a.(i).(j2) -. (c *. a.(i).(j)) + done + done + done ; + (a, r) + +let qr ?(in_place = false) a = + let a = if in_place then a else Array.map Array.copy a in + qr_in_place a + +let mul_mv ?(trans = false) a x = + let rows = Array.length a in + if rows = 0 + then [||] + else + let cols = Array.length a.(0) in + let m, n, get = + if trans + then + let get i j = a.(j).(i) in + (cols, rows, get) + else + let get i j = a.(i).(j) in + (rows, cols, get) in + if n <> Array.length x then failwith "Dimension mismatch" ; + let result = Array.make m 0. in + for i = 0 to m - 1 do + let v, _ = + Array.fold_left + (fun (acc, j) x -> (acc +. (get i j *. x), succ j)) + (0., 0) x in + result.(i) <- v + done ; + result + +let is_nan v = match classify_float v with FP_nan -> true | _ -> false + +let error_msg msg = Error (`Msg msg) + +let triu_solve r b = + let m = Array.length b in + if m <> Array.length r + then + error_msg + "triu_solve R b requires R to be square with same number of rows as b" + else if m = 0 + then Ok [||] + else if m <> Array.length r.(0) + then error_msg "triu_solve R b requires R to be a square" + else + let sol = Array.copy b in + for i = m - 1 downto 0 do + sol.(i) <- sol.(i) /. r.(i).(i) ; + for j = 0 to i - 1 do + sol.(j) <- sol.(j) -. (r.(j).(i) *. sol.(i)) + done + done ; + if Array.exists is_nan sol + then error_msg "triu_solve detected NaN result" + else Ok sol + +let ols ?(in_place = false) a b = + let q, r = qr ~in_place a in + triu_solve r (mul_mv ~trans:true q b) + +let make_lr_inputs responder predictors m = + ( Array.init (Array.length m) (fun i -> + Array.map (fun a -> a m.(i)) predictors), + Array.init (Array.length m) (fun i -> responder m.(i)) ) + +let r_square m responder predictors r = + let predictors_matrix, responder_vector = + make_lr_inputs responder predictors m in + let sum_responder = Array.fold_left ( +. ) 0. responder_vector in + let mean = sum_responder /. float (Array.length responder_vector) in + let tot_ss = ref 0. in + let res_ss = ref 0. in + let predicted i = + let x = ref 0. in + for j = 0 to Array.length r - 1 do + x := !x +. (predictors_matrix.(i).(j) *. r.(j)) + done ; + !x in + for i = 0 to Array.length responder_vector - 1 do + tot_ss := !tot_ss +. ((responder_vector.(i) -. mean) ** 2.) ; + res_ss := !res_ss +. ((responder_vector.(i) -. predicted i) ** 2.) + done ; + 1. -. (!res_ss /. !tot_ss) + +let ols responder predictors m = + let matrix, vector = make_lr_inputs responder predictors m in + match ols ~in_place:true matrix vector with + | Ok estimates -> + let r_square = r_square m responder predictors estimates in + Ok (estimates, r_square) + | Error _ as err -> err From 1f6936f223a598d4d9515beb55efc034c54e592a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 24 Jun 2020 15:14:12 +0200 Subject: [PATCH 047/140] Add conduit-mirage.flow sub-package --- mirage/conduit_mirage_flow.ml | 41 ++++++++++++++++++++++++++++++++++ mirage/conduit_mirage_flow.mli | 18 +++++++++++++++ mirage/dune | 6 +++++ 3 files changed, 65 insertions(+) create mode 100644 mirage/conduit_mirage_flow.ml create mode 100644 mirage/conduit_mirage_flow.mli diff --git a/mirage/conduit_mirage_flow.ml b/mirage/conduit_mirage_flow.ml new file mode 100644 index 00000000..e68d3e16 --- /dev/null +++ b/mirage/conduit_mirage_flow.ml @@ -0,0 +1,41 @@ +open Lwt.Infix + +type flow = Conduit_mirage.flow + +type error = Conduit_mirage.error + +type write_error = [ Mirage_flow.write_error | Conduit_mirage.error ] + +let pp_error = Conduit_mirage.pp_error + +let pp_write_error ppf = function + | #Mirage_flow.write_error as err -> Mirage_flow.pp_write_error ppf err + | #Conduit_mirage.error as err -> Conduit_mirage.pp_error ppf err + +let read flow = + let raw = Cstruct.create 0x1000 in + Conduit_mirage.recv flow raw >>= function + | Ok `End_of_flow -> Lwt.return_ok `Eof + | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) + | Error _ as err -> Lwt.return err + +let write flow raw = + let rec go x = + if Cstruct.len x = 0 + then Lwt.return_ok () + else + Conduit_mirage.send flow x >>= function + | Error _ as err -> Lwt.return err + | Ok len -> go (Cstruct.shift x len) in + go raw + +let writev flow cs = + let rec go = function + | [] -> Lwt.return_ok () + | x :: r -> ( + write flow x >>= function + | Ok () -> go r + | Error _ as err -> Lwt.return err) in + go cs + +let close flow = Conduit_mirage.close flow >>= fun _ -> Lwt.return_unit diff --git a/mirage/conduit_mirage_flow.mli b/mirage/conduit_mirage_flow.mli new file mode 100644 index 00000000..1135b37d --- /dev/null +++ b/mirage/conduit_mirage_flow.mli @@ -0,0 +1,18 @@ +(** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. + This module is deprecated when the current implementation of [read] has + another behaviour: + + [conduit] provides: + + {[ val read : flow -> Cstruct.t -> (int or_eoi, error) result Lwt.t ]} + + where [mirage-flow] expects: + + {[ val read : flow -> (Cstruct.t or_eoi, error) result Lwt.t ]} + + This current implementation allocates an {b arbitrary} 4096 bytes buffer to + fit under the [mirage-flow] interface. [conduit] did the choice to follow + the POSIX interface and let the end-user to allocate by himself the input + buffer. *) + +include Mirage_flow.S with type flow = Conduit_mirage.flow diff --git a/mirage/dune b/mirage/dune index 75abaf27..a4193405 100644 --- a/mirage/dune +++ b/mirage/dune @@ -15,3 +15,9 @@ (public_name conduit-mirage.dns) (modules conduit_mirage_dns) (libraries conduit-mirage dns-client.mirage)) + +(library + (name conduit_mirage_flow) + (public_name conduit-mirage.flow) + (modules conduit_mirage_flow) + (libraries conduit-mirage mirage-flow)) From 42159017e8a1e029bf898ed77b623fda9b3e24c6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 24 Jun 2020 15:25:58 +0200 Subject: [PATCH 048/140] Add Conduit_lwt.io_of_flow --- lwt/conduit_lwt.mli | 3 +++ lwt/internal.ml | 31 +++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/lwt/conduit_lwt.mli b/lwt/conduit_lwt.mli index 0a3b9ba9..8a9bcb37 100644 --- a/lwt/conduit_lwt.mli +++ b/lwt/conduit_lwt.mli @@ -6,6 +6,9 @@ include and type output = Cstruct.t and type +'a s = 'a Lwt.t +val io_of_flow : + flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel + val serve_with_handler : handler:('flow -> unit Lwt.t) -> service:('cfg, 'master, 'flow) Service.service -> diff --git a/lwt/internal.ml b/lwt/internal.ml index 9b023570..53cc4a0f 100644 --- a/lwt/internal.ml +++ b/lwt/internal.ml @@ -10,6 +10,37 @@ include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt +let io_of_flow flow = + let open Lwt.Infix in + let ic_closed = ref false and oc_closed = ref false in + let close () = + if !ic_closed && !oc_closed + then + close flow >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" pp_error err + else Lwt.return_unit in + let ic_close () = + ic_closed := true ; + close () in + let oc_close () = + oc_closed := true ; + close () in + let recv buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + recv flow raw >>= function + | Ok (`Input len) -> Lwt.return len + | Ok `End_of_flow -> Lwt.return 0 + | Error err -> failwith "%a" pp_error err in + let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in + let send buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + send flow raw >>= function + | Ok len -> Lwt.return len + | Error err -> failwith "%a" pp_error err in + let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in + (ic, oc) + let ( >>? ) = Lwt_result.bind let serve_with_handler : From e214f5ee24cdf5f9e1ff28d8f0a0f8c673853c99 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 15:04:17 +0200 Subject: [PATCH 049/140] Move librairies in their own directory --- .gitignore | 1 + async/dune | 17 -------------- lwt/dune | 23 ------------------- {async => src/async-ssl}/conduit_async_ssl.ml | 0 .../async-ssl}/conduit_async_ssl.mli | 0 src/async-ssl/dune | 4 ++++ {async => src/async-tls}/conduit_async_tls.ml | 0 .../async-tls}/conduit_async_tls.mli | 0 src/async-tls/dune | 4 ++++ {async => src/async}/conduit_async.ml | 0 {async => src/async}/conduit_async.mli | 0 src/async/dune | 4 ++++ {async => src/async}/internal.ml | 0 {async => src/async}/tCP.ml | 0 {lib => src/core}/README.md | 0 {lib => src/core}/conduit.ml | 0 {lib => src/core}/conduit.mli | 0 {lib => src/core}/dune | 0 {lib => src/core}/e0.ml | 0 {lib => src/core}/e0.mli | 0 {lib => src/core}/e1.ml | 0 {lib => src/core}/e1.mli | 0 {lib => src/core}/index.mld | 0 {lib => src/core}/sigs.ml | 0 {lwt => src/lwt-ssl}/conduit_lwt_ssl.ml | 0 {lwt => src/lwt-ssl}/conduit_lwt_ssl.mli | 0 src/lwt-ssl/dune | 4 ++++ {lwt => src/lwt-tls}/conduit_lwt_tls.ml | 0 {lwt => src/lwt-tls}/conduit_lwt_tls.mli | 0 src/lwt-tls/dune | 4 ++++ {lwt => src/lwt}/conduit_lwt.ml | 0 {lwt => src/lwt}/conduit_lwt.mli | 0 src/lwt/dune | 4 ++++ {lwt => src/lwt}/internal.ml | 0 {lwt => src/lwt}/tCP.ml | 0 {lwt => src/mirage}/conduit_lwt_flow.ml | 0 {lwt => src/mirage}/conduit_lwt_flow.mli | 0 {mirage => src/mirage}/conduit_mirage.ml | 0 {mirage => src/mirage}/conduit_mirage.mli | 0 {mirage => src/mirage}/conduit_mirage_dns.ml | 0 {mirage => src/mirage}/conduit_mirage_dns.mli | 0 {mirage => src/mirage}/conduit_mirage_flow.ml | 0 .../mirage}/conduit_mirage_flow.mli | 0 {mirage => src/mirage}/conduit_mirage_tcp.ml | 0 {mirage => src/mirage}/conduit_mirage_tcp.mli | 0 {mirage => src/mirage}/dune | 0 {tls => src/tls}/conduit_tls.ml | 0 {tls => src/tls}/conduit_tls.mli | 0 {tls => src/tls}/dune | 0 49 files changed, 25 insertions(+), 40 deletions(-) delete mode 100644 async/dune delete mode 100644 lwt/dune rename {async => src/async-ssl}/conduit_async_ssl.ml (100%) rename {async => src/async-ssl}/conduit_async_ssl.mli (100%) create mode 100644 src/async-ssl/dune rename {async => src/async-tls}/conduit_async_tls.ml (100%) rename {async => src/async-tls}/conduit_async_tls.mli (100%) create mode 100644 src/async-tls/dune rename {async => src/async}/conduit_async.ml (100%) rename {async => src/async}/conduit_async.mli (100%) create mode 100644 src/async/dune rename {async => src/async}/internal.ml (100%) rename {async => src/async}/tCP.ml (100%) rename {lib => src/core}/README.md (100%) rename {lib => src/core}/conduit.ml (100%) rename {lib => src/core}/conduit.mli (100%) rename {lib => src/core}/dune (100%) rename {lib => src/core}/e0.ml (100%) rename {lib => src/core}/e0.mli (100%) rename {lib => src/core}/e1.ml (100%) rename {lib => src/core}/e1.mli (100%) rename {lib => src/core}/index.mld (100%) rename {lib => src/core}/sigs.ml (100%) rename {lwt => src/lwt-ssl}/conduit_lwt_ssl.ml (100%) rename {lwt => src/lwt-ssl}/conduit_lwt_ssl.mli (100%) create mode 100644 src/lwt-ssl/dune rename {lwt => src/lwt-tls}/conduit_lwt_tls.ml (100%) rename {lwt => src/lwt-tls}/conduit_lwt_tls.mli (100%) create mode 100644 src/lwt-tls/dune rename {lwt => src/lwt}/conduit_lwt.ml (100%) rename {lwt => src/lwt}/conduit_lwt.mli (100%) create mode 100644 src/lwt/dune rename {lwt => src/lwt}/internal.ml (100%) rename {lwt => src/lwt}/tCP.ml (100%) rename {lwt => src/mirage}/conduit_lwt_flow.ml (100%) rename {lwt => src/mirage}/conduit_lwt_flow.mli (100%) rename {mirage => src/mirage}/conduit_mirage.ml (100%) rename {mirage => src/mirage}/conduit_mirage.mli (100%) rename {mirage => src/mirage}/conduit_mirage_dns.ml (100%) rename {mirage => src/mirage}/conduit_mirage_dns.mli (100%) rename {mirage => src/mirage}/conduit_mirage_flow.ml (100%) rename {mirage => src/mirage}/conduit_mirage_flow.mli (100%) rename {mirage => src/mirage}/conduit_mirage_tcp.ml (100%) rename {mirage => src/mirage}/conduit_mirage_tcp.mli (100%) rename {mirage => src/mirage}/dune (100%) rename {tls => src/tls}/conduit_tls.ml (100%) rename {tls => src/tls}/conduit_tls.mli (100%) rename {tls => src/tls}/dune (100%) diff --git a/.gitignore b/.gitignore index 4f4239ac..03dd8e0f 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ _opam/ .*.swp *.install .merlin +*~ diff --git a/async/dune b/async/dune deleted file mode 100644 index 75512b5e..00000000 --- a/async/dune +++ /dev/null @@ -1,17 +0,0 @@ -(library - (name conduit_async) - (public_name conduit-async) - (modules conduit_async internal tCP) - (libraries cstruct async conduit)) - -(library - (name conduit_async_tls) - (public_name conduit-async-tls) - (modules conduit_async_tls) - (libraries conduit-tls conduit-async)) - -(library - (name conduit_async_ssl) - (public_name conduit-async-ssl) - (modules conduit_async_ssl) - (libraries core async_ssl conduit-async)) diff --git a/lwt/dune b/lwt/dune deleted file mode 100644 index 08ecde8b..00000000 --- a/lwt/dune +++ /dev/null @@ -1,23 +0,0 @@ -(library - (name conduit_lwt) - (public_name conduit-lwt) - (modules conduit_lwt internal tCP) - (libraries cstruct lwt lwt.unix conduit)) - -(library - (name conduit_lwt_ssl) - (public_name conduit-lwt-ssl) - (modules conduit_lwt_ssl) - (libraries conduit-lwt lwt_ssl)) - -(library - (name conduit_lwt_tls) - (public_name conduit-lwt-tls) - (modules conduit_lwt_tls) - (libraries conduit-lwt conduit-tls)) - -(library - (name conduit_lwt_flow) - (public_name conduit-lwt.flow) - (modules conduit_lwt_flow) - (libraries conduit-lwt mirage-flow)) diff --git a/async/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml similarity index 100% rename from async/conduit_async_ssl.ml rename to src/async-ssl/conduit_async_ssl.ml diff --git a/async/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli similarity index 100% rename from async/conduit_async_ssl.mli rename to src/async-ssl/conduit_async_ssl.mli diff --git a/src/async-ssl/dune b/src/async-ssl/dune new file mode 100644 index 00000000..1df7a0f9 --- /dev/null +++ b/src/async-ssl/dune @@ -0,0 +1,4 @@ +(library + (name conduit_async_ssl) + (public_name conduit-async-ssl) + (libraries core async_ssl conduit-async)) diff --git a/async/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml similarity index 100% rename from async/conduit_async_tls.ml rename to src/async-tls/conduit_async_tls.ml diff --git a/async/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli similarity index 100% rename from async/conduit_async_tls.mli rename to src/async-tls/conduit_async_tls.mli diff --git a/src/async-tls/dune b/src/async-tls/dune new file mode 100644 index 00000000..55464ea5 --- /dev/null +++ b/src/async-tls/dune @@ -0,0 +1,4 @@ +(library + (name conduit_async_tls) + (public_name conduit-async-tls) + (libraries conduit-tls conduit-async)) diff --git a/async/conduit_async.ml b/src/async/conduit_async.ml similarity index 100% rename from async/conduit_async.ml rename to src/async/conduit_async.ml diff --git a/async/conduit_async.mli b/src/async/conduit_async.mli similarity index 100% rename from async/conduit_async.mli rename to src/async/conduit_async.mli diff --git a/src/async/dune b/src/async/dune new file mode 100644 index 00000000..1e77f437 --- /dev/null +++ b/src/async/dune @@ -0,0 +1,4 @@ +(library + (name conduit_async) + (public_name conduit-async) + (libraries cstruct async conduit)) diff --git a/async/internal.ml b/src/async/internal.ml similarity index 100% rename from async/internal.ml rename to src/async/internal.ml diff --git a/async/tCP.ml b/src/async/tCP.ml similarity index 100% rename from async/tCP.ml rename to src/async/tCP.ml diff --git a/lib/README.md b/src/core/README.md similarity index 100% rename from lib/README.md rename to src/core/README.md diff --git a/lib/conduit.ml b/src/core/conduit.ml similarity index 100% rename from lib/conduit.ml rename to src/core/conduit.ml diff --git a/lib/conduit.mli b/src/core/conduit.mli similarity index 100% rename from lib/conduit.mli rename to src/core/conduit.mli diff --git a/lib/dune b/src/core/dune similarity index 100% rename from lib/dune rename to src/core/dune diff --git a/lib/e0.ml b/src/core/e0.ml similarity index 100% rename from lib/e0.ml rename to src/core/e0.ml diff --git a/lib/e0.mli b/src/core/e0.mli similarity index 100% rename from lib/e0.mli rename to src/core/e0.mli diff --git a/lib/e1.ml b/src/core/e1.ml similarity index 100% rename from lib/e1.ml rename to src/core/e1.ml diff --git a/lib/e1.mli b/src/core/e1.mli similarity index 100% rename from lib/e1.mli rename to src/core/e1.mli diff --git a/lib/index.mld b/src/core/index.mld similarity index 100% rename from lib/index.mld rename to src/core/index.mld diff --git a/lib/sigs.ml b/src/core/sigs.ml similarity index 100% rename from lib/sigs.ml rename to src/core/sigs.ml diff --git a/lwt/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml similarity index 100% rename from lwt/conduit_lwt_ssl.ml rename to src/lwt-ssl/conduit_lwt_ssl.ml diff --git a/lwt/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli similarity index 100% rename from lwt/conduit_lwt_ssl.mli rename to src/lwt-ssl/conduit_lwt_ssl.mli diff --git a/src/lwt-ssl/dune b/src/lwt-ssl/dune new file mode 100644 index 00000000..77aa64a4 --- /dev/null +++ b/src/lwt-ssl/dune @@ -0,0 +1,4 @@ +(library + (name conduit_lwt_ssl) + (public_name conduit-lwt-ssl) + (libraries conduit-lwt lwt_ssl)) diff --git a/lwt/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml similarity index 100% rename from lwt/conduit_lwt_tls.ml rename to src/lwt-tls/conduit_lwt_tls.ml diff --git a/lwt/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli similarity index 100% rename from lwt/conduit_lwt_tls.mli rename to src/lwt-tls/conduit_lwt_tls.mli diff --git a/src/lwt-tls/dune b/src/lwt-tls/dune new file mode 100644 index 00000000..f896114f --- /dev/null +++ b/src/lwt-tls/dune @@ -0,0 +1,4 @@ +(library + (name conduit_lwt_tls) + (public_name conduit-lwt-tls) + (libraries conduit-lwt conduit-tls)) diff --git a/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml similarity index 100% rename from lwt/conduit_lwt.ml rename to src/lwt/conduit_lwt.ml diff --git a/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli similarity index 100% rename from lwt/conduit_lwt.mli rename to src/lwt/conduit_lwt.mli diff --git a/src/lwt/dune b/src/lwt/dune new file mode 100644 index 00000000..ccb9d936 --- /dev/null +++ b/src/lwt/dune @@ -0,0 +1,4 @@ +(library + (name conduit_lwt) + (public_name conduit-lwt) + (libraries cstruct lwt lwt.unix conduit)) diff --git a/lwt/internal.ml b/src/lwt/internal.ml similarity index 100% rename from lwt/internal.ml rename to src/lwt/internal.ml diff --git a/lwt/tCP.ml b/src/lwt/tCP.ml similarity index 100% rename from lwt/tCP.ml rename to src/lwt/tCP.ml diff --git a/lwt/conduit_lwt_flow.ml b/src/mirage/conduit_lwt_flow.ml similarity index 100% rename from lwt/conduit_lwt_flow.ml rename to src/mirage/conduit_lwt_flow.ml diff --git a/lwt/conduit_lwt_flow.mli b/src/mirage/conduit_lwt_flow.mli similarity index 100% rename from lwt/conduit_lwt_flow.mli rename to src/mirage/conduit_lwt_flow.mli diff --git a/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml similarity index 100% rename from mirage/conduit_mirage.ml rename to src/mirage/conduit_mirage.ml diff --git a/mirage/conduit_mirage.mli b/src/mirage/conduit_mirage.mli similarity index 100% rename from mirage/conduit_mirage.mli rename to src/mirage/conduit_mirage.mli diff --git a/mirage/conduit_mirage_dns.ml b/src/mirage/conduit_mirage_dns.ml similarity index 100% rename from mirage/conduit_mirage_dns.ml rename to src/mirage/conduit_mirage_dns.ml diff --git a/mirage/conduit_mirage_dns.mli b/src/mirage/conduit_mirage_dns.mli similarity index 100% rename from mirage/conduit_mirage_dns.mli rename to src/mirage/conduit_mirage_dns.mli diff --git a/mirage/conduit_mirage_flow.ml b/src/mirage/conduit_mirage_flow.ml similarity index 100% rename from mirage/conduit_mirage_flow.ml rename to src/mirage/conduit_mirage_flow.ml diff --git a/mirage/conduit_mirage_flow.mli b/src/mirage/conduit_mirage_flow.mli similarity index 100% rename from mirage/conduit_mirage_flow.mli rename to src/mirage/conduit_mirage_flow.mli diff --git a/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml similarity index 100% rename from mirage/conduit_mirage_tcp.ml rename to src/mirage/conduit_mirage_tcp.ml diff --git a/mirage/conduit_mirage_tcp.mli b/src/mirage/conduit_mirage_tcp.mli similarity index 100% rename from mirage/conduit_mirage_tcp.mli rename to src/mirage/conduit_mirage_tcp.mli diff --git a/mirage/dune b/src/mirage/dune similarity index 100% rename from mirage/dune rename to src/mirage/dune diff --git a/tls/conduit_tls.ml b/src/tls/conduit_tls.ml similarity index 100% rename from tls/conduit_tls.ml rename to src/tls/conduit_tls.ml diff --git a/tls/conduit_tls.mli b/src/tls/conduit_tls.mli similarity index 100% rename from tls/conduit_tls.mli rename to src/tls/conduit_tls.mli diff --git a/tls/dune b/src/tls/dune similarity index 100% rename from tls/dune rename to src/tls/dune From a4a22fe2da8140fa25805840db23022baded1b34 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 15:44:20 +0200 Subject: [PATCH 050/140] Minor naming cleanup - Change Scheduler -> IO to match the convetion of the rest of MirageOS projects - Hide a few internal signature which are not useful for users of conduit - Rename `Service.make` and `Service.serve` into `Service.init` - Rename Flow.flow into Flow.unpack (and rename the Flow.pack type into Flow.unpack) - Rename Flow.abstract into Flow.pack - Rename Flow.is into Flow.cast - Rename Conduit.Service.SERVICE into Conduit.SERVICE - Rename X.serve_with_handler into X.serve --- bench/cost.ml | 8 +- src/async-ssl/conduit_async_ssl.ml | 10 +-- src/async-tls/conduit_async_tls.ml | 2 +- src/async/conduit_async.mli | 9 +-- src/async/internal.ml | 8 +- src/async/tCP.ml | 6 +- src/core/conduit.ml | 125 +++++++++++++++++------------ src/core/conduit.mli | 67 ++++++++-------- src/core/e0.ml | 6 +- src/core/e0.mli | 6 +- src/core/e1.ml | 6 +- src/core/e1.mli | 6 +- src/core/sigs.ml | 75 +++++------------ src/lwt-ssl/conduit_lwt_ssl.ml | 10 +-- src/lwt-tls/conduit_lwt_tls.ml | 2 +- src/lwt/conduit_lwt.mli | 16 ++-- src/lwt/internal.ml | 8 +- src/lwt/tCP.ml | 6 +- src/mirage/conduit_mirage.ml | 8 +- src/mirage/conduit_mirage.mli | 6 +- src/mirage/conduit_mirage_tcp.ml | 6 +- src/tls/conduit_tls.ml | 33 +++----- src/tls/conduit_tls.mli | 4 +- tests/common.ml | 32 ++++---- tests/flow.ml | 4 +- tests/resolvers.ml | 2 +- 26 files changed, 236 insertions(+), 235 deletions(-) diff --git a/bench/cost.ml b/bench/cost.ml index e17c174f..be91e6ce 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -15,7 +15,7 @@ module Fake_protocol0 = struct and output = string - and +'a s = 'a + and +'a io = 'a type endpoint = Unix.file_descr @@ -43,7 +43,7 @@ module Fake_protocol1 = struct and output = string - and +'a s = 'a + and +'a io = 'a type endpoint = Unix.file_descr @@ -67,7 +67,7 @@ module Fake_protocol2 = struct and output = string - and +'a s = 'a + and +'a io = 'a type endpoint = Unix.file_descr @@ -104,7 +104,7 @@ let run () = Tuyau.connect Unix.stderr fake0 >>= fun flow -> Tuyau.send flow hello_world >>= fun _ -> let samples0 = Benchmark.run (fn_fully_abstr flow) in - let samples1 = Benchmark.run (fn_abstr (Tuyau.flow flow)) in + let samples1 = Benchmark.run (fn_abstr (Tuyau.unpack flow)) in match ( Linear_algebra.ols (fun m -> m.(1)) [| (fun m -> m.(0)) |] samples0, diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index 2612e9c0..94acc2a3 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -89,7 +89,7 @@ struct type output = Cstruct.t - type +'a s = 'a Async.Deferred.t + type +'a io = 'a Async.Deferred.t type endpoint = context * Protocol.endpoint @@ -192,14 +192,14 @@ let protocol_with_ssl : Conduit_async.register ~protocol:(module M) module Make (Service : sig - include Conduit_async.Service.SERVICE + include Conduit_async.SERVICE val reader : flow -> Reader.t val writer : flow -> Writer.t end) = struct - type +'a s = 'a Async.Deferred.t + type +'a io = 'a Async.Deferred.t type error = | Service of Service.error @@ -218,12 +218,12 @@ struct type flow = Service.flow with_ssl - let make (context, edn) = + let init (context, edn) = match (context.crt_file, context.key_file) with | None, None | Some _, None | None, Some _ -> Async.return (Error Missing_crt_or_key) | _ -> ( - Service.make edn >>= function + Service.init edn >>= function | Ok t -> Async.return (Ok (context, t)) | Error err -> Async.return (Error (Service err))) diff --git a/src/async-tls/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml index ac3aca37..f4eae035 100644 --- a/src/async-tls/conduit_async_tls.ml +++ b/src/async-tls/conduit_async_tls.ml @@ -1,5 +1,5 @@ open Async -include Conduit_tls.Make (Conduit_async.Async_scheduler) (Conduit_async) +include Conduit_tls.Make (Conduit_async.IO) (Conduit_async) module TCP = struct open Conduit_async.TCP diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 12487f9e..93396757 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -2,16 +2,15 @@ open Async_unix -module Async_scheduler : - Conduit.Sigs.SCHEDULER with type +'a t = 'a Async.Deferred.t +module IO : Conduit.IO with type +'a t = 'a Async.Deferred.t include Conduit.S with type input = Cstruct.t and type output = Cstruct.t - and type +'a s = 'a Async.Deferred.t + and type +'a io = 'a Async.Deferred.t -val serve_with_handler : +val serve : handler:('flow -> unit Async.Deferred.t) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> @@ -40,7 +39,7 @@ module TCP : sig type configuration = | Listen : ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration - module Server : Service.SERVICE with type configuration = configuration + module Server : SERVICE with type configuration = configuration val service : (configuration, Server.t, Protocol.flow) Service.service diff --git a/src/async/internal.ml b/src/async/internal.ml index a3b22de1..39882b6e 100644 --- a/src/async/internal.ml +++ b/src/async/internal.ml @@ -1,4 +1,4 @@ -module Async_scheduler = struct +module IO = struct type +'a t = 'a Async.Deferred.t let bind x f = Async.Deferred.bind x ~f @@ -6,13 +6,13 @@ module Async_scheduler = struct let return x = Async.Deferred.return x end -include Conduit.Make (Async_scheduler) (Cstruct) (Cstruct) +include Conduit.Make (IO) (Cstruct) (Cstruct) let failwith fmt = Format.kasprintf failwith fmt let ( >>? ) x f = Async.Deferred.Result.bind x ~f -let serve_with_handler : +let serve : type cfg master flow. handler:(flow -> unit Async.Deferred.t) -> service:(cfg, master, flow) Service.service -> @@ -23,7 +23,7 @@ let serve_with_handler : let stop = Async.Condition.create () in let module Svc = (val Service.impl service) in let main = - Service.serve cfg ~service >>= function + Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err | Ok master -> ( let rec loop () = diff --git a/src/async/tCP.ml b/src/async/tCP.ml index 7ee605d2..a84b50cd 100644 --- a/src/async/tCP.ml +++ b/src/async/tCP.ml @@ -8,7 +8,7 @@ module Protocol = struct type output = Cstruct.t - type +'a s = 'a Async.Deferred.t + type +'a io = 'a Async.Deferred.t type flow = | Socket : { @@ -89,7 +89,7 @@ let protocol = Internal.register ~protocol:(module Protocol) type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration module Server = struct - type +'a s = 'a Async.Deferred.t + type +'a io = 'a Async.Deferred.t type flow = Protocol.flow @@ -124,7 +124,7 @@ module Server = struct let ( >>? ) x f = x >>= function Ok x -> f x | Error _ as err -> Async.return err - let make (Listen where_to_listen) = + let init (Listen where_to_listen) = let (Socket_type (socket_type, addr)) = match Tcp.Where_to_listen.address where_to_listen with | `Inet _ as addr -> Socket_type (Socket.Type.tcp, addr) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 46d645b4..65dc1e85 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -6,10 +6,12 @@ let strf = Format.asprintf type _ witness = .. +type (+'a, 's) app + type _ resolver = | Resolver : { priority : int option; - resolve : [ `host ] Domain_name.t -> ('edn option, 's) Sigs.app; + resolve : [ `host ] Domain_name.t -> ('edn option, 's) app; witness : 's witness; } -> ('edn * 's) resolver @@ -50,7 +52,7 @@ module type S = sig type output - type +'a s + type +'a io type scheduler @@ -61,23 +63,23 @@ module type S = sig val pp_error : error Fmt.t val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io - val send : flow -> output -> (int, [> error ]) result s + val send : flow -> output -> (int, [> error ]) result io - val close : flow -> (unit, [> error ]) result s + val close : flow -> (unit, [> error ]) result io module type FLOW = Sigs.FLOW with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io module type PROTOCOL = Sigs.PROTOCOL with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io type ('edn, 'flow) impl = (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) @@ -94,19 +96,19 @@ module type S = sig val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - val flow : flow -> pack + val unpack : flow -> unpack val impl : ('edn, 'flow) protocol -> (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - val is : flow -> ('edn, 'flow) protocol -> 'flow option + val cast : flow -> ('edn, 'flow) protocol -> 'flow option - val abstract : ('edn, 'v) protocol -> 'v -> flow + val pack : ('edn, 'v) protocol -> 'v -> flow - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io val empty : resolvers @@ -121,13 +123,13 @@ module type S = sig resolvers -> ?protocol:('edn, 'v) protocol -> [ `host ] Domain_name.t -> - (flow, [> error ]) result s + (flow, [> error ]) result io - val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result s + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io - module Service : sig - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + module Service : sig type ('cfg, 't, 'flow) impl = (module SERVICE with type configuration = 'cfg @@ -142,14 +144,14 @@ module type S = sig val pp_error : error Fmt.t - val serve : - 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s + val init : + 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result io val accept : - service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result s + service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result io val close : - service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result s + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io val impl : ('cfg, 't, 'flow) service -> @@ -160,15 +162,38 @@ module type S = sig end end -module Make - (Scheduler : Sigs.SCHEDULER) - (Input : Sigs.SINGLETON) - (Output : Sigs.SINGLETON) : +module type IO = Sigs.IO + +module type BUFFER = Sigs.BUFFER + +module type BIJECTION = sig + type +'a s + + type t + + external inj : 'a s -> ('a, t) app = "%identity" + + external prj : ('a, t) app -> 'a s = "%identity" +end + +module Higher (Functor : sig + type +'a t +end) : BIJECTION with type +'a s = 'a Functor.t = struct + type +'a s = 'a Functor.t + + type t + + external inj : 'a s -> ('a, t) app = "%identity" + + external prj : ('a, t) app -> 'a s = "%identity" +end + +module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : S with type input = Input.t and type output = Output.t - and type +'a s = 'a Scheduler.t = struct - module Bijection = Sigs.Higher (Scheduler) + and type +'a io = 'a IO.t = struct + module Bijection = Higher (IO) type scheduler = Bijection.t @@ -176,16 +201,16 @@ module Make let prj = Bijection.prj - let return = Scheduler.return + let return = IO.return - let ( >>= ) x f = Scheduler.bind x f + let ( >>= ) x f = IO.bind x f let ( >>| ) x f = x >>= fun x -> return (f x) let ( >>? ) x f = x >>= function Ok x -> f x | Error err -> return (Error err) - type +'a s = 'a Scheduler.t + type +'a io = 'a IO.t type _ witness += Witness : scheduler witness @@ -199,20 +224,20 @@ module Make Sigs.PROTOCOL with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io module type FLOW = Sigs.FLOW with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io type ('edn, 'flow) impl = (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) type 'edn key = ('edn * scheduler) Map.key - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io module F = struct type _ t = @@ -310,8 +335,8 @@ module Make | `Msg err -> pf ppf "%s" err | `Not_found -> pf ppf "Not found" - let flow_of_endpoint : type edn. edn key -> edn -> (flow, [> error ]) result s - = + let flow_of_endpoint : + type edn. edn key -> edn -> (flow, [> error ]) result io = fun key edn -> let rec go = function | [] -> return (Error `Not_found) @@ -325,7 +350,7 @@ module Make go (Ptr.bindings ()) let flow_of_protocol : - type edn flow. (edn, flow) protocol -> edn -> (flow, [> error ]) result s + type edn flow. (edn, flow) protocol -> edn -> (flow, [> error ]) result io = fun (module Witness) edn -> let (Protocol (_, (module Protocol))) = Witness.witness in @@ -347,7 +372,7 @@ module Make and sup = 1 - let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list s = + let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list io = fun m domain_name -> let rec go acc = function | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) @@ -368,7 +393,7 @@ module Make go [] (List.sort compare (Map.bindings m)) let create : - resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result s = + resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result io = fun m domain_name -> resolve m domain_name >>= fun l -> let rec go = function @@ -379,7 +404,7 @@ module Make | Error _err -> go r) in go l - let abstract : type edn v. (edn, v) protocol -> v -> flow = + let pack : type edn v. (edn, v) protocol -> v -> flow = fun (module Witness) flow -> Witness.T (Value flow) let resolve : @@ -387,7 +412,7 @@ module Make resolvers -> ?protocol:(edn, v) protocol -> [ `host ] Domain_name.t -> - (flow, [> error ]) result s = + (flow, [> error ]) result io = fun m ?protocol domain_name -> match protocol with | None -> create m domain_name @@ -406,15 +431,15 @@ module Make go l let connect : - type edn v. edn -> (edn, v) protocol -> (flow, [> error ]) result s = + type edn v. edn -> (edn, v) protocol -> (flow, [> error ]) result io = fun edn (module Witness) -> let (Protocol (_, (module Protocol))) = Witness.witness in Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) >>? fun flow -> return (Ok (Witness.T (Value flow))) - type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - let flow : flow -> pack = + let unpack : flow -> unpack = fun flow -> let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = Ptr.prj flow in @@ -429,15 +454,15 @@ module Make let (Protocol (_, (module Protocol))) = Witness.witness in (module Protocol) - let is : type edn v. flow -> (edn, v) protocol -> v option = + 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 - module Service = struct - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + module Service = struct type ('cfg, 't, 'flow) impl = (module SERVICE with type configuration = 'cfg @@ -463,18 +488,18 @@ module Make let pp_error ppf = function `Msg err -> Fmt.string ppf err - let serve : + let init : type cfg t flow. - cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result s = + cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result io = fun edn ~service:(module Witness) -> let (Service (_, (module Service))) = Witness.witness in - Service.make edn >>= function + Service.init edn >>= function | Ok t -> return (Ok t) | Error err -> return (error_msgf "%a" Service.pp_error err) let accept : type cfg t flow. - service:(cfg, t, flow) service -> t -> (flow, [> error ]) result s = + service:(cfg, t, flow) service -> t -> (flow, [> error ]) result io = fun ~service:(module Witness) t -> let (Service (_, (module Service))) = Witness.witness in Service.accept t >>= function @@ -483,7 +508,7 @@ module Make let close : type cfg t flow. - service:(cfg, t, flow) service -> t -> (unit, [> error ]) result s = + service:(cfg, t, flow) service -> t -> (unit, [> error ]) result io = fun ~service:(module Witness) t -> let (Service (_, (module Service))) = Witness.witness in Service.close t >>= function diff --git a/src/core/conduit.mli b/src/core/conduit.mli index dd4ea6ee..574b7f4d 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -1,5 +1,3 @@ -module Sigs = Sigs - type ('a, 'b) refl = Refl : ('a, 'a) refl type resolvers @@ -17,7 +15,7 @@ module type S = sig type output (** The type for payload outputs. *) - type +'a s + type +'a io (** The type for I/O effects. *) type scheduler @@ -43,15 +41,15 @@ module type S = sig val pp_error : error Fmt.t val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result s + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been received from the flow [flow] and copied in [input]. *) - val send : flow -> output -> (int, [> error ]) result s + val send : flow -> output -> (int, [> error ]) result io (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been sent over the flow [flow]. *) - val close : flow -> (unit, [> error ]) result s + val close : flow -> (unit, [> error ]) result io (** [close flow] closes [flow]. Subsequent calls to {!recv} will return [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) @@ -80,14 +78,14 @@ module type S = sig Sigs.FLOW with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io (** A protocol is a {!FLOW} plus [connect]. *) module type PROTOCOL = Sigs.PROTOCOL with type input = input and type output = output - and type +'a s = 'a s + and type +'a io = 'a io type ('edn, 'flow) impl = (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) @@ -189,15 +187,15 @@ module type S = sig ]} *) - type pack = Flow : 'flow * (module FLOW with type flow = 'flow) -> pack + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - val flow : flow -> pack - (** [flow flow] projects the module implementation associated to the given + val unpack : flow -> unpack + (** [pack flow] projects the module implementation associated to the given abstract [flow] such as: {[ Conduit.connect edn >>= fun flow -> - let Conduit.Flow (flow, (module Flow)) = Conduit.flow flow in + let Conduit.Flow (flow, (module Flow)) = Conduit.unpack flow in Flow.send flow "Hello World!" ]} *) @@ -207,8 +205,8 @@ module type S = sig (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) (** [impl protocol] is [protocol]'s implementation. *) - val is : flow -> (_, 'flow) protocol -> 'flow option - (** [is flow protocol] tries to {i destruct} the given [flow] to the concrete + val cast : flow -> (_, 'flow) protocol -> 'flow option + (** [cast flow protocol] tries to {i cast} the given [flow] to the concrete type described by the given [protocol]. {[ @@ -218,21 +216,21 @@ module type S = sig ]} *) - val abstract : (_, 'v) protocol -> 'v -> flow - (** [abstract protocol concrete_flow] abstracts the given [flow] into the + val pack : (_, 'v) protocol -> 'v -> flow + (** [pack protocol concrete_flow] abstracts the given [flow] into the {!flow} type from a given [protocol]. It permits to use [Conduit] with a concrete value created by the user. {[ let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let flow = Conduit.abstract Conduit_tcp.t socket in + let flow = Conduit.pack Conduit_tcp.t socket in Conduit.send flow "Hello World!" ]} *) (** {2:resolution Domain name resolvers.} *) - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option s + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io (** The type for resolver functions, which resolve domain names to endpoints. For instance, the DNS resolver function is: @@ -277,7 +275,7 @@ module type S = sig resolvers -> ?protocol:('edn, 'v) protocol -> [ `host ] Domain_name.t -> - (flow, [> error ]) result s + (flow, [> error ]) result io (** [resolve resolvers domain_name] is the flow created by connecting to the domain name [domain_name], using the resolvers [resolvers]. Each resolver tries to resolve the given domain-name (they are ordered by the given @@ -307,13 +305,13 @@ module type S = sig ]} *) - val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result s + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io (** {2:service Server-side conduits.} *) - module Service : sig - module type SERVICE = Sigs.SERVICE with type +'a s = 'a s + module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + module Service : sig type ('cfg, 't, 'flow) impl = (module SERVICE with type configuration = 'cfg @@ -346,18 +344,18 @@ module type S = sig val pp_error : error Fmt.t - val serve : - 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result s - (** [serve cfg ~service] initialises the service with the configuration - [cfg]. *) + val init : + 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result io + (** [init cfg ~service] initialises the service with the + configuration [cfg]. *) val accept : - service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result s + service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result io (** [accept service t] waits for a connection on the service [t]. The result is a {i flow} connected to the client. *) val close : - service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result s + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io (** [close ~service t] releases the resources associated to the server [t]. *) val impl : @@ -370,11 +368,14 @@ module type S = sig end end -module Make - (Scheduler : Sigs.SCHEDULER) - (Input : Sigs.SINGLETON) - (Output : Sigs.SINGLETON) : +module type IO = Sigs.IO +(** @inline *) + +module type BUFFER = Sigs.BUFFER +(** @inline *) + +module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : S with type input = Input.t and type output = Output.t - and type +'a s = 'a Scheduler.t + and type +'a io = 'a IO.t diff --git a/src/core/e0.ml b/src/core/e0.ml index eaf3b41b..1bdb5ecf 100644 --- a/src/core/e0.ml +++ b/src/core/e0.ml @@ -77,7 +77,11 @@ module Tbl = struct if t.size > Array.length t.data lsl 1 then resize t end -module Make (Key : Sigs.FUNCTOR) = struct +module type S1 = sig + type 'a t +end + +module Make (Key : S1) = struct type t = .. type _ id = .. diff --git a/src/core/e0.mli b/src/core/e0.mli index 13ac4b24..b3dc6ddb 100644 --- a/src/core/e0.mli +++ b/src/core/e0.mli @@ -1,6 +1,10 @@ type ('a, 'b) refl = Refl : ('a, 'a) refl -module Make (Key : Sigs.FUNCTOR) : sig +module type S1 = sig + type 'a t +end + +module Make (Key : S1) : sig (* XXX(dinosaure): only on [>= 4.06.0] *) type t = private .. diff --git a/src/core/e1.ml b/src/core/e1.ml index 5a4268ba..4f1a9a8f 100644 --- a/src/core/e1.ml +++ b/src/core/e1.ml @@ -36,7 +36,11 @@ let identifier_equal a b = (compare : int -> int -> int) a b = 0 let identifier_compare a b = (compare : int -> int -> int) a b -module Make (K : Sigs.FUNCTOR) (V : Sigs.FUNCTOR) = struct +module type S1 = sig + type 'a t +end + +module Make (K : S1) (V : S1) = struct module Key = struct type 'a info = 'a K.t diff --git a/src/core/e1.mli b/src/core/e1.mli index d5ccad8d..7bb12573 100644 --- a/src/core/e1.mli +++ b/src/core/e1.mli @@ -8,7 +8,11 @@ val identifier_equal : identifier -> identifier -> bool val identifier_compare : identifier -> identifier -> int -module Make (K : Sigs.FUNCTOR) (V : Sigs.FUNCTOR) : sig +module type S1 = sig + type 'a t +end + +module Make (K : S1) (V : S1) : sig type 'a key module Key : sig diff --git a/src/core/sigs.ml b/src/core/sigs.ml index fa78b7d3..f0325550 100644 --- a/src/core/sigs.ml +++ b/src/core/sigs.ml @@ -1,50 +1,5 @@ type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] -module type FUNCTOR = sig - type 'a t -end - -module type SINGLETON = sig - type t -end - -type (+'a, 's) app - -type 's scheduler = { - bind : 'a 'b. ('a, 's) app -> ('a -> ('b, 's) app) -> ('b, 's) app; - return : 'a. 'a -> ('a, 's) app; -} - -module type BIJECTION = sig - type +'a s - - type t - - external inj : 'a s -> ('a, t) app = "%identity" - - external prj : ('a, t) app -> 'a s = "%identity" -end - -module Higher (Functor : sig - type +'a t -end) : BIJECTION with type +'a s = 'a Functor.t = struct - type +'a s = 'a Functor.t - - type t - - external inj : 'a s -> ('a, t) app = "%identity" - - external prj : ('a, t) app -> 'a s = "%identity" -end - -module type SCHEDULER = sig - type +'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - - val return : 'a -> 'a t -end - module type FLOW = sig (** [FLOW] is the signature for flow clients. @@ -69,7 +24,7 @@ module type FLOW = sig a protocol without such complexity. *) - type +'a s + type +'a io type flow @@ -99,15 +54,15 @@ module type FLOW = sig val pp_error : error Fmt.t (** [pp_error] is the pretty-printer for {!error}. *) - val recv : flow -> input -> (int or_end_of_flow, error) result s + val recv : flow -> input -> (int or_end_of_flow, error) result io (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from the flow [flow] and copied in [input]. *) - val send : flow -> output -> (int, error) result s + val send : flow -> output -> (int, error) result io (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been sent over the flow [flow]. *) - val close : flow -> (unit, error) result s + val close : flow -> (unit, error) result io (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an [Error]. *) @@ -118,11 +73,11 @@ module type PROTOCOL = sig type endpoint - val connect : endpoint -> (flow, error) result s + val connect : endpoint -> (flow, error) result io end module type SERVICE = sig - type +'a s + type +'a io type flow @@ -132,11 +87,23 @@ module type SERVICE = sig type configuration - val make : configuration -> (t, error) result s + val init : configuration -> (t, error) result io val pp_error : error Fmt.t - val accept : t -> (flow, error) result s + val accept : t -> (flow, error) result io + + val close : t -> (unit, error) result io +end + +module type IO = sig + type +'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t - val close : t -> (unit, error) result s + val return : 'a -> 'a t +end + +module type BUFFER = sig + type t end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index 9aa052d0..96b4a3df 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -30,7 +30,7 @@ module Protocol (Flow : Conduit_lwt.PROTOCOL) = struct type output = Cstruct.t - type +'a s = 'a Lwt.t + type +'a io = 'a Lwt.t type error = [ `Flow of Flow.error | `Verify of string ] @@ -76,12 +76,12 @@ let protocol_with_ssl : type 't master = { master : 't; context : Ssl.context } module Server (Service : sig - include Conduit_lwt.Service.SERVICE + include Conduit_lwt.SERVICE val file_descr : flow -> Lwt_unix.file_descr end) = struct - type +'a s = 'a Lwt.t + type +'a io = 'a Lwt.t type configuration = Ssl.context * Service.configuration @@ -93,8 +93,8 @@ struct let pp_error ppf (`Service err) = Service.pp_error ppf err - let make (context, edn) = - Service.make edn >|= reword_error (fun err -> `Service err) + let init (context, edn) = + Service.init edn >|= reword_error (fun err -> `Service err) >>? fun master -> Lwt.return_ok { master; context } let accept { master; context } = diff --git a/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml index cb17a000..98e70c51 100644 --- a/src/lwt-tls/conduit_lwt_tls.ml +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -1,4 +1,4 @@ -include Conduit_tls.Make (Conduit_lwt.Lwt_scheduler) (Conduit_lwt) +include Conduit_tls.Make (Conduit_lwt.IO) (Conduit_lwt) module TCP = struct open Conduit_lwt.TCP diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 8a9bcb37..85745c3f 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -1,20 +1,20 @@ -module Lwt_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t +module IO : Conduit.IO with type +'a t = 'a Lwt.t include Conduit.S with type input = Cstruct.t and type output = Cstruct.t - and type +'a s = 'a Lwt.t + and type +'a io = 'a Lwt.t val io_of_flow : flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel -val serve_with_handler : +val serve : handler:('flow -> unit Lwt.t) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t -(** [serve_with_handler ~handler ~service cfg] creates an usual infinite [service] +(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from the given configuration ['cfg]. It returns the {i promise} to launch the loop and a condition variable to stop the loop. @@ -53,14 +53,14 @@ end module TCP : sig (** Implementation of TCP protocol as a client. - + Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. This is a description of what they currently do. - + {b NOTE}: [recv] wants to fill the given buffer as much as possible until it has reached {i end-of-input}. In other words, [recv] can do a multiple call to [Lwt_unix.recv] to fill the given buffer. - + {b NOTE}: [send] tries to send as much as it can the given buffer. However, if internal call of [Lwt_unix.send] returns something smaller than what we requested, we stop the process and return how many byte(s) we sended. In @@ -98,7 +98,7 @@ module TCP : sig type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } module Server : - Service.SERVICE + SERVICE with type configuration = configuration and type t = Lwt_unix.file_descr and type flow = Protocol.flow diff --git a/src/lwt/internal.ml b/src/lwt/internal.ml index 53cc4a0f..86ef3003 100644 --- a/src/lwt/internal.ml +++ b/src/lwt/internal.ml @@ -1,4 +1,4 @@ -module Lwt_scheduler = struct +module IO = struct type +'a t = 'a Lwt.t let bind x f = Lwt.bind x f @@ -6,7 +6,7 @@ module Lwt_scheduler = struct let return x = Lwt.return x end -include Conduit.Make (Lwt_scheduler) (Cstruct) (Cstruct) +include Conduit.Make (IO) (Cstruct) (Cstruct) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt @@ -43,7 +43,7 @@ let io_of_flow flow = let ( >>? ) = Lwt_result.bind -let serve_with_handler : +let serve : type cfg master flow. handler:(flow -> unit Lwt.t) -> service:(cfg, master, flow) Service.service -> @@ -54,7 +54,7 @@ let serve_with_handler : let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in let main = - Service.serve cfg ~service >>= function + Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err | Ok master -> ( let rec loop () = diff --git a/src/lwt/tCP.ml b/src/lwt/tCP.ml index 8b7328f9..c695125d 100644 --- a/src/lwt/tCP.ml +++ b/src/lwt/tCP.ml @@ -12,7 +12,7 @@ module Protocol = struct type output = Cstruct.t - type +'a s = 'a Lwt.t + type +'a io = 'a Lwt.t type endpoint = Lwt_unix.sockaddr @@ -197,7 +197,7 @@ end type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } module Server = struct - type +'a s = 'a Lwt.t + type +'a io = 'a Lwt.t type nonrec configuration = configuration = { sockaddr : Lwt_unix.sockaddr; @@ -247,7 +247,7 @@ module Server = struct | Unix.ADDR_INET _ -> true | Unix.ADDR_UNIX _ -> false - let make { sockaddr; capacity } = + let init { sockaddr; capacity } = let socket = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in diff --git a/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml index e451f5c7..6a311f61 100644 --- a/src/mirage/conduit_mirage.ml +++ b/src/mirage/conduit_mirage.ml @@ -1,4 +1,4 @@ -module Mirage_scheduler = struct +module IO = struct type +'a t = 'a Lwt.t let bind x f = Lwt.bind x f @@ -6,13 +6,13 @@ module Mirage_scheduler = struct let return x = Lwt.return x end -include Conduit.Make (Mirage_scheduler) (Cstruct) (Cstruct) +include Conduit.Make (IO) (Cstruct) (Cstruct) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt let ( >>? ) = Lwt_result.bind -let serve_with_handler : +let serve : type cfg master flow. handler:(flow -> unit Lwt.t) -> service:(cfg, master, flow) Service.service -> @@ -23,7 +23,7 @@ let serve_with_handler : let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in let main = - Service.serve cfg ~service >>= function + Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err | Ok master -> ( let rec loop () = diff --git a/src/mirage/conduit_mirage.mli b/src/mirage/conduit_mirage.mli index e5d804f4..571ff247 100644 --- a/src/mirage/conduit_mirage.mli +++ b/src/mirage/conduit_mirage.mli @@ -1,12 +1,12 @@ -module Mirage_scheduler : Conduit.Sigs.SCHEDULER with type +'a t = 'a Lwt.t +module IO : Conduit.IO with type +'a t = 'a Lwt.t include Conduit.S with type input = Cstruct.t and type output = Cstruct.t - and type +'a s = 'a Lwt.t + and type +'a io = 'a Lwt.t -val serve_with_handler : +val serve : handler:('flow -> unit Lwt.t) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index 700adf1c..d7341fc3 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -42,7 +42,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct type output = Conduit_mirage.output - type +'a s = 'a Conduit_mirage.s + type +'a io = 'a Conduit_mirage.io type error = | Input_too_large @@ -213,7 +213,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct } module Server = struct - type +'a s = 'a Conduit_mirage.s + type +'a io = 'a Conduit_mirage.io type error = Connection_aborted @@ -227,7 +227,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct type t = service - let make { stack; keepalive; nodelay; port } = + let init { stack; keepalive; nodelay; port } = let queue = Queue.create () in let condition = Lwt_condition.create () in let mutex = Lwt_mutex.create () in diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index a75db5e5..59c4c14a 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -1,5 +1,4 @@ module Ke = Ke.Rke -module Sigs = Conduit.Sigs let option_fold ~none ~some = function Some x -> some x | None -> none @@ -10,15 +9,15 @@ let option_fold ~none ~some = function Some x -> some x | None -> none even if it an infinitely grow. *) module Make - (Scheduler : Sigs.SCHEDULER) + (IO : Conduit.IO) (Conduit : Conduit.S with type input = Cstruct.t and type output = Cstruct.t - and type +'a s = 'a Scheduler.t) = + and type +'a io = 'a IO.t) = struct - let return x = Scheduler.return x + let return x = IO.return x - let ( >>= ) x f = Scheduler.bind x f + let ( >>= ) x f = IO.bind x f let ( >>| ) x f = x >>= fun x -> return (f x) @@ -47,17 +46,12 @@ struct | Some tls -> Tls.Engine.handshake_in_progress tls | None -> false - module Make_protocol - (Flow : Sigs.PROTOCOL - with type input = Conduit.input - and type output = Conduit.output - and type +'a s = 'a Scheduler.t) = - struct + module Make_protocol (Flow : Conduit.PROTOCOL) = struct type input = Conduit.input type output = Conduit.output - type +'a s = 'a Conduit.s + type +'a io = 'a Conduit.io type endpoint = Flow.endpoint * Tls.Config.client @@ -79,7 +73,7 @@ struct let flow_error err = `Flow err let flow_wr_opt : - Flow.flow -> Cstruct.t option -> (unit, error) result Conduit.s = + Flow.flow -> Cstruct.t option -> (unit, error) result Conduit.io = fun flow -> function | None -> return (Ok ()) | Some raw -> @@ -106,7 +100,7 @@ struct (char, Bigarray.int8_unsigned_elt) Ke.t -> Flow.flow -> Cstruct.t -> - (Tls.Engine.state option, error) result Scheduler.t = + (Tls.Engine.state option, error) result IO.t = fun tls queue flow raw -> match Tls.Engine.handle_tls tls raw with | `Fail (failure, `Response resp) -> @@ -134,7 +128,7 @@ struct (char, Bigarray.int8_unsigned_elt) Ke.t -> Flow.flow -> Cstruct.t -> - (Tls.Engine.state option, error) result Scheduler.t = + (Tls.Engine.state option, error) result IO.t = fun tls queue flow raw0 -> let rec go tls raw1 = match Tls.Engine.can_handle_appdata tls with @@ -317,9 +311,8 @@ struct tls : Tls.Config.server; } - module Make_server (Service : Sigs.SERVICE with type +'a s = 'a Scheduler.t) = - struct - type +'a s = 'a Conduit.s + module Make_server (Service : Conduit.SERVICE) = struct + type +'a io = 'a Conduit.io type configuration = Service.configuration * Tls.Config.server @@ -334,8 +327,8 @@ struct type t = Service.t service_with_tls - let make (edn, tls) = - Service.make edn >>| reword_error service_error >>? fun service -> + let init (edn, tls) = + Service.init edn >>| reword_error service_error >>? fun service -> Log.info (fun m -> m "Start a TLS service.") ; return (Ok { service; tls }) diff --git a/src/tls/conduit_tls.mli b/src/tls/conduit_tls.mli index 26bcf570..6ee9bb7a 100644 --- a/src/tls/conduit_tls.mli +++ b/src/tls/conduit_tls.mli @@ -38,11 +38,11 @@ is not available. *) module Make - (Scheduler : Conduit.Sigs.SCHEDULER) + (IO : Conduit.IO) (Conduit : Conduit.S with type input = Cstruct.t and type output = Cstruct.t - and type +'a s = 'a Scheduler.t) : sig + and type +'a io = 'a IO.t) : sig type 'flow protocol_with_tls val underlying : 'flow protocol_with_tls -> 'flow diff --git a/tests/common.ml b/tests/common.ml index bdb56257..1de95032 100644 --- a/tests/common.ml +++ b/tests/common.ml @@ -3,11 +3,11 @@ module type S = sig type 'a condition - val serve_with_handler : - handler:('flow -> unit s) -> + val serve : + handler:('flow -> unit io) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> - unit condition * unit s + unit condition * unit io end module type CONDITION = sig @@ -17,20 +17,20 @@ end let ( <.> ) f g x = f (g x) module Make - (Scheduler : Conduit.Sigs.SCHEDULER) + (IO : Conduit.IO) (Condition : CONDITION) (Conduit : S - with type +'a s = 'a Scheduler.t + with type +'a io = 'a IO.t and type 'a condition = 'a Condition.t and type input = Cstruct.t and type output = Cstruct.t) = struct - let return = Scheduler.return + let return = IO.return - let ( >>= ) = Scheduler.bind + let ( >>= ) = IO.bind let ( >>? ) x f = - x >>= function Ok x -> f x | Error err -> Scheduler.return (Error err) + x >>= function Ok x -> f x | Error err -> IO.return (Error err) let localhost = Domain_name.(host_exn <.> of_string_exn) "localhost" @@ -62,10 +62,10 @@ struct Bigstringaf.blit src ~src_off dst ~dst_off ~len in let rec go () = match getline queue with - | Some line -> Scheduler.return (Ok (`Line line)) + | Some line -> IO.return (Ok (`Line line)) | None -> ( Conduit.recv flow tmp >>? function - | `End_of_flow -> Scheduler.return (Ok `Close) + | `End_of_flow -> IO.return (Ok `Close) | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; go ()) in @@ -99,10 +99,10 @@ struct cfg -> protocol:(_, flow) Conduit.protocol -> service:(cfg, master, flow) Conduit.Service.service -> - unit Condition.t * unit Scheduler.t = + unit Condition.t * unit IO.t = fun cfg ~protocol ~service -> - Conduit.serve_with_handler - ~handler:(fun flow -> transmission (Conduit.abstract protocol flow)) + Conduit.serve + ~handler:(fun flow -> transmission (Conduit.pack protocol flow)) ~service cfg (* part *) @@ -129,9 +129,9 @@ struct let responses = go [] ic in close_in ic ; client ~resolvers localhost responses >>= function - | Ok () -> Scheduler.return () - | Error `Closed_by_peer -> Scheduler.return () + | Ok () -> IO.return () + | Error `Closed_by_peer -> IO.return () | Error (#Conduit.error as err) -> Fmt.epr "client: %a.\n%!" Conduit.pp_error err ; - Scheduler.return () + IO.return () end diff --git a/tests/flow.ml b/tests/flow.ml index bdb526d1..b6bee1e5 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -37,7 +37,7 @@ module Memory_flow0 = struct and output = string - type +'a s = 'a + type +'a io = 'a type flow = { mutable i : string; @@ -125,7 +125,7 @@ module Memory_flow1 = struct and output = string - type +'a s = 'a + type +'a io = 'a type flow = { mutable i : string list; diff --git a/tests/resolvers.ml b/tests/resolvers.ml index 5286891d..4dd16136 100644 --- a/tests/resolvers.ml +++ b/tests/resolvers.ml @@ -16,7 +16,7 @@ struct and output = string - type +'a s = 'a + type +'a io = 'a type endpoint = Edn.t From 96b789d4b5bba77059da6e4878a1cffb010d1ec3 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 15:53:37 +0200 Subject: [PATCH 051/140] Simplify the code organisation for lwt and async libs --- src/async/conduit_async.ml | 250 +++++++++++++++++++++- src/async/internal.ml | 80 ------- src/async/tCP.ml | 159 -------------- src/lwt/conduit_lwt.ml | 416 ++++++++++++++++++++++++++++++++++++- src/lwt/internal.ml | 91 -------- src/lwt/tCP.ml | 315 ---------------------------- 6 files changed, 662 insertions(+), 649 deletions(-) delete mode 100644 src/async/internal.ml delete mode 100644 src/async/tCP.ml delete mode 100644 src/lwt/internal.ml delete mode 100644 src/lwt/tCP.ml diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 4d947097..bca22651 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -1,2 +1,248 @@ -include Internal -module TCP = TCP +module IO = struct + type +'a t = 'a Async.Deferred.t + + let bind x f = Async.Deferred.bind x ~f + + let return x = Async.Deferred.return x +end + +include Conduit.Make (IO) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf failwith fmt + +let ( >>? ) x f = Async.Deferred.Result.bind x ~f + +let serve : + type cfg master flow. + handler:(flow -> unit Async.Deferred.t) -> + service:(cfg, master, flow) Service.service -> + cfg -> + unit Async.Condition.t * unit Async.Deferred.t = + fun ~handler ~service cfg -> + let open Async in + let stop = Async.Condition.create () in + let module Svc = (val Service.impl service) in + let main = + Service.init cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok master -> ( + let rec loop () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in + let accept = + Svc.accept master >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in + + Async.Deferred.any [ close; accept ] >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for (handler flow) ; + Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Async.return (Error err0) + | Error _err1 -> Async.return (Error err0)) in + loop () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) + +let reader_and_writer_of_flow flow = + let open Async in + let recv flow writer = + let tmp = Cstruct.create 0x1000 in + let rec loop () = + recv flow tmp >>= function + | Ok (`Input len) -> + Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop + | Ok `End_of_flow -> + Pipe.close writer ; + Async.return () + | Error err -> failwith "%a" pp_error err in + loop () in + let send flow reader = + let rec loop () = + Pipe.read reader >>= function + | `Eof -> Async.return () + | `Ok v -> + let rec go tmp = + if Cstruct.len tmp = 0 + then Async.return () + else + send flow tmp >>= function + | Ok shift -> go (Cstruct.shift tmp shift) + | Error err -> failwith "%a" pp_error err in + go (Cstruct.of_string v) >>= loop in + loop () in + let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in + let pwriter = Pipe.create_writer (send flow) in + Reader.of_pipe (Core.Info.of_string "reader") preader >>= fun reader -> + Writer.of_pipe (Core.Info.of_string "writer") pwriter >>= fun (writer, _) -> + Async.return (reader, writer) + +module TCP = struct + open Async + open Async_unix + + type endpoint = + | Inet of Socket.Address.Inet.t + | Unix of Socket.Address.Unix.t + + module Protocol = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a io = 'a Async.Deferred.t + + type flow = + | Socket : { + address : [< Socket.Address.t ]; + socket : ([ `Active ], [< Socket.Address.t ]) Socket.t; + reader : Async.Reader.t; + writer : Async.Writer.t; + } + -> flow + + let address (Socket { address; _ }) = + match address with #Socket.Address.t as addr -> addr + + let reader (Socket { reader; _ }) = reader + + let writer (Socket { writer; _ }) = writer + + type nonrec endpoint = endpoint = + | Inet of Socket.Address.Inet.t + | Unix of Socket.Address.Unix.t + + type error = Core.Error.t + + let pp_error = Core.Error.pp + + let connect edn = + let connect = function + | Inet address -> + Tcp.connect (Tcp.Where_to_connect.of_inet_address address) + >>| fun (socket, reader, writer) -> + Socket { address; socket; reader; writer } + | Unix address -> + Tcp.connect (Tcp.Where_to_connect.of_unix_address address) + >>| fun (socket, reader, writer) -> + Socket { address; socket; reader; writer } in + Monitor.try_with (fun () -> connect edn) >>= function + | Ok _ as v -> Async.return v + | Error exn -> Async.return (Error (Core.Error.of_exn exn)) + + let of_cstruct raw = + let { Cstruct.buffer; off; len } = raw in + Core.Bigsubstring.create ~pos:off ~len buffer + + (* XXX(dinosaure): as [lwt] and seems required for [conduit-tls], [recv] wants to read + as much as possible. Due to underlying non-blocking socket, even if we reached [`Eof], + we must retry to read until we have something or the underlying socket was closed. *) + let rec recv (Socket { socket; reader; _ } as flow) raw = + Monitor.try_with (fun () -> + Reader.read_bigsubstring reader (of_cstruct raw)) + >>= function + | Error err -> + Reader.close reader >>= fun () -> + Async.return (Error (Core.Error.of_exn err)) + | Ok (`Ok n) -> Async.return (Ok (`Input n)) + | Ok `Eof -> ( + Fd.ready_to (Socket.fd socket) `Read >>= function + | `Bad_fd | `Closed -> Async.return (Ok `End_of_flow) + | `Ready -> Scheduler.yield () >>= fun () -> recv flow raw) + + let send (Socket { writer; _ }) raw = + Writer.write_bigsubstring writer (of_cstruct raw) ; + Writer.flushed writer >>= fun () -> Async.return (Ok (Cstruct.len raw)) + + let close (Socket { socket; reader; writer; _ }) = + (* XXX(dinosaure): we should be protected against the double-close. *) + if Reader.is_closed reader + && Writer.is_closed writer + && Fd.is_closed (Socket.fd socket) + then Async.return (Ok ()) + else ( + Socket.shutdown socket `Both ; + Reader.close reader >>= fun () -> + Writer.close writer >>= fun () -> Async.return (Ok ())) + end + + let protocol = register ~protocol:(module Protocol) + + type configuration = + | Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration + + module Server = struct + type +'a io = 'a Async.Deferred.t + + type flow = Protocol.flow + + type error = Exn of [ `Make | `Accept ] * exn | Socket_closed + + let pp_error ppf = function + | Exn (`Make, exn) -> + Format.fprintf ppf "Got an exception while making socket: %s" + (Printexc.to_string exn) + | Exn (`Accept, exn) -> + Format.fprintf ppf "Got an exception while accepting socket: %s" + (Printexc.to_string exn) + | Socket_closed -> Format.fprintf ppf "Socket closed" + + type nonrec configuration = configuration + + type t = + | Master : + ([ `Passive ], ([< Socket.Address.t ] as 'a)) Socket.t * 'a + -> t + + let close_socket_on_error ~process socket ~f = + Monitor.try_with f >>| function + | Ok v -> Ok v + | Error exn -> + Async.don't_wait_for (Unix.close (Socket.fd socket)) ; + Error (Exn (process, exn)) + + type socket_type = + | Socket_type : + ([< Socket.Address.t ] as 'a) Socket.Type.t * 'a + -> socket_type + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error _ as err -> Async.return err + + let init (Listen where_to_listen) = + let (Socket_type (socket_type, addr)) = + match Tcp.Where_to_listen.address where_to_listen with + | `Inet _ as addr -> Socket_type (Socket.Type.tcp, addr) + | `Unix _ as addr -> Socket_type (Socket.Type.unix, addr) in + let socket = Socket.create socket_type in + let f () = Socket.bind socket addr >>| Socket.listen in + close_socket_on_error ~process:`Make socket ~f >>? fun socket -> + Async.return (Ok (Master (socket, addr))) + + let accept (Master (socket, _)) = + Socket.accept socket >>= function + | `Ok (socket, address) -> + let reader = Reader.create (Socket.fd socket) in + let writer = Writer.create (Socket.fd socket) in + let flow = Protocol.Socket { socket; reader; writer; address } in + Async.return (Ok flow) + | `Socket_closed -> Async.return (Error Socket_closed) + + let close (Master (socket, _)) = + Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) + end + + let service = Service.register ~service:(module Server) + + let resolv_conf ~port domain_name = + Monitor.try_with (fun () -> + Unix.Inet_addr.of_string_or_getbyname + (Domain_name.to_string domain_name)) + >>= function + | Ok inet_addr -> + let inet_addr = Socket.Address.Inet.create inet_addr ~port in + Async.return (Some (Inet inet_addr)) + | _ -> Async.return None +end diff --git a/src/async/internal.ml b/src/async/internal.ml deleted file mode 100644 index 39882b6e..00000000 --- a/src/async/internal.ml +++ /dev/null @@ -1,80 +0,0 @@ -module IO = struct - type +'a t = 'a Async.Deferred.t - - let bind x f = Async.Deferred.bind x ~f - - let return x = Async.Deferred.return x -end - -include Conduit.Make (IO) (Cstruct) (Cstruct) - -let failwith fmt = Format.kasprintf failwith fmt - -let ( >>? ) x f = Async.Deferred.Result.bind x ~f - -let serve : - type cfg master flow. - handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, master, flow) Service.service -> - cfg -> - unit Async.Condition.t * unit Async.Deferred.t = - fun ~handler ~service cfg -> - let open Async in - let stop = Async.Condition.create () in - let module Svc = (val Service.impl service) in - let main = - Service.init cfg ~service >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( - let rec loop () = - let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in - let accept = - Svc.accept master >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in - - Async.Deferred.any [ close; accept ] >>= function - | Ok (`Flow flow) -> - Async.don't_wait_for (handler flow) ; - Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok `Stop -> Svc.close master - | Error err0 -> ( - Svc.close master >>= function - | Ok () -> Async.return (Error err0) - | Error _err1 -> Async.return (Error err0)) in - loop () >>= function - | Ok () -> Async.return () - | Error err -> failwith "%a" Svc.pp_error err) in - (stop, main) - -let reader_and_writer_of_flow flow = - let open Async in - let recv flow writer = - let tmp = Cstruct.create 0x1000 in - let rec loop () = - recv flow tmp >>= function - | Ok (`Input len) -> - Pipe.write writer (Cstruct.to_string (Cstruct.sub tmp 0 len)) >>= loop - | Ok `End_of_flow -> - Pipe.close writer ; - Async.return () - | Error err -> failwith "%a" pp_error err in - loop () in - let send flow reader = - let rec loop () = - Pipe.read reader >>= function - | `Eof -> Async.return () - | `Ok v -> - let rec go tmp = - if Cstruct.len tmp = 0 - then Async.return () - else - send flow tmp >>= function - | Ok shift -> go (Cstruct.shift tmp shift) - | Error err -> failwith "%a" pp_error err in - go (Cstruct.of_string v) >>= loop in - loop () in - let preader = Pipe.create_reader ~close_on_exception:true (recv flow) in - let pwriter = Pipe.create_writer (send flow) in - Reader.of_pipe (Core.Info.of_string "reader") preader >>= fun reader -> - Writer.of_pipe (Core.Info.of_string "writer") pwriter >>= fun (writer, _) -> - Async.return (reader, writer) diff --git a/src/async/tCP.ml b/src/async/tCP.ml deleted file mode 100644 index a84b50cd..00000000 --- a/src/async/tCP.ml +++ /dev/null @@ -1,159 +0,0 @@ -open Async -open Async_unix - -type endpoint = Inet of Socket.Address.Inet.t | Unix of Socket.Address.Unix.t - -module Protocol = struct - type input = Cstruct.t - - type output = Cstruct.t - - type +'a io = 'a Async.Deferred.t - - type flow = - | Socket : { - address : [< Socket.Address.t ]; - socket : ([ `Active ], [< Socket.Address.t ]) Socket.t; - reader : Async.Reader.t; - writer : Async.Writer.t; - } - -> flow - - let address (Socket { address; _ }) = - match address with #Socket.Address.t as addr -> addr - - let reader (Socket { reader; _ }) = reader - - let writer (Socket { writer; _ }) = writer - - type nonrec endpoint = endpoint = - | Inet of Socket.Address.Inet.t - | Unix of Socket.Address.Unix.t - - type error = Core.Error.t - - let pp_error = Core.Error.pp - - let connect edn = - let connect = function - | Inet address -> - Tcp.connect (Tcp.Where_to_connect.of_inet_address address) - >>| fun (socket, reader, writer) -> - Socket { address; socket; reader; writer } - | Unix address -> - Tcp.connect (Tcp.Where_to_connect.of_unix_address address) - >>| fun (socket, reader, writer) -> - Socket { address; socket; reader; writer } in - Monitor.try_with (fun () -> connect edn) >>= function - | Ok _ as v -> Async.return v - | Error exn -> Async.return (Error (Core.Error.of_exn exn)) - - let of_cstruct raw = - let { Cstruct.buffer; off; len } = raw in - Core.Bigsubstring.create ~pos:off ~len buffer - - (* XXX(dinosaure): as [lwt] and seems required for [conduit-tls], [recv] wants to read - as much as possible. Due to underlying non-blocking socket, even if we reached [`Eof], - we must retry to read until we have something or the underlying socket was closed. *) - let rec recv (Socket { socket; reader; _ } as flow) raw = - Monitor.try_with (fun () -> - Reader.read_bigsubstring reader (of_cstruct raw)) - >>= function - | Error err -> - Reader.close reader >>= fun () -> - Async.return (Error (Core.Error.of_exn err)) - | Ok (`Ok n) -> Async.return (Ok (`Input n)) - | Ok `Eof -> ( - Fd.ready_to (Socket.fd socket) `Read >>= function - | `Bad_fd | `Closed -> Async.return (Ok `End_of_flow) - | `Ready -> Scheduler.yield () >>= fun () -> recv flow raw) - - let send (Socket { writer; _ }) raw = - Writer.write_bigsubstring writer (of_cstruct raw) ; - Writer.flushed writer >>= fun () -> Async.return (Ok (Cstruct.len raw)) - - let close (Socket { socket; reader; writer; _ }) = - (* XXX(dinosaure): we should be protected against the double-close. *) - if Reader.is_closed reader - && Writer.is_closed writer - && Fd.is_closed (Socket.fd socket) - then Async.return (Ok ()) - else ( - Socket.shutdown socket `Both ; - Reader.close reader >>= fun () -> - Writer.close writer >>= fun () -> Async.return (Ok ())) -end - -let protocol = Internal.register ~protocol:(module Protocol) - -type configuration = Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration - -module Server = struct - type +'a io = 'a Async.Deferred.t - - type flow = Protocol.flow - - type error = Exn of [ `Make | `Accept ] * exn | Socket_closed - - let pp_error ppf = function - | Exn (`Make, exn) -> - Format.fprintf ppf "Got an exception while making socket: %s" - (Printexc.to_string exn) - | Exn (`Accept, exn) -> - Format.fprintf ppf "Got an exception while accepting socket: %s" - (Printexc.to_string exn) - | Socket_closed -> Format.fprintf ppf "Socket closed" - - type nonrec configuration = configuration - - type t = - | Master : ([ `Passive ], ([< Socket.Address.t ] as 'a)) Socket.t * 'a -> t - - let close_socket_on_error ~process socket ~f = - Monitor.try_with f >>| function - | Ok v -> Ok v - | Error exn -> - Async.don't_wait_for (Unix.close (Socket.fd socket)) ; - Error (Exn (process, exn)) - - type socket_type = - | Socket_type : - ([< Socket.Address.t ] as 'a) Socket.Type.t * 'a - -> socket_type - - let ( >>? ) x f = - x >>= function Ok x -> f x | Error _ as err -> Async.return err - - let init (Listen where_to_listen) = - let (Socket_type (socket_type, addr)) = - match Tcp.Where_to_listen.address where_to_listen with - | `Inet _ as addr -> Socket_type (Socket.Type.tcp, addr) - | `Unix _ as addr -> Socket_type (Socket.Type.unix, addr) in - let socket = Socket.create socket_type in - let f () = Socket.bind socket addr >>| Socket.listen in - close_socket_on_error ~process:`Make socket ~f >>? fun socket -> - Async.return (Ok (Master (socket, addr))) - - let accept (Master (socket, _)) = - Socket.accept socket >>= function - | `Ok (socket, address) -> - let reader = Reader.create (Socket.fd socket) in - let writer = Writer.create (Socket.fd socket) in - let flow = Protocol.Socket { socket; reader; writer; address } in - Async.return (Ok flow) - | `Socket_closed -> Async.return (Error Socket_closed) - - let close (Master (socket, _)) = - Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) -end - -let service = Internal.Service.register ~service:(module Server) - -let resolv_conf ~port domain_name = - Monitor.try_with (fun () -> - Unix.Inet_addr.of_string_or_getbyname (Domain_name.to_string domain_name)) - >>= function - | Ok inet_addr -> - let inet_addr = Socket.Address.Inet.create inet_addr ~port in - Async.return (Some (Inet inet_addr)) - | _ -> Async.return None diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 4d947097..dc87f6d9 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -1,2 +1,414 @@ -include Internal -module TCP = TCP +module IO = struct + type +'a t = 'a Lwt.t + + let bind x f = Lwt.bind x f + + let return x = Lwt.return x +end + +include Conduit.Make (IO) (Cstruct) (Cstruct) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let io_of_flow flow = + let open Lwt.Infix in + let ic_closed = ref false and oc_closed = ref false in + let close () = + if !ic_closed && !oc_closed + then + close flow >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" pp_error err + else Lwt.return_unit in + let ic_close () = + ic_closed := true ; + close () in + let oc_close () = + oc_closed := true ; + close () in + let recv buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + recv flow raw >>= function + | Ok (`Input len) -> Lwt.return len + | Ok `End_of_flow -> Lwt.return 0 + | Error err -> failwith "%a" pp_error err in + let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in + let send buf off len = + let raw = Cstruct.of_bigarray buf ~off ~len in + send flow raw >>= function + | Ok len -> Lwt.return len + | Error err -> failwith "%a" pp_error err in + let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in + (ic, oc) + +let ( >>? ) = Lwt_result.bind + +let serve : + type cfg master flow. + handler:(flow -> unit Lwt.t) -> + service:(cfg, master, flow) Service.service -> + cfg -> + unit Lwt_condition.t * unit Lwt.t = + fun ~handler ~service cfg -> + let open Lwt.Infix in + let stop = Lwt_condition.create () in + let module Svc = (val Service.impl service) in + let main = + Service.init cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok master -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Svc.close master + | Error err0 -> ( + Svc.close master >>= function + | Ok () -> Lwt.return_error err0 + | Error _err1 -> Lwt.return_error err0) in + loop () >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Svc.pp_error err) in + (stop, main) + +module type CONDUIT = sig + type endpoint + + type flow + + type configuration + + type master + + val protocol : (endpoint, flow) protocol + + val service : (configuration, master, flow) Service.service +end + +module TCP = struct + open Lwt.Infix + + let pf = Format.fprintf + + let pp_sockaddr ppf = function + | Unix.ADDR_UNIX v -> pf ppf "<%s>" v + | Unix.ADDR_INET (inet_addr, port) -> + pf ppf "<%s:%d>" (Unix.string_of_inet_addr inet_addr) port + + module Protocol = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a io = 'a Lwt.t + + type endpoint = Lwt_unix.sockaddr + + type flow = { + socket : Lwt_unix.file_descr; + sockaddr : Lwt_unix.sockaddr; + linger : Bytes.t; + mutable closed : bool; + } + + let peer { sockaddr; _ } = sockaddr + + let sock { socket; _ } = Lwt_unix.getsockname socket + + let file_descr { socket; _ } = socket + + type error = + [ `Closed_by_peer + | `Operation_not_permitted + | `Address_already_in_use of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Address_family_not_supported_by_protocol of Unix.sockaddr + | `Operation_already_in_progress + | `Bad_address + | `Network_is_unreachable + | `Connection_timed_out + | `Connection_refused + | `Transport_endpoint_is_not_connected ] + + let pp_error ppf = function + | `Closed_by_peer -> pf ppf "Connection closed by peer" + | `Operation_not_permitted -> pf ppf "Operation not permitted" + | `Address_already_in_use sockaddr -> + pf ppf "Address %a already in use" pp_sockaddr sockaddr + | `Cannot_assign_requested_address sockaddr -> + pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr + | `Address_family_not_supported_by_protocol sockaddr -> + pf ppf "Address family %a not supported by protocol" pp_sockaddr + sockaddr + | `Operation_already_in_progress -> pf ppf "Operation already in progress" + | `Bad_address -> pf ppf "Bad address" + | `Network_is_unreachable -> pf ppf "Network is unreachable" + | `Connection_timed_out -> pf ppf "Connection timed out" + | `Connection_refused -> pf ppf "Connection refused" + | `Transport_endpoint_is_not_connected -> + pf ppf "Transport endpoint is not connected" + + let io_buffer_size = 65536 + + let connect sockaddr = + let socket = + Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 + in + let linger = Bytes.create io_buffer_size in + let rec go () = + let process () = + Lwt_unix.connect socket sockaddr >>= fun () -> + Lwt.return_ok { socket; sockaddr; linger; closed = false } in + Lwt.catch process @@ function + | Unix.(Unix_error ((EACCES | EPERM), _, _)) -> + Lwt.return_error `Operation_not_permitted + | Unix.(Unix_error (EADDRINUSE, _, _)) -> + Lwt.return_error (`Address_already_in_use sockaddr) + | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> + Lwt.return_error (`Cannot_assign_requested_address sockaddr) + | Unix.(Unix_error (EAFNOSUPPORT, _, _)) -> + Lwt.return_error + (`Address_family_not_supported_by_protocol sockaddr) + | Unix.(Unix_error (EALREADY, _, _)) -> + Lwt.return_error `Operation_already_in_progress + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ENETUNREACH, _, _)) -> + Lwt.return_error `Network_is_unreachable + | Unix.(Unix_error (ETIMEDOUT, _, _)) -> + Lwt.return_error `Connection_timed_out + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> go () + | Unix.(Unix_error (EINTR, _, _)) -> go () + | Unix.(Unix_error (ECONNREFUSED, _, _)) -> + Lwt.return_error `Connection_refused + | exn -> Lwt.fail exn + (* | EPROTOTYPE: impossible *) + (* | EISCONN: impossible *) + (* | ENOTSOCK: impossible *) + (* | EBADF: impossible *) + (* | EINPROGRESS: TODO *) in + go () + + (* XXX(dinosaure): [recv] wants to fill [raw] as much as possible until + it has reached [`End_of_file]. *) + let rec recv ({ socket; closed; _ } as t) raw = + if closed + then Lwt.return_ok `End_of_flow + else + let rec process filled raw = + let max = Cstruct.len raw in + Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) + >>= fun len -> + if len = 0 + then + Lwt.return_ok (if filled = 0 then `End_of_flow else `Input filled) + else ( + Cstruct.blit_from_bytes t.linger 0 raw 0 len ; + if len = Bytes.length t.linger && max > Bytes.length t.linger + then + if Lwt_unix.readable t.socket + then process (filled + len) (Cstruct.shift raw len) + else + Lwt.return_ok + (if filled + len = 0 + then `End_of_flow + else `Input (filled + len)) + else + Lwt.return_ok + (if filled + len = 0 + then `End_of_flow + else `Input (filled + len))) in + Lwt.catch (fun () -> process 0 raw) @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw + | Unix.(Unix_error (EINTR, _, _)) -> recv t raw + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ENOTCONN, _, _)) -> + Lwt.return_error `Transport_endpoint_is_not_connected + (* | Unix.(Unix_error (ECONNREFUSED, _, _)): TODO *) + (* | EBADF: impossible *) + | exn -> Lwt.fail exn + + (* XXX(dinosaure): [send] tries to send as much as it can [raw]. However, + if [send] returns something smaller that what we requested, we stop + the process and return how many byte(s) we sended. + + Try to send into a closed socket is an error. *) + let rec send ({ socket; closed; _ } as t) raw = + if closed + then Lwt.return_error `Closed_by_peer + else + let max = Cstruct.len raw in + let len0 = min (Bytes.length t.linger) max in + Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; + let process () = + Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> + if len1 = len0 + then + if max > len0 + then send t (Cstruct.shift raw len0) + else Lwt.return_ok max + else Lwt.return_ok len1 + (* worst case *) in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> send t raw + | Unix.(Unix_error (EINTR, _, _)) -> send t raw + | Unix.(Unix_error (EACCES, _, _)) -> + Lwt.return_error `Operation_not_permitted + | Unix.(Unix_error (ECONNRESET, _, _)) -> + Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; + t.closed <- true ; + Lwt.return_error `Closed_by_peer + | Unix.(Unix_error (EPIPE, _, _)) -> + Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; + t.closed <- true ; + Lwt.return_error `Closed_by_peer + | Unix.(Unix_error (EDESTADDRREQ, _, _)) + | Unix.(Unix_error (ENOTCONN, _, _)) -> + Lwt.return_error `Transport_endpoint_is_not_connected + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + (* ENOTSOCK: impossible *) + (* EISCONN: TODO *) + (* EOPNOTSUPP: TODO *) + (* ENOBUFS: TODO & impossible into Linux *) + | exn -> Lwt.fail exn + + let rec close t = + let process () = + if not t.closed + then ( + Lwt_unix.close t.socket >>= fun () -> + t.closed <- true ; + Lwt.return_ok ()) + else Lwt.return_ok () in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> close t + | Unix.(Unix_error (EINTR, _, _)) -> close t + | exn -> Lwt.fail exn + end + + type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } + + module Server = struct + type +'a io = 'a Lwt.t + + type nonrec configuration = configuration = { + sockaddr : Lwt_unix.sockaddr; + capacity : int; + } + + type t = Lwt_unix.file_descr + + type flow = Protocol.flow + + type error = + [ `Address_is_protected of Unix.sockaddr + | `Operation_not_permitted of Unix.sockaddr + | `Address_already_in_use of Unix.sockaddr + | `Address_is_not_valid of Unix.sockaddr + | `Cannot_assign_requested_address of Unix.sockaddr + | `Bad_address + | `Too_many_symbolic_links of Unix.sockaddr + | `Name_too_long of Unix.sockaddr + | `Operation_not_supported + | `Limit_reached + | `Protocol_error + | `Firewall_rules_forbid_connection ] + + let pp_error ppf = function + | `Address_is_protected sockaddr -> + pf ppf "Address %a is protected" pp_sockaddr sockaddr + | `Operation_not_permitted sockaddr -> + pf ppf "Operation on %a is not permitted" pp_sockaddr sockaddr + | `Address_already_in_use sockaddr -> + pf ppf "Address %a already in use" pp_sockaddr sockaddr + | `Address_is_not_valid sockaddr -> + pf ppf "Address %a is not valid" pp_sockaddr sockaddr + | `Cannot_assign_requested_address sockaddr -> + pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr + | `Bad_address -> pf ppf "Bad address" + | `Too_many_symbolic_links sockaddr -> + pf ppf "Too many symbolic links on %a" pp_sockaddr sockaddr + | `Name_too_long sockaddr -> + pf ppf "Name %a too long" pp_sockaddr sockaddr + | `Operation_not_supported -> pf ppf "Operation not supported" + | `Limit_reached -> pf ppf "Limit of file-descriptors reached" + | `Protocol_error -> pf ppf "Protocol error" + | `Firewall_rules_forbid_connection -> + pf ppf "Firewill rules forbid connection" + + let is_addr_inet = function + | Unix.ADDR_INET _ -> true + | Unix.ADDR_UNIX _ -> false + + let init { sockaddr; capacity } = + let socket = + Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 + in + Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true ; + let process () = + Lwt_unix.bind socket sockaddr >>= fun () -> + Lwt_unix.listen socket capacity ; + Lwt.return_ok socket in + Lwt.catch process @@ function + (* bind *) + | Unix.(Unix_error (EACCES, _, _)) when is_addr_inet sockaddr -> + Lwt.return_error (`Address_is_protected sockaddr) + | Unix.(Unix_error (EACCES, _, _)) (* when is_addr_unix sockaddr *) -> + Lwt.return_error (`Operation_not_permitted sockaddr) + | Unix.(Unix_error (EADDRINUSE, _, _)) -> + Lwt.return_error (`Address_already_in_use sockaddr) + | Unix.(Unix_error (EINVAL, _, _)) -> + Lwt.return_error (`Address_is_not_valid sockaddr) + (* | ENOTSOCK: impossible *) + | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> + Lwt.return_error (`Cannot_assign_requested_address sockaddr) + | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address + | Unix.(Unix_error (ELOOP, _, _)) -> + Lwt.return_error (`Too_many_symbolic_links sockaddr) + | Unix.(Unix_error (ENAMETOOLONG, _, _)) -> + Lwt.return_error (`Name_too_long sockaddr) + (* listen *) + (* | Unix.(Unix_error (EADDRINUSE, _, _)) -> *) + | Unix.(Unix_error (EOPNOTSUPP, _, _)) -> + Lwt.return_error `Operation_not_supported + | exn -> Lwt.fail exn + + let rec accept master = + let process () = + Lwt_unix.accept master >>= fun (socket, sockaddr) -> + let linger = Bytes.create 0x1000 in + Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } + in + Lwt.catch process @@ function + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept master + | Unix.(Unix_error (EINTR, _, _)) -> accept master + | Unix.(Unix_error (EMFILE, _, _)) + | Unix.(Unix_error ((ENOBUFS | ENOMEM), _, _)) -> + Lwt.return_error `Limit_reached + | Unix.(Unix_error (EPROTOTYPE, _, _)) -> Lwt.return_error `Protocol_error + | Unix.(Unix_error (EPERM, _, _)) -> + Lwt.return_error `Firewall_rules_forbid_connection + | exn -> Lwt.fail exn + + let close _master = + (* XXX(dinosaure): it seems that on MacOS, try to close the [master] + socket raises an error. *) + Lwt.return_ok () + end + + let protocol = register ~protocol:(module Protocol) + + include (val repr protocol) + + let service = Service.register ~service:(module Server) + + let resolv_conf ~port domain_name = + Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> Lwt.return_none +end diff --git a/src/lwt/internal.ml b/src/lwt/internal.ml deleted file mode 100644 index 86ef3003..00000000 --- a/src/lwt/internal.ml +++ /dev/null @@ -1,91 +0,0 @@ -module IO = struct - type +'a t = 'a Lwt.t - - let bind x f = Lwt.bind x f - - let return x = Lwt.return x -end - -include Conduit.Make (IO) (Cstruct) (Cstruct) - -let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt - -let io_of_flow flow = - let open Lwt.Infix in - let ic_closed = ref false and oc_closed = ref false in - let close () = - if !ic_closed && !oc_closed - then - close flow >>= function - | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" pp_error err - else Lwt.return_unit in - let ic_close () = - ic_closed := true ; - close () in - let oc_close () = - oc_closed := true ; - close () in - let recv buf off len = - let raw = Cstruct.of_bigarray buf ~off ~len in - recv flow raw >>= function - | Ok (`Input len) -> Lwt.return len - | Ok `End_of_flow -> Lwt.return 0 - | Error err -> failwith "%a" pp_error err in - let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in - let send buf off len = - let raw = Cstruct.of_bigarray buf ~off ~len in - send flow raw >>= function - | Ok len -> Lwt.return len - | Error err -> failwith "%a" pp_error err in - let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in - (ic, oc) - -let ( >>? ) = Lwt_result.bind - -let serve : - type cfg master flow. - handler:(flow -> unit Lwt.t) -> - service:(cfg, master, flow) Service.service -> - cfg -> - unit Lwt_condition.t * unit Lwt.t = - fun ~handler ~service cfg -> - let open Lwt.Infix in - let stop = Lwt_condition.create () in - let module Svc = (val Service.impl service) in - let main = - Service.init cfg ~service >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( - let rec loop () = - let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in - let accept = - Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in - - Lwt.pick [ stop; accept ] >>= function - | Ok (`Flow flow) -> - Lwt.async (fun () -> handler flow) ; - Lwt.pause () >>= loop - | Ok `Stop -> Svc.close master - | Error err0 -> ( - Svc.close master >>= function - | Ok () -> Lwt.return_error err0 - | Error _err1 -> Lwt.return_error err0) in - loop () >>= function - | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" Svc.pp_error err) in - (stop, main) - -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type master - - val protocol : (endpoint, flow) protocol - - val service : (configuration, master, flow) Service.service -end diff --git a/src/lwt/tCP.ml b/src/lwt/tCP.ml deleted file mode 100644 index c695125d..00000000 --- a/src/lwt/tCP.ml +++ /dev/null @@ -1,315 +0,0 @@ -open Lwt.Infix - -let pf = Format.fprintf - -let pp_sockaddr ppf = function - | Unix.ADDR_UNIX v -> pf ppf "<%s>" v - | Unix.ADDR_INET (inet_addr, port) -> - pf ppf "<%s:%d>" (Unix.string_of_inet_addr inet_addr) port - -module Protocol = struct - type input = Cstruct.t - - type output = Cstruct.t - - type +'a io = 'a Lwt.t - - type endpoint = Lwt_unix.sockaddr - - type flow = { - socket : Lwt_unix.file_descr; - sockaddr : Lwt_unix.sockaddr; - linger : Bytes.t; - mutable closed : bool; - } - - let peer { sockaddr; _ } = sockaddr - - let sock { socket; _ } = Lwt_unix.getsockname socket - - let file_descr { socket; _ } = socket - - type error = - [ `Closed_by_peer - | `Operation_not_permitted - | `Address_already_in_use of Unix.sockaddr - | `Cannot_assign_requested_address of Unix.sockaddr - | `Address_family_not_supported_by_protocol of Unix.sockaddr - | `Operation_already_in_progress - | `Bad_address - | `Network_is_unreachable - | `Connection_timed_out - | `Connection_refused - | `Transport_endpoint_is_not_connected ] - - let pp_error ppf = function - | `Closed_by_peer -> pf ppf "Connection closed by peer" - | `Operation_not_permitted -> pf ppf "Operation not permitted" - | `Address_already_in_use sockaddr -> - pf ppf "Address %a already in use" pp_sockaddr sockaddr - | `Cannot_assign_requested_address sockaddr -> - pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr - | `Address_family_not_supported_by_protocol sockaddr -> - pf ppf "Address family %a not supported by protocol" pp_sockaddr - sockaddr - | `Operation_already_in_progress -> pf ppf "Operation already in progress" - | `Bad_address -> pf ppf "Bad address" - | `Network_is_unreachable -> pf ppf "Network is unreachable" - | `Connection_timed_out -> pf ppf "Connection timed out" - | `Connection_refused -> pf ppf "Connection refused" - | `Transport_endpoint_is_not_connected -> - pf ppf "Transport endpoint is not connected" - - let io_buffer_size = 65536 - - let connect sockaddr = - let socket = - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 - in - let linger = Bytes.create io_buffer_size in - let rec go () = - let process () = - Lwt_unix.connect socket sockaddr >>= fun () -> - Lwt.return_ok { socket; sockaddr; linger; closed = false } in - Lwt.catch process @@ function - | Unix.(Unix_error ((EACCES | EPERM), _, _)) -> - Lwt.return_error `Operation_not_permitted - | Unix.(Unix_error (EADDRINUSE, _, _)) -> - Lwt.return_error (`Address_already_in_use sockaddr) - | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> - Lwt.return_error (`Cannot_assign_requested_address sockaddr) - | Unix.(Unix_error (EAFNOSUPPORT, _, _)) -> - Lwt.return_error (`Address_family_not_supported_by_protocol sockaddr) - | Unix.(Unix_error (EALREADY, _, _)) -> - Lwt.return_error `Operation_already_in_progress - | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address - | Unix.(Unix_error (ENETUNREACH, _, _)) -> - Lwt.return_error `Network_is_unreachable - | Unix.(Unix_error (ETIMEDOUT, _, _)) -> - Lwt.return_error `Connection_timed_out - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> go () - | Unix.(Unix_error (EINTR, _, _)) -> go () - | Unix.(Unix_error (ECONNREFUSED, _, _)) -> - Lwt.return_error `Connection_refused - | exn -> Lwt.fail exn - (* | EPROTOTYPE: impossible *) - (* | EISCONN: impossible *) - (* | ENOTSOCK: impossible *) - (* | EBADF: impossible *) - (* | EINPROGRESS: TODO *) in - go () - - (* XXX(dinosaure): [recv] wants to fill [raw] as much as possible until - it has reached [`End_of_file]. *) - let rec recv ({ socket; closed; _ } as t) raw = - if closed - then Lwt.return_ok `End_of_flow - else - let rec process filled raw = - let max = Cstruct.len raw in - Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) - >>= fun len -> - if len = 0 - then Lwt.return_ok (if filled = 0 then `End_of_flow else `Input filled) - else ( - Cstruct.blit_from_bytes t.linger 0 raw 0 len ; - if len = Bytes.length t.linger && max > Bytes.length t.linger - then - if Lwt_unix.readable t.socket - then process (filled + len) (Cstruct.shift raw len) - else - Lwt.return_ok - (if filled + len = 0 - then `End_of_flow - else `Input (filled + len)) - else - Lwt.return_ok - (if filled + len = 0 then `End_of_flow else `Input (filled + len))) - in - Lwt.catch (fun () -> process 0 raw) @@ function - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw - | Unix.(Unix_error (EINTR, _, _)) -> recv t raw - | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address - | Unix.(Unix_error (ENOTCONN, _, _)) -> - Lwt.return_error `Transport_endpoint_is_not_connected - (* | Unix.(Unix_error (ECONNREFUSED, _, _)): TODO *) - (* | EBADF: impossible *) - | exn -> Lwt.fail exn - - (* XXX(dinosaure): [send] tries to send as much as it can [raw]. However, - if [send] returns something smaller that what we requested, we stop - the process and return how many byte(s) we sended. - - Try to send into a closed socket is an error. *) - let rec send ({ socket; closed; _ } as t) raw = - if closed - then Lwt.return_error `Closed_by_peer - else - let max = Cstruct.len raw in - let len0 = min (Bytes.length t.linger) max in - Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; - let process () = - Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> - if len1 = len0 - then - if max > len0 - then send t (Cstruct.shift raw len0) - else Lwt.return_ok max - else Lwt.return_ok len1 - (* worst case *) in - Lwt.catch process @@ function - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> send t raw - | Unix.(Unix_error (EINTR, _, _)) -> send t raw - | Unix.(Unix_error (EACCES, _, _)) -> - Lwt.return_error `Operation_not_permitted - | Unix.(Unix_error (ECONNRESET, _, _)) -> - Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; - t.closed <- true ; - Lwt.return_error `Closed_by_peer - | Unix.(Unix_error (EPIPE, _, _)) -> - Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; - t.closed <- true ; - Lwt.return_error `Closed_by_peer - | Unix.(Unix_error (EDESTADDRREQ, _, _)) - | Unix.(Unix_error (ENOTCONN, _, _)) -> - Lwt.return_error `Transport_endpoint_is_not_connected - | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address - (* ENOTSOCK: impossible *) - (* EISCONN: TODO *) - (* EOPNOTSUPP: TODO *) - (* ENOBUFS: TODO & impossible into Linux *) - | exn -> Lwt.fail exn - - let rec close t = - let process () = - if not t.closed - then ( - Lwt_unix.close t.socket >>= fun () -> - t.closed <- true ; - Lwt.return_ok ()) - else Lwt.return_ok () in - Lwt.catch process @@ function - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> close t - | Unix.(Unix_error (EINTR, _, _)) -> close t - | exn -> Lwt.fail exn -end - -type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } - -module Server = struct - type +'a io = 'a Lwt.t - - type nonrec configuration = configuration = { - sockaddr : Lwt_unix.sockaddr; - capacity : int; - } - - type t = Lwt_unix.file_descr - - type flow = Protocol.flow - - type error = - [ `Address_is_protected of Unix.sockaddr - | `Operation_not_permitted of Unix.sockaddr - | `Address_already_in_use of Unix.sockaddr - | `Address_is_not_valid of Unix.sockaddr - | `Cannot_assign_requested_address of Unix.sockaddr - | `Bad_address - | `Too_many_symbolic_links of Unix.sockaddr - | `Name_too_long of Unix.sockaddr - | `Operation_not_supported - | `Limit_reached - | `Protocol_error - | `Firewall_rules_forbid_connection ] - - let pp_error ppf = function - | `Address_is_protected sockaddr -> - pf ppf "Address %a is protected" pp_sockaddr sockaddr - | `Operation_not_permitted sockaddr -> - pf ppf "Operation on %a is not permitted" pp_sockaddr sockaddr - | `Address_already_in_use sockaddr -> - pf ppf "Address %a already in use" pp_sockaddr sockaddr - | `Address_is_not_valid sockaddr -> - pf ppf "Address %a is not valid" pp_sockaddr sockaddr - | `Cannot_assign_requested_address sockaddr -> - pf ppf "Cannot assign request address %a" pp_sockaddr sockaddr - | `Bad_address -> pf ppf "Bad address" - | `Too_many_symbolic_links sockaddr -> - pf ppf "Too many symbolic links on %a" pp_sockaddr sockaddr - | `Name_too_long sockaddr -> pf ppf "Name %a too long" pp_sockaddr sockaddr - | `Operation_not_supported -> pf ppf "Operation not supported" - | `Limit_reached -> pf ppf "Limit of file-descriptors reached" - | `Protocol_error -> pf ppf "Protocol error" - | `Firewall_rules_forbid_connection -> - pf ppf "Firewill rules forbid connection" - - let is_addr_inet = function - | Unix.ADDR_INET _ -> true - | Unix.ADDR_UNIX _ -> false - - let init { sockaddr; capacity } = - let socket = - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 - in - Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true ; - let process () = - Lwt_unix.bind socket sockaddr >>= fun () -> - Lwt_unix.listen socket capacity ; - Lwt.return_ok socket in - Lwt.catch process @@ function - (* bind *) - | Unix.(Unix_error (EACCES, _, _)) when is_addr_inet sockaddr -> - Lwt.return_error (`Address_is_protected sockaddr) - | Unix.(Unix_error (EACCES, _, _)) (* when is_addr_unix sockaddr *) -> - Lwt.return_error (`Operation_not_permitted sockaddr) - | Unix.(Unix_error (EADDRINUSE, _, _)) -> - Lwt.return_error (`Address_already_in_use sockaddr) - | Unix.(Unix_error (EINVAL, _, _)) -> - Lwt.return_error (`Address_is_not_valid sockaddr) - (* | ENOTSOCK: impossible *) - | Unix.(Unix_error (EADDRNOTAVAIL, _, _)) -> - Lwt.return_error (`Cannot_assign_requested_address sockaddr) - | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address - | Unix.(Unix_error (ELOOP, _, _)) -> - Lwt.return_error (`Too_many_symbolic_links sockaddr) - | Unix.(Unix_error (ENAMETOOLONG, _, _)) -> - Lwt.return_error (`Name_too_long sockaddr) - (* listen *) - (* | Unix.(Unix_error (EADDRINUSE, _, _)) -> *) - | Unix.(Unix_error (EOPNOTSUPP, _, _)) -> - Lwt.return_error `Operation_not_supported - | exn -> Lwt.fail exn - - let rec accept master = - let process () = - Lwt_unix.accept master >>= fun (socket, sockaddr) -> - let linger = Bytes.create 0x1000 in - Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } in - Lwt.catch process @@ function - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept master - | Unix.(Unix_error (EINTR, _, _)) -> accept master - | Unix.(Unix_error (EMFILE, _, _)) - | Unix.(Unix_error ((ENOBUFS | ENOMEM), _, _)) -> - Lwt.return_error `Limit_reached - | Unix.(Unix_error (EPROTOTYPE, _, _)) -> Lwt.return_error `Protocol_error - | Unix.(Unix_error (EPERM, _, _)) -> - Lwt.return_error `Firewall_rules_forbid_connection - | exn -> Lwt.fail exn - - let close _master = - (* XXX(dinosaure): it seems that on MacOS, try to close the [master] - socket raises an error. *) - Lwt.return_ok () -end - -let protocol = Internal.register ~protocol:(module Protocol) - -include (val Internal.repr protocol) - -let service = Internal.Service.register ~service:(module Server) - -let resolv_conf ~port domain_name = - Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function - | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> - Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) - | _ -> Lwt.return_none From 7a8fc1e446f963901dd942609ef381dc94bdd87c Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 16:03:41 +0200 Subject: [PATCH 052/140] Rename master -> service --- src/async/conduit_async.ml | 20 ++++++++++---------- src/lwt-ssl/conduit_lwt_ssl.ml | 16 ++++++++-------- src/lwt-ssl/conduit_lwt_ssl.mli | 8 ++++---- src/lwt/conduit_lwt.ml | 22 +++++++++++----------- src/lwt/conduit_lwt.mli | 2 +- src/mirage/conduit_mirage.ml | 16 ++++++++-------- tests/common.ml | 4 ++-- tests/ping_pong.ml | 4 ++-- tests/with_async.ml | 4 ++-- 9 files changed, 48 insertions(+), 48 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index bca22651..dca87063 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -13,9 +13,9 @@ let failwith fmt = Format.kasprintf failwith fmt let ( >>? ) x f = Async.Deferred.Result.bind x ~f let serve : - type cfg master flow. + type cfg t flow. handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, master, flow) Service.service -> + service:(cfg, t, flow) Service.service -> cfg -> unit Async.Condition.t * unit Async.Deferred.t = fun ~handler ~service cfg -> @@ -25,20 +25,20 @@ let serve : let main = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( + | Ok t -> ( let rec loop () = let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in let accept = - Svc.accept master >>? fun flow -> + Svc.accept t >>? fun flow -> Async.(Deferred.ok (return (`Flow flow))) in Async.Deferred.any [ close; accept ] >>= function | Ok (`Flow flow) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok `Stop -> Svc.close master + | Ok `Stop -> Svc.close t | Error err0 -> ( - Svc.close master >>= function + Svc.close t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in loop () >>= function @@ -192,7 +192,7 @@ module TCP = struct type nonrec configuration = configuration type t = - | Master : + | Socket : ([ `Passive ], ([< Socket.Address.t ] as 'a)) Socket.t * 'a -> t @@ -219,9 +219,9 @@ module TCP = struct let socket = Socket.create socket_type in let f () = Socket.bind socket addr >>| Socket.listen in close_socket_on_error ~process:`Make socket ~f >>? fun socket -> - Async.return (Ok (Master (socket, addr))) + Async.return (Ok (Socket (socket, addr))) - let accept (Master (socket, _)) = + let accept (Socket (socket, _)) = Socket.accept socket >>= function | `Ok (socket, address) -> let reader = Reader.create (Socket.fd socket) in @@ -230,7 +230,7 @@ module TCP = struct Async.return (Ok flow) | `Socket_closed -> Async.return (Error Socket_closed) - let close (Master (socket, _)) = + let close (Socket (socket, _)) = Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index 96b4a3df..ef1b8550 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -73,7 +73,7 @@ let protocol_with_ssl : let module M = Protocol (Flow) in Conduit_lwt.register ~protocol:(module M) -type 't master = { master : 't; context : Ssl.context } +type 't service = { service : 't; context : Ssl.context } module Server (Service : sig include Conduit_lwt.SERVICE @@ -85,7 +85,7 @@ struct type configuration = Ssl.context * Service.configuration - type t = Service.t master + type t = Service.t service type flow = Lwt_ssl.socket @@ -95,10 +95,10 @@ struct let init (context, edn) = Service.init edn >|= reword_error (fun err -> `Service err) - >>? fun master -> Lwt.return_ok { master; context } + >>? fun service -> Lwt.return_ok { service; context } - let accept { master; context } = - Service.accept master >|= reword_error (fun err -> `Service err) + let accept { service; context } = + Service.accept service >|= reword_error (fun err -> `Service err) >>? fun flow -> let accept () = Lwt_ssl.ssl_accept (Service.file_descr flow) context in let process socket = Lwt.return_ok socket in @@ -106,8 +106,8 @@ struct Lwt_unix.close (Service.file_descr flow) >>= fun () -> Lwt.fail exn in Lwt.try_bind accept process error - let close { master; _ } = - Service.close master >|= reword_error (fun err -> `Service err) + let close { service; _ } = + Service.close service >|= reword_error (fun err -> `Service err) end let service_with_ssl : @@ -115,7 +115,7 @@ let service_with_ssl : (cfg, t, flow) Conduit_lwt.Service.service -> file_descr:(flow -> Lwt_unix.file_descr) -> (edn, Lwt_ssl.socket) Conduit_lwt.protocol -> - (Ssl.context * cfg, t master, Lwt_ssl.socket) Conduit_lwt.Service.service = + (Ssl.context * cfg, t service, Lwt_ssl.socket) Conduit_lwt.Service.service = fun service ~file_descr _ -> let module S = (val Conduit_lwt.Service.impl service) in let module M = Server (struct diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index ced936ae..48c5719d 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -59,14 +59,14 @@ val protocol_with_ssl : (** [protocol_with_ssl ~key protocol] returns a representation of the given protocol with SSL. *) -type 't master -(** Type of the {i master} socket. *) +type 't service +(** The type for SSL services. *) val service_with_ssl : ('cfg, 't, 'flow) Service.service -> file_descr:('flow -> Lwt_unix.file_descr) -> ('edn, Lwt_ssl.socket) protocol -> - (Ssl.context * 'cfg, 't master, Lwt_ssl.socket) Service.service + (Ssl.context * 'cfg, 't service, Lwt_ssl.socket) Service.service (** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a representation of the given service with SSL. The service deliver an SSL flow which must be described by a [Lwt_ssl.socket Witness.protocol] (eg. @@ -83,7 +83,7 @@ module TCP : sig val service : ( Ssl.context * configuration, - Server.t master, + Server.t service, Lwt_ssl.socket ) Service.service diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index dc87f6d9..0dcd6752 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -44,9 +44,9 @@ let io_of_flow flow = let ( >>? ) = Lwt_result.bind let serve : - type cfg master flow. + type cfg service flow. handler:(flow -> unit Lwt.t) -> - service:(cfg, master, flow) Service.service -> + service:(cfg, service, flow) Service.service -> cfg -> unit Lwt_condition.t * unit Lwt.t = fun ~handler ~service cfg -> @@ -56,19 +56,19 @@ let serve : let main = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( + | Ok service -> ( let rec loop () = let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = - Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in Lwt.pick [ stop; accept ] >>= function | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok `Stop -> Svc.close master + | Ok `Stop -> Svc.close service | Error err0 -> ( - Svc.close master >>= function + Svc.close service >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function @@ -377,15 +377,15 @@ module TCP = struct Lwt.return_error `Operation_not_supported | exn -> Lwt.fail exn - let rec accept master = + let rec accept service = let process () = - Lwt_unix.accept master >>= fun (socket, sockaddr) -> + Lwt_unix.accept service >>= fun (socket, sockaddr) -> let linger = Bytes.create 0x1000 in Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } in Lwt.catch process @@ function - | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept master - | Unix.(Unix_error (EINTR, _, _)) -> accept master + | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept service + | Unix.(Unix_error (EINTR, _, _)) -> accept service | Unix.(Unix_error (EMFILE, _, _)) | Unix.(Unix_error ((ENOBUFS | ENOMEM), _, _)) -> Lwt.return_error `Limit_reached @@ -394,7 +394,7 @@ module TCP = struct Lwt.return_error `Firewall_rules_forbid_connection | exn -> Lwt.fail exn - let close _master = + let close _service = (* XXX(dinosaure): it seems that on MacOS, try to close the [master] socket raises an error. *) Lwt.return_ok () diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 85745c3f..d6b36a49 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -11,7 +11,7 @@ val io_of_flow : val serve : handler:('flow -> unit Lwt.t) -> - service:('cfg, 'master, 'flow) Service.service -> + service:('cfg, 'service, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t (** [serve ~handler ~service cfg] creates an usual infinite [service] diff --git a/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml index 6a311f61..e293177c 100644 --- a/src/mirage/conduit_mirage.ml +++ b/src/mirage/conduit_mirage.ml @@ -13,9 +13,9 @@ let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt let ( >>? ) = Lwt_result.bind let serve : - type cfg master flow. + type cfg service flow. handler:(flow -> unit Lwt.t) -> - service:(cfg, master, flow) Service.service -> + service:(cfg, service, flow) Service.service -> cfg -> unit Lwt_condition.t * unit Lwt.t = fun ~handler ~service cfg -> @@ -25,19 +25,19 @@ let serve : let main = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok master -> ( + | Ok service -> ( let rec loop () = let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = - Svc.accept master >>? fun flow -> Lwt.return_ok (`Flow flow) in + Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in Lwt.pick [ stop; accept ] >>= function | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok `Stop -> Svc.close master + | Ok `Stop -> Svc.close service | Error err0 -> ( - Svc.close master >>= function + Svc.close service >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function @@ -52,9 +52,9 @@ module type CONDUIT = sig type configuration - type master + type service val protocol : (endpoint, flow) protocol - val service : (configuration, master, flow) Service.service + val service : (configuration, service, flow) Service.service end diff --git a/tests/common.ml b/tests/common.ml index 1de95032..3b9d6d28 100644 --- a/tests/common.ml +++ b/tests/common.ml @@ -95,10 +95,10 @@ struct | Ok () -> return () let server : - type cfg master flow. + type cfg service flow. cfg -> protocol:(_, flow) Conduit.protocol -> - service:(cfg, master, flow) Conduit.Service.service -> + service:(cfg, service, flow) Conduit.Service.service -> unit Condition.t * unit IO.t = fun cfg ~protocol ~service -> Conduit.serve diff --git a/tests/ping_pong.ml b/tests/ping_pong.ml index 26c80571..1d64f92a 100644 --- a/tests/ping_pong.ml +++ b/tests/ping_pong.ml @@ -65,10 +65,10 @@ let config cert key = | _ -> Fmt.failwith "Invalid key or certificate" let run_with : - type cfg master flow. + type cfg service flow. cfg -> protocol:(_, flow) Conduit_lwt.protocol -> - service:(cfg, master, flow) Conduit_lwt.Service.service -> + service:(cfg, service, flow) Conduit_lwt.Service.service -> string list -> unit = fun cfg ~protocol ~service clients -> diff --git a/tests/with_async.ml b/tests/with_async.ml index 07374cc6..abb3a32b 100644 --- a/tests/with_async.ml +++ b/tests/with_async.ml @@ -55,10 +55,10 @@ let resolvers = let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : - type cfg master flow. + type cfg service flow. cfg -> protocol:(_, flow) Conduit_async.protocol -> - service:(cfg, master, flow) Conduit_async.Service.service -> + service:(cfg, service, flow) Conduit_async.Service.service -> string list -> unit = fun cfg ~protocol ~service clients -> From 414f16510377a54d9de7582de259857dd2a5f5e6 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 16:18:14 +0200 Subject: [PATCH 053/140] Refactor tests a bit --- tests/README.md | 26 ------- tests/dune | 77 +------------------ tests/flow.ml | 21 +++-- tests/flow.mli | 1 + tests/{ => ping-pong}/client0 | 0 tests/{ => ping-pong}/client1 | 0 tests/{ => ping-pong}/client2 | 0 tests/{ => ping-pong}/common.ml | 0 tests/ping-pong/dune | 54 +++++++++++++ tests/{ => ping-pong}/server.key | 0 tests/{ => ping-pong}/server.pem | 0 tests/{ => ping-pong}/test_async.ml | 0 tests/{ => ping-pong}/test_lwt.ml | 18 ++--- tests/{ => ping-pong}/with_async.ml | 0 tests/{ping_pong.ml => ping-pong/with_lwt.ml} | 0 tests/resolvers.ml | 4 +- tests/resolvers.mli | 1 + tests/tests.ml | 1 + 18 files changed, 79 insertions(+), 124 deletions(-) delete mode 100644 tests/README.md create mode 100644 tests/flow.mli rename tests/{ => ping-pong}/client0 (100%) rename tests/{ => ping-pong}/client1 (100%) rename tests/{ => ping-pong}/client2 (100%) rename tests/{ => ping-pong}/common.ml (100%) create mode 100644 tests/ping-pong/dune rename tests/{ => ping-pong}/server.key (100%) rename tests/{ => ping-pong}/server.pem (100%) rename tests/{ => ping-pong}/test_async.ml (100%) rename tests/{ => ping-pong}/test_lwt.ml (70%) rename tests/{ => ping-pong}/with_async.ml (100%) rename tests/{ping_pong.ml => ping-pong/with_lwt.ml} (100%) create mode 100644 tests/resolvers.mli create mode 100644 tests/tests.ml diff --git a/tests/README.md b/tests/README.md deleted file mode 100644 index 3545bd40..00000000 --- a/tests/README.md +++ /dev/null @@ -1,26 +0,0 @@ -### ping-pong tests - -`ping-pong` wants to test `conduit-lwt-unix`. The process to test it is: -- we start a server which respond with "ping" if it receives "pong" and vice-versa -- we launch many clients to communicate with it - -Currently, `ping-pong` tests: -- a simple TCP/IP server/clients -- a TLS + TCP/IP server/clients -- a SSL + TCP/IP server/clients - -All of these share the same server and the same client implementation. The test shows to -us that the logic of the server/client is independent from the protocol used. - -Finally, where all clients are finished, we stop the server. - -### Async tests - -`with_async` does the same job as `ping_pong` and it ~is~ implemented in the same way than -`ping_pong` but with `async`. The test does not take the advantage of `Reader.t` or `Writer.t` -due to the non-atomicity of `Conduit_async_tls.Protocol.{recv,send}` (see `conduit-tls` for -more details). So we re-use a `getline` implementation as `ping_pong`. - -### Results - -The test wants to show that these programs terminate correctly! diff --git a/tests/dune b/tests/dune index ee0c00c7..2a0f6c3a 100644 --- a/tests/dune +++ b/tests/dune @@ -1,77 +1,4 @@ -(library - (name common) - (modules common) - (libraries bigarray cstruct stdlib-shims bigstringaf ke fmt rresult conduit)) - -(executable - (name ping_pong) - (modules ping_pong) - (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-lwt - conduit-lwt-tls conduit-lwt-ssl)) - -(executable - (name with_async) - (modules with_async) - (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async - conduit-async-tls conduit-async-ssl)) - -(executable - (name test_lwt) - (modules test_lwt) - (libraries unix)) - -(rule - (alias runtest) - (package conduit-lwt) - (deps - (:test test_lwt.exe) - ping_pong.exe - server.pem - server.key - client0 - client1 - client2) - (action - (run %{test}))) - -(executable - (name test_async) - (modules test_async) - (libraries unix)) - -(rule - (alias runtest) - (package conduit-async) - (deps - (:test test_async.exe) - ping_pong.exe - with_async.exe - server.pem - server.key - client0 - client1 - client2) - (action - (run %{test}))) - -(executable - (name flow) - (modules flow) - (libraries alcotest rresult conduit)) - -(rule - (alias runtest) +(test + (name tests) (package conduit) - (action - (run ./flow.exe))) - -(executable - (name resolvers) - (modules resolvers) (libraries alcotest rresult conduit)) - -(rule - (alias runtest) - (package conduit) - (action - (run ./resolvers.exe))) diff --git a/tests/flow.ml b/tests/flow.ml index b6bee1e5..91c363a3 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -247,14 +247,13 @@ let test_output_strings = (String.concat "" (List.map Bytes.to_string bufs)) "Hello World!" -let () = - Alcotest.run "flow" - [ - ( "memory", - [ - test_input_string; - test_output_string; - test_input_strings; - test_output_strings; - ] ); - ] +let tests = + [ + ( "flow", + [ + test_input_string; + test_output_string; + test_input_strings; + test_output_strings; + ] ); + ] diff --git a/tests/flow.mli b/tests/flow.mli new file mode 100644 index 00000000..32a8a123 --- /dev/null +++ b/tests/flow.mli @@ -0,0 +1 @@ +val tests : (string * unit Alcotest.test_case list) list diff --git a/tests/client0 b/tests/ping-pong/client0 similarity index 100% rename from tests/client0 rename to tests/ping-pong/client0 diff --git a/tests/client1 b/tests/ping-pong/client1 similarity index 100% rename from tests/client1 rename to tests/ping-pong/client1 diff --git a/tests/client2 b/tests/ping-pong/client2 similarity index 100% rename from tests/client2 rename to tests/ping-pong/client2 diff --git a/tests/common.ml b/tests/ping-pong/common.ml similarity index 100% rename from tests/common.ml rename to tests/ping-pong/common.ml diff --git a/tests/ping-pong/dune b/tests/ping-pong/dune new file mode 100644 index 00000000..9af60313 --- /dev/null +++ b/tests/ping-pong/dune @@ -0,0 +1,54 @@ +(library + (name common) + (modules common) + (libraries bigarray cstruct stdlib-shims bigstringaf ke fmt rresult conduit)) + +(executable + (name with_lwt) + (modules with_lwt) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-lwt + conduit-lwt-tls conduit-lwt-ssl)) + +(executable + (name test_lwt) + (modules test_lwt) + (libraries unix)) + +(rule + (alias runtest) + (package conduit-lwt) + (deps + (:test test_lwt.exe) + with_lwt.exe + server.pem + server.key + client0 + client1 + client2) + (action + (run %{test}))) + +(executable + (name with_async) + (modules with_async) + (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async + conduit-async-tls conduit-async-ssl)) + +(executable + (name test_async) + (modules test_async) + (libraries unix)) + +(rule + (alias runtest) + (package conduit-async) + (deps + (:test test_async.exe) + with_async.exe + server.pem + server.key + client0 + client1 + client2) + (action + (run %{test}))) diff --git a/tests/server.key b/tests/ping-pong/server.key similarity index 100% rename from tests/server.key rename to tests/ping-pong/server.key diff --git a/tests/server.pem b/tests/ping-pong/server.pem similarity index 100% rename from tests/server.pem rename to tests/ping-pong/server.pem diff --git a/tests/test_async.ml b/tests/ping-pong/test_async.ml similarity index 100% rename from tests/test_async.ml rename to tests/ping-pong/test_async.ml diff --git a/tests/test_lwt.ml b/tests/ping-pong/test_lwt.ml similarity index 70% rename from tests/test_lwt.ml rename to tests/ping-pong/test_lwt.ml index c8bd28e6..c9019529 100644 --- a/tests/test_lwt.ml +++ b/tests/ping-pong/test_lwt.ml @@ -15,17 +15,17 @@ let properly_exited = function Unix.WEXITED 0 -> true | _ -> false let () = let pid = - Unix.create_process_env "./ping_pong.exe" - [| "./ping_pong.exe"; "client0"; "client1"; "client2" |] + Unix.create_process_env "./with_lwt.exe" + [| "./with_lwt.exe"; "client0"; "client1"; "client2" |] [||] Unix.stdin Unix.stdout Unix.stderr in let _, status = Unix.waitpid [] pid in res := !res && properly_exited status ; - Format.printf ">>> ping_pong.exe: %a.\n%!" pp_process_status status ; + Format.printf ">>> with_lwt.exe: %a.\n%!" pp_process_status status ; let pid = - Unix.create_process_env "./ping_pong.exe" + Unix.create_process_env "./with_lwt.exe" [| - "./ping_pong.exe"; + "./with_lwt.exe"; "--with-ssl"; "server.pem"; "server.key"; @@ -36,12 +36,12 @@ let () = [||] Unix.stdin Unix.stdout Unix.stderr in let _, status = Unix.waitpid [] pid in res := !res && properly_exited status ; - Format.printf ">>> ping_pong.exe --with-ssl: %a.\n%!" pp_process_status status ; + Format.printf ">>> with_lwt.exe --with-ssl: %a.\n%!" pp_process_status status ; let pid = - Unix.create_process_env "./ping_pong.exe" + Unix.create_process_env "./with_lwt.exe" [| - "./ping_pong.exe"; + "./with_lwt.exe"; "--with-tls"; "server.pem"; "server.key"; @@ -52,6 +52,6 @@ let () = [||] Unix.stdin Unix.stdout Unix.stderr in let _, status = Unix.waitpid [] pid in res := !res && properly_exited status ; - Format.printf ">>> ping_pong.exe --with-tls: %a.\n%!" pp_process_status status ; + Format.printf ">>> with_lwt.exe --with-tls: %a.\n%!" pp_process_status status ; if !res then exit exit_success else exit exit_failure diff --git a/tests/with_async.ml b/tests/ping-pong/with_async.ml similarity index 100% rename from tests/with_async.ml rename to tests/ping-pong/with_async.ml diff --git a/tests/ping_pong.ml b/tests/ping-pong/with_lwt.ml similarity index 100% rename from tests/ping_pong.ml rename to tests/ping-pong/with_lwt.ml diff --git a/tests/resolvers.ml b/tests/resolvers.ml index 4dd16136..9051845d 100644 --- a/tests/resolvers.ml +++ b/tests/resolvers.ml @@ -161,6 +161,4 @@ let only_one = Alcotest.(check bool) "call string" !string_called true ; Alcotest.(check bool) "call unit" !unit_called true -let () = - Alcotest.run "resolvers" - [ ("resolve", [ all_resolvers; priorities; only_one ]) ] +let tests = [ ("resolvers", [ all_resolvers; priorities; only_one ]) ] diff --git a/tests/resolvers.mli b/tests/resolvers.mli new file mode 100644 index 00000000..32a8a123 --- /dev/null +++ b/tests/resolvers.mli @@ -0,0 +1 @@ +val tests : (string * unit Alcotest.test_case list) list diff --git a/tests/tests.ml b/tests/tests.ml new file mode 100644 index 00000000..c981da8b --- /dev/null +++ b/tests/tests.ml @@ -0,0 +1 @@ +let () = Alcotest.run "conduit" (Flow.tests @ Resolvers.tests) From a302c32a668095a04309da33bc3d26e3bb0e8578 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 16:19:45 +0200 Subject: [PATCH 054/140] Remove `module type CONDUIT` Not sure why it is used for. --- src/lwt/conduit_lwt.ml | 14 -------------- src/lwt/conduit_lwt.mli | 14 -------------- src/mirage/conduit_mirage.ml | 14 -------------- src/mirage/conduit_mirage.mli | 14 -------------- 4 files changed, 56 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 0dcd6752..1683ade5 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -76,20 +76,6 @@ let serve : | Error err -> failwith "%a" Svc.pp_error err) in (stop, main) -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type master - - val protocol : (endpoint, flow) protocol - - val service : (configuration, master, flow) Service.service -end - module TCP = struct open Lwt.Infix diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index d6b36a49..14db4378 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -37,20 +37,6 @@ val serve : of {i types witnesses}. *) -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type master - - val protocol : (endpoint, flow) protocol - - val service : (configuration, master, flow) Service.service -end - module TCP : sig (** Implementation of TCP protocol as a client. diff --git a/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml index e293177c..9595ada2 100644 --- a/src/mirage/conduit_mirage.ml +++ b/src/mirage/conduit_mirage.ml @@ -44,17 +44,3 @@ let serve : | Ok () -> Lwt.return_unit | Error err -> failwith "%a" Svc.pp_error err) in (stop, main) - -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type service - - val protocol : (endpoint, flow) protocol - - val service : (configuration, service, flow) Service.service -end diff --git a/src/mirage/conduit_mirage.mli b/src/mirage/conduit_mirage.mli index 571ff247..f0556b8f 100644 --- a/src/mirage/conduit_mirage.mli +++ b/src/mirage/conduit_mirage.mli @@ -11,17 +11,3 @@ val serve : service:('cfg, 'master, 'flow) Service.service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t - -module type CONDUIT = sig - type endpoint - - type flow - - type configuration - - type master - - val protocol : (endpoint, flow) protocol - - val service : (configuration, master, flow) Service.service -end From f7613ac999cdeff223a121957eea2ebd6032d08d Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 16:23:02 +0200 Subject: [PATCH 055/140] Rename resolv_conf to resolve --- src/async-ssl/conduit_async_ssl.ml | 4 ++-- src/async-ssl/conduit_async_ssl.mli | 2 +- src/async-tls/conduit_async_tls.ml | 4 ++-- src/async-tls/conduit_async_tls.mli | 2 +- src/async/conduit_async.ml | 2 +- src/async/conduit_async.mli | 2 +- src/lwt-ssl/conduit_lwt_ssl.ml | 4 ++-- src/lwt-ssl/conduit_lwt_ssl.mli | 2 +- src/lwt-tls/conduit_lwt_tls.ml | 4 ++-- src/lwt-tls/conduit_lwt_tls.mli | 2 +- src/lwt/conduit_lwt.ml | 2 +- src/lwt/conduit_lwt.mli | 2 +- tests/ping-pong/with_async.ml | 6 +++--- tests/ping-pong/with_lwt.ml | 6 +++--- 14 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index 94acc2a3..3ab3c1fc 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -306,8 +306,8 @@ module TCP = struct service_with_ssl service ~reader:Protocol.reader ~writer:Protocol.writer protocol - let resolv_conf ~port ~context domain_name = - resolv_conf ~port domain_name >>| function + let resolve ~port ~context domain_name = + resolve ~port domain_name >>| function | Some edn -> Some (context, edn) | None -> None end diff --git a/src/async-ssl/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli index e1ac0962..1282f9f9 100644 --- a/src/async-ssl/conduit_async_ssl.mli +++ b/src/async-ssl/conduit_async_ssl.mli @@ -65,5 +65,5 @@ module TCP : sig Protocol.flow with_ssl ) Service.service - val resolv_conf : port:int -> context:context -> (context * endpoint) resolver + val resolve : port:int -> context:context -> (context * endpoint) resolver end diff --git a/src/async-tls/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml index f4eae035..9179385a 100644 --- a/src/async-tls/conduit_async_tls.ml +++ b/src/async-tls/conduit_async_tls.ml @@ -8,8 +8,8 @@ module TCP = struct let service = service_with_tls service protocol - let resolv_conf ~port ~config domain_name = - resolv_conf ~port domain_name >>| function + let resolve ~port ~config domain_name = + resolve ~port domain_name >>| function | Some edn -> Some (edn, config) | None -> None end diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index daaf20aa..487738d5 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -32,7 +32,7 @@ module TCP : sig Protocol.flow protocol_with_tls ) Service.service - val resolv_conf : + val resolve : port:int -> config:Tls.Config.client -> (endpoint * Tls.Config.client) resolver diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index dca87063..b1c66ed6 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -236,7 +236,7 @@ module TCP = struct let service = Service.register ~service:(module Server) - let resolv_conf ~port domain_name = + let resolve ~port domain_name = Monitor.try_with (fun () -> Unix.Inet_addr.of_string_or_getbyname (Domain_name.to_string domain_name)) diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 93396757..ba3646a2 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -43,5 +43,5 @@ module TCP : sig val service : (configuration, Server.t, Protocol.flow) Service.service - val resolv_conf : port:int -> endpoint resolver + val resolve : port:int -> endpoint resolver end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index ef1b8550..066a5915 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -126,9 +126,9 @@ let service_with_ssl : Conduit_lwt.Service.register ~service:(module M) module TCP = struct - let resolv_conf ~port ~context ?verify domain_name = + let resolve ~port ~context ?verify domain_name = let file_descr = Conduit_lwt.TCP.Protocol.file_descr in - Conduit_lwt.TCP.resolv_conf ~port domain_name >|= function + Conduit_lwt.TCP.resolve ~port domain_name >|= function | Some edn -> Some (endpoint ~context ~file_descr ?verify edn) | None -> None diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index 48c5719d..9bc6277a 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -92,7 +92,7 @@ module TCP : sig Protocol.flow -> (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t - val resolv_conf : + val resolve : port:int -> context:Ssl.context -> ?verify:verify -> diff --git a/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml index 98e70c51..7fa71c8e 100644 --- a/src/lwt-tls/conduit_lwt_tls.ml +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -9,9 +9,9 @@ module TCP = struct let service = service_with_tls service protocol - let resolv_conf ~port ~config domain_name = + let resolve ~port ~config domain_name = let open Lwt.Infix in - resolv_conf ~port domain_name >|= function + resolve ~port domain_name >|= function | Some edn -> Some (edn, config) | None -> None end diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 5439a338..f6c05f41 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -53,7 +53,7 @@ module TCP : sig Protocol.flow protocol_with_tls ) Service.service - val resolv_conf : + val resolve : port:int -> config:Tls.Config.client -> (Lwt_unix.sockaddr * Tls.Config.client) resolver diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 1683ade5..13d83dd6 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -392,7 +392,7 @@ module TCP = struct let service = Service.register ~service:(module Server) - let resolv_conf ~port domain_name = + let resolve ~port domain_name = Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 14db4378..921b1300 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -110,5 +110,5 @@ module TCP : sig val service : (configuration, Server.t, Protocol.flow) Service.service - val resolv_conf : port:int -> Lwt_unix.sockaddr resolver + val resolve : port:int -> Lwt_unix.sockaddr resolver end diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index abb3a32b..bbf005b9 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -33,18 +33,18 @@ let tls_protocol, tls_service = let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt -let resolve_ping_pong = Conduit_async.TCP.resolv_conf ~port:5000 +let resolve_ping_pong = Conduit_async.TCP.resolve ~port:5000 let resolve_ssl_ping_pong = let context = Conduit_async_ssl.context ~verify_modes:Ssl.Verify_mode.[ Verify_none ] () in - Conduit_async_ssl.TCP.resolv_conf ~port:7000 ~context + Conduit_async_ssl.TCP.resolve ~port:7000 ~context let resolve_tls_ping_pong = let null ~host:_ _ = Ok None in let config = Tls.Config.client ~authenticator:null () in - Conduit_async_tls.TCP.resolv_conf ~port:9000 ~config + Conduit_async_tls.TCP.resolve ~port:9000 ~config let resolvers = Conduit.empty diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 1d64f92a..c8181eb4 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -27,16 +27,16 @@ let ssl_protocol, ssl_service = (* Resolution *) -let resolve_ping_pong = Conduit_lwt.TCP.resolv_conf ~port:4000 +let resolve_ping_pong = Conduit_lwt.TCP.resolve ~port:4000 let resolve_tls_ping_pong = let null ~host:_ _ = Ok None in let config = Tls.Config.client ~authenticator:null () in - Conduit_lwt_tls.TCP.resolv_conf ~port:8000 ~config + Conduit_lwt_tls.TCP.resolve ~port:8000 ~config let resolve_ssl_ping_pong = let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in - Conduit_lwt_ssl.TCP.resolv_conf ~port:6000 ~context ?verify:None + Conduit_lwt_ssl.TCP.resolve ~port:6000 ~context ?verify:None let resolvers = Conduit.empty From 10e3d633ff60c5bf860b763d6475267dcf4740bb Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 29 Jun 2020 16:43:43 +0200 Subject: [PATCH 056/140] Be consistent when using Server/Service: try to use Service everywhere --- src/async-ssl/conduit_async_ssl.mli | 6 +++--- src/async-tls/conduit_async_tls.mli | 4 ++-- src/async/conduit_async.ml | 9 ++++++--- src/async/conduit_async.mli | 9 ++++++--- src/lwt-ssl/conduit_lwt_ssl.ml | 4 ++-- src/lwt-ssl/conduit_lwt_ssl.mli | 4 ++-- src/lwt-tls/conduit_lwt_tls.mli | 4 ++-- src/lwt/conduit_lwt.ml | 7 +++++-- src/lwt/conduit_lwt.mli | 9 ++++++--- src/mirage/conduit_mirage_tcp.ml | 4 ++-- 10 files changed, 36 insertions(+), 24 deletions(-) diff --git a/src/async-ssl/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli index 1282f9f9..d6867818 100644 --- a/src/async-ssl/conduit_async_ssl.mli +++ b/src/async-ssl/conduit_async_ssl.mli @@ -60,10 +60,10 @@ module TCP : sig val protocol : (context * endpoint, Protocol.flow with_ssl) protocol val service : - ( context * Server.configuration, - context * Server.t, + ( context * Service.configuration, + context * Service.t, Protocol.flow with_ssl ) - Service.service + service val resolve : port:int -> context:context -> (context * endpoint) resolver end diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index 487738d5..fd5dcc77 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -28,9 +28,9 @@ module TCP : sig val service : ( configuration * Tls.Config.server, - Server.t service_with_tls, + Service.t service_with_tls, Protocol.flow protocol_with_tls ) - Service.service + service val resolve : port:int -> diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index b1c66ed6..bdd22a89 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -7,15 +7,18 @@ module IO = struct end include Conduit.Make (IO) (Cstruct) (Cstruct) +module S = Service let failwith fmt = Format.kasprintf failwith fmt let ( >>? ) x f = Async.Deferred.Result.bind x ~f +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service + let serve : type cfg t flow. handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, t, flow) Service.service -> + service:(cfg, t, flow) service -> cfg -> unit Async.Condition.t * unit Async.Deferred.t = fun ~handler ~service cfg -> @@ -173,7 +176,7 @@ module TCP = struct type configuration = | Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration - module Server = struct + module Service = struct type +'a io = 'a Async.Deferred.t type flow = Protocol.flow @@ -234,7 +237,7 @@ module TCP = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end - let service = Service.register ~service:(module Server) + let service = S.register ~service:(module Service) let resolve ~port domain_name = Monitor.try_with (fun () -> diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index ba3646a2..45436c2c 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -10,9 +10,12 @@ include and type output = Cstruct.t and type +'a io = 'a Async.Deferred.t +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service +(** The type for async services. *) + val serve : handler:('flow -> unit Async.Deferred.t) -> - service:('cfg, 'master, 'flow) Service.service -> + service:('cfg, 'master, 'flow) service -> 'cfg -> unit Async.Condition.t * unit Async.Deferred.t @@ -39,9 +42,9 @@ module TCP : sig type configuration = | Listen : ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration - module Server : SERVICE with type configuration = configuration + module Service : SERVICE with type configuration = configuration - val service : (configuration, Server.t, Protocol.flow) Service.service + val service : (configuration, Service.t, Protocol.flow) service val resolve : port:int -> endpoint resolver end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index 066a5915..df41048f 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -75,7 +75,7 @@ let protocol_with_ssl : type 't service = { service : 't; context : Ssl.context } -module Server (Service : sig +module Service (Service : sig include Conduit_lwt.SERVICE val file_descr : flow -> Lwt_unix.file_descr @@ -118,7 +118,7 @@ let service_with_ssl : (Ssl.context * cfg, t service, Lwt_ssl.socket) Conduit_lwt.Service.service = fun service ~file_descr _ -> let module S = (val Conduit_lwt.Service.impl service) in - let module M = Server (struct + let module M = Service (struct include S let file_descr = file_descr diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index 9bc6277a..282545b2 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -83,9 +83,9 @@ module TCP : sig val service : ( Ssl.context * configuration, - Server.t service, + Service.t service, Lwt_ssl.socket ) - Service.service + Conduit_lwt.service type verify = Ssl.context -> diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index f6c05f41..5cefa735 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -49,9 +49,9 @@ module TCP : sig val service : ( configuration * Tls.Config.server, - Server.t service_with_tls, + Service.t service_with_tls, Protocol.flow protocol_with_tls ) - Service.service + service val resolve : port:int -> diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 13d83dd6..7a5fe554 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -7,6 +7,9 @@ module IO = struct end include Conduit.Make (IO) (Cstruct) (Cstruct) +module S = Service + +type ('a, 'b, 'c) service = ('a, 'b, 'c) S.service let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt @@ -278,7 +281,7 @@ module TCP = struct type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } - module Server = struct + module Service = struct type +'a io = 'a Lwt.t type nonrec configuration = configuration = { @@ -390,7 +393,7 @@ module TCP = struct include (val repr protocol) - let service = Service.register ~service:(module Server) + let service = S.register ~service:(module Service) let resolve ~port domain_name = Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 921b1300..9dd69d69 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -9,9 +9,12 @@ include val io_of_flow : flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service +(** The type for lwt services. *) + val serve : handler:('flow -> unit Lwt.t) -> - service:('cfg, 'service, 'flow) Service.service -> + service:('cfg, 'service, 'flow) service -> 'cfg -> unit Lwt_condition.t * unit Lwt.t (** [serve ~handler ~service cfg] creates an usual infinite [service] @@ -83,7 +86,7 @@ module TCP : sig type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } - module Server : + module Service : SERVICE with type configuration = configuration and type t = Lwt_unix.file_descr @@ -108,7 +111,7 @@ module TCP : sig type flow += T of t - val service : (configuration, Server.t, Protocol.flow) Service.service + val service : (configuration, Service.t, Protocol.flow) service val resolve : port:int -> Lwt_unix.sockaddr resolver end diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index d7341fc3..89e539de 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -212,7 +212,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct mutable closed : bool; } - module Server = struct + module Service = struct type +'a io = 'a Conduit_mirage.io type error = Connection_aborted @@ -269,5 +269,5 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt.return (Ok ())) end - let service = Conduit_mirage.Service.register ~service:(module Server) + let service = Conduit_mirage.Service.register ~service:(module Service) end From 6fc534b6a8b71a88fcd575bfb3d1d599ad325aac Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 29 Jun 2020 17:41:37 +0200 Subject: [PATCH 057/140] conduit-async-{tls,ssl} require conduit-async --- conduit-async-ssl.opam | 2 +- conduit-async-tls.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/conduit-async-ssl.opam b/conduit-async-ssl.opam index 483270a1..afbaeda1 100644 --- a/conduit-async-ssl.opam +++ b/conduit-async-ssl.opam @@ -23,7 +23,7 @@ depends: [ "ocaml" {>= "4.03.0"} "dune" "core" - "conduit" + "conduit-async" "async" {>= "v0.12.0"} "async_ssl" "conduit-tls" diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam index 483270a1..afbaeda1 100644 --- a/conduit-async-tls.opam +++ b/conduit-async-tls.opam @@ -23,7 +23,7 @@ depends: [ "ocaml" {>= "4.03.0"} "dune" "core" - "conduit" + "conduit-async" "async" {>= "v0.12.0"} "async_ssl" "conduit-tls" From 9779d777cd03f85e770ecc1c1174dd382979bc58 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 10 Jul 2020 17:37:51 +0200 Subject: [PATCH 058/140] Re-export resolvers type to signature --- src/core/conduit.ml | 4 ++++ src/core/conduit.mli | 2 ++ 2 files changed, 6 insertions(+) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 65dc1e85..21a71daa 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -110,6 +110,8 @@ module type S = sig type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + type nonrec resolvers = resolvers + val empty : resolvers val add : @@ -313,6 +315,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let ( <.> ) f g x = f (g x) + type nonrec resolvers = resolvers + let empty = empty let add : diff --git a/src/core/conduit.mli b/src/core/conduit.mli index 574b7f4d..e870d908 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -245,6 +245,8 @@ module type S = sig ]} *) + type nonrec resolvers = resolvers + val empty : resolvers val add : From ad082e7e39b113af32baf05a4a316fa138cb0b33 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 14 Aug 2020 14:45:46 +0200 Subject: [PATCH 059/140] Resolver from the DNS stack return a Mirage TCP endpoint --- src/mirage/conduit_mirage_dns.ml | 15 +++++++++++---- src/mirage/conduit_mirage_dns.mli | 7 ++++--- src/mirage/dune | 2 +- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/mirage/conduit_mirage_dns.ml b/src/mirage/conduit_mirage_dns.ml index bf66d4b3..85c06b34 100644 --- a/src/mirage/conduit_mirage_dns.ml +++ b/src/mirage/conduit_mirage_dns.ml @@ -1,4 +1,3 @@ -open Conduit_mirage open Lwt.Infix module Make @@ -10,12 +9,20 @@ struct include Dns_client_mirage.Make (R) (T) (C) (S) let resolv : + S.t -> + ?keepalive:Mirage_protocols.Keepalive.t -> + ?nodelay:bool -> t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) resolver = - fun t ?nameserver ~port domain_name -> + (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver = + fun stack ?keepalive ?(nodelay= false) t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function - | Ok domain_name -> Lwt.return_some (domain_name, port) + | Ok ip -> + Lwt.return_some + { Conduit_mirage_tcp.stack + ; keepalive + ; nodelay + ; ip; port } | Error _err -> Lwt.return_none end diff --git a/src/mirage/conduit_mirage_dns.mli b/src/mirage/conduit_mirage_dns.mli index cdebcf5a..acbbd1b4 100644 --- a/src/mirage/conduit_mirage_dns.mli +++ b/src/mirage/conduit_mirage_dns.mli @@ -1,5 +1,3 @@ -open Conduit_mirage - module Make (R : Mirage_random.S) (T : Mirage_time.S) @@ -8,8 +6,11 @@ module Make include module type of Dns_client_mirage.Make (R) (T) (C) (S) val resolv : + S.t -> + ?keepalive:Mirage_protocols.Keepalive.t -> + ?nodelay:bool -> t -> ?nameserver:Transport.ns_addr -> port:int -> - (Ipaddr.V4.t * int) resolver + (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver end diff --git a/src/mirage/dune b/src/mirage/dune index a4193405..efde26fb 100644 --- a/src/mirage/dune +++ b/src/mirage/dune @@ -14,7 +14,7 @@ (name conduit_mirage_dns) (public_name conduit-mirage.dns) (modules conduit_mirage_dns) - (libraries conduit-mirage dns-client.mirage)) + (libraries conduit-mirage conduit-mirage.tcp dns-client.mirage)) (library (name conduit_mirage_flow) From 9815aa091e9c285e236e1deffb0dc48723ac72a0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 26 Aug 2020 17:42:33 +0200 Subject: [PATCH 060/140] Add mirage-time dependency into conduit-mirage --- conduit-mirage.opam | 1 + src/mirage/dune | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/conduit-mirage.opam b/conduit-mirage.opam index 99705f42..38f8d287 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -24,5 +24,6 @@ depends: [ "conduit" "tcpip" "mirage-flow" + "mirage-time" "dns-client" ] diff --git a/src/mirage/dune b/src/mirage/dune index efde26fb..1c16ad79 100644 --- a/src/mirage/dune +++ b/src/mirage/dune @@ -14,7 +14,7 @@ (name conduit_mirage_dns) (public_name conduit-mirage.dns) (modules conduit_mirage_dns) - (libraries conduit-mirage conduit-mirage.tcp dns-client.mirage)) + (libraries mirage-time conduit-mirage conduit-mirage.tcp dns-client.mirage)) (library (name conduit_mirage_flow) From a44d4d99daeddb7af06906b4320ed35264179b8d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 30 Aug 2020 22:16:57 +0200 Subject: [PATCH 061/140] Add Service.equal to be able to prove the type of cfg/t/flow This function is helpful to be able to tweak on the configuration value required to launch the given service without a full-knowledge of it. By this way, we are able to spcialize certain (well-known) services and keep the abstraction of the given service. --- src/core/conduit.ml | 13 +++++++++++++ src/core/conduit.mli | 15 +++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 21a71daa..d8527f7a 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -140,6 +140,11 @@ module type S = sig type ('cfg, 't, 'flow) service + val equal : + ('cfg0, 't0, 'flow0) service -> + ('cfg1, 't1, 'flow1) service -> + (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option + val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service type error = [ `Msg of string ] @@ -492,6 +497,14 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let pp_error ppf = function `Msg err -> Fmt.string ppf err + let equal : type a b c d e f. + (a, b, c) service -> (d, e, f) service -> + ((a, d) refl * (b, e) refl * (c, f) refl) option + = fun (module A) (module B)-> + match A.Id with + | B.Id -> Some (Refl, Refl, Refl) + | _ -> None + let init : type cfg t flow. cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result io = diff --git a/src/core/conduit.mli b/src/core/conduit.mli index e870d908..c2ee353b 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -325,6 +325,21 @@ module type S = sig for configuration, ['t] is the type for state states. ['flow] is the type for underlying flows. *) + val equal : + ('cfg0, 't0, 'flow0) service -> + ('cfg1, 't1, 'flow1) service -> + (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option + (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are + physically the same. For instance, Conduit] asserts: + + {[ + let service = Service.register ~service:(module V) ;; + + let () = match Service.equal service service with + | Some (Refl, Refl, Refl) -> ... + | _ -> assert false + ]} *) + val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service (** [register ~service] is the service using the implementation [service]. [service] must define [make] and [accept] function to be able to create From 2f6912c4521536dfe34762cc345ad0304ca66888 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 30 Aug 2020 22:32:43 +0200 Subject: [PATCH 062/140] Extend the initialization of a Async TCP service An async TCP service can take a [?backlog] option. We reflect that on the API. --- src/async/conduit_async.ml | 6 +++--- src/async/conduit_async.mli | 2 +- tests/ping-pong/with_async.ml | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index bdd22a89..72c88c75 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -174,7 +174,7 @@ module TCP = struct let protocol = register ~protocol:(module Protocol) type configuration = - | Listen : ('a, 'b) Tcp.Where_to_listen.t -> configuration + | Listen : int option * ('a, 'b) Tcp.Where_to_listen.t -> configuration module Service = struct type +'a io = 'a Async.Deferred.t @@ -214,13 +214,13 @@ module TCP = struct let ( >>? ) x f = x >>= function Ok x -> f x | Error _ as err -> Async.return err - let init (Listen where_to_listen) = + let init (Listen (backlog, where_to_listen)) = let (Socket_type (socket_type, addr)) = match Tcp.Where_to_listen.address where_to_listen with | `Inet _ as addr -> Socket_type (Socket.Type.tcp, addr) | `Unix _ as addr -> Socket_type (Socket.Type.unix, addr) in let socket = Socket.create socket_type in - let f () = Socket.bind socket addr >>| Socket.listen in + let f () = Socket.bind socket addr >>| Socket.listen ?backlog in close_socket_on_error ~process:`Make socket ~f >>? fun socket -> Async.return (Ok (Socket (socket, addr))) diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 45436c2c..b7e87087 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -40,7 +40,7 @@ module TCP : sig val protocol : (Protocol.endpoint, Protocol.flow) protocol type configuration = - | Listen : ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration + | Listen : int option * ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration module Service : SERVICE with type configuration = configuration diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index bbf005b9..1a2ad588 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -79,13 +79,13 @@ let run_with : let run_with_tcp clients = run_with - (Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 5000)) + (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 5000)) ~protocol:tcp_protocol ~service:tcp_service clients let run_with_ssl cert key clients = let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in run_with - (ctx, Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 7000)) + (ctx, Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 7000)) ~protocol:ssl_protocol ~service:ssl_service clients let load_file filename = @@ -110,7 +110,7 @@ let config cert key = let run_with_tls cert key clients = let ctx = config cert key in run_with - (Conduit_async.TCP.Listen (Tcp.Where_to_listen.of_port 9000), ctx) + (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 9000), ctx) ~protocol:tls_protocol ~service:tls_service clients let () = From 9d838819d1d91ba16ae98af4633c7298eec5b2c7 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 30 Aug 2020 23:20:46 +0200 Subject: [PATCH 063/140] Add ?timeout option on the Conduit_*.serve function This permits us to stop to wait a connection if we spend more than [timeout] seconds. --- src/async/conduit_async.ml | 19 +++++++++++++------ src/async/conduit_async.mli | 1 + src/lwt/conduit_lwt.ml | 16 ++++++++++++---- src/lwt/conduit_lwt.mli | 6 ++++-- tests/ping-pong/common.ml | 1 + 5 files changed, 31 insertions(+), 12 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 72c88c75..4e7a9af0 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -17,11 +17,12 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service let serve : type cfg t flow. + ?timeout:int -> handler:(flow -> unit Async.Deferred.t) -> service:(cfg, t, flow) service -> cfg -> unit Async.Condition.t * unit Async.Deferred.t = - fun ~handler ~service cfg -> + fun ?timeout ~handler ~service cfg -> let open Async in let stop = Async.Condition.create () in let module Svc = (val Service.impl service) in @@ -34,13 +35,19 @@ let serve : let accept = Svc.accept t >>? fun flow -> Async.(Deferred.ok (return (`Flow flow))) in - - Async.Deferred.any [ close; accept ] >>= function - | Ok (`Flow flow) -> + let events () = match timeout with + | None -> + Async.Deferred.any [ close; accept; ] >>| fun res -> `Result res + | Some t -> + let t = Core.Time.Span.of_int_sec t in + Async.with_timeout t (Async.Deferred.any [ close; accept; ]) in + + events () >>= function + | `Result (Ok (`Flow flow)) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok `Stop -> Svc.close t - | Error err0 -> ( + | `Result (Ok `Stop) | `Timeout -> Svc.close t + | `Result (Error err0) -> ( Svc.close t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index b7e87087..27fb46d6 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -14,6 +14,7 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service (** The type for async services. *) val serve : + ?timeout:int -> handler:('flow -> unit Async.Deferred.t) -> service:('cfg, 'master, 'flow) service -> 'cfg -> diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 7a5fe554..1b783bd4 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -48,11 +48,12 @@ let ( >>? ) = Lwt_result.bind let serve : type cfg service flow. + ?timeout:int -> handler:(flow -> unit Lwt.t) -> service:(cfg, service, flow) Service.service -> cfg -> unit Lwt_condition.t * unit Lwt.t = - fun ~handler ~service cfg -> + fun ?timeout ~handler ~service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in @@ -64,12 +65,19 @@ let serve : let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in - - Lwt.pick [ stop; accept ] >>= function + let events = match timeout with + | None -> [ stop; accept ] + | Some t -> + let timeout = + Lwt_unix.sleep (float_of_int t) >>= fun () -> + Lwt.return_ok `Timeout in + [ stop; accept; timeout ] in + + Lwt.pick events >>= function | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok `Stop -> Svc.close service + | Ok (`Stop | `Timeout) -> Svc.close service | Error err0 -> ( Svc.close service >>= function | Ok () -> Lwt.return_error err0 diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 9dd69d69..495aa386 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -13,6 +13,7 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service (** The type for lwt services. *) val serve : + ?timeout:int -> handler:('flow -> unit Lwt.t) -> service:('cfg, 'service, 'flow) service -> 'cfg -> @@ -22,7 +23,7 @@ val serve : the loop and a condition variable to stop the loop. {[ - let stop, loop = serve_with_handle + let stop, loop = serve ~handler ~service:TCP.service cfg in Lwt.both (Lwt_unix.sleep 10. >>= fun () -> @@ -31,7 +32,8 @@ val serve : loop ]} - In your example, we want to launch a server only for 10 seconds. *) + In your example, we want to launch a server only for 10 seconds. To help the user, + the option [?timeout] allows us to wait less than [timeout] seconds. *) (** Common interface to properly expose a protocol. diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index 3b9d6d28..daaab439 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -4,6 +4,7 @@ module type S = sig type 'a condition val serve : + ?timeout:int -> handler:('flow -> unit io) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> From e25fce5e0995165017a9efde8a1a7f2f8ba5c2de Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 2 Sep 2020 16:15:39 +0200 Subject: [PATCH 064/140] Apply dune build @fmt --auto-promote --- src/async/conduit_async.ml | 14 ++++++++------ src/async/conduit_async.mli | 4 +++- src/core/conduit.ml | 14 +++++++------- src/lwt/conduit_lwt.ml | 11 ++++++----- src/mirage/conduit_mirage_dns.ml | 9 +++------ 5 files changed, 27 insertions(+), 25 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 4e7a9af0..bd06649c 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -35,14 +35,16 @@ let serve : let accept = Svc.accept t >>? fun flow -> Async.(Deferred.ok (return (`Flow flow))) in - let events () = match timeout with - | None -> - Async.Deferred.any [ close; accept; ] >>| fun res -> `Result res + let events = + match timeout with + | None -> [ close; accept ] | Some t -> - let t = Core.Time.Span.of_int_sec t in - Async.with_timeout t (Async.Deferred.any [ close; accept; ]) in + let t = Core.Time.Span.of_int_sec t in + let timeout = + Async.after t >>| fun () -> Async.return `Timeout in + [ close; accept; timeout ] in - events () >>= function + Async.Deferred.any events >>= function | `Result (Ok (`Flow flow)) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 27fb46d6..16de552f 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -41,7 +41,9 @@ module TCP : sig val protocol : (Protocol.endpoint, Protocol.flow) protocol type configuration = - | Listen : int option * ('a, 'b) Async.Tcp.Where_to_listen.t -> configuration + | Listen : + int option * ('a, 'b) Async.Tcp.Where_to_listen.t + -> configuration module Service : SERVICE with type configuration = configuration diff --git a/src/core/conduit.ml b/src/core/conduit.ml index d8527f7a..aa6cbc7e 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -497,13 +497,13 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let pp_error ppf = function `Msg err -> Fmt.string ppf err - let equal : type a b c d e f. - (a, b, c) service -> (d, e, f) service -> - ((a, d) refl * (b, e) refl * (c, f) refl) option - = fun (module A) (module B)-> - match A.Id with - | B.Id -> Some (Refl, Refl, Refl) - | _ -> None + let equal : + type a b c d e f. + (a, b, c) service -> + (d, e, f) service -> + ((a, d) refl * (b, e) refl * (c, f) refl) option = + fun (module A) (module B) -> + match A.Id with B.Id -> Some (Refl, Refl, Refl) | _ -> None let init : type cfg t flow. diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 1b783bd4..ba8754b6 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -65,13 +65,14 @@ let serve : let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in - let events = match timeout with + let events = + match timeout with | None -> [ stop; accept ] | Some t -> - let timeout = - Lwt_unix.sleep (float_of_int t) >>= fun () -> - Lwt.return_ok `Timeout in - [ stop; accept; timeout ] in + let timeout = + Lwt_unix.sleep (float_of_int t) >>= fun () -> + Lwt.return_ok `Timeout in + [ stop; accept; timeout ] in Lwt.pick events >>= function | Ok (`Flow flow) -> diff --git a/src/mirage/conduit_mirage_dns.ml b/src/mirage/conduit_mirage_dns.ml index 85c06b34..52aaf4d3 100644 --- a/src/mirage/conduit_mirage_dns.ml +++ b/src/mirage/conduit_mirage_dns.ml @@ -16,13 +16,10 @@ struct ?nameserver:Transport.ns_addr -> port:int -> (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver = - fun stack ?keepalive ?(nodelay= false) t ?nameserver ~port domain_name -> + fun stack ?keepalive ?(nodelay = false) t ?nameserver ~port domain_name -> gethostbyname ?nameserver t domain_name >>= function | Ok ip -> - Lwt.return_some - { Conduit_mirage_tcp.stack - ; keepalive - ; nodelay - ; ip; port } + Lwt.return_some + { Conduit_mirage_tcp.stack; keepalive; nodelay; ip; port } | Error _err -> Lwt.return_none end From ee0fa7d1e2d5c70e05fdf521f016cbcc7530ea8e Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 2 Sep 2020 16:19:10 +0200 Subject: [PATCH 065/140] Fix compilation about the addition of ?timeout argument into Conduit_async.serve --- src/async/conduit_async.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index bd06649c..3fe2ee72 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -40,16 +40,15 @@ let serve : | None -> [ close; accept ] | Some t -> let t = Core.Time.Span.of_int_sec t in - let timeout = - Async.after t >>| fun () -> Async.return `Timeout in + let timeout = Async.after t >>| fun () -> Ok `Timeout in [ close; accept; timeout ] in Async.Deferred.any events >>= function - | `Result (Ok (`Flow flow)) -> + | Ok (`Flow flow) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | `Result (Ok `Stop) | `Timeout -> Svc.close t - | `Result (Error err0) -> ( + | Ok (`Stop | `Timeout) -> Svc.close t + | Error err0 -> ( Svc.close t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in From 9da9b21ee9c276c808ca460c81f27f8f5397076b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 2 Sep 2020 16:48:05 +0200 Subject: [PATCH 066/140] Fix GitHub Action and handle only ubuntu - Mac OSX CI can not work due to a bad installation of libssl and `opam depext libssl` does not work - Windows CI can not work due to `core` which does not work on this platform --- .github/workflows/test.yml | 27 ++++----------------------- 1 file changed, 4 insertions(+), 23 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f832859e..1daf0513 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -6,18 +6,14 @@ jobs: runs-on: ${{ matrix.operating-system }} strategy: matrix: - ocaml-version: [ '4.08.1', '4.09.0', '4.10.0' ] - operating-system: [macos-latest, ubuntu-latest, windows-latest] + ocaml-version: [ '4.08.1', '4.09.0', '4.10.0', '4.11.1' ] + operating-system: [ ubuntu-latest ] steps: - - uses: actions/checkout@master - - uses: avsm/setup-ocaml@master + - uses: actions/checkout@v2 + - uses: avsm/setup-ocaml@v1 with: ocaml-version: ${{ matrix.ocaml-version }} - - name: Install pkg-config - if: runner.os == 'macOS' - run: brew install pkg-config - name: Deps - if: runner.os != 'Windows' run: | opam pin add -n conduit.dev . opam pin add -n conduit-lwt.dev . @@ -30,22 +26,7 @@ jobs: opam pin add -n conduit-lwt-ssl.dev . opam depext -y conduit conduit-tls conduit-lwt conduit-async conduit-mirage opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-lwt-ssl conduit-async conduit-async-tls conduit-async-ssl conduit-mirage - - name: Deps (Windows) - if: runner.os == 'Windows' - run: | - opam pin add -n conduit.dev . - opam pin add -n conduit-lwt.dev . - opam pin add -n conduit-mirage.dev . - opam pin add -n conduit-tls.dev . - opam pin add -n conduit-lwt-tls.dev . - opam depext -y conduit conduit-tls conduit-lwt conduit-mirage - opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-mirage - - name: Build (Windows) - if: runner.os == 'Windows' - run: opam exec -- dune build -p conduit,conduit-tls,conduit-lwt,conduit-mirage - name: Build - if: runner.os != 'Windows' run: opam exec -- dune build - name: Test - if: runner.os != 'Windows' run: opam exec -- dune runtest --no-buffer --verbose -j 1 From 4dffc531e6dde24fcc6aec84bb453f5bea277e80 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 10:19:31 +0200 Subject: [PATCH 067/140] Delay the initialisation of the server --- src/async/conduit_async.ml | 4 ++-- src/async/conduit_async.mli | 2 +- src/lwt/conduit_lwt.ml | 4 ++-- src/lwt/conduit_lwt.mli | 2 +- tests/ping-pong/common.ml | 4 ++-- tests/ping-pong/with_async.ml | 2 +- tests/ping-pong/with_lwt.ml | 2 +- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 3fe2ee72..0e363b82 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -21,12 +21,12 @@ let serve : handler:(flow -> unit Async.Deferred.t) -> service:(cfg, t, flow) service -> cfg -> - unit Async.Condition.t * unit Async.Deferred.t = + unit Async.Condition.t * (unit -> unit Async.Deferred.t) = fun ?timeout ~handler ~service cfg -> let open Async in let stop = Async.Condition.create () in let module Svc = (val Service.impl service) in - let main = + let main () = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err | Ok t -> ( diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 16de552f..c05af020 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -18,7 +18,7 @@ val serve : handler:('flow -> unit Async.Deferred.t) -> service:('cfg, 'master, 'flow) service -> 'cfg -> - unit Async.Condition.t * unit Async.Deferred.t + unit Async.Condition.t * (unit -> unit Async.Deferred.t) val reader_and_writer_of_flow : flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index ba8754b6..30ff0f1a 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -52,12 +52,12 @@ let serve : handler:(flow -> unit Lwt.t) -> service:(cfg, service, flow) Service.service -> cfg -> - unit Lwt_condition.t * unit Lwt.t = + unit Lwt_condition.t * (unit -> unit Lwt.t) = fun ?timeout ~handler ~service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in - let main = + let main () = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err | Ok service -> ( diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 495aa386..11048501 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -17,7 +17,7 @@ val serve : handler:('flow -> unit Lwt.t) -> service:('cfg, 'service, 'flow) service -> 'cfg -> - unit Lwt_condition.t * unit Lwt.t + unit Lwt_condition.t * (unit -> unit Lwt.t) (** [serve ~handler ~service cfg] creates an usual infinite [service] loop from the given configuration ['cfg]. It returns the {i promise} to launch the loop and a condition variable to stop the loop. diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index daaab439..78816a80 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -8,7 +8,7 @@ module type S = sig handler:('flow -> unit io) -> service:('cfg, 'master, 'flow) Service.service -> 'cfg -> - unit condition * unit io + unit condition * (unit -> unit io) end module type CONDITION = sig @@ -100,7 +100,7 @@ struct cfg -> protocol:(_, flow) Conduit.protocol -> service:(cfg, service, flow) Conduit.Service.service -> - unit Condition.t * unit IO.t = + unit Condition.t * (unit -> unit IO.t) = fun cfg ~protocol ~service -> Conduit.serve ~handler:(fun flow -> transmission (Conduit.pack protocol flow)) diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index 1a2ad588..323f24e1 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -74,7 +74,7 @@ let run_with : Condition.broadcast stop () ; Async.return () in Async.don't_wait_for - (Async.Deferred.all_unit [ server; clients ] >>| fun () -> shutdown 0) ; + (Async.Deferred.all_unit [ server (); clients ] >>| fun () -> shutdown 0) ; Core.never_returns (Scheduler.go ()) let run_with_tcp clients = diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index c8181eb4..1425e723 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -78,7 +78,7 @@ let run_with : Lwt.join clients >>= fun () -> Lwt_condition.broadcast stop () ; Lwt.return_unit in - Lwt_main.run (Lwt.join [ server; clients ]) + Lwt_main.run (Lwt.join [ server (); clients ]) let run_with_tcp clients = run_with From d975a1ba8c8833d0e8549750797fe2b2810cad9e Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 10 Sep 2020 14:24:11 +0200 Subject: [PATCH 068/140] Add ke and bigstringaf as a dependency of conduit-mirage (@hannesm) --- conduit-mirage.opam | 2 ++ 1 file changed, 2 insertions(+) diff --git a/conduit-mirage.opam b/conduit-mirage.opam index 38f8d287..4e0dbce7 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -26,4 +26,6 @@ depends: [ "mirage-flow" "mirage-time" "dns-client" + "ke" + "bigstringaf" ] From 6493c30186c6c32a904521f2910710294fe2de02 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 10 Sep 2020 16:59:59 +0200 Subject: [PATCH 069/140] conduit-mirage requires at least dns-client.4.6.0 --- conduit-mirage.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conduit-mirage.opam b/conduit-mirage.opam index 4e0dbce7..25067d69 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -25,7 +25,7 @@ depends: [ "tcpip" "mirage-flow" "mirage-time" - "dns-client" + "dns-client" {>= "4.6.0"} "ke" "bigstringaf" ] From 056e94b57e6fc2a08b587e949a7c38d2f1b79e6a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 11 Sep 2020 23:23:01 +0200 Subject: [PATCH 070/140] Refine dependencies of conduit-async packages (@anuragsoni) --- conduit-async-ssl.opam | 1 - conduit-async-tls.opam | 1 - conduit-async.opam | 3 +-- 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/conduit-async-ssl.opam b/conduit-async-ssl.opam index afbaeda1..6b4bbca6 100644 --- a/conduit-async-ssl.opam +++ b/conduit-async-ssl.opam @@ -26,6 +26,5 @@ depends: [ "conduit-async" "async" {>= "v0.12.0"} "async_ssl" - "conduit-tls" "stdlib-shims" {with-test} ] diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam index afbaeda1..fdf51782 100644 --- a/conduit-async-tls.opam +++ b/conduit-async-tls.opam @@ -25,7 +25,6 @@ depends: [ "core" "conduit-async" "async" {>= "v0.12.0"} - "async_ssl" "conduit-tls" "stdlib-shims" {with-test} ] diff --git a/conduit-async.opam b/conduit-async.opam index 483270a1..cc5108b8 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -25,7 +25,6 @@ depends: [ "core" "conduit" "async" {>= "v0.12.0"} - "async_ssl" - "conduit-tls" + "cstruct" "stdlib-shims" {with-test} ] From db46ef3bbeaef73af9062649bb201519a8299d9d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 29 Sep 2020 11:26:43 +0200 Subject: [PATCH 071/140] Use ocamlformat.0.15.0 now! --- .ocamlformat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.ocamlformat b/.ocamlformat index 3fa5ff9c..e7aa0a4a 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.14.2 +version = 0.15.0 break-infix = fit-or-vertical parse-docstrings = true indicate-multiline-delimiters=no From 5e0a0b4892ec0eabd0dffe04e7302ae6b62bb3e6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 29 Sep 2020 11:48:23 +0200 Subject: [PATCH 072/140] Fix the documentation on the core library --- src/core/conduit.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/conduit.mli b/src/core/conduit.mli index c2ee353b..f2f93b6c 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -330,7 +330,7 @@ module type S = sig ('cfg1, 't1, 'flow1) service -> (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are - physically the same. For instance, Conduit] asserts: + physically the same. For instance, [Conduit] asserts: {[ let service = Service.register ~service:(module V) ;; From 4b1adb90f381186180acbb99bbba0f09e32688ac Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 29 Sep 2020 16:26:39 +0200 Subject: [PATCH 073/140] Add endpoint and replace it by [ `host ] Domain_name.t --- src/async/conduit_async.ml | 21 ++++++++++------- src/async/dune | 2 +- src/core/conduit.ml | 19 +++++++++------- src/core/conduit.mli | 15 ++++++++---- src/core/dune | 2 +- src/core/endpoint.ml | 39 ++++++++++++++++++++++++++++++++ src/core/endpoint.mli | 17 ++++++++++++++ src/lwt/conduit_lwt.ml | 13 +++++++---- src/lwt/dune | 2 +- src/mirage/conduit_mirage_dns.ml | 13 +++++++---- tests/ping-pong/common.ml | 2 +- tests/resolvers.ml | 12 ++++++---- 12 files changed, 118 insertions(+), 39 deletions(-) create mode 100644 src/core/endpoint.ml create mode 100644 src/core/endpoint.mli diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 0e363b82..a36bd576 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -247,13 +247,18 @@ module TCP = struct let service = S.register ~service:(module Service) - let resolve ~port domain_name = - Monitor.try_with (fun () -> - Unix.Inet_addr.of_string_or_getbyname - (Domain_name.to_string domain_name)) - >>= function - | Ok inet_addr -> - let inet_addr = Socket.Address.Inet.create inet_addr ~port in + let resolve ~port = function + | Conduit.Endpoint.IP ip -> + let inet_addr = + Socket.Address.Inet.create (Ipaddr_unix.to_inet_addr ip) ~port in Async.return (Some (Inet inet_addr)) - | _ -> Async.return None + | Domain domain_name -> ( + Monitor.try_with (fun () -> + Unix.Inet_addr.of_string_or_getbyname + (Domain_name.to_string domain_name)) + >>= function + | Ok inet_addr -> + let inet_addr = Socket.Address.Inet.create inet_addr ~port in + Async.return (Some (Inet inet_addr)) + | _ -> Async.return None) end diff --git a/src/async/dune b/src/async/dune index 1e77f437..dd545288 100644 --- a/src/async/dune +++ b/src/async/dune @@ -1,4 +1,4 @@ (library (name conduit_async) (public_name conduit-async) - (libraries cstruct async conduit)) + (libraries cstruct async ipaddr.unix conduit)) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index aa6cbc7e..28f719c6 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -1,3 +1,4 @@ +module Endpoint = Endpoint module Sigs = Sigs type ('a, 'b) refl = Refl : ('a, 'a) refl @@ -11,7 +12,7 @@ type (+'a, 's) app type _ resolver = | Resolver : { priority : int option; - resolve : [ `host ] Domain_name.t -> ('edn option, 's) app; + resolve : Endpoint.t -> ('edn option, 's) app; witness : 's witness; } -> ('edn * 's) resolver @@ -48,6 +49,8 @@ type resolvers = Map.t let empty = Map.empty module type S = sig + module Endpoint : module type of Endpoint + type input type output @@ -108,7 +111,7 @@ module type S = sig val pack : ('edn, 'v) protocol -> 'v -> flow - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + type 'edn resolver = Endpoint.t -> 'edn option io type nonrec resolvers = resolvers @@ -124,7 +127,7 @@ module type S = sig val resolve : resolvers -> ?protocol:('edn, 'v) protocol -> - [ `host ] Domain_name.t -> + Endpoint.t -> (flow, [> error ]) result io val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io @@ -200,6 +203,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : with type input = Input.t and type output = Output.t and type +'a io = 'a IO.t = struct + module Endpoint = Endpoint module Bijection = Higher (IO) type scheduler = Bijection.t @@ -244,7 +248,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : type 'edn key = ('edn * scheduler) Map.key - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + type 'edn resolver = Endpoint.t -> 'edn option io module F = struct type _ t = @@ -381,7 +385,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : and sup = 1 - let resolve : resolvers -> [ `host ] Domain_name.t -> endpoint list io = + let resolve : resolvers -> Endpoint.t -> endpoint list io = fun m domain_name -> let rec go acc = function | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) @@ -401,8 +405,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | None, None -> 0 in go [] (List.sort compare (Map.bindings m)) - let create : - resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result io = + let create : resolvers -> Endpoint.t -> (flow, [> error ]) result io = fun m domain_name -> resolve m domain_name >>= fun l -> let rec go = function @@ -420,7 +423,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : type edn v. resolvers -> ?protocol:(edn, v) protocol -> - [ `host ] Domain_name.t -> + Endpoint.t -> (flow, [> error ]) result io = fun m ?protocol domain_name -> match protocol with diff --git a/src/core/conduit.mli b/src/core/conduit.mli index f2f93b6c..c5c5ec5c 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -1,3 +1,5 @@ +module Endpoint = Endpoint + type ('a, 'b) refl = Refl : ('a, 'a) refl type resolvers @@ -9,6 +11,8 @@ val empty : resolvers type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value module type S = sig + module Endpoint : module type of Endpoint + type input (** The type for payload inputs. *) @@ -230,13 +234,14 @@ module type S = sig (** {2:resolution Domain name resolvers.} *) - type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + type 'edn resolver = Endpoint.t -> 'edn option io (** The type for resolver functions, which resolve domain names to endpoints. For instance, the DNS resolver function is: {[ - let http_resolver : Unix.sockaddr resolver = - fun domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with + let http_resolver : Unix.sockaddr resolver = function + | IP ip -> Some (Ipaddr_unix.to_inet_addr ip, 80) + | Domain domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with | { Unix.h_addr_list; _ } -> if Array.length h_addr_list > 0 then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) @@ -276,7 +281,7 @@ module type S = sig val resolve : resolvers -> ?protocol:('edn, 'v) protocol -> - [ `host ] Domain_name.t -> + Endpoint.t -> (flow, [> error ]) result io (** [resolve resolvers domain_name] is the flow created by connecting to the domain name [domain_name], using the resolvers [resolvers]. Each resolver @@ -298,7 +303,7 @@ module type S = sig |> add tcp ~priority:10 resolver_on_my_private_network |> add tcp ~priority:20 resolver_on_internet - let () = Conduit.resolve resolvers mirage_io >>? function + let () = Conduit.resolve resolvers (Conduit.Endpoint.domain mirage_io) >>? function | TCP.T (Conduit.Value file_descr) as flow -> let peer = Unix.getpeername file_descr in ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) diff --git a/src/core/dune b/src/core/dune index 994bc5be..ebe9f2f6 100644 --- a/src/core/dune +++ b/src/core/dune @@ -1,4 +1,4 @@ (library (name conduit) (public_name conduit) - (libraries stdlib-shims domain-name)) + (libraries stdlib-shims ipaddr domain-name)) diff --git a/src/core/endpoint.ml b/src/core/endpoint.ml new file mode 100644 index 00000000..a23bfd9f --- /dev/null +++ b/src/core/endpoint.ml @@ -0,0 +1,39 @@ +type t = Domain of [ `host ] Domain_name.t | IP of Ipaddr.t + +let pp ppf = function + | Domain domain_name -> Domain_name.pp ppf domain_name + | IP ip -> Ipaddr.pp ppf ip + +let error_msg str = Error (`Msg str) + +let error_msgf fmt = Format.kasprintf error_msg fmt + +let of_string str = + let ( >>= ) = Result.bind in + match Domain_name.of_string str >>= Domain_name.host with + | Ok domain_name -> Ok (Domain domain_name) + | Error _err0 -> + match Ipaddr.of_string str with + | Ok ip -> Ok (IP ip) + | Error _err1 -> error_msgf "Invalid endpoint: %s" str + +let v str = + match of_string str with Ok v -> v | Error (`Msg err) -> invalid_arg err + +let to_string = function + | Domain domain_name -> Domain_name.to_string domain_name + | IP ip -> Ipaddr.to_string ip + +let domain domain_name = Domain domain_name + +let ip ip = IP ip + +let compare a b = + let sup = 1 and inf = -1 in + match (a, b) with + | Domain a, Domain b -> Domain_name.compare a b + | Domain _, IP _ -> sup + | IP _, Domain _ -> inf + | IP a, IP b -> Ipaddr.compare a b + +let equal a b = compare a b = 0 diff --git a/src/core/endpoint.mli b/src/core/endpoint.mli new file mode 100644 index 00000000..5e335e7d --- /dev/null +++ b/src/core/endpoint.mli @@ -0,0 +1,17 @@ +type t = Domain of [ `host ] Domain_name.t | IP of Ipaddr.t + +val pp : Format.formatter -> t -> unit + +val of_string : string -> (t, [> `Msg of string ]) result + +val v : string -> t + +val to_string : t -> string + +val domain : [ `host ] Domain_name.t -> t + +val ip : Ipaddr.t -> t + +val compare : t -> t -> int + +val equal : t -> t -> bool diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 30ff0f1a..d80262ef 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -404,9 +404,12 @@ module TCP = struct let service = S.register ~service:(module Service) - let resolve ~port domain_name = - Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function - | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> - Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) - | _ -> Lwt.return_none + let resolve ~port = function + | Conduit.Endpoint.IP ip -> + Lwt.return_some (Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port)) + | Conduit.Endpoint.Domain domain_name -> ( + Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> Lwt.return_none) end diff --git a/src/lwt/dune b/src/lwt/dune index ccb9d936..5c467f89 100644 --- a/src/lwt/dune +++ b/src/lwt/dune @@ -1,4 +1,4 @@ (library (name conduit_lwt) (public_name conduit-lwt) - (libraries cstruct lwt lwt.unix conduit)) + (libraries cstruct lwt ipaddr.unix lwt.unix conduit)) diff --git a/src/mirage/conduit_mirage_dns.ml b/src/mirage/conduit_mirage_dns.ml index 52aaf4d3..6d63f2b0 100644 --- a/src/mirage/conduit_mirage_dns.ml +++ b/src/mirage/conduit_mirage_dns.ml @@ -16,10 +16,15 @@ struct ?nameserver:Transport.ns_addr -> port:int -> (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver = - fun stack ?keepalive ?(nodelay = false) t ?nameserver ~port domain_name -> - gethostbyname ?nameserver t domain_name >>= function - | Ok ip -> + fun stack ?keepalive ?(nodelay = false) t ?nameserver ~port -> function + | Conduit.Endpoint.IP (Ipaddr.V6 _) -> Lwt.return_none + | IP (Ipaddr.V4 ip) -> Lwt.return_some { Conduit_mirage_tcp.stack; keepalive; nodelay; ip; port } - | Error _err -> Lwt.return_none + | Domain domain_name -> ( + gethostbyname ?nameserver t domain_name >>= function + | Ok ip -> + Lwt.return_some + { Conduit_mirage_tcp.stack; keepalive; nodelay; ip; port } + | Error _err -> Lwt.return_none) end diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index 78816a80..7f6136e8 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -129,7 +129,7 @@ struct let ic = open_in filename in let responses = go [] ic in close_in ic ; - client ~resolvers localhost responses >>= function + client ~resolvers (Conduit.Endpoint.domain localhost) responses >>= function | Ok () -> IO.return () | Error `Closed_by_peer -> IO.return () | Error (#Conduit.error as err) -> diff --git a/tests/resolvers.ml b/tests/resolvers.ml index 9051845d..8b0ddd8c 100644 --- a/tests/resolvers.ml +++ b/tests/resolvers.ml @@ -73,7 +73,7 @@ let all_resolvers = |> Conduit.add dummy_int int |> Conduit.add dummy_string string |> Conduit.add dummy_unit unit in - let _ = Conduit.resolve resolvers localhost in + let _ = Conduit.resolve resolvers (Conduit.Endpoint.domain localhost) in Alcotest.(check bool) "call int" !int_called true ; Alcotest.(check bool) "call string" !string_called true ; Alcotest.(check bool) "call unit" !unit_called true @@ -105,7 +105,7 @@ let priorities = |> Conduit.add ~priority:0 dummy_int int |> Conduit.add ~priority:10 dummy_string string |> Conduit.add dummy_unit unit in - let _ = Conduit.resolve resolvers localhost in + let _ = Conduit.resolve resolvers (Conduit.Endpoint.domain localhost) in Alcotest.(check (option int)) "call int" !int_called (Some 0) ; Alcotest.(check (option int)) "call string" !string_called (Some 1) ; Alcotest.(check (option int)) "call unit" !unit_called (Some 2) ; @@ -120,7 +120,7 @@ let priorities = |> Conduit.add dummy_int int |> Conduit.add ~priority:0 dummy_string string |> Conduit.add dummy_unit unit in - let _ = Conduit.resolve resolvers localhost in + let _ = Conduit.resolve resolvers (Conduit.Endpoint.domain localhost) in Alcotest.(check (option int)) "call int" !int_called (Some 2) ; Alcotest.(check (option int)) "call string" !string_called (Some 0) ; Alcotest.(check (option int)) "call unit" !unit_called (Some 1) ; @@ -135,7 +135,7 @@ let priorities = |> Conduit.add dummy_int int |> Conduit.add dummy_string string |> Conduit.add dummy_unit unit in - let _ = Conduit.resolve resolvers localhost in + let _ = Conduit.resolve resolvers (Conduit.Endpoint.domain localhost) in Alcotest.(check (option int)) "call int" !int_called (Some 2) ; Alcotest.(check (option int)) "call string" !string_called (Some 1) ; Alcotest.(check (option int)) "call unit" !unit_called (Some 0) @@ -156,7 +156,9 @@ let only_one = |> Conduit.add dummy_int int |> Conduit.add dummy_string string |> Conduit.add dummy_unit unit in - let _ = Conduit.resolve resolvers ~protocol:dummy_string localhost in + let _ = + Conduit.resolve resolvers ~protocol:dummy_string + (Conduit.Endpoint.domain localhost) in Alcotest.(check bool) "call int" !int_called true ; Alcotest.(check bool) "call string" !string_called true ; Alcotest.(check bool) "call unit" !unit_called true From e8d7b171deb86a56bf787d102755a3f456725360 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 30 Sep 2020 13:43:00 +0200 Subject: [PATCH 074/140] Use Result's module of stdlib-shims package --- src/core/endpoint.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/endpoint.ml b/src/core/endpoint.ml index a23bfd9f..40509444 100644 --- a/src/core/endpoint.ml +++ b/src/core/endpoint.ml @@ -9,7 +9,7 @@ let error_msg str = Error (`Msg str) let error_msgf fmt = Format.kasprintf error_msg fmt let of_string str = - let ( >>= ) = Result.bind in + let ( >>= ) = Stdlib.Result.bind in match Domain_name.of_string str >>= Domain_name.host with | Ok domain_name -> Ok (Domain domain_name) | Error _err0 -> From daafc52531b611ac67d9cf2669fca0b539f25b21 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 30 Sep 2020 14:39:05 +0200 Subject: [PATCH 075/140] Define our own Result.bind operator --- src/core/endpoint.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/endpoint.ml b/src/core/endpoint.ml index 40509444..a390443e 100644 --- a/src/core/endpoint.ml +++ b/src/core/endpoint.ml @@ -9,7 +9,7 @@ let error_msg str = Error (`Msg str) let error_msgf fmt = Format.kasprintf error_msg fmt let of_string str = - let ( >>= ) = Stdlib.Result.bind in + let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in match Domain_name.of_string str >>= Domain_name.host with | Ok domain_name -> Ok (Domain domain_name) | Error _err0 -> From f4ab2649ba65f3a79b9a694425f999decf56165d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 1 Oct 2020 17:42:12 +0200 Subject: [PATCH 076/140] Add documentation on Conduit.Endpoint module --- src/core/endpoint.mli | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/src/core/endpoint.mli b/src/core/endpoint.mli index 5e335e7d..59c9fef5 100644 --- a/src/core/endpoint.mli +++ b/src/core/endpoint.mli @@ -1,17 +1,35 @@ -type t = Domain of [ `host ] Domain_name.t | IP of Ipaddr.t +type t = + | Domain of [ `host ] Domain_name.t + | IP of Ipaddr.t (** Type of endpoint. *) val pp : Format.formatter -> t -> unit +(** Pretty-printer of {!t}. *) val of_string : string -> (t, [> `Msg of string ]) result +(** [of_string str] returns an endpoint from the given [string]. + We tried to parse the given [string] as an {i hostname} and if + it fails, we try to consider it as an IP (V4 or V6). + + If the given [string] is neither a {i hostname} nor an IP, we + return an error. *) val v : string -> t +(** An alias of {!of_string}. In the case of an error, we raise + an exception. *) val to_string : t -> string +(** [to_string t] returns a valid string which represents the + endpoint. By {i valid}, we means that the returned [string] + can safely be used with {!v}. *) val domain : [ `host ] Domain_name.t -> t +(** [domain domain_name] returns an endpoint from a {i hostname}. *) val ip : Ipaddr.t -> t +(** [ip v] returns an endpoint from an {!Ipaddr.t}. *) val compare : t -> t -> int +(** Comparison function for {!t}. *) val equal : t -> t -> bool +(** Equal function for {!t}. *) From 8912d458b2f3e43245e99cf3cb74e9c00712a8b0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 2 Oct 2020 17:45:14 +0200 Subject: [PATCH 077/140] Add ipaddr as a dependency of conduit --- conduit.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/conduit.opam b/conduit.opam index ec0b1703..1bd6beed 100644 --- a/conduit.opam +++ b/conduit.opam @@ -44,6 +44,7 @@ build: [ depends: [ "ocaml" {>= "4.07.0"} "dune" + "ipaddr" "domain-name" "stdlib-shims" "alcotest" {with-test} From 175ab18dfa9c52f2a735c0b7f8a81fad66ca8422 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 4 Oct 2020 10:44:58 +0200 Subject: [PATCH 078/140] conduit-lwt-tls: initialize the mirage-crypto-rng.lwt PRNG --- conduit-lwt-tls.opam | 1 + src/lwt-tls/conduit_lwt_tls.ml | 2 ++ src/lwt-tls/dune | 2 +- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/conduit-lwt-tls.opam b/conduit-lwt-tls.opam index 7566c892..7eb7f670 100644 --- a/conduit-lwt-tls.opam +++ b/conduit-lwt-tls.opam @@ -25,4 +25,5 @@ depends: [ "dune" "conduit-lwt" "conduit-tls" + "mirage-crypto-rng" {>= "0.8.0"} ] diff --git a/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml index 7fa71c8e..f32e11d7 100644 --- a/src/lwt-tls/conduit_lwt_tls.ml +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -1,5 +1,7 @@ include Conduit_tls.Make (Conduit_lwt.IO) (Conduit_lwt) +let () = Mirage_crypto_rng_lwt.initialize () + module TCP = struct open Conduit_lwt.TCP diff --git a/src/lwt-tls/dune b/src/lwt-tls/dune index f896114f..e8611fa6 100644 --- a/src/lwt-tls/dune +++ b/src/lwt-tls/dune @@ -1,4 +1,4 @@ (library (name conduit_lwt_tls) (public_name conduit-lwt-tls) - (libraries conduit-lwt conduit-tls)) + (libraries conduit-lwt conduit-tls mirage-crypto-rng.lwt)) From 665e6acf98af317c2ff4ca87d007308f58439ce6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 6 Oct 2020 11:31:13 +0200 Subject: [PATCH 079/140] Prepare 3.0.0 --- CHANGES.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 34af3c52..9d8da74c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +## v3.0.0 (2020-10-06) + +* **breaking change** **New version of `conduit`. Most of the new API has a + description on the pull-request + [#311](https://github.com/mirage/ocaml-conduit/pull/311). + ## v2.2.2 (2020-06-14) * conduit-lwt-unix no longer calls Mirage_crypto_rng_unix.initialize, and is From 4603c4b000a9b4782b898d8347aaf3f15fa38812 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 8 Oct 2020 20:24:05 +0200 Subject: [PATCH 080/140] Add an ocamldoc's HOW-TO about Conduit --- src/core/README.md | 173 ----------- src/core/dune | 4 + src/core/index.mld | 731 ++++++++++++++++++++++++++++++++++++++------- 3 files changed, 635 insertions(+), 273 deletions(-) delete mode 100644 src/core/README.md diff --git a/src/core/README.md b/src/core/README.md deleted file mode 100644 index e44605de..00000000 --- a/src/core/README.md +++ /dev/null @@ -1,173 +0,0 @@ -## Conduit - core library - -The main goal of `conduit` is to be able to use an abstract type flow as a -representation of a `socket` independently of the implementation. - -Of course, this case appears on MirageOS where the implementation depends on the -_target_. But it can be more general where, as a library, you should not depends -on a given implementation of a protocol. In such context, you are able to -implement a way to communicate with a peer without a full knowledge of the -underlying protocol used. - -By this abstraction, protocol implementer can _compose_ the protocol with an -other layer such as TLS and still be able to provide the same interface. - -`conduit` wants to provide a common way to start a server too. This feature is -less abstracted than the communication with a peer but it provides a better -interface than before. - -### Implementation and `resolvers` - -Conduit splits the knowledge of protocols into 2 elements: -- a global `Hashtbl.t` -- a local `resolvers` - -A protocol must be registered with `register_protocol`: -```ocaml -let witness = Conduit.register_protocol ~key ~protocol:(module Protocol) -``` - -A protocol must follow an interface described by `PROTOCOL`. The implementer -must create a new `key` with `Conduit.key`. - -The _witness_ can be ignored and hidden. However, it should be properly exposed -with the protocol to help the end-user to enforce `conduit` to use this specific -protocol. - -The registration fills the internal global `Hashtbl` of `conduit`. Even if this -implementation is available into `conduit`, it's not true that `conduit` will -systematically use it (it's the main difference with the old version of -`conduit`). However, the _key_ used to register your protocol must exposed, -otherwise your protocol will never be available with `conduit`. - -In fact, the registration needs a `key` which is a _witness_ of needed value to -_initialize_ a flow according your protocol implementation. For example, an -`Unix.socket` must need a `Unix.socket_domain` to be created. The type of this -value will be a part of the _witness_ `key`. - -By this way, registration of a protocol must be done like this: -```ocaml -let key = Conduit.key "my-protocol" -let witness = Conduit.register_protocol ~key ~protocol:(module Protocol) -``` - -Then, `key` must be exposed to the end-user to be able to fill `resolvers`. - -#### As the end-user wants - -So even if your protocol is well registered into `conduit`, the end-user still -is able to use or ignore it. The existence into the resolution process of -`conduit` of your protocol only exists if the end-user fill the given -`resolvers` with your `key`. - -By this way, it is on the responsibility of the end-user to properly create -needed values by the _initialization_ of the flow according your protocol -implementation. - -```ocaml -(* we assume a TCP/IP protocol imported by a library. *) -val key : Unix.inet_addr Conduit.key -val witness : Unix.file_descr Conduit.Witness.protocol - -let resolve domain_name : Unix.inet_addr option = Unix.gethostbyname domain_name -let resolvers = Conduit.register_resolver ~key resolve Conduit.empty - -let _ = - Conduit.flow resolvers domain_name >>= fun flow -> ... -``` - -In your example, others protocols can be registered such as SSH or TCP + TLS, -however, the end-user registered into the `resolvers` only the TCP protocol. -Such example shows that the end-user can restrict the resolution on few -protocols like secured protocols. - -This new way to start a connection lets the end-user to specify: -- which protocol he wants to use -- how such protocol can be created -- which resolves the domain-name - -Usually, the third point is a call to `gethostbyname` which trusts on your -`/etc/resolv.conf` but such service does not exist into a MirageOS world. So -`conduit` gives the ability to specify which service handles that. - -The second point is the most important where it lets the user to specify a -process/function to _initialize_ a communication. For example, the TLS stack -expects an _authenticator_ which verifies the given certificate by your peer - -the user is able to specify an _authenticator_ which trusts on a specifc chain -of certificates. - -The first point is to let the user to enforce a protocol. Instead to try several -of them in order to their priorities, the user can enforce to use a special one. - -### Create a new flow - -As an implementer of a protocol, the way to create a /flow/ differs for each -protocols. We said that an `Unix.socket` needs a `Unix.socket_domain` to be -created. However, it's not the case for a TLS flow which should need a -`Tls.Config.t` (or basically something more complex). - -At the end, `conduit` lets the end-user to create this kind of value used then -to properly create a `flow`. Finally `conduit` has the ability to let the -implementer to define the type of this required value. - -In your previous example it's our `resolve` function. - -The rule is easy, for N `key`, the end-user should (but it's not mandatory) -define N `resolve` functions. A registration of them into a `resolvers` element -will let `conduit` to try to initiate a _flow_ to the associated protocol - this -association is done by the registration of the protocol between the `key` and -the implementation. - -At the end, the process of the resolution is clear: -``` -[ `host ] Domain_name.t -> 'edn -> 'flow -> Conduit.flow -``` - -Where `'edn` is specified by the `key` and `'flow`, by the protocol. The -end-user must implement a function `resolver : [ host ] Domain_name.t` and the -implementer must provide a function `flow : 'edn -> 'flow`. Then, `conduit` does -the glue between them to provide a fully-abstract `Conduit.flow`. - -### How to use the `flow` - -As an abstracted value, the returned `flow` can be use by: -- `Conduit.recv` -- `Conduit.send` -- `Conduit.close` - -NOTE: semantic of them depends on the implementation used by `conduit`. - -Internally, `conduit` _extracts_ your `flow` and infer the proper implementation -associated. Then, it uses this implementation registered into our internal -global `Hashtbl.t`. - -In other words, a `flow` created by our TCP/IP implementation stack will be -associated to this implementation as long as it exists. - -### Provide something more than `PROTOCOL` - -It appears that some protocols want to expose more functions that what -`PROTOCOL` defines. By this fact, `conduit` should able to expose such -functions. With the _witness_ given by the registration of the protocol, the -end-user has the ability to extract by himself the real underlying flow. - -For example, a TCP/IP `flow` can returns some information such as the IP and -port where it is connected. With the _witness_ of the TCP/IP protocol, we are -able to extract the underlying `Unix.file_descr` (considering as is) and use -directly `Unix.*` functions. - -```ocaml -let peer = match Conduit.is flow witness with - | Some socket -> Unix.getpeername socket - | None -> failwith "It's not an Unix TCP/IP connection" -``` - -A layer such as TLS can expose such accessors too like: -```ocaml -type 'flow with_tls - -val underlying : 'flow with_tls -> 'flow -val handshake : 'flow with_tls -> bool -``` - -The end-user has several ways to extract structural `flow` from the abstracted one. diff --git a/src/core/dune b/src/core/dune index ebe9f2f6..621cc71e 100644 --- a/src/core/dune +++ b/src/core/dune @@ -2,3 +2,7 @@ (name conduit) (public_name conduit) (libraries stdlib-shims ipaddr domain-name)) + +(documentation + (package conduit) + (mld_files index)) diff --git a/src/core/index.mld b/src/core/index.mld index 20dc4422..d555a4d6 100644 --- a/src/core/index.mld +++ b/src/core/index.mld @@ -1,162 +1,693 @@ -{1 Conduit - an abstraction of protocols.} +{1 Conduit - defunctorize protocols.} -Conduit is a little library to be able to abtract the protocol used to -communicate with a peer. - -{2 Implement a protocol.} - -A Conduit's protocol can be defined as: +[Conduit] is a library which wants to be used into multiple perspectives: +{ul +{- As a protocol implementer.} +{- As a simple end-user who wants to use a protocol.} +{- As a library implementer who wants to {i delay} the choice of protocols.}} + +In this document, we will explain step by step these perspectives to understand +the purpose of [Conduit]. More globally the {b first} goal of [Conduit] is to {i +de-functorize} (it wants to give you an other way than the _functorization_) an +implementation which requires a protocol to be able to communicate with a peer. +The {b second} goal of [Conduit] is to let the user to construct the {i +dispatch} of protocols from a well-known (or partially-known) context (it is +like an injection of a specific implementation into [Conduit] - or more +concretely, an application of your {i de-functorized} implementation with a +specific protocol implementation). + +{2 Abstract a {i protocol}.} + +{3 Definition of a {i protocol}.} + +[Conduit] has a strong definition of a {!Conduit.S.PROTOCOL}. A protocol is a +system that allows entities to transmit {i payloads}. These entities do not +have to care about the underlying transport mechanism. flows simply deal +with routing and delivering of these payloads. That abstraction allows +these protocols to compose. + +For example, the Transmission Control Protocol (TCP) is representable as a +flow, because it is able to encapsulate some {i payloads} without +interpreting it. A counter-example is the Simple Mail Transfer Protocol +(SMTP) which needs an interpretation of its {i payloads}: tokens such as +[EHLO] or [QUIT] have a direct incidence over the life-cycle of the +connection. + +An other protocol representable as a flow is the Transport Layer Security +(TLS), as it deals only with privacy and data integrity. [Conduit] is able +to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level +protocols can be built in top of these abstract flows: for instance, Secure +Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure +(HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these +can be abstracted to work over any flow implementations. + +{3 Concrete implementation.} + +Let's start to implement a TCP/IP protocol with UNIX. At first, [Conduit] needs +a {i scheduler} and the type of [input]/[output]. [Conduit_lwt] is a +specialisation of [Conduit] with LWT with {!Cstruct.t} as input/output. It is +the same for [Conduit_async] with ASYNC. + +For our example (and to simplify our code), we will specialise [Conduit] with +UNIX, [bytes] as input and [string] as output. {[ -module type S = sig - type flow - type endpoint - - type error - - val pp_error : error Fmt.t +module Scheduler = struct + type 'a t = 'a - val connect : endpoint -> (flow, error) result - val send : flow -> string -> (int, error) result - val recv : flow -> bytes -> (int, error) result - val close : flow -> (unit, error) result + let return x = x + let bind x f = f x end + +module Conduit = Conduit.Make(Scheduler)(Bytes)(String) ]} -This definition is pretty-close to the [Unix] module: +Then, we can start to implement our TCP/IP protocol from what [Unix] gives to us +- of course, this code require the [unix.cm{x}a] library: {[ module TCP = struct + type 'a io = 'a + + type input = bytes and output = string + type flow = Unix.file_descr + type endpoint = Unix.sockaddr - type error = (Unix.error * string * string) + type error = | - let pp_error (error, call, _) = - Fmt.pf ppf "%s: %s" call (Unix.error_message error) + let pp_error : Format.formatter -> error -> unit = fun _ -> function _ -> . let connect sockaddr = - try let socket = Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in - Unix.connect socket sockaddr ; Ok socket - with Unix.Unix_error (err, call, args) -> Error (err, call, args) + let domain = Unix.domain_of_sockaddr sockaddr in + let socket = Unix.socket domain Unix.SOCK_STREAM 0 in + Unix.connect socket sockaddr ; Ok socket + + let recv socket buf = + let off = 0 and len = Bytes.length buf in + let len' = Unix.read socket buf off len in + if len' = 0 then Ok `End_of_flow + else Ok (`Input len') let send socket str = - try - let rec go off len = - let len' = Unix.write_substring socket str off len in - if len' < len then go (off + len') (len - len') in - go 0 (String.length str) ; Ok (String.length str) - with Unix.Unix_error (err, call, args) -> Error (err, call, args) + let off = 0 and len = String.length str in + let buf = Bytes.unsafe_of_string str in + let rec go off len = + let len' = Unix.write socket buf off len in + if len' < len then go (off + len') (len - len') in + go off len ; Ok len + + let close socket = Unix.close socket ; Ok () +end +]} - let recv socket buf = - try - let len = Unix.read socket 0 (Bytes.length buf) in - if len = 0 then Ok `End_of_flow else Ok (`Input len) - with Unix.Unix_error (err, call, args) -> Error (err, call, args) +The code is really simple and it does not care about details such as [exception] +- so, don't try to use this code into a productive context! We can verify that our +implementation respects the interface {!Conduit.S.PROTOCOL}: + +{[ +module TCP : Conduit.PROTOCOL + with type flow = Unix.file_descr + and type endpoint = Unix.sockaddr + and type 'a io = 'a + and type input = bytes + and type output = string += struct + ... +end +]} + +By this way, we ensure the possibility to register it with [Conduit]: + +{[ +let tcp + : (Unix.sockaddr, Unix.file_descr) Conduit.protocol + = Conduit.register ~protocol:(module TCP) +]} + +So we create our first [Conduit] protocol! As you can see, [Conduit] some useful +information such as: +{ul +{- the type of the endpoint required to initiate the protocol.} +{- the type of the flow.}} + +These informations is important for [Conduit] because: +{ul +{- it permits the user to pass its own typed value to initiate a protocol.} +{- it permits the user to {i destruct} the {!Conduit.S.flow} to the underlying + typed value.}} + +The protocol can be used with [Conduit] now! From the point of view of the +protocol implementer, the cost to be [Conduit]-compatible is worth as long as we +respect {!Conduit.S.PROTOCOL} (and our definition). + +Of course, in our example, we took the most understandable protocol, the TCP/IP +protocol. But [Conduit] is usable with anything! [endpoint] and [flow] are still +under the control of the implementer. For example, a SSH protocol requires +something more complex such as a private RSA key - in that case, you still are +able to register it with [Conduit]. + +{2 The [Conduit] protocol.} + +[Conduit] has 2 ways to initiate a connection: +{ul +{- When we have a full-knowledge of which protocols are available.} +{- When we don't any clue about protocol implementation.}} + +The first case is the most common case where we want to make a simple +executable. However, the second case can appear when we want to make a library! +A library which wants to communicate with a peer should assert one and unique +implementation of TCP - and, with MirageOS, it's impossible to do that when the +TCP implementation can be the UNIX one or [mirage-tcpip]. + +But let's start with the first case, we want to make an executable: + +{[ +let ( >>= ) = Result.bind - let close socket = - try Unix.close socket ; Ok () - with Unix.Unix_error (err, call, args) -> Error (err, call, args) +let run () = + let open Result in + Conduit.connect Unix.(ADDR_INET (inet_addr_loopback, 4242)) tcp >>= fun flow -> + Conduit.send flow "Hello World!" >>= fun _ -> + Conduit.close flow + +let () = match run () with + | Ok () -> () + | Error err -> Format.eprintf "%a" Conduit.pp_error err ]} -This is an example of how to implement the TCP protocol according the Conduit's -interface {!PROTOCOL}. We concretely define the flow as an [Unix.file_descr] and -the endpoint (the value required to create the flow) as an [Unix.sockaddr]. +We use the power of the type system to ensure that if we want to start a [tcp : +(Unix.sockaddr, Unix.file_descr) Conduit.protocol], we must initiate it with a +[Unix.sockaddr]. To compile and execute it (with 2 shells): + +{v +$1> ocamlfind opt -linkpkg -package conduit,unix,result main.ml +$2> nc -l localhost 4242 +$1> ./a.out +$2> Hello World! +v} + +{3 Destruct your [flow].} -Now, the protocol must be registered into [Conduit] with: +[Conduit] lets the possibility to {i destruct} the {!Conduit.S.flow}. It mostly +means that from the {i abstract} value [flow], you can get the underlying +[Unix.file_descr] in our context. Of course, you need to know that the [flow] {b +can} be an [Unix.file_descr]. Come back as the protocol implementer, you must +expose {i the extension} of the type {!Conduit.S.flow} to be able to {i +destruct} it then: {[ -let tcp = Conduit.register ~protocol:(module TCP) +let tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocl = ... +include (val Conduit.repr tcp) +]} + +The last line expands to: + +{[ +type t = (Unix.sockaddr, Unix.file_descr) Conduit.value (* = Value of Unix.file_descr *) +type Conduit.flow += T of t +]} + +With this definition, we are able to {i pattern-flow} on our {!Conduit.S.flow}: + +{[ +let run () = + let open Result in + Conduit.connect Unix.(ADDR_INET (inet_addr_loopback, 4242)) tcp >>= function + | T (Value socket) -> + let oc = Unix.out_channel_of_descr socket in + let ppf = Format.formatter_of_out_channel oc in + Format.fprintf ppf "Hello World (from %d)!" (Unix.getpid ()) ; + Unix.close socket ; Ok () + | _ -> + Conduit.send flow "Hello World!" >>= fun _ -> + Conduit.close flow +]} + +In this example, we separate the computation in two branches: +{ul +{- When we ensure that the given flow comes from our TCP/IP implementation.} +{- When we don't know - and keep it as an {i abstract} value.}} + +It permits to do something special (like [Unix.setsockopt]) when we {b +well-known} the protocol. Of course, it's not possible to {i destruct} a [flow] +if you don't know about any protocol implementation used - and it can be the +case when you make a library. + +{3 When you make a library.} + +This is one of the real case of [Conduit]. As a library implementer such as an +HTTP library, you want to be able to start a connection {b but} we don't want to +use a {i specific} implementation of a protocol. In the case of TCP/IP, most of +times, we rely on the host's TCP/IP implementation, the UNIX one. But it's not +the case for MirageOS where the TCP/IP implementation used can change! + +This case is more concrete about the TLS implementation. Did you want to enforce +the use of OpenSSL for your user or you want to let them to choose the +implementation? + +At this question, it's hard to: +{ul +{- be able to start a TLS connection.} +{- let the user to choose the TLS implementation.}} + +How I can, as the library implementer, know how to initiate a TLS connection +(without any clues)? This is what [Conduit] wants to solve! + +The other way to initiate a connection with [Conduit] is: + +{[ +let run ~resolvers edn = + Conduit.resolve ~resolvers edn >>= fun flow -> + Conduit.send flow "Hello World!" >>= fun _ -> + Conduit.close flow +]} + +It introduces 2 values: +{ul +{- a [resolvers] which is like a set of protocols.} +{- a [edn] which is a {!Conduit.Endpoint.t}, a concrete value.}} + +The deal is to be able to start a connection from a fully-known value (our +{!Conduit.Endpoin.t}) and a context which contains all available protocols. This +context, the [resolvers], should be constructed by something higher than your +library - it can be the end-user or an another library. + +Let's stick on our HTTP implementation. On our side, we have a way to send over +a {!Conduit.S.FLOW} a HTTP/1.1 request. And we are able to parse and extract a +HTTP/1.1 response from the same given {!Conduit.S.FLOW}: + +{[ +type request +type response + +val request : uri:Uri.t -> [ `GET | `POST ] -> string option -> request + +val send : Conduit.flow -> request -> (unit, Conduit.error) result +val recv : Conduit.flow -> (response, Conduit.error) result +]} + +As a HTTP client, we should provide something like: + +{[ +val get : uri:Uri.t -> (response, error) result +val post : uri:Uri.t -> (response, error) result +]} + +With [Conduit], we will extend a bit these functions: + +{[ +val get : + resolvers:Conduit.resolvers -> + edn:Uri.t * Conduit.Endpoint.t -> + (response, error) result + +val post : + resolvers:Conduit.resolvers -> + edn:Uri.t * Conduit.Endpoint.t -> + string -> + (response, error) result +]} + +By this way, we let the user to decide which protocol he wants to use (see +[resolvers]) and with which peer he wants to communicate (see [edn]). We still +are at the library-level and, at this stage, we can not have any clue (again) +about the TCP/IP or the TLS implementation. Implementation of these functions +should be: + +{[ +let get ~resolvers (uri, edn) = + let req = request ~uri `GET None in + Conduit.resolve ~resolvers edn >>= fun flow -> + send flow req >>= fun () -> + recv flow >>= fun resp -> + Conduit.close flow >>= fun () -> + Ok resp + +let post ~resolvers (uri, edn) body = + let req = request ~uri `POST (Some body) in + Conduit.resolve ~resolvers edn >>= fun flow -> + send flow req >>= fun () -> + recv flow >>= fun resp -> + Conduit.close flow >>= fun () -> + Ok resp ]} -The registration gives to us a {i type-witness} which is a small representation -of our protocol. This value {b must} be exposed to the user: +{3 The library user.} + +It's on the responsability of the end-user to {i fill} the [resolvers] and give +the right {!Conduit.Endpoint.t} value from what he knows. If he wants an +executable, he is necessary aware about which protocol he can use. So we will +assume that he knows a TCP/IP protocol and a TLS protocol: {[ val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol +val tls : (Unix.sockaddr * tls_config, tls_socket) Conduit.protocol +]} + +Of course, the best representation of an HTTP target is an [Uri.t]. We will try +to {i transform} a given [Uri.t] to a [resolver] and an [edn]: + +{[ +let resolve ~port = function + | Conduit.Endpoint.IP v -> Some (Unix.ADDR_INET (Ipaddr_unix.to_inet_addr v, port)) + | Conduit.Endpoint.Domain v -> + match Unix.gethostbyname (Domain_name.to_string v) with + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> None + +let resolve_with_tls ~port edn = + match resolve ~port with + | Some sockaddr -> Some (sockaddr, global_tls_config) + | None -> None + +let uri_to_conduit uri = + let host = match Uri.host uri with + | Some host -> host + | None -> invalid_arg "An URI requires a host" in + let edn = Conduit.Endpoint.of_string host in + match Uri.scheme uri, Uri.host uri, Uri.port uri with + | (Some "http" | None), None -> + let resolvers = Conduit.add tcp (resolve ~port:80) Conduit.empty in + (resolvers, edn) + | Some "http", Some port -> + let resolvers = Conduit.add tcp (resolve ~port) Conduit.empty in + (resolvers, edn) + | Some "https", None -> + let resolvers = Conduit.add tls (resolve_with_tls ~port:443) Conduit.empty in + (resolvers, edn) + | Some "https", Some port -> + let resolvers = Conduit.add tls (resolve_with_tls ~port) Conduit.empty in + (resolvers, edn) + | None, None -> + let resolvers = + Conduit.empty + |> Conduit.add tcp (resolve ~port:80) + |> Conduit.add ~priority:10 tls (resolve_with_tls ~port:443) in + (resolvers, edn) + | Some scheme, _ -> invalid_arg "Invalid scheme" + +let get ~uri = + let resolvers, edn = uri_to_conduit uri in + get ~resolvers (uri, edn) + +let post ~uri = + let resolvers, edn = uri_to_conduit uri in + post ~resolvers (uri, edn) +]} + +The code is a bit long but the most important point is to let the end-user +(someone or something like a library) the full control of the dispatch of +protocols according his context and independantly to our HTTP library. + +The default case (when we don't recognize a port or a scheme) lets us to {i +inject} the TCP/IP protocol and the TLS protocol with an higher priority. In +this case, [Conduit] will try to initiate a TLS connection and, if it fails, it +will try the usual TCP/IP connection. + +{b NOTE.} Why {!Conduit.Endpoint.t} is {b not} an [Uri.t]? If you follow the +development of [Conduit], at the beginning, [Conduit] did the dispatch from an +[Uri.t]. It is not the case anymore where, even if we can describe lot of things +with an [Uri.t], the value still is a special case from the point-of-view of a +{i protocol} (according our definition). + +Indeed, the [port] value for example does not have any sense for a device +protocol. Moreover, the {i scheme} should not be the qualifier of a protocol +implementation. And the example above shows that the dispatch from an [Uri.t] is +a bit more complex than what we can imagine. + +[Conduit] wants to be easy to use - and the user should be able to {i +infer}/determine/describe the dispatch of protocols on his side. The previous +version taught us that an [Uri.t] is not a good choice (at the [Conduit]'s +layer) when we spend too much time to reverse-engineer the dispatch. + +{3 [Conduit] for a client.} + +[Conduit] is a tool which is able to {i inject} a {i protocol} without {i +functorization}. The end-user must keep in his mind that the [Conduit]'s +dispatch disqualify a protocol from 3 signals: +{ul + +{- if the [resolvers] is not filled with the protocol. + + Even if the protocol is {i registered} (with {!Conduit.S.register}), + [Conduit] look-up only on the given [resolvers]. So if the user did not fill + the [resolvers] with the registered protocol, [Conduit] is not able to start + the connection.} + +{- if the given {!Conduit.Endpoint.t} is not reachable by processes filled by + the end-user. + + The user is able to disqualify some {!Conduit.Endpoin.t} if he wants - for + example, an user can give a [resolvers] which is able to {i resolve} only one + specific domain-name. Of course, the common way is to use [Unix.gethostbyname] + but we can use something else like our greatest MirageOS DNS stack!} + +{- if the [connect] of the protocol fails. + + Even if we can {i resolve} the given {!Conduit.Endpoint.t}, the peer is may + be not accessible (for any reasons). For example, a website is not + neccessarily accessible with TLS - and in that case, we should try an other + protocol.}} + +From that, the end-user is able to easily infer how [Conduit] can choose a +specific protocol - but the real difference from the old version of [Conduit] is +the full-control of the end-user about the dispatch. + +[Conduit] does not come with any {i global} ({i mutlable}?) knowledge of what it +should do when a library maintainer wants to start a connection. All are decided +by the end-user and [Conduit] just tries to give the most easy way (with the +simpliest mental model) to plug (like {i a conduit}!) both sides. + +{2 Composition.} + +TLS is a protocol which requires... an other protocol! In the real world, TLS is +used over a TCP/IP [socket] but a problem appears for us (specifically for +MirageOS) when the TCP/IP protocol is not well-known. + +Indeed, about MirageOS, the TCP/IP protocol can our first TCP/IP protocol +implemented above but it can be [mirage-tcpip]. At this stage, we talk about {i +protocol composition}. The same goes for SSH or any cryptographic layered +protocol. + +It seems hard to deal with that in [Conduit] but it's not. Let's take an example +about a possible TLS implementation which is abstracted over... a +{!Conduit.S.PROTOCOL}! + +{[ +type 'a with_tls = + { underlying : 'a + ; tls : Tls.state } + +let underlying { underlying; _ } = underlying + +module Make_TLS (Protocol : Conduit.PROTOCOL) = struct + type 'a io = 'a Protocol.io + + type input = Protocol.input + type output = Protocol.output + + type flow = Protocol.flow with_tls + + type endpoint = Protocol.endpoint * Tls.config + + ... +end ]} -As you can see, the value keeps the type of your [endpoint] and the type of your -[flow]. This value is the uniq link to your implementation [TCP]. +It's an idiomatic code but it should be easy to concretely replace undefined +types/values by [ocaml-tls] or [ocaml-ssl]. The global idea is, from the ['a +with_tls], we are able to get some values such as: +{ul +{- the underlying representation of the protocol used.} +{- some information about the TLS state (ciphers used for example).}} + +Of course, we probably need to expose the {i functor} but we decided to +represent {i protocol} with values in [Conduit]. So we can take this advantage +to expose less things to the end-user and to the application of the {i functors} +by pack/unpack modules: -{2 Use a Conduit's protocol.} +{[ +let protocol_with_tls + : ('edn, 'flow) Conduit.protocol -> ('edn * Tls.config, 'flow with_tls) Conduit.protocol + = fun protocol -> + let module Protocol = (val Conduit.impl protocol) in + let module M = Make_TLS (Protocol) in + Conduit.register ~protocol:(module M) +]} -Now, the implementation of our protocol is reachable at any point of your code -with Conduit. The library provides mainly 2 ways to start a transmission: +For the point-of-view of the end-user, the composition of a well-known TCP/IP +protocol (or something else!) and our TLS implementation is: {[ -let loopback = Unix.ADDR_INET Unix.inet_addr_loopback +val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol +let tls + : (Unix.sockaddr * Tls.config, Unix.file_descr with_tls) Conduit.protocol + = protocol_with_tls tcp +]} + +And of course, all previous mechanisms available for a [Conduit.protocol] still +are available for our [tls] protocol such as the {i destruction}: -let socket : Unix.file_descr = Conduit.connect loopback My_protocol.tcp +{[ +include (val Conduit.repr tls) + +let run sockaddr tls_config = + Conduit.connect (sockaddr, tls_config) tls >>= function + | T (V tls_socket) -> + let socket = underlying tls_socket in + let peer = Unix.getpeername socket in + ... + | flow -> ... ]} -It's the usual way when you want to start a TCP transmission. However, in some -cases, you want to start {i "a transmission"} regardless the kind of the -transmission. Conduit provides a {i resolution} mechanism which is able to start -any kind of protocols. +{2 A correspondance.} + +Finally, it exists a correspondance between [Conduit] and a {i functorized} +implementation. -{3 Resolution.} +{[ +module Make (Flow : FLOW) = struct + let send_hello_world flow = Flow.send flow "Hello World!" +end +]} -We consider [[ `host ] Domain_name.t] as the most general concrete type to -represent a peer. From it, we can extract the [Unix.sockaddr] such as: +In [Conduit] the snippet code above is: {[ -let http_resolv domain_name = - match Unix.gethostbyname (Domain_name.to_string domain_name) with - | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> - Some (Unix.INET_ADDR (h_addr_list.(0), 80)) - | _ -> None - | exception _ -> None +let send_hello_world (flow : Conduit.flow) = Conduit.send flow "Hello World!" ]} -But we can extract (or decide to bind) something else such as a set of TLS -certificates. More generally, the value returned by your resolution is free as -long as a Conduit's protocol can use it to initialise a transmission. +About the specialisation of your implementation from a specific protocol, we +assume that you have a knowledge of which protocols are available (such as the +TCP/IP protocol). Without [Conduit], this protocol is an implementation which +should respect the [FLOW] interface: + +{[ +module TCP : FLOW = ... +]} -Then, Conduit defines a [resolvers] which can contains your function such as -[http_resolv] and let the user to bind them to a specific protocol. For example, -we can bind our [http_resolv] with our TCP protocol: +With conduit, the implementation must respect the same interface too. But, +instead of manipulating an OCaml module, we use an OCaml value such as: {[ -let my_resolvers = Conduit.add My_protocol.tcp http_resolv Conduit.empty +let tcp = Conduit.register ~protocol:(module TCP) ]} -Finally, we can use this value to start {i "a transmission"}: +Then, the usual {i injection} of the TCP implementation with {i functors} is: {[ -let google = Domain_name.(host_exn (of_string_exn "google.com")) +module M = Make(TCP) + +let () = + let flow = TCP.make localhost in + M.send_hello_world flow +]} + +Where, with [Conduit], the {i injection} is: -let flow : Conduit.flow = Conduit.resolve my_resolvers google +{[ +let () = + let flow = Conduit.connect ~protocol:tcp localhost in + send_hello_world flow ]} -You can denote that we finally return a {!Conduit.flow} value which is an -abstract type instead to return a concrete [Unix.file_descr] value as before. -From it, you still able to use [send]/[recv] functions with: +{2 The service.} + +The new version of [Conduit] did the choice to provide something else to +initiate a service. The context of the initialisation of a service (such as a +TCP) service is more complete than the client. The implementer of a service +(such as an HTTP service) must be aware about which implementation he wants to +use - and he does not really need a {i dispatch} process between several +protocol implementations. + +In that case, [Conduit] comes like a simple framework which enforces a certain +interface about service implementation, with the same protocol's registration +mechanism and without the {i dispatch} (with the [resolvers]) process - because +you should fully-know how to initiate your service! + +{3 A concrete implementation.} + +As the protocol, the service must respect an interface: {!Conduit.S.SERVICE}. +This interface is what a POSIX-compliant protocol provides: {[ -let hello (flow : Conduit.flow) = - Conduit.send flow "Hello World!" +module Service = struct + type 'a io = 'a + + type flow = Unix.file_descr + type t = Unix.file_descr + + type error = | + + let pp_error : Format.formatter -> error -> unit = fun _ -> function _ -> . + + type configuration = Unix.sockaddr + + let init sockaddr = + let domain = Unix.domain_of_sockaddr sockaddr in + let socket = Unix.socket domain Unix.SOCK_STREAM 0 in + Unix.bind socket sockaddr ; + Unix.listen socket 40 ; Ok socket + + let accept socket = + let client, _ = Unix.accept socket in + Ok client + + let close socket = Unix.close socket ; Ok () +end ]} -But the flow can be an usual TCP transmission or something more complex like a -TLS connection. But all of this complexity is hidden by the abstract type. +Again, this implementation is a simple example and it should not be used into a +productive context. -More generally, in some context, it's useful to be abstract over the protocol -used to communicate with a peer. Specially when you have several ways to -communicate with your peer. An example is Git which can communicate with: +{3 Registration & use.} +[Conduit] provides then all of these functions: {ul -{- TCP with a [git://] URL.} -{- SSH with a [git@] endpoint.} -{- HTTP with a [http://] URL.} -{- HTTPS with a [https://] URL.}} - -However contents of the transmission is pretty the same betweem all of these -ways. Instead to duplicate the process to communicate with our peer, it could be -better to use one and a full abstract [flow] and be less-aware about the -underlying protocol used - or, at least, shift this responsability to the final -user. - -An other case is about MirageOS which does not assert that the TCP/IP stack - -and the TCP protocol - is available into your unikernel. Of course, the protocol -can exists but it can be replaced by something else. \ No newline at end of file +{- [init] to initiate the service.} +{- [accept] to wait a client.} +{- [close] to close the service.}} + +The registration of the service with [Conduit] is: + +{[ +let tcp_service + : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Conduit.service + = Conduit.Service.regiseter (module Service) +]} + +As you can see, we have 3 parameters (instead of 2 for a protocol). In fact, the +[Unix.file_descr] which represents the service can be different from the value +which represent the client. It does not appear in our case but in some context +(such as TLS), it's required to have this difference. + +Of course, to be able to handle multiple functions, we should have something +like [Thread] ([LWT] or [ASYNC]) to concurrently handle clients. Then, we are +able to implement an usual (infinite) {i service loop}: + +{[ +let serve_with_handler + : Unix.sockaddr -> (Conduit.flow -> unit) -> unit + = fun cfg ~handler -> + let service = tcp_service in + Conduit.Service.init ~service cfg >>= fun t -> + let rec go t = + Conduit.Service.accept ~service t >>= fun socket -> + let flow = Conduit.pack tcp socket in + let _ = Thread.create handler flow in + go t in + go t +]} + +Again, we are the ability to {i abstract} the socket with a well-known protocol +(such as our previous TCP/IP protocol) and give it to an user-defined function. +Finally, the user will be able to {i destruct} it or use it for a more abstract +process. + +The service has less abilities than the client, but as we said before, the +context is a bit different where we should fully-known how we initiate our +service (on which port, with which configuration, etc.). The {i dispatch} +mechanism is not needed at this stage. \ No newline at end of file From e0559111f007933e7d5888af91f771b701789191 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 8 Oct 2020 20:31:57 +0200 Subject: [PATCH 081/140] Update the CHANGES.md to include the small HOW-TO about conduit --- CHANGES.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 9d8da74c..5c661942 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,8 +1,11 @@ ## v3.0.0 (2020-10-06) -* **breaking change** **New version of `conduit`. Most of the new API has a +* **breaking change** - New version of `conduit`. Most of the new API has a description on the pull-request - [#311](https://github.com/mirage/ocaml-conduit/pull/311). + [#311](https://github.com/mirage/ocaml-conduit/pull/311). Documentation is + updated as well with a small HOW-TO (available + [here](https://mirage.github.io/ocaml-conduit/conduit/index.html)) which + describes the new API. ## v2.2.2 (2020-06-14) From b64478cbf34adcff4affd59bfa975d91b1d6353a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 9 Oct 2020 12:29:07 +0200 Subject: [PATCH 082/140] Minor update on index.mld --- src/core/index.mld | 149 +++++++++++++++++++++++++++++++++------------ 1 file changed, 109 insertions(+), 40 deletions(-) diff --git a/src/core/index.mld b/src/core/index.mld index d555a4d6..04acbefe 100644 --- a/src/core/index.mld +++ b/src/core/index.mld @@ -45,7 +45,7 @@ can be abstracted to work over any flow implementations. Let's start to implement a TCP/IP protocol with UNIX. At first, [Conduit] needs a {i scheduler} and the type of [input]/[output]. [Conduit_lwt] is a -specialisation of [Conduit] with LWT with {!Cstruct.t} as input/output. It is +specialisation of [Conduit] with LWT and {!Cstruct.t} as input/output. It is the same for [Conduit_async] with ASYNC. For our example (and to simplify our code), we will specialise [Conduit] with @@ -63,7 +63,7 @@ module Conduit = Conduit.Make(Scheduler)(Bytes)(String) ]} Then, we can start to implement our TCP/IP protocol from what [Unix] gives to us -- of course, this code require the [unix.cm{x}a] library: +— of course, this code require the [unix.cm{x}a] library: {[ module TCP = struct @@ -103,7 +103,7 @@ end ]} The code is really simple and it does not care about details such as [exception] -- so, don't try to use this code into a productive context! We can verify that our +— so, don't try to use this code into a productive context! We can verify that our implementation respects the interface {!Conduit.S.PROTOCOL}: {[ @@ -126,8 +126,8 @@ let tcp = Conduit.register ~protocol:(module TCP) ]} -So we create our first [Conduit] protocol! As you can see, [Conduit] some useful -information such as: +So we create our first [Conduit] protocol! As you can see, [Conduit] keeps some +useful information such as: {ul {- the type of the endpoint required to initiate the protocol.} {- the type of the flow.}} @@ -157,11 +157,11 @@ able to register it with [Conduit]. The first case is the most common case where we want to make a simple executable. However, the second case can appear when we want to make a library! -A library which wants to communicate with a peer should assert one and unique -implementation of TCP - and, with MirageOS, it's impossible to do that when the -TCP implementation can be the UNIX one or [mirage-tcpip]. +A library which wants to communicate with a peer should {b not} assert one and +unique implementation of TCP/IP — and, with MirageOS, it's impossible to do that +when the TCP/IP implementation can be the UNIX one or [mirage-tcpip]. -But let's start with the first case, we want to make an executable: +But let's start with the first case, when we want to make an executable: {[ let ( >>= ) = Result.bind @@ -188,6 +188,11 @@ $1> ./a.out $2> Hello World! v} +This is the most simple case mostly because we fullu-know our context — our +dependencies, our target (UNIX), etc. Such context can not be well-known and, +for a MirageOS library — or any system agnostic libraries, we must be abstract +over these protocols. + {3 Destruct your [flow].} [Conduit] lets the possibility to {i destruct} the {!Conduit.S.flow}. It mostly @@ -209,7 +214,7 @@ type t = (Unix.sockaddr, Unix.file_descr) Conduit.value (* = Value of Unix.file_ type Conduit.flow += T of t ]} -With this definition, we are able to {i pattern-flow} on our {!Conduit.S.flow}: +With this definition, we are able to {i pattern-match} on our {!Conduit.S.flow}: {[ let run () = @@ -233,7 +238,28 @@ In this example, we separate the computation in two branches: It permits to do something special (like [Unix.setsockopt]) when we {b well-known} the protocol. Of course, it's not possible to {i destruct} a [flow] if you don't know about any protocol implementation used - and it can be the -case when you make a library. +case when you make a library again. + +{4 The usage of the destruction.} + +Some libraries permits to manipule the flow even if they processed on it. This +case appear for example for an HTTP library when it reads and writes into the +{!Conduit.S.flow} and gives it to the end-user then into the the user-defined {i +handler}: + +{[ +val http_serve : handler:(Conduit.flow -> Request.t -> Response.t) -> http_cfg -> unit +]} + +In that case, the library wants to manipulate an {i abstract} flow (and let the +user to do the {i injection} of a TCP/IP protocol or a TCP/IP + TLS protocol). +However, we should let the user to be able to {i destruct} the value to the +[Unix.file_descr] (according to our example). + +At this stage, the user will use [http_serve], he will define [handler] and he +has a full knowledge of his context (and which protocol implementation he wants +to use). With these 3 conditions, he is able to properly {i destruct} the given +flow and introspect it (like to know who is the client with [Unix.getpeername]). {3 When you make a library.} @@ -244,7 +270,7 @@ times, we rely on the host's TCP/IP implementation, the UNIX one. But it's not the case for MirageOS where the TCP/IP implementation used can change! This case is more concrete about the TLS implementation. Did you want to enforce -the use of OpenSSL for your user or you want to let them to choose the +the use of OpenSSL for your user or you want to let them to choose the TLS implementation? At this question, it's hard to: @@ -267,7 +293,8 @@ let run ~resolvers edn = It introduces 2 values: {ul {- a [resolvers] which is like a set of protocols.} -{- a [edn] which is a {!Conduit.Endpoint.t}, a concrete value.}} +{- a [edn] which is a {!Conduit.Endpoint.t}, a concrete value to represent your + peer.}} The deal is to be able to start a connection from a fully-known value (our {!Conduit.Endpoin.t}) and a context which contains all available protocols. This @@ -292,7 +319,7 @@ As a HTTP client, we should provide something like: {[ val get : uri:Uri.t -> (response, error) result -val post : uri:Uri.t -> (response, error) result +val post : uri:Uri.t -> string -> (response, error) result ]} With [Conduit], we will extend a bit these functions: @@ -404,8 +431,8 @@ protocols according his context and independantly to our HTTP library. The default case (when we don't recognize a port or a scheme) lets us to {i inject} the TCP/IP protocol and the TLS protocol with an higher priority. In -this case, [Conduit] will try to initiate a TLS connection and, if it fails, it -will try the usual TCP/IP connection. +this case, [Conduit] will try to initiate a TLS connection first and, if it +fails, it will try the usual TCP/IP connection. {b NOTE.} Why {!Conduit.Endpoint.t} is {b not} an [Uri.t]? If you follow the development of [Conduit], at the beginning, [Conduit] did the dispatch from an @@ -435,15 +462,19 @@ dispatch disqualify a protocol from 3 signals: Even if the protocol is {i registered} (with {!Conduit.S.register}), [Conduit] look-up only on the given [resolvers]. So if the user did not fill the [resolvers] with the registered protocol, [Conduit] is not able to start - the connection.} + the connection with this protocol.} {- if the given {!Conduit.Endpoint.t} is not reachable by processes filled by the end-user. The user is able to disqualify some {!Conduit.Endpoin.t} if he wants - for example, an user can give a [resolvers] which is able to {i resolve} only one - specific domain-name. Of course, the common way is to use [Unix.gethostbyname] - but we can use something else like our greatest MirageOS DNS stack!} + specific domain-name (like ["localhost"]). Of course, the common way is to + use [Unix.gethostbyname] but we can use something else like our greatest + MirageOS DNS stack! + + The resolution is not done by [Conduit] and only {!Conduit.S.resolver} given + by the end-user are able to determine required values to initiate protocols.} {- if the [connect] of the protocol fails. @@ -467,10 +498,9 @@ TLS is a protocol which requires... an other protocol! In the real world, TLS is used over a TCP/IP [socket] but a problem appears for us (specifically for MirageOS) when the TCP/IP protocol is not well-known. -Indeed, about MirageOS, the TCP/IP protocol can our first TCP/IP protocol +Indeed, about MirageOS, the TCP/IP protocol can be our first TCP/IP protocol implemented above but it can be [mirage-tcpip]. At this stage, we talk about {i -protocol composition}. The same goes for SSH or any cryptographic layered -protocol. +protocol composition}. The same goes for SSH or any layered protocol. It seems hard to deal with that in [Conduit] but it's not. Let's take an example about a possible TLS implementation which is abstracted over... a @@ -498,16 +528,17 @@ end ]} It's an idiomatic code but it should be easy to concretely replace undefined -types/values by [ocaml-tls] or [ocaml-ssl]. The global idea is, from the ['a -with_tls], we are able to get some values such as: +types/values by [ocaml-tls] or [ocaml-ssl] (and if you are curious, you can take +a look on [conduit-tls]). The global idea is, from the ['a with_tls], we are +able to get some values such as: {ul {- the underlying representation of the protocol used.} {- some information about the TLS state (ciphers used for example).}} Of course, we probably need to expose the {i functor} but we decided to -represent {i protocol} with values in [Conduit]. So we can take this advantage -to expose less things to the end-user and to the application of the {i functors} -by pack/unpack modules: +represent {i protocols} with values in [Conduit]. So we can take this advantage +to expose less things to the end-user and do the application of the {i functor} +by {i pack/unpack} modules: {[ let protocol_with_tls @@ -563,10 +594,10 @@ let send_hello_world (flow : Conduit.flow) = Conduit.send flow "Hello World!" About the specialisation of your implementation from a specific protocol, we assume that you have a knowledge of which protocols are available (such as the TCP/IP protocol). Without [Conduit], this protocol is an implementation which -should respect the [FLOW] interface: +should respect the {!Conduit.S.PROTOCOL} interface: {[ -module TCP : FLOW = ... +module TCP : Conduit.S.PROTOCOL = ... ]} With conduit, the implementation must respect the same interface too. But, @@ -598,20 +629,20 @@ let () = The new version of [Conduit] did the choice to provide something else to initiate a service. The context of the initialisation of a service (such as a -TCP) service is more complete than the client. The implementer of a service -(such as an HTTP service) must be aware about which implementation he wants to -use - and he does not really need a {i dispatch} process between several -protocol implementations. +TCP service) should be more complete than the client. The implementer of a +service (such as an HTTP service) must be aware about which implementation he +wants to use - and he does not really need a {i dispatch} process between +several protocol implementations. In that case, [Conduit] comes like a simple framework which enforces a certain interface about service implementation, with the same protocol's registration -mechanism and without the {i dispatch} (with the [resolvers]) process - because -you should fully-know how to initiate your service! +mechanism and without the {i dispatch} (with the [resolvers]) process — because +you should fully-know how to initiate your service)! {3 A concrete implementation.} As the protocol, the service must respect an interface: {!Conduit.S.SERVICE}. -This interface is what a POSIX-compliant protocol provides: +This interface is what a POSIX-compliant service provides: {[ module Service = struct @@ -683,11 +714,49 @@ let serve_with_handler ]} Again, we are the ability to {i abstract} the socket with a well-known protocol -(such as our previous TCP/IP protocol) and give it to an user-defined function. -Finally, the user will be able to {i destruct} it or use it for a more abstract -process. +(such as our previous TCP/IP protocol) and give it to an user-defined function +[handler]. Finally, the user will be able to {i destruct} it or use it for a +more abstract process. The service has less abilities than the client, but as we said before, the context is a bit different where we should fully-known how we initiate our service (on which port, with which configuration, etc.). The {i dispatch} -mechanism is not needed at this stage. \ No newline at end of file +mechanism is not needed at this stage. + +[Conduit_lwt] and [Conduit_async] provide both a [serve] such as our previous +[serve_with_handler] function (but they are more complete). + +{2 Dependencies & eco-system.} + +[Conduit] is a small package, it requires: +{ul +{- [domain-name] to have a representation of a domain-name.} +{- [ipaddr] to have a representation of an IP.} +{- [stdlib-shims] for internal stuffs.}} + +As a protocol implementer, the compatibility with MirageOS require that you: ++ Functorize your code ++ Or use [Conduit] + +In some context, the first option is good - and this is what [mirage-tcpip] does +(when the TCP/IP is a composition of several others protocols...). But from some +high-level libraries such as [Irmin] or [Cohttp], [Conduit] seems the best to {i +de-functorize} the stack. + +Of course, even if [Conduit] was made for MirageOS, it can be use into several +others contexts, hence the existence of [Conduit_lwt] and [Conduit_async]. + +{2 Conclusion.} + +A MirageOS project wants to provide the best way to abstract everythings which +is commonly available on an operating-system. At this layer, we can said that +[Conduit] is close to re-implement [/etc/services]! + +It serves the MirageOS purpose but, moreover, it unlocks the ability to be +abstracted over protocols. This ability is a game between what we can assert +about the definition of a protocol and the type-system. + +This document is like a little HOW-TO but tests are a good example of how to use +[Conduit] too. Then, the documentation of each function give you an example in +which case it could be useful to use them. Feel free to complete or fix some +french^Wenglish issues! \ No newline at end of file From 7b517f6adcc7242dcb0a8e344ad35f1894d89921 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 9 Oct 2020 15:45:44 +0200 Subject: [PATCH 083/140] Add a simple HOW-TO which explain how to change a protocol with Conduit --- src/core/dune | 2 +- src/core/howto.mld | 300 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 301 insertions(+), 1 deletion(-) create mode 100644 src/core/howto.mld diff --git a/src/core/dune b/src/core/dune index 621cc71e..8b5eecee 100644 --- a/src/core/dune +++ b/src/core/dune @@ -5,4 +5,4 @@ (documentation (package conduit) - (mld_files index)) + (mld_files howto index)) diff --git a/src/core/howto.mld b/src/core/howto.mld new file mode 100644 index 00000000..2a2ef44e --- /dev/null +++ b/src/core/howto.mld @@ -0,0 +1,300 @@ +{1 Conduit.} + +[Conduit] is a library which wants to replace your protocol implementation. +Instead to use {!Unix.read} and {!Unix.write}, we use: +- {!Conduit.S.recv} +- {!Conduit.S.send} + +We assume that [Conduit] is MirageOS-compatible (instead of [Unix] module). + +{2 A ping-pong client.} + +We will start with a [getline] function: +{[ +val getline : Conduit_lwt.flow -> + ([ `Line of string | `End_of_flow ], Conduit_lwt.error) result Lwt.t +]} + +As the POSIX [getline] (see [man 3 getline]). The ping-pong client sends a line +to a ping-pong server if it receives then ["pong"], it continues to talk until +it has nothing to send. Otherwise, it closes. + +{[ +let client ~resolvers edn = + Conduit_lwt.resolve ~resolvers edn >>? fun flow -> + let rec go () = match input_line stdin with + | line -> + ( Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Format.printf "> %s.\n%!" line ; + getline flow >>? function + | `Line "pong" -> Format.printf "< pong.\n%!" ; go () + | `Line line -> Format.printf "< %s.\n%!" ; go () + | `End_of_flow -> Conduit_lwt.flow flow ) + | exception End_of_file -> Conduit_lwt.close flow in + go () +]} + +[getline] can be implemented as well with {!Conduit.S.recv}. + +{2 A ping-pong server.} + +A ping-pong server accepts a client and if it receives: +- ["ping"], it responses ["pong"] +- ["pong"], it responses ["ping"] +- something else, it responses the received line and it closes the connection + +[Conduit_lwt] (and [Conduit_async]) provides a simple function +{!Conduit_lwt.serve} to initiate a service. Let's implement the server logic: + +{[ +let handler flow = + let rec go () = + getline flow >>= function + | Ok `End_of_flow | Error _ -> Conduit_lwt.close flow + | Ok (`Line "ping") -> + Conduit_lwt.send flow (Cstruct.of_string "pong\n") >>? fun _ -> go () + | Ok (`Line "pong") -> + Conduit_lwt.send flow (Cstruct.of_string "ping\n") >>? fun _ -> go () + | Ok (`Line line) -> + Conduit_lwt.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + Conduit_lwt.close flow in + go () >>= function + | Error err -> failwith "%a" Conduit_lwt.pp_error err + | Ok () -> Lwt.return_unit + +let server cfg ~protocol ~service = + Conduit_lwt.serve + ~handler:(fun flow -> handler (Conduit_lwt.pack protocol flow)) + ~service cfg +]} + +Now, we are able to start clients and a simple server. At this stage of the +development, we did not choose the protocol implementation (such as a +{!Unix.socket}). We will see how to {i inject} a protocol behind [Conduit]. + +In our code, we use {!Conduit.S.pack} which wants to {i hide} the given flow. +Indeed, the flow given by {!Conduit_lwt.serve} has the concrete type +[Lwt_unix.file_descr] so we must {i abstract} it to a {!Conduit.S.flow}. + +{2 Initiate a server & a client.} + +[Conduit_lwt] propose a [Conduit]-compatible TCP/IP protocol: {!Conduit_lwt.TCP} +(and the same goes for {!Conduit_async.TCP}). This is your host's TCP/IP stack. +Let's launch the ping-pong server with that: + +{[ +let fiber ~uri = + let host = Uri.host_with_default ~default:"127.0.0.1" uri in + let port = Option.value ~default:8080 (Uri.port uri) in + let cfg : Conduit_lwt.TCP.configuration = + { Conduit_lwt.TCP.sockaddr= Unix.(ADDR_INET (inet_addr_of_string host, port)) + ; capacity= 40 } in + let _always, run = server cfg + ~protocol:Conduit_lwt.TCP.protocol + ~service:Conduit_lwt.TCP.service in + run () + +let () = + let uri = Uri.of_string Sys.argv.(1) in + Lwt_main.run (fiber ~uri) +]} + +We enforce to use the TCP/IP protocol in that case and we give a service's +defined configuration value to launch our ping-pong service. [cfg] depends on +[service]. Indeed, the type of {!Conduit_lwt.TCP.service} is: + +{[ +type configuration = { sockaddr : Lwt_unix.sockaddr; capacity : int } + +val service : (configuration, Service.t, Protocol.flow) Conduit_lwt.service +]} + +For the client, we must {i construct} a {!Conduit.resolvers} and give an +{!Conduit.Endpoint.t}. We will make them from an {!Uri.t}: + +{[ +let conduit_of_uri uri = + let host = Uri.host_with_default ~default:"localhost" uri in + let port = Option.value ~default:8080 (Uri.port uri) in + match Uri.scheme uri with + | Some "pg" | None -> + let resolvers = + Conduit.empty + |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) in + resolvers, Conduit_lwt.Endpoint.v host + | Some scheme -> invalid_arg "Invalid scheme: %s" scheme + +let fiber ~uri = + let resolvers, edn = conduit_of_uri uri in + client ~resolvers edn >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Conduit_lwt.pp_error err + +let () = + let uri = Uri.of_string Sys.argv.(1) in + Lwt_main.run (fiber ~uri) +]} + +{3 Compilation & run.} + +Let's try our binaries, we use 2 shells ([$1>] and [$2>]): +{v +$1> ocamlfind opt -thread -linkpkg -package conduit-lwt,uri client.ml -o client +$2> ocamlfind opt -thread -linkpkg -package conduit-lwt,uri server.ml -o server +$2> ./server pg://127.0.0.1/ +$1> ./client pg://localhost/ + 1> ping + 1> > ping + 1> < ping + 1> pong + 1> > pong + 1> < ping +v} + +{2 Upgrade our protocol with crypto.} + +It seems that we exchange lot of secret information! So we should upgrade to +TLS. At this stage, our [server] and our [client] function should {b not} change - +and this is the final goal of [Conduit]: {i abstract} the protocol. + +{!Conduit_lwt_tls.TCP} provides, as {!Conduit_lwt.TCP} two values: +{[ +val protocol : + ( Lwt_unix.sockaddr * Tls.Config.client, + Protocol.flow protocol_with_tls ) + protocol + +val service : + ( configuration * Tls.Config.server, + Service.t service_with_tls, + Protocol.flow protocol_with_tls ) + service +]} + +So, instead to use {!Conduit_lwt.TCP.protocol} and {!Conduit_lwt.TCP.service}, +we will use them to upgrade our protocol (when the scheme is ["pgs"]): + +{v server.ml v} +{[ +let () = Mirage_crypto_rng_unix.initialize () + +let load_file filename = + let ic = open_in filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + really_input ic rs 0 ln ; + close_in ic ; + Cstruct.of_bytes rs + +let config cert key = + let cert = load_file cert in + let key = load_file key in + match + (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key) + with + | Ok certs, Ok (`RSA key) -> + Tls.Config.server ~certificates:(`Single (certs, key)) () + | _ -> failwith "Invalid key or certificate" + +let fiber ~uri = + let host = Uri.host_with_default ~default:"127.0.0.1" uri in + let cfg ~port = + { Conduit_lwt.TCP.sockaddr= Unix.(ADDR_INET (inet_addr_of_string host, port)) + ; capacity= 40 } in + let _always, run = match Uri.scheme uri with + | None | Some "pg" -> + let port = Option.value ~default:8080 (Uri.port uri) in + server (cfg ~port) + ~protocol:Conduit_lwt.TCP.protocol + ~service:Conduit_lwt.TCP.service + | Some "pgs" -> + let port = Option.value ~default:4343 (Uri.port uri) in + let cfg = cfg ~port, config "server.pem" "server.key" in + server cfg + ~protocol:Conduit_lwt_tls.TCP.protocol + ~service:Conduit_lwt_tls.TCP.service + | Some scheme -> invalid_arg "Invalid scheme: %s" scheme in + run () + +let () = + let uri = Uri.of_string Sys.argv.(1) in + Lwt_main.run (fiber ~uri) +]} + +And for the client, we just need to update the function [conduit_of_uri]: + +{v client.ml v} +{[ +let tls_config = Tls.Config.client ~authenticator:(fun ~host:_ _ -> Ok None) () + +let () = Mirage_crypto_rng_unix.initialize () + +let conduit_of_uri uri = + let host = Uri.host_with_default ~default:"localhost" uri in + let edn = Conduit_lwt.Endpoint.v host in + let resolvers = match Uri.scheme uri with + | Some "pg" -> + let open Conduit_lwt.TCP in + let port = Option.value ~default:8080 (Uri.port uri) in + let resolvers = + Conduit.empty + |> Conduit_lwt.add protocol (TCP.resolve ~port) in + resolvers + | Some "pgs" -> + let open Conduit_lwt_tls.TCP in + let port = Option.value ~default:4343 (Uri.port uri) in + let resolvers = + Conduit.empty + |> Conduit_lwt.add protocol (resolve ~port ~config:tls_config) in + resolvers + | None -> + let module TCP = Conduit_lwt.TCP in + let module TLS = Conduit_lwt_tls.TCP in + let u_port = Option.value ~default:8080 (Uri.port uri) in + let s_port = Option.value ~default:4343 (Uri.port uri) in + let resolvers = + Conduit.empty + |> Conduit_lwt.add ~priority:10 TLS.protocol + (TLS.resolve ~port:s_port ~config:tls_config) + |> Conduit_lwt.add TCP.protocol (TCP.resolve ~port:u_port) in + resolvers + | Some scheme -> Fmt.invalid_arg "Invalid scheme: %s" scheme in + resolvers, edn +]} + +Above, we can see that for the default case (when we don't have a scheme), we {i +inject} two protocols, the secure one (with a priority) and the unsecure one. +[Conduit] will try the secure one and if it fails, it fallbacks to the second +one. This case can appear when you want to communicate with a peer and you have +multiple possibilies such as [http] and [htps]. + +{3 Compilation & run.} + +Let's show result: + +{v +$1> ocamlfind opt -thread -linkpkg -package conduit-lwt-tls,mirage-crypto-rng.unix \ + client.ml -o client +$2> ocamlfind opt -thread -linkpkg -package conduit-lwt-tls,mirage-crypto-rng.unix \ + server.ml -o server +$2> ./server pgs://127.0.0.1/ +$1> ./client localhost + 1> pong + 1> > pong + 1> < ping +v} + +{2 Conclusion.} + +From a client logic and a server logic, with [Conduit], we are able to abstract +both over the protocol implementation. [Conduit] comes with several +implementations (TCP/IP, TLS and SSL) but a protocol implementer can add its own +protocol implementation only with the core of [Conduit]. + +Then, from the user point-of-view, he can decide which protocol he wants to use. +We see that upgrading a existing code-base to another protocol has no cost as +long as the code-base use [Conduit]. + +Of course, the end-user (our [fiber] functions) must be updated according new +protocols but it does not imply any change on the logic of the server and the +logic of the client: this is the goal of [Conduit]! \ No newline at end of file From 69030bec3a0c3f60cef2e3edaf6100b99878a577 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 9 Oct 2020 16:59:11 +0200 Subject: [PATCH 084/140] Move the other howto (which is more complete) as readme.mld --- src/core/dune | 2 +- src/core/{index.mld => readme.mld} | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename src/core/{index.mld => readme.mld} (100%) diff --git a/src/core/dune b/src/core/dune index 8b5eecee..7b91c74f 100644 --- a/src/core/dune +++ b/src/core/dune @@ -5,4 +5,4 @@ (documentation (package conduit) - (mld_files howto index)) + (mld_files howto readme)) diff --git a/src/core/index.mld b/src/core/readme.mld similarity index 100% rename from src/core/index.mld rename to src/core/readme.mld From 6ae5a0efac2ac64532060d0de658a724db641c21 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 11 Oct 2020 12:17:02 +0200 Subject: [PATCH 085/140] Update CHANGES.md --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 5c661942..a4813521 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,7 +4,7 @@ description on the pull-request [#311](https://github.com/mirage/ocaml-conduit/pull/311). Documentation is updated as well with a small HOW-TO (available - [here](https://mirage.github.io/ocaml-conduit/conduit/index.html)) which + [here](https://mirage.github.io/ocaml-conduit/conduit/howto.html)) which describes the new API. ## v2.2.2 (2020-06-14) From 60711d58dbd495fb2313a76e75061e33f268ab20 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 11 Oct 2020 14:17:20 +0200 Subject: [PATCH 086/140] Update .gitignore about some trials with conduit --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 03dd8e0f..443bd4aa 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ _build/ _opam/ +sandbox/ .*.swp *.install .merlin From 5b48125678cea634bd1247f35cdb1fd517785187 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 15:54:49 +0200 Subject: [PATCH 087/140] Fix use of lwt_io + conduit-tls --- src/lwt/conduit_lwt.ml | 12 +++++++----- src/tls/conduit_tls.ml | 33 +++++++++++++++++++++++---------- 2 files changed, 30 insertions(+), 15 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index d80262ef..caba37e3 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -15,11 +15,12 @@ let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt let io_of_flow flow = let open Lwt.Infix in + let mutex = Lwt_mutex.create () in let ic_closed = ref false and oc_closed = ref false in let close () = if !ic_closed && !oc_closed then - close flow >>= function + Lwt_mutex.with_lock mutex (fun () -> close flow) >>= function | Ok () -> Lwt.return_unit | Error err -> failwith "%a" pp_error err else Lwt.return_unit in @@ -29,16 +30,17 @@ let io_of_flow flow = let oc_close () = oc_closed := true ; close () in - let recv buf off len = + let rec rrecv buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - recv flow raw >>= function + Lwt_mutex.with_lock mutex (fun () -> recv flow raw) >>= function + | Ok (`Input 0) -> Lwt_unix.yield () >>= fun () -> rrecv buf off len | Ok (`Input len) -> Lwt.return len | Ok `End_of_flow -> Lwt.return 0 | Error err -> failwith "%a" pp_error err in - let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input recv in + let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input rrecv in let send buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - send flow raw >>= function + Lwt_mutex.with_lock mutex (fun () -> send flow raw) >>= function | Ok len -> Lwt.return len | Error err -> failwith "%a" pp_error err in let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 59c4c14a..5c37fa8b 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -119,7 +119,7 @@ struct (* XXX(dinosaure): it seems that decoding TLS inputs can produce something bigger than expected. For example, decoding 4096 bytes can produce 4119 byte(s). *) - Log.debug (fun m -> m "|- TLS state: Ok") ; + Log.debug (fun m -> m "|- TLS state: Ok.") ; queue_wr_opt queue data ; flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) @@ -151,7 +151,8 @@ struct flow_wr_opt flow resp >>? fun () -> if Tls.Engine.handshake_in_progress tls then ( - Log.debug (fun m -> m "<- Read the TLS flow") ; + Log.debug (fun m -> + m "<- Read the TLS flow (while handshake).") ; Flow.recv flow raw0 >>| reword_error flow_error >>? function | `End_of_flow -> Log.warn (fun m -> @@ -222,21 +223,33 @@ struct m "<- Connection closed by underlying protocol.") ; t.tls <- None ; return (Ok `End_of_flow) - | `Input len -> - let handle = + | `Input len -> ( + Log.debug (fun m -> m "<- Got %d byte(s)." len) ; + let handle raw = if Tls.Engine.handshake_in_progress tls - then handle_handshake tls t.queue t.flow - else handle_tls tls t.queue t.flow in - let uid = - Hashtbl.hash (Cstruct.to_string (Cstruct.sub t.raw 0 len)) - in + then handle_handshake tls t.queue t.flow raw + else handle_tls tls t.queue t.flow raw in + let before = Tls.Engine.handshake_in_progress tls in Log.debug (fun m -> + let uid = + Hashtbl.hash + (Cstruct.to_string (Cstruct.sub t.raw 0 len)) in m "<~ [%04x] Got %d bytes (handshake in progress: %b)." uid len (Tls.Engine.handshake_in_progress tls)) ; handle (Cstruct.sub t.raw 0 len) >>? fun tls -> + let after = + Option.fold ~none:false + ~some:Tls.Engine.handshake_in_progress tls in t.tls <- tls ; - recv t raw)) + match (tls, before, after) with + | Some _, false, false | Some _, true, false -> + return (Ok (`Input 0)) + | Some _, false, true (* renegociate *) + | Some _, true, true (* continue handshake *) + | None, _, _ -> + Log.debug (fun m -> m "Retry to receive something.") ; + recv t raw))) | _ -> let max = Cstruct.len raw in let len = min (Ke.length t.queue) max in From aecc3d895e70d49441eb466aa4e3c42014d6df41 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 16:31:59 +0200 Subject: [PATCH 088/140] Fix Conduit_lwt.TCP protocol from the recv-first behavior of Lwt_io --- src/lwt/conduit_lwt.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index caba37e3..089b811c 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -222,7 +222,11 @@ module TCP = struct (if filled + len = 0 then `End_of_flow else `Input (filled + len))) in - Lwt.catch (fun () -> process 0 raw) @@ function + Lwt.catch (fun () -> + if not (Lwt_unix.readable t.socket) + then Lwt.return_ok (`Input 0) + else process 0 raw) + @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address From 5611ef7ce09f1862452fd3fb9b42ec48c4398fd6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 19:42:24 +0200 Subject: [PATCH 089/140] Emit the opportunity to re-schedule to the user --- src/tls/conduit_tls.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 5c37fa8b..43529f59 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -160,6 +160,7 @@ struct "Got EOF from underlying connection while \ handshake.") ; return (Ok None) + | `Input 0 -> return (Ok (Some tls)) | `Input len -> let uid = Hashtbl.hash @@ -223,6 +224,9 @@ struct m "<- Connection closed by underlying protocol.") ; t.tls <- None ; return (Ok `End_of_flow) + | `Input 0 -> + t.tls <- Some tls ; + return (Ok (`Input 0)) | `Input len -> ( Log.debug (fun m -> m "<- Got %d byte(s)." len) ; let handle raw = @@ -275,6 +279,9 @@ struct Log.warn (fun m -> m "[-] Underlying flow already closed.") ; t.tls <- None ; return (Error `Closed_by_peer) + | `Input 0 -> + t.tls <- Some tls ; + return (Ok 0) | `Input len -> ( let res = handle_handshake tls t.queue t.flow (Cstruct.sub t.raw 0 len) From c63d602621f3a1be35ddd15cb9625fedcb7c3ce9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 19:43:08 +0200 Subject: [PATCH 090/140] Really read first behavior or re-schedule on Conduit_lwt.TCP --- src/lwt/conduit_lwt.ml | 41 +++++++++++++++++++++++++++++++++++++---- 1 file changed, 37 insertions(+), 4 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 089b811c..a78c03cb 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -113,9 +113,29 @@ module TCP = struct socket : Lwt_unix.file_descr; sockaddr : Lwt_unix.sockaddr; linger : Bytes.t; + recv_first : bool; mutable closed : bool; } + (* XXX(dinosaure): [recv_first] is here to fit into [Lwt_io], from what we know, + * a tuple of [Lwt_io] [in_channel/out_channel] tries to receive first. However, + * such behavior is problematic for HTTP: + * - as a HTTP client, we should send first + * - as a HTTP server, we should recv first + * - with TLS layer [conduit-tls], both work - where + * the handshake can be done by send or recv + * + * For my perspective, [Lwt_io] is not the right way to abstract a [Conduit.flow] + * and we should directly use [Conduit.send]/[Conduit.recv] when we need to use + * them. Because [Lwt_io] tries to receive in any case, we must check (with [Lwt_unix.readable]) + * if the socket can be read. In that case and if we want to [recv_first], we start + * to waiting something from our peer. In the other case, we returns [`Input 0] + * which gives an opportunity for the scheduler to send something (so, [send_first]). + * + * Such patch is really close to what LWT/[Lwt_io] does. A problem should be a diff + * on behaviors between [Conduit_lwt] and [mirage-tcpip] + [Conduit_mirage]. The best + * way to delete it is to deprecate [io_of_flow]. *) + let peer { sockaddr; _ } = sockaddr let sock { socket; _ } = Lwt_unix.getsockname socket @@ -163,7 +183,14 @@ module TCP = struct let rec go () = let process () = Lwt_unix.connect socket sockaddr >>= fun () -> - Lwt.return_ok { socket; sockaddr; linger; closed = false } in + Lwt.return_ok + { + socket; + sockaddr; + linger; + closed = false; + recv_first = Lwt_unix.readable socket; + } in Lwt.catch process @@ function | Unix.(Unix_error ((EACCES | EPERM), _, _)) -> Lwt.return_error `Operation_not_permitted @@ -223,7 +250,7 @@ module TCP = struct then `End_of_flow else `Input (filled + len))) in Lwt.catch (fun () -> - if not (Lwt_unix.readable t.socket) + if (not (Lwt_unix.readable t.socket)) && not t.recv_first then Lwt.return_ok (`Input 0) else process 0 raw) @@ function @@ -385,8 +412,14 @@ module TCP = struct let process () = Lwt_unix.accept service >>= fun (socket, sockaddr) -> let linger = Bytes.create 0x1000 in - Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } - in + Lwt.return_ok + { + Protocol.socket; + sockaddr; + linger; + closed = false; + recv_first = Lwt_unix.readable socket; + } in Lwt.catch process @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept service | Unix.(Unix_error (EINTR, _, _)) -> accept service From bcd85b5c046c4c0ea3fae3be3c031eefa50517cc Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 19:43:42 +0200 Subject: [PATCH 091/140] Add yield on IO impl. needed to re-scheduler when we get `Input 0/0 (recv/send) --- tests/ping-pong/common.ml | 26 +++++++++++++++++++++----- tests/ping-pong/with_async.ml | 2 ++ tests/ping-pong/with_lwt.ml | 26 ++++++++++++++++++++++++++ 3 files changed, 49 insertions(+), 5 deletions(-) diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index 7f6136e8..d3c8b058 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -15,10 +15,16 @@ module type CONDITION = sig type 'a t end +module type IO = sig + include Conduit.IO + + val yield : unit -> unit t +end + let ( <.> ) f g x = f (g x) module Make - (IO : Conduit.IO) + (IO : IO) (Condition : CONDITION) (Conduit : S with type +'a io = 'a IO.t @@ -67,6 +73,7 @@ struct | None -> ( Conduit.recv flow tmp >>? function | `End_of_flow -> IO.return (Ok `Close) + | `Input 0 -> IO.yield () >>= go | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; go ()) in @@ -76,6 +83,15 @@ struct let ping = Cstruct.of_string "ping\n" + let send flow raw = + let rec go flow raw = + Conduit.send flow raw >>? function + | 0 -> IO.yield () >>= fun () -> go flow raw + | len -> + let raw = Cstruct.shift raw len in + if Cstruct.len raw = 0 then return (Ok ()) else go flow raw in + go flow raw + let transmission flow = let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in let rec go () = @@ -83,13 +99,13 @@ struct | Ok `Close | Error _ -> Conduit.close flow | Ok (`Line "ping") -> Fmt.epr "[!] received ping.\n%!" ; - Conduit.send flow pong >>? fun _ -> go () + send flow pong >>? go | Ok (`Line "pong") -> Fmt.epr "[!] received pong.\n%!" ; - Conduit.send flow ping >>? fun _ -> go () + send flow ping >>? go | Ok (`Line line) -> Fmt.epr "[!] received %S.\n%!" line ; - Conduit.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + send flow (Cstruct.of_string (line ^ "\n")) >>? fun () -> Conduit.close flow in go () >>= function | Error err -> Fmt.failwith "%a" Conduit.pp_error err @@ -114,7 +130,7 @@ struct let rec go = function | [] -> Conduit.close flow | line :: rest -> ( - Conduit.send flow (Cstruct.of_string (line ^ "\n")) >>? fun _ -> + send flow (Cstruct.of_string (line ^ "\n")) >>? fun () -> getline queue flow >>? function | `Close -> Conduit.close flow | `Line "pong" -> go rest diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index 323f24e1..a7d400aa 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -11,6 +11,8 @@ include Common.Make let bind x f = Async.Deferred.bind x ~f let return = Async.Deferred.return + + let yield () = Async.Deferred.return () end) (Async.Condition) (struct diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 1425e723..307ea62e 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -6,8 +6,34 @@ let () = Printexc.record_backtrace true let () = Ssl.init () +let reporter ppf = + let report src level ~over k msgf = + let k _ = + over () ; + k () in + let with_metadata header _tags k ppf fmt = + Format.kfprintf k ppf + ("%a[%a]: " ^^ fmt ^^ "\n%!") + Logs_fmt.pp_header (level, header) + Fmt.(styled `Magenta string) + (Logs.Src.name src) in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + { Logs.report } + +let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () + +let () = Logs.set_reporter (reporter Fmt.stderr) + +let () = Logs.set_level ~all:true (Some Logs.Debug) + let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt +module Lwt = struct + include Lwt + + let yield = Lwt_unix.yield +end + include Common.Make (Lwt) (Lwt_condition) (struct type 'a condition = 'a Lwt_condition.t From ad1bc31c9e86cbdd37f180a4b189d87be4133a20 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 19:45:44 +0200 Subject: [PATCH 092/140] Re-schedule when we got 0 when we tried to send something --- src/lwt/conduit_lwt.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index a78c03cb..a3168db7 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -38,12 +38,13 @@ let io_of_flow flow = | Ok `End_of_flow -> Lwt.return 0 | Error err -> failwith "%a" pp_error err in let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input rrecv in - let send buf off len = + let rec ssend buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in Lwt_mutex.with_lock mutex (fun () -> send flow raw) >>= function + | Ok 0 -> Lwt_unix.yield () >>= fun () -> ssend buf off len | Ok len -> Lwt.return len | Error err -> failwith "%a" pp_error err in - let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output send in + let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output ssend in (ic, oc) let ( >>? ) = Lwt_result.bind From a915c61c205b71cb69414e8e51ed7e3ec6d44cff Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:17:24 +0200 Subject: [PATCH 093/140] Delete recv_first and check Lwt_unix.readable to re-schedule or not the upper process --- src/lwt/conduit_lwt.ml | 80 ++++++++++++++---------------------------- 1 file changed, 26 insertions(+), 54 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index a3168db7..cd8f629a 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -33,7 +33,10 @@ let io_of_flow flow = let rec rrecv buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in Lwt_mutex.with_lock mutex (fun () -> recv flow raw) >>= function - | Ok (`Input 0) -> Lwt_unix.yield () >>= fun () -> rrecv buf off len + | Ok (`Input 0) -> + if len = 0 + then Lwt.return 0 + else Lwt_unix.yield () >>= fun () -> rrecv buf off len | Ok (`Input len) -> Lwt.return len | Ok `End_of_flow -> Lwt.return 0 | Error err -> failwith "%a" pp_error err in @@ -41,7 +44,10 @@ let io_of_flow flow = let rec ssend buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in Lwt_mutex.with_lock mutex (fun () -> send flow raw) >>= function - | Ok 0 -> Lwt_unix.yield () >>= fun () -> ssend buf off len + | Ok 0 -> + if len = 0 + then Lwt.return 0 + else Lwt_unix.yield () >>= fun () -> ssend buf off len | Ok len -> Lwt.return len | Error err -> failwith "%a" pp_error err in let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output ssend in @@ -114,29 +120,9 @@ module TCP = struct socket : Lwt_unix.file_descr; sockaddr : Lwt_unix.sockaddr; linger : Bytes.t; - recv_first : bool; mutable closed : bool; } - (* XXX(dinosaure): [recv_first] is here to fit into [Lwt_io], from what we know, - * a tuple of [Lwt_io] [in_channel/out_channel] tries to receive first. However, - * such behavior is problematic for HTTP: - * - as a HTTP client, we should send first - * - as a HTTP server, we should recv first - * - with TLS layer [conduit-tls], both work - where - * the handshake can be done by send or recv - * - * For my perspective, [Lwt_io] is not the right way to abstract a [Conduit.flow] - * and we should directly use [Conduit.send]/[Conduit.recv] when we need to use - * them. Because [Lwt_io] tries to receive in any case, we must check (with [Lwt_unix.readable]) - * if the socket can be read. In that case and if we want to [recv_first], we start - * to waiting something from our peer. In the other case, we returns [`Input 0] - * which gives an opportunity for the scheduler to send something (so, [send_first]). - * - * Such patch is really close to what LWT/[Lwt_io] does. A problem should be a diff - * on behaviors between [Conduit_lwt] and [mirage-tcpip] + [Conduit_mirage]. The best - * way to delete it is to deprecate [io_of_flow]. *) - let peer { sockaddr; _ } = sockaddr let sock { socket; _ } = Lwt_unix.getsockname socket @@ -184,14 +170,7 @@ module TCP = struct let rec go () = let process () = Lwt_unix.connect socket sockaddr >>= fun () -> - Lwt.return_ok - { - socket; - sockaddr; - linger; - closed = false; - recv_first = Lwt_unix.readable socket; - } in + Lwt.return_ok { socket; sockaddr; linger; closed = false } in Lwt.catch process @@ function | Unix.(Unix_error ((EACCES | EPERM), _, _)) -> Lwt.return_error `Operation_not_permitted @@ -251,9 +230,9 @@ module TCP = struct then `End_of_flow else `Input (filled + len))) in Lwt.catch (fun () -> - if (not (Lwt_unix.readable t.socket)) && not t.recv_first - then Lwt.return_ok (`Input 0) - else process 0 raw) + if Lwt_unix.readable t.socket + then process 0 raw + else Lwt.return_ok (`Input 0)) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw @@ -273,19 +252,18 @@ module TCP = struct if closed then Lwt.return_error `Closed_by_peer else - let max = Cstruct.len raw in - let len0 = min (Bytes.length t.linger) max in - Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; - let process () = - Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> - if len1 = len0 - then - if max > len0 - then send t (Cstruct.shift raw len0) - else Lwt.return_ok max - else Lwt.return_ok len1 - (* worst case *) in - Lwt.catch process @@ function + let rec process pushed raw = + if Cstruct.len raw = 0 + then Lwt.return_ok pushed + else + let max = Cstruct.len raw in + let len0 = min (Bytes.length t.linger) max in + Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; + Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> + if len1 = len0 && len0 = max + then Lwt.return_ok (pushed + len1) + else process (pushed + len1) (Cstruct.shift raw len1) in + Lwt.catch (fun () -> process 0 raw) @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> send t raw | Unix.(Unix_error (EINTR, _, _)) -> send t raw | Unix.(Unix_error (EACCES, _, _)) -> @@ -413,14 +391,8 @@ module TCP = struct let process () = Lwt_unix.accept service >>= fun (socket, sockaddr) -> let linger = Bytes.create 0x1000 in - Lwt.return_ok - { - Protocol.socket; - sockaddr; - linger; - closed = false; - recv_first = Lwt_unix.readable socket; - } in + Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } + in Lwt.catch process @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> accept service | Unix.(Unix_error (EINTR, _, _)) -> accept service From 82da075e43317449e298f5cbd777f5645b92a41b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:18:44 +0200 Subject: [PATCH 094/140] Some useful logs about conduit-tls --- src/tls/conduit_tls.ml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 43529f59..0a335a92 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -160,12 +160,15 @@ struct "Got EOF from underlying connection while \ handshake.") ; return (Ok None) - | `Input 0 -> return (Ok (Some tls)) + | `Input 0 -> + Log.debug (fun m -> + m "Underlying connection asks to re-schedule.") ; + return (Ok (Some tls)) | `Input len -> - let uid = - Hashtbl.hash - (Cstruct.to_string (Cstruct.sub raw0 0 len)) in Log.debug (fun m -> + let uid = + Hashtbl.hash + (Cstruct.to_string (Cstruct.sub raw0 0 len)) in m "<~ [%04x] Got %d bytes (handshake in progress: \ true)." @@ -225,7 +228,7 @@ struct t.tls <- None ; return (Ok `End_of_flow) | `Input 0 -> - t.tls <- Some tls ; + Log.debug (fun m -> m "We must re-schedule, nothing to read.") ; return (Ok (`Input 0)) | `Input len -> ( Log.debug (fun m -> m "<- Got %d byte(s)." len) ; @@ -262,7 +265,7 @@ struct return (Ok (`Input len)) let rec send t raw = - Log.debug (fun m -> m "~> Start to send.") ; + Log.debug (fun m -> m "~> Start to send %d bytes." (Cstruct.len raw)) ; match t.tls with | None -> return (Error `Closed_by_peer) | Some tls when Tls.Engine.can_handle_appdata tls -> ( @@ -276,11 +279,11 @@ struct | Some tls -> ( Flow.recv t.flow t.raw >>| reword_error flow_error >>? function | `End_of_flow -> - Log.warn (fun m -> m "[-] Underlying flow already closed.") ; + Log.debug (fun m -> m "[-] Underlying flow already closed.") ; t.tls <- None ; return (Error `Closed_by_peer) | `Input 0 -> - t.tls <- Some tls ; + Log.debug (fun m -> m "[-] Underlying flow re-schedule.") ; return (Ok 0) | `Input len -> ( let res = From 7ff1e0dc481403d471bdf4deae60cf4d1833427b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:19:26 +0200 Subject: [PATCH 095/140] Delete the re-scheduling on the TLS layer according the state of the handshake (not useful and error-prone) --- src/tls/conduit_tls.ml | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 0a335a92..44f9171a 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -230,13 +230,12 @@ struct | `Input 0 -> Log.debug (fun m -> m "We must re-schedule, nothing to read.") ; return (Ok (`Input 0)) - | `Input len -> ( + | `Input len -> Log.debug (fun m -> m "<- Got %d byte(s)." len) ; let handle raw = if Tls.Engine.handshake_in_progress tls then handle_handshake tls t.queue t.flow raw else handle_tls tls t.queue t.flow raw in - let before = Tls.Engine.handshake_in_progress tls in Log.debug (fun m -> let uid = Hashtbl.hash @@ -245,18 +244,8 @@ struct uid len (Tls.Engine.handshake_in_progress tls)) ; handle (Cstruct.sub t.raw 0 len) >>? fun tls -> - let after = - Option.fold ~none:false - ~some:Tls.Engine.handshake_in_progress tls in t.tls <- tls ; - match (tls, before, after) with - | Some _, false, false | Some _, true, false -> - return (Ok (`Input 0)) - | Some _, false, true (* renegociate *) - | Some _, true, true (* continue handshake *) - | None, _, _ -> - Log.debug (fun m -> m "Retry to receive something.") ; - recv t raw))) + recv t raw)) | _ -> let max = Cstruct.len raw in let len = min (Ke.length t.queue) max in From 857f1e0c536528c08550f705721ac9bebf33cfce Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:19:47 +0200 Subject: [PATCH 096/140] Delete logs on tests (too verbose) --- tests/ping-pong/with_lwt.ml | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 307ea62e..72172fb9 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -6,26 +6,6 @@ let () = Printexc.record_backtrace true let () = Ssl.init () -let reporter ppf = - let report src level ~over k msgf = - let k _ = - over () ; - k () in - let with_metadata header _tags k ppf fmt = - Format.kfprintf k ppf - ("%a[%a]: " ^^ fmt ^^ "\n%!") - Logs_fmt.pp_header (level, header) - Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in - { Logs.report } - -let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () - -let () = Logs.set_reporter (reporter Fmt.stderr) - -let () = Logs.set_level ~all:true (Some Logs.Debug) - let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt module Lwt = struct From a0e1e0b83ef5f0a28f46b18a4602a513342d168e Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:11:21 +0200 Subject: [PATCH 097/140] Add a way to destruct the flow to the Conduit_lwt_ssl Lwt_ssl.socket --- src/lwt-ssl/conduit_lwt_ssl.ml | 2 ++ src/lwt-ssl/conduit_lwt_ssl.mli | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index df41048f..2c011184 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -143,4 +143,6 @@ module TCP = struct let service = service_with_ssl service ~file_descr:Protocol.file_descr protocol + + include (val Conduit_lwt.repr protocol) end diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index 282545b2..18dfb1d1 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -97,4 +97,11 @@ module TCP : sig context:Ssl.context -> ?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 end From 82692fc6b64bfd1b98d1b2270e64dd455d4f17f1 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:25:55 +0200 Subject: [PATCH 098/140] Add documentation about [io_of_flow] --- src/lwt/conduit_lwt.mli | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 11048501..e421e11d 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -8,6 +8,16 @@ include val io_of_flow : flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel +(** [io_of_flow flow] creates an input flow and an output flow according + to [Lwt_io]. This function, even if it creates something more usable + is {b deprecated}. Indeed, [Lwt_io] has its own way to schedule [read] + and [write] - you should be aware about that more specially when you + use [Conduit_tls] or [Conduit_lwt_ssl]. + + Due to a specific behavior, [Lwt_io] does not fit with some specific + protocols - non thread-safe protocols, {i send-first} protocols, etc. + From these reasons, and even if {!TCP} try to the best to fit under + an [Lwt_io], you should not use this function. *) type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service (** The type for lwt services. *) From 331786d9485de6755a18fa94fda031a41216b6b3 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 14 Oct 2020 17:18:41 +0200 Subject: [PATCH 099/140] Minor fixes and add a paragraph about MirageOS --- src/core/howto.mld | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/core/howto.mld b/src/core/howto.mld index 2a2ef44e..d71a825d 100644 --- a/src/core/howto.mld +++ b/src/core/howto.mld @@ -16,8 +16,8 @@ val getline : Conduit_lwt.flow -> ]} As the POSIX [getline] (see [man 3 getline]). The ping-pong client sends a line -to a ping-pong server if it receives then ["pong"], it continues to talk until -it has nothing to send. Otherwise, it closes. +to a ping-pong server and, if it receives then ["pong"], it continues to talk +until it has nothing to send. Otherwise, it closes the connection. {[ let client ~resolvers edn = @@ -28,8 +28,8 @@ let client ~resolvers edn = Format.printf "> %s.\n%!" line ; getline flow >>? function | `Line "pong" -> Format.printf "< pong.\n%!" ; go () - | `Line line -> Format.printf "< %s.\n%!" ; go () - | `End_of_flow -> Conduit_lwt.flow flow ) + | `Line line -> Format.printf "< %s.\n%!" ; Conduit_lwt.close flow + | `End_of_flow -> Conduit_lwt.close flow ) | exception End_of_file -> Conduit_lwt.close flow in go () ]} @@ -266,7 +266,7 @@ Above, we can see that for the default case (when we don't have a scheme), we {i inject} two protocols, the secure one (with a priority) and the unsecure one. [Conduit] will try the secure one and if it fails, it fallbacks to the second one. This case can appear when you want to communicate with a peer and you have -multiple possibilies such as [http] and [htps]. +multiple possibilies such as [http] and [https]. {3 Compilation & run.} @@ -297,4 +297,22 @@ long as the code-base use [Conduit]. Of course, the end-user (our [fiber] functions) must be updated according new protocols but it does not imply any change on the logic of the server and the -logic of the client: this is the goal of [Conduit]! \ No newline at end of file +logic of the client: this is the goal of [Conduit]! + +{2 MirageOS compatibility.} + +For MirageOS, it's hard to abstract the entire stack with {i functors} to be +able to launch a simple HTTP request - and it's even more difficult with a +(non-required) cryptographic layered protocol such as TLS. [Conduit] should help +users and protocol implementers to be compatible with MirageOS. + +As you can see, [Conduit] is not mandatory at the logic of your protocol and you +are able to {i functorize} this part with something close to {!Conduit.S} (as +[cohttp] does). The application of your {i functor} with [Conduit] lets the user +to orchestrate your implementation with others protocols (such as +[mirage-tcpip]) without anothers {i functors}. + +Of course, [Conduit] is not only about MirageOS when the question of the +abstraction can appear for anyone: which TLS implementation should I use? Should +I enforce one of them? Again, it's about abstraction and [Conduit] is a response +about that more generally. From 4cd8090acd2c3a4738103c7ccef8797293ec954f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 15 Oct 2020 11:59:01 +0200 Subject: [PATCH 100/140] Minor fixes about documentation --- src/async-ssl/conduit_async_ssl.mli | 4 ++++ src/async-tls/conduit_async_tls.mli | 4 ++++ src/async/conduit_async.mli | 14 ++++++++++++++ src/lwt-ssl/conduit_lwt_ssl.mli | 16 +++++++--------- src/lwt-tls/conduit_lwt_tls.mli | 6 +++--- src/lwt/conduit_lwt.mli | 9 +-------- src/mirage/conduit_lwt_flow.mli | 2 +- src/mirage/conduit_mirage_dns.mli | 3 +++ src/tls/conduit_tls.mli | 7 ++++++- 9 files changed, 43 insertions(+), 22 deletions(-) diff --git a/src/async-ssl/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli index d6867818..dbed373b 100644 --- a/src/async-ssl/conduit_async_ssl.mli +++ b/src/async-ssl/conduit_async_ssl.mli @@ -1,3 +1,5 @@ +(** SSL layer with Conduit and Async. *) + open Async open Async_ssl open Conduit_async @@ -54,6 +56,8 @@ val service_with_ssl : ('edn, 'flow with_ssl) protocol -> (context * 'cfg, context * 't, 'flow with_ssl) Service.service +(** {2 Composition between Host's TCP/IP stack protocol and SSL.} *) + module TCP : sig open Conduit_async.TCP diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index fd5dcc77..fa752572 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -1,3 +1,5 @@ +(** TLS layer with Conduit and Async. *) + open Conduit_async type 'flow protocol_with_tls @@ -20,6 +22,8 @@ val service_with_tls : 'flow protocol_with_tls ) Service.service +(** {2 Composition between Host's TCP/IP stack protocol and TLS.} *) + module TCP : sig open Conduit_async.TCP diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index c05af020..56726b54 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -19,10 +19,24 @@ val serve : service:('cfg, 'master, 'flow) service -> 'cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) +(** [serve ~handler ~service cfg] creates an usual infinite [service] + loop from the given configuration ['cfg]. It returns the {i promise} + to launch the loop and a condition variable to stop the loop. + + {[ + let stop, loop = serve + ~handler ~service:TCP.service cfg in + Async_unix.Signal.handle [ Core.Signal.int ] + ~f:(fun _sig -> Async.Condition.broadcast stop ()) ; + loop () + ]} +*) val reader_and_writer_of_flow : flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t +(** {2 Host's TCP/IP stack protocol with Async.} *) + module TCP : sig type endpoint = | Inet of Socket.Address.Inet.t diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index 18dfb1d1..f2ad0922 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -1,17 +1,14 @@ (** Implementation of the SSL support (according [Lwt_ssl]) with - [conduit-lwt-unix]. + [conduit-lwt]. This implementation assumes that underlying protocol used to compose with - SSL must deliver a [Lwt_unix.file_descr] - such as [Conduit_lwt_unix_tcp]. + SSL must deliver a [Lwt_unix.file_descr] - such as [Conduit_lwt.TCP]. From that, we are able to compose your protocol with [Lwt_ssl] such as: {[ - let ssl_endpoint, ssl_protocol = - protocol_with_ssl ~key:TCP.endpoint TCP.protocol - - let ssl_configuration, ssl_service = - service_with_ssl ~key:TCP.configuration TCP.service - ~file_descr:TCP.file_descr ssl_protocol + let ssl_protocol = protocol_with_ssl TCP.protocol + let ssl_service = service_with_ssl TCP.service + ~file_descr:TCP.file_descr ssl_protocol ]} Then, TCP + SSL is available as any others [conduit] protocols or services @@ -25,7 +22,8 @@ {b NOTE}: [verify] is called after a call to [flow] (which should do the [connect] call). So, nothing was exchanged between you and your peer at this - time - even the handshake. *) + time - even the handshake. It permits to fill the SSL socket with some + information such as the hostname of the peer with [Ssl.set_client_SNI_hostname]. *) open Conduit_lwt diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 5cefa735..56a21c78 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -1,9 +1,9 @@ (** Implementation of the TLS support (according [ocaml-tls]) with - [conduit-lwt-unix]. + [conduit-lwt]. This implementation is a {i specialization} of [conduit-tls] with - [conduit-lwt-unix]. Underlying protocol or service can be anything into the - scope of [conduit-lwt]/[conduit-lwt-unix]. + [conduit-lwt]. Underlying protocol or service can be anything into the + scope of [conduit-lwt]. For more details about behaviours, you should look into [conduit-tls]. *) diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index e421e11d..5a106b1b 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -39,19 +39,12 @@ val serve : (Lwt_unix.sleep 10. >>= fun () -> Lwt_condition.broadcast stop () ; Lwt.return ()) - loop + (loop ()) ]} In your example, we want to launch a server only for 10 seconds. To help the user, the option [?timeout] allows us to wait less than [timeout] seconds. *) -(** Common interface to properly expose a protocol. - - If a protocol wants to be fully-compatible with [conduit], - it should expose such implementation which is an aggregate - of {i types witnesses}. -*) - module TCP : sig (** Implementation of TCP protocol as a client. diff --git a/src/mirage/conduit_lwt_flow.mli b/src/mirage/conduit_lwt_flow.mli index f9714023..be564f6a 100644 --- a/src/mirage/conduit_lwt_flow.mli +++ b/src/mirage/conduit_lwt_flow.mli @@ -1,5 +1,5 @@ (** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. - This module is deprecated when the current implementation of [read] has + This module is {b deprecated} when the current implementation of [read] has another behaviour: [conduit] provides: diff --git a/src/mirage/conduit_mirage_dns.mli b/src/mirage/conduit_mirage_dns.mli index acbbd1b4..73246255 100644 --- a/src/mirage/conduit_mirage_dns.mli +++ b/src/mirage/conduit_mirage_dns.mli @@ -1,3 +1,6 @@ +(** MirageOS-functor to be able to resolve a domain-name + such as [gethostbyname] with [ocaml-dns]. *) + module Make (R : Mirage_random.S) (T : Mirage_time.S) diff --git a/src/tls/conduit_tls.mli b/src/tls/conduit_tls.mli index 6ee9bb7a..10959659 100644 --- a/src/tls/conduit_tls.mli +++ b/src/tls/conduit_tls.mli @@ -35,7 +35,12 @@ A solution such as a {i mutex} to ensure the exclusivity between [send] and [recv] can be used - it does not exists at this layer where such abstraction - is not available. *) + is not available. + + This design appear when you use [LWT] or [ASYNC] which can do a concurrence + between {i promises}. Without such {i scheduler}, the process is sequential + and the OCaml {i scheduler} should not re-order sub-processes of + [Conduit.send] and [Conduit.recv]. *) module Make (IO : Conduit.IO) From 850d19bf7e201125951c269148b448857ebcd37f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 15 Oct 2020 16:48:52 +0200 Subject: [PATCH 101/140] Update the README.md --- README.md | 58 ++++++++++++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index d258d815..dcbce637 100644 --- a/README.md +++ b/README.md @@ -1,37 +1,47 @@ -## conduit -- an OCaml network connection establishment library +## Conduit - a framework to abstract the protocol -[![Build Status](https://travis-ci.org/mirage/ocaml-conduit.svg?branch=master)](https://travis-ci.org/mirage/ocaml-conduit) +The `conduit` library is a simple framework to abstract a _protocol_. It +permits, for a protocol implementer, to get rid the responsibility of the +protocols choice (such as the TLS implementation). So, it provides a degree of +abstraction from precise protocol (like TLS or TCP/IP) libraries used - since +there are a variety of them. -The `conduit` library takes care of establishing and listening for -TCP and SSL/TLS connections for the Lwt and Async libraries. +### Documentation & Tutorials -The reason this library exists is to provide a degree of abstraction -from the precise SSL library used, since there are a variety of ways -to bind to a library (e.g. the C FFI, or the Ctypes library), as well -as well as which library is used (just OpenSSL for now). +The documentation is available [here][doc]. -By default, OpenSSL is used as the preferred connection library, but -you can force the use of the pure OCaml TLS stack by setting the -environment variable `CONDUIT_TLS=native` when starting your program. +A simple HOW-TO to describe how to implement a ping-pong server/client and how +to upgrade them with TLS is available [here][howto] -The opam packages available are: +A more complete (but less easier to understand) document to describe Conduit is +available [here][readme]. -- `conduit`: the main `Conduit` module -- `conduit-lwt`: the portable Lwt implementation -- `conduit-lwt-unix`: the Lwt/Unix implementation -- `conduit-async` the Jane Street Async implementation -- `conduit-mirage`: the MirageOS compatible implementation +### Distribution -### Debugging - -Some of the `Lwt_unix`-based modules use a non-empty `CONDUIT_DEBUG` -environment variable to output debugging information to standard error. -Just set this variable when running the program to see what URIs -are being resolved to. +Conduit comes with several packages: +- `conduit`: the core library which has only 3 dependencies +- `conduit-tls`: a Conduit-compatible [ocaml-tls][ocaml-tls] implementation +- `conduit-lwt`: the library with [lwt][lwt], it provides a Conduit-compatible + Host's TCP/IP protocol +- `conduit-async`: the library with [async][async], it provides a + Conduit-compatible Host's TCP/IP protocol +- `conduit-lwt-{ssl,tls}` provides the Host's TCP/IP protocol with SSL (OpenSSL) + and TLS (`ocaml-tls`) +- `conduit-async-{ssl,tls}` provides the Host's TCP/IP protocol with SSL + (OpenSSL) and TLS (`ocaml-tls`) +- `conduit-mirage` a Conduit-compatible [mirage-tcpip][mirage-tcpip] protocol ### Further Informartion -* **API Docs:** http://docs.mirage.io/ +* **API Docs:** http://mirage.github.io/ocaml-conduit/ * **WWW:** https://github.com/mirage/ocaml-conduit * **E-mail:** * **Bugs:** https://github.com/mirage/ocaml-conduit/issues + +[doc]: https://mirage.github.io/ocaml-conduit/conduit/index.html +[howto]: https://mirage.github.io/ocaml-conduit/conduit/howto.html +[readme]: https://mirage.github.io/ocaml-conduit/conduit/readme.html +[ocaml-tls]: https://github.com/mirleft/ocaml-tls +[lwt]: https://github.com/ocsigen/lwt +[async]: https://github.com/janestreet/async +[mirage-tcpip]: https://github.com/mirage/mirage-tcpip From 9f4664990ca0d608c5698ea28d264f04e05907ad Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 15 Oct 2020 17:46:00 +0200 Subject: [PATCH 102/140] The readme.mld is less detailed and more comprehensible than before --- src/core/readme.mld | 807 +++++++------------------------------------- 1 file changed, 124 insertions(+), 683 deletions(-) diff --git a/src/core/readme.mld b/src/core/readme.mld index 04acbefe..84d6089e 100644 --- a/src/core/readme.mld +++ b/src/core/readme.mld @@ -1,762 +1,203 @@ -{1 Conduit - defunctorize protocols.} +{1 Conduit.} -[Conduit] is a library which wants to be used into multiple perspectives: -{ul -{- As a protocol implementer.} -{- As a simple end-user who wants to use a protocol.} -{- As a library implementer who wants to {i delay} the choice of protocols.}} - -In this document, we will explain step by step these perspectives to understand -the purpose of [Conduit]. More globally the {b first} goal of [Conduit] is to {i -de-functorize} (it wants to give you an other way than the _functorization_) an -implementation which requires a protocol to be able to communicate with a peer. -The {b second} goal of [Conduit] is to let the user to construct the {i -dispatch} of protocols from a well-known (or partially-known) context (it is -like an injection of a specific implementation into [Conduit] - or more -concretely, an application of your {i de-functorized} implementation with a -specific protocol implementation). - -{2 Abstract a {i protocol}.} - -{3 Definition of a {i protocol}.} - -[Conduit] has a strong definition of a {!Conduit.S.PROTOCOL}. A protocol is a -system that allows entities to transmit {i payloads}. These entities do not -have to care about the underlying transport mechanism. flows simply deal -with routing and delivering of these payloads. That abstraction allows -these protocols to compose. - -For example, the Transmission Control Protocol (TCP) is representable as a -flow, because it is able to encapsulate some {i payloads} without -interpreting it. A counter-example is the Simple Mail Transfer Protocol -(SMTP) which needs an interpretation of its {i payloads}: tokens such as -[EHLO] or [QUIT] have a direct incidence over the life-cycle of the -connection. - -An other protocol representable as a flow is the Transport Layer Security -(TLS), as it deals only with privacy and data integrity. [Conduit] is able -to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level -protocols can be built in top of these abstract flows: for instance, Secure -Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure -(HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these -can be abstracted to work over any flow implementations. - -{3 Concrete implementation.} - -Let's start to implement a TCP/IP protocol with UNIX. At first, [Conduit] needs -a {i scheduler} and the type of [input]/[output]. [Conduit_lwt] is a -specialisation of [Conduit] with LWT and {!Cstruct.t} as input/output. It is -the same for [Conduit_async] with ASYNC. - -For our example (and to simplify our code), we will specialise [Conduit] with -UNIX, [bytes] as input and [string] as output. +Conduit is a little library to be able to abtract the protocol used to +communicate with a peer. + +{2 Implement a protocol.} + +A Conduit's protocol can be defined as: {[ -module Scheduler = struct - type 'a t = 'a +module type S = sig + type flow + type endpoint - let return x = x - let bind x f = f x -end + type error + + val pp_error : error Fmt.t -module Conduit = Conduit.Make(Scheduler)(Bytes)(String) + val connect : endpoint -> (flow, error) result + val send : flow -> string -> (int, error) result + val recv : flow -> bytes -> (int, error) result + val close : flow -> (unit, error) result +end ]} -Then, we can start to implement our TCP/IP protocol from what [Unix] gives to us -— of course, this code require the [unix.cm{x}a] library: +This definition is pretty-close to the [Unix] module: {[ module TCP = struct - type 'a io = 'a - - type input = bytes and output = string - type flow = Unix.file_descr - type endpoint = Unix.sockaddr - type error = | + type error = (Unix.error * string * string) - let pp_error : Format.formatter -> error -> unit = fun _ -> function _ -> . + let pp_error (error, call, _) = + Fmt.pf ppf "%s: %s" call (Unix.error_message error) let connect sockaddr = - let domain = Unix.domain_of_sockaddr sockaddr in - let socket = Unix.socket domain Unix.SOCK_STREAM 0 in - Unix.connect socket sockaddr ; Ok socket - - let recv socket buf = - let off = 0 and len = Bytes.length buf in - let len' = Unix.read socket buf off len in - if len' = 0 then Ok `End_of_flow - else Ok (`Input len') + try let socket = Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in + Unix.connect socket sockaddr ; Ok socket + with Unix.Unix_error (err, call, args) -> Error (err, call, args) let send socket str = - let off = 0 and len = String.length str in - let buf = Bytes.unsafe_of_string str in - let rec go off len = - let len' = Unix.write socket buf off len in - if len' < len then go (off + len') (len - len') in - go off len ; Ok len - - let close socket = Unix.close socket ; Ok () -end -]} - -The code is really simple and it does not care about details such as [exception] -— so, don't try to use this code into a productive context! We can verify that our -implementation respects the interface {!Conduit.S.PROTOCOL}: + try + let rec go off len = + let len' = Unix.write_substring socket str off len in + if len' < len then go (off + len') (len - len') in + go 0 (String.length str) ; Ok (String.length str) + with Unix.Unix_error (err, call, args) -> Error (err, call, args) -{[ -module TCP : Conduit.PROTOCOL - with type flow = Unix.file_descr - and type endpoint = Unix.sockaddr - and type 'a io = 'a - and type input = bytes - and type output = string -= struct - ... + let recv socket buf = + try + let len = Unix.read socket 0 (Bytes.length buf) in + if len = 0 then Ok `End_of_flow else Ok (`Input len) + with Unix.Unix_error (err, call, args) -> Error (err, call, args) + + let close socket = + try Unix.close socket ; Ok () + with Unix.Unix_error (err, call, args) -> Error (err, call, args) end ]} -By this way, we ensure the possibility to register it with [Conduit]: - -{[ -let tcp - : (Unix.sockaddr, Unix.file_descr) Conduit.protocol - = Conduit.register ~protocol:(module TCP) -]} - -So we create our first [Conduit] protocol! As you can see, [Conduit] keeps some -useful information such as: -{ul -{- the type of the endpoint required to initiate the protocol.} -{- the type of the flow.}} - -These informations is important for [Conduit] because: -{ul -{- it permits the user to pass its own typed value to initiate a protocol.} -{- it permits the user to {i destruct} the {!Conduit.S.flow} to the underlying - typed value.}} - -The protocol can be used with [Conduit] now! From the point of view of the -protocol implementer, the cost to be [Conduit]-compatible is worth as long as we -respect {!Conduit.S.PROTOCOL} (and our definition). - -Of course, in our example, we took the most understandable protocol, the TCP/IP -protocol. But [Conduit] is usable with anything! [endpoint] and [flow] are still -under the control of the implementer. For example, a SSH protocol requires -something more complex such as a private RSA key - in that case, you still are -able to register it with [Conduit]. - -{2 The [Conduit] protocol.} - -[Conduit] has 2 ways to initiate a connection: -{ul -{- When we have a full-knowledge of which protocols are available.} -{- When we don't any clue about protocol implementation.}} - -The first case is the most common case where we want to make a simple -executable. However, the second case can appear when we want to make a library! -A library which wants to communicate with a peer should {b not} assert one and -unique implementation of TCP/IP — and, with MirageOS, it's impossible to do that -when the TCP/IP implementation can be the UNIX one or [mirage-tcpip]. - -But let's start with the first case, when we want to make an executable: - -{[ -let ( >>= ) = Result.bind - -let run () = - let open Result in - Conduit.connect Unix.(ADDR_INET (inet_addr_loopback, 4242)) tcp >>= fun flow -> - Conduit.send flow "Hello World!" >>= fun _ -> - Conduit.close flow - -let () = match run () with - | Ok () -> () - | Error err -> Format.eprintf "%a" Conduit.pp_error err -]} - -We use the power of the type system to ensure that if we want to start a [tcp : -(Unix.sockaddr, Unix.file_descr) Conduit.protocol], we must initiate it with a -[Unix.sockaddr]. To compile and execute it (with 2 shells): - -{v -$1> ocamlfind opt -linkpkg -package conduit,unix,result main.ml -$2> nc -l localhost 4242 -$1> ./a.out -$2> Hello World! -v} - -This is the most simple case mostly because we fullu-know our context — our -dependencies, our target (UNIX), etc. Such context can not be well-known and, -for a MirageOS library — or any system agnostic libraries, we must be abstract -over these protocols. - -{3 Destruct your [flow].} - -[Conduit] lets the possibility to {i destruct} the {!Conduit.S.flow}. It mostly -means that from the {i abstract} value [flow], you can get the underlying -[Unix.file_descr] in our context. Of course, you need to know that the [flow] {b -can} be an [Unix.file_descr]. Come back as the protocol implementer, you must -expose {i the extension} of the type {!Conduit.S.flow} to be able to {i -destruct} it then: - -{[ -let tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocl = ... -include (val Conduit.repr tcp) -]} - -The last line expands to: - -{[ -type t = (Unix.sockaddr, Unix.file_descr) Conduit.value (* = Value of Unix.file_descr *) -type Conduit.flow += T of t -]} - -With this definition, we are able to {i pattern-match} on our {!Conduit.S.flow}: - -{[ -let run () = - let open Result in - Conduit.connect Unix.(ADDR_INET (inet_addr_loopback, 4242)) tcp >>= function - | T (Value socket) -> - let oc = Unix.out_channel_of_descr socket in - let ppf = Format.formatter_of_out_channel oc in - Format.fprintf ppf "Hello World (from %d)!" (Unix.getpid ()) ; - Unix.close socket ; Ok () - | _ -> - Conduit.send flow "Hello World!" >>= fun _ -> - Conduit.close flow -]} - -In this example, we separate the computation in two branches: -{ul -{- When we ensure that the given flow comes from our TCP/IP implementation.} -{- When we don't know - and keep it as an {i abstract} value.}} - -It permits to do something special (like [Unix.setsockopt]) when we {b -well-known} the protocol. Of course, it's not possible to {i destruct} a [flow] -if you don't know about any protocol implementation used - and it can be the -case when you make a library again. - -{4 The usage of the destruction.} +This is an example of how to implement the TCP protocol according the Conduit's +interface {!Conduit.S.PROTOCOL}. We concretely define the flow as an +[Unix.file_descr] and the endpoint (the value required to create the flow) as an +[Unix.sockaddr]. -Some libraries permits to manipule the flow even if they processed on it. This -case appear for example for an HTTP library when it reads and writes into the -{!Conduit.S.flow} and gives it to the end-user then into the the user-defined {i -handler}: +Now, the protocol must be registered into [Conduit] with: {[ -val http_serve : handler:(Conduit.flow -> Request.t -> Response.t) -> http_cfg -> unit -]} - -In that case, the library wants to manipulate an {i abstract} flow (and let the -user to do the {i injection} of a TCP/IP protocol or a TCP/IP + TLS protocol). -However, we should let the user to be able to {i destruct} the value to the -[Unix.file_descr] (according to our example). - -At this stage, the user will use [http_serve], he will define [handler] and he -has a full knowledge of his context (and which protocol implementation he wants -to use). With these 3 conditions, he is able to properly {i destruct} the given -flow and introspect it (like to know who is the client with [Unix.getpeername]). - -{3 When you make a library.} - -This is one of the real case of [Conduit]. As a library implementer such as an -HTTP library, you want to be able to start a connection {b but} we don't want to -use a {i specific} implementation of a protocol. In the case of TCP/IP, most of -times, we rely on the host's TCP/IP implementation, the UNIX one. But it's not -the case for MirageOS where the TCP/IP implementation used can change! - -This case is more concrete about the TLS implementation. Did you want to enforce -the use of OpenSSL for your user or you want to let them to choose the TLS -implementation? - -At this question, it's hard to: -{ul -{- be able to start a TLS connection.} -{- let the user to choose the TLS implementation.}} - -How I can, as the library implementer, know how to initiate a TLS connection -(without any clues)? This is what [Conduit] wants to solve! - -The other way to initiate a connection with [Conduit] is: - -{[ -let run ~resolvers edn = - Conduit.resolve ~resolvers edn >>= fun flow -> - Conduit.send flow "Hello World!" >>= fun _ -> - Conduit.close flow +let tcp = Conduit.register ~protocol:(module TCP) ]} -It introduces 2 values: -{ul -{- a [resolvers] which is like a set of protocols.} -{- a [edn] which is a {!Conduit.Endpoint.t}, a concrete value to represent your - peer.}} - -The deal is to be able to start a connection from a fully-known value (our -{!Conduit.Endpoin.t}) and a context which contains all available protocols. This -context, the [resolvers], should be constructed by something higher than your -library - it can be the end-user or an another library. - -Let's stick on our HTTP implementation. On our side, we have a way to send over -a {!Conduit.S.FLOW} a HTTP/1.1 request. And we are able to parse and extract a -HTTP/1.1 response from the same given {!Conduit.S.FLOW}: +The registration gives to us a {i type-witness} which is a small representation +of our protocol. This value {b must} be exposed to the user: {[ -type request -type response - -val request : uri:Uri.t -> [ `GET | `POST ] -> string option -> request - -val send : Conduit.flow -> request -> (unit, Conduit.error) result -val recv : Conduit.flow -> (response, Conduit.error) result +val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol ]} -As a HTTP client, we should provide something like: +As you can see, the value keeps the type of your [endpoint] and the type of your +[flow]. This value is the unique link to your implementation [TCP]. -{[ -val get : uri:Uri.t -> (response, error) result -val post : uri:Uri.t -> string -> (response, error) result -]} +{2 Use a Conduit's protocol.} -With [Conduit], we will extend a bit these functions: +Now, the implementation of our protocol is reachable at any point of your code +with Conduit. The library provides mainly 2 ways to start a transmission: {[ -val get : - resolvers:Conduit.resolvers -> - edn:Uri.t * Conduit.Endpoint.t -> - (response, error) result - -val post : - resolvers:Conduit.resolvers -> - edn:Uri.t * Conduit.Endpoint.t -> - string -> - (response, error) result -]} - -By this way, we let the user to decide which protocol he wants to use (see -[resolvers]) and with which peer he wants to communicate (see [edn]). We still -are at the library-level and, at this stage, we can not have any clue (again) -about the TCP/IP or the TLS implementation. Implementation of these functions -should be: +let loopback = Unix.ADDR_INET (Unix.inet_addr_loopback, 8080) -{[ -let get ~resolvers (uri, edn) = - let req = request ~uri `GET None in - Conduit.resolve ~resolvers edn >>= fun flow -> - send flow req >>= fun () -> - recv flow >>= fun resp -> - Conduit.close flow >>= fun () -> - Ok resp - -let post ~resolvers (uri, edn) body = - let req = request ~uri `POST (Some body) in - Conduit.resolve ~resolvers edn >>= fun flow -> - send flow req >>= fun () -> - recv flow >>= fun resp -> - Conduit.close flow >>= fun () -> - Ok resp +let socket : Unix.file_descr = Conduit.connect loopback My_protocol.tcp ]} -{3 The library user.} - -It's on the responsability of the end-user to {i fill} the [resolvers] and give -the right {!Conduit.Endpoint.t} value from what he knows. If he wants an -executable, he is necessary aware about which protocol he can use. So we will -assume that he knows a TCP/IP protocol and a TLS protocol: +It's the usual way when you want to start a TCP transmission. However, in some +cases, you want to start {i "a transmission"} regardless the kind of the +transmission. Conduit provides a {i resolution} mechanism which is able to start +any kind of protocols. -{[ -val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol -val tls : (Unix.sockaddr * tls_config, tls_socket) Conduit.protocol -]} +{3 Resolution.} -Of course, the best representation of an HTTP target is an [Uri.t]. We will try -to {i transform} a given [Uri.t] to a [resolver] and an [edn]: +We consider {!Conduit.Endpoint.t} as the most general concrete type to +represent a peer. From it, we can extract the [Unix.sockaddr] such as: {[ -let resolve ~port = function - | Conduit.Endpoint.IP v -> Some (Unix.ADDR_INET (Ipaddr_unix.to_inet_addr v, port)) - | Conduit.Endpoint.Domain v -> - match Unix.gethostbyname (Domain_name.to_string v) with +let http_resolv = function + | IP v -> Some (Unix.INET_ADDR (Ipaddr_unix.to_inet_addr v, 80)) + | Domain domain_name -> + match Unix.gethostbyname (Domain_name.to_string domain_name) with | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> - Some (Unix.ADDR_INET (h_addr_list.(0), port)) + Some (Unix.INET_ADDR (h_addr_list.(0), 80)) | _ -> None - -let resolve_with_tls ~port edn = - match resolve ~port with - | Some sockaddr -> Some (sockaddr, global_tls_config) - | None -> None - -let uri_to_conduit uri = - let host = match Uri.host uri with - | Some host -> host - | None -> invalid_arg "An URI requires a host" in - let edn = Conduit.Endpoint.of_string host in - match Uri.scheme uri, Uri.host uri, Uri.port uri with - | (Some "http" | None), None -> - let resolvers = Conduit.add tcp (resolve ~port:80) Conduit.empty in - (resolvers, edn) - | Some "http", Some port -> - let resolvers = Conduit.add tcp (resolve ~port) Conduit.empty in - (resolvers, edn) - | Some "https", None -> - let resolvers = Conduit.add tls (resolve_with_tls ~port:443) Conduit.empty in - (resolvers, edn) - | Some "https", Some port -> - let resolvers = Conduit.add tls (resolve_with_tls ~port) Conduit.empty in - (resolvers, edn) - | None, None -> - let resolvers = - Conduit.empty - |> Conduit.add tcp (resolve ~port:80) - |> Conduit.add ~priority:10 tls (resolve_with_tls ~port:443) in - (resolvers, edn) - | Some scheme, _ -> invalid_arg "Invalid scheme" - -let get ~uri = - let resolvers, edn = uri_to_conduit uri in - get ~resolvers (uri, edn) - -let post ~uri = - let resolvers, edn = uri_to_conduit uri in - post ~resolvers (uri, edn) -]} - -The code is a bit long but the most important point is to let the end-user -(someone or something like a library) the full control of the dispatch of -protocols according his context and independantly to our HTTP library. - -The default case (when we don't recognize a port or a scheme) lets us to {i -inject} the TCP/IP protocol and the TLS protocol with an higher priority. In -this case, [Conduit] will try to initiate a TLS connection first and, if it -fails, it will try the usual TCP/IP connection. - -{b NOTE.} Why {!Conduit.Endpoint.t} is {b not} an [Uri.t]? If you follow the -development of [Conduit], at the beginning, [Conduit] did the dispatch from an -[Uri.t]. It is not the case anymore where, even if we can describe lot of things -with an [Uri.t], the value still is a special case from the point-of-view of a -{i protocol} (according our definition). - -Indeed, the [port] value for example does not have any sense for a device -protocol. Moreover, the {i scheme} should not be the qualifier of a protocol -implementation. And the example above shows that the dispatch from an [Uri.t] is -a bit more complex than what we can imagine. - -[Conduit] wants to be easy to use - and the user should be able to {i -infer}/determine/describe the dispatch of protocols on his side. The previous -version taught us that an [Uri.t] is not a good choice (at the [Conduit]'s -layer) when we spend too much time to reverse-engineer the dispatch. - -{3 [Conduit] for a client.} - -[Conduit] is a tool which is able to {i inject} a {i protocol} without {i -functorization}. The end-user must keep in his mind that the [Conduit]'s -dispatch disqualify a protocol from 3 signals: -{ul - -{- if the [resolvers] is not filled with the protocol. - - Even if the protocol is {i registered} (with {!Conduit.S.register}), - [Conduit] look-up only on the given [resolvers]. So if the user did not fill - the [resolvers] with the registered protocol, [Conduit] is not able to start - the connection with this protocol.} - -{- if the given {!Conduit.Endpoint.t} is not reachable by processes filled by - the end-user. - - The user is able to disqualify some {!Conduit.Endpoin.t} if he wants - for - example, an user can give a [resolvers] which is able to {i resolve} only one - specific domain-name (like ["localhost"]). Of course, the common way is to - use [Unix.gethostbyname] but we can use something else like our greatest - MirageOS DNS stack! - - The resolution is not done by [Conduit] and only {!Conduit.S.resolver} given - by the end-user are able to determine required values to initiate protocols.} - -{- if the [connect] of the protocol fails. - - Even if we can {i resolve} the given {!Conduit.Endpoint.t}, the peer is may - be not accessible (for any reasons). For example, a website is not - neccessarily accessible with TLS - and in that case, we should try an other - protocol.}} - -From that, the end-user is able to easily infer how [Conduit] can choose a -specific protocol - but the real difference from the old version of [Conduit] is -the full-control of the end-user about the dispatch. - -[Conduit] does not come with any {i global} ({i mutlable}?) knowledge of what it -should do when a library maintainer wants to start a connection. All are decided -by the end-user and [Conduit] just tries to give the most easy way (with the -simpliest mental model) to plug (like {i a conduit}!) both sides. - -{2 Composition.} - -TLS is a protocol which requires... an other protocol! In the real world, TLS is -used over a TCP/IP [socket] but a problem appears for us (specifically for -MirageOS) when the TCP/IP protocol is not well-known. - -Indeed, about MirageOS, the TCP/IP protocol can be our first TCP/IP protocol -implemented above but it can be [mirage-tcpip]. At this stage, we talk about {i -protocol composition}. The same goes for SSH or any layered protocol. - -It seems hard to deal with that in [Conduit] but it's not. Let's take an example -about a possible TLS implementation which is abstracted over... a -{!Conduit.S.PROTOCOL}! - -{[ -type 'a with_tls = - { underlying : 'a - ; tls : Tls.state } - -let underlying { underlying; _ } = underlying - -module Make_TLS (Protocol : Conduit.PROTOCOL) = struct - type 'a io = 'a Protocol.io - - type input = Protocol.input - type output = Protocol.output - - type flow = Protocol.flow with_tls - - type endpoint = Protocol.endpoint * Tls.config - - ... -end + | exception _ -> None ]} -It's an idiomatic code but it should be easy to concretely replace undefined -types/values by [ocaml-tls] or [ocaml-ssl] (and if you are curious, you can take -a look on [conduit-tls]). The global idea is, from the ['a with_tls], we are -able to get some values such as: -{ul -{- the underlying representation of the protocol used.} -{- some information about the TLS state (ciphers used for example).}} +But we can extract (or decide to bind) something else such as a set of TLS +certificates. More generally, the value returned by your resolution is free as +long as a Conduit's protocol can use it to initialise a transmission. -Of course, we probably need to expose the {i functor} but we decided to -represent {i protocols} with values in [Conduit]. So we can take this advantage -to expose less things to the end-user and do the application of the {i functor} -by {i pack/unpack} modules: +Then, Conduit defines a [resolvers] which can contains your function such as +[http_resolv] and let the user to bind them to a specific protocol. For example, +we can bind our [http_resolv] with our TCP protocol: {[ -let protocol_with_tls - : ('edn, 'flow) Conduit.protocol -> ('edn * Tls.config, 'flow with_tls) Conduit.protocol - = fun protocol -> - let module Protocol = (val Conduit.impl protocol) in - let module M = Make_TLS (Protocol) in - Conduit.register ~protocol:(module M) +let my_resolvers = Conduit.add My_protocol.tcp http_resolv Conduit.empty ]} -For the point-of-view of the end-user, the composition of a well-known TCP/IP -protocol (or something else!) and our TLS implementation is: +Finally, we can use this value to start {i "a transmission"}: {[ -val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol -let tls - : (Unix.sockaddr * Tls.config, Unix.file_descr with_tls) Conduit.protocol - = protocol_with_tls tcp -]} +let google = Conduit.Endpoint.v "google.com" -And of course, all previous mechanisms available for a [Conduit.protocol] still -are available for our [tls] protocol such as the {i destruction}: - -{[ -include (val Conduit.repr tls) - -let run sockaddr tls_config = - Conduit.connect (sockaddr, tls_config) tls >>= function - | T (V tls_socket) -> - let socket = underlying tls_socket in - let peer = Unix.getpeername socket in - ... - | flow -> ... -]} - -{2 A correspondance.} - -Finally, it exists a correspondance between [Conduit] and a {i functorized} -implementation. - -{[ -module Make (Flow : FLOW) = struct - let send_hello_world flow = Flow.send flow "Hello World!" -end +let flow : Conduit.flow = Conduit.resolve my_resolvers google ]} -In [Conduit] the snippet code above is: +You can denote that we finally return a {!Conduit.flow} value which is an +abstract type instead to return a concrete [Unix.file_descr] value as before. +From it, you still able to use [send]/[recv] functions with: {[ -let send_hello_world (flow : Conduit.flow) = Conduit.send flow "Hello World!" +let hello (flow : Conduit.flow) = + Conduit.send flow "Hello World!" ]} -About the specialisation of your implementation from a specific protocol, we -assume that you have a knowledge of which protocols are available (such as the -TCP/IP protocol). Without [Conduit], this protocol is an implementation which -should respect the {!Conduit.S.PROTOCOL} interface: +But the flow can be an usual TCP transmission or something more complex like a +TLS connection. But all of this complexity is hidden by the abstract type. -{[ -module TCP : Conduit.S.PROTOCOL = ... -]} +{3 Destruction.} -With conduit, the implementation must respect the same interface too. But, -instead of manipulating an OCaml module, we use an OCaml value such as: +A library which uses Conduit should pass the {!Conduit.S.flow} to the user as an +HTTP server should do to handle clients. In that case, the end-user who uses the +library is aware about which implementation he injected into Conduit. He should +be able to {i destruct} the given {!Conduit.S.flow} to its protocols {i +injected}. Assume that we used our TCP/IP implementation, to permit the {i +destruction}, we must add: {[ let tcp = Conduit.register ~protocol:(module TCP) +include (val Conduit.repr tcp) ]} -Then, the usual {i injection} of the TCP implementation with {i functors} is: - -{[ -module M = Make(TCP) - -let () = - let flow = TCP.make localhost in - M.send_hello_world flow -]} - -Where, with [Conduit], the {i injection} is: - -{[ -let () = - let flow = Conduit.connect ~protocol:tcp localhost in - send_hello_world flow -]} - -{2 The service.} - -The new version of [Conduit] did the choice to provide something else to -initiate a service. The context of the initialisation of a service (such as a -TCP service) should be more complete than the client. The implementer of a -service (such as an HTTP service) must be aware about which implementation he -wants to use - and he does not really need a {i dispatch} process between -several protocol implementations. - -In that case, [Conduit] comes like a simple framework which enforces a certain -interface about service implementation, with the same protocol's registration -mechanism and without the {i dispatch} (with the [resolvers]) process — because -you should fully-know how to initiate your service)! - -{3 A concrete implementation.} - -As the protocol, the service must respect an interface: {!Conduit.S.SERVICE}. -This interface is what a POSIX-compliant service provides: - -{[ -module Service = struct - type 'a io = 'a - - type flow = Unix.file_descr - type t = Unix.file_descr - - type error = | - - let pp_error : Format.formatter -> error -> unit = fun _ -> function _ -> . - - type configuration = Unix.sockaddr - - let init sockaddr = - let domain = Unix.domain_of_sockaddr sockaddr in - let socket = Unix.socket domain Unix.SOCK_STREAM 0 in - Unix.bind socket sockaddr ; - Unix.listen socket 40 ; Ok socket - - let accept socket = - let client, _ = Unix.accept socket in - Ok client - - let close socket = Unix.close socket ; Ok () -end -]} - -Again, this implementation is a simple example and it should not be used into a -productive context. - -{3 Registration & use.} - -[Conduit] provides then all of these functions: -{ul -{- [init] to initiate the service.} -{- [accept] to wait a client.} -{- [close] to close the service.}} - -The registration of the service with [Conduit] is: +This snippet can be expanded to: {[ -let tcp_service - : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Conduit.service - = Conduit.Service.regiseter (module Service) +val tcp : (Unix.sockaddr, Unix.file_descr) Conduit.protocol +type Conduit.flow += T of Unix.file_descr Conduit.value ]} -As you can see, we have 3 parameters (instead of 2 for a protocol). In fact, the -[Unix.file_descr] which represents the service can be different from the value -which represent the client. It does not appear in our case but in some context -(such as TLS), it's required to have this difference. - -Of course, to be able to handle multiple functions, we should have something -like [Thread] ([LWT] or [ASYNC]) to concurrently handle clients. Then, we are -able to implement an usual (infinite) {i service loop}: +The end user is then able to {i destruct} the flow to this type: {[ -let serve_with_handler - : Unix.sockaddr -> (Conduit.flow -> unit) -> unit - = fun cfg ~handler -> - let service = tcp_service in - Conduit.Service.init ~service cfg >>= fun t -> - let rec go t = - Conduit.Service.accept ~service t >>= fun socket -> - let flow = Conduit.pack tcp socket in - let _ = Thread.create handler flow in - go t in - go t +let hello (flow : Conduit.flow) = match flow with + | T (Value file_descr) -> + Unix.write file_descr "Hello World!" + | flow -> + Conduit.send flow "Hello World!" ]} -Again, we are the ability to {i abstract} the socket with a well-known protocol -(such as our previous TCP/IP protocol) and give it to an user-defined function -[handler]. Finally, the user will be able to {i destruct} it or use it for a -more abstract process. - -The service has less abilities than the client, but as we said before, the -context is a bit different where we should fully-known how we initiate our -service (on which port, with which configuration, etc.). The {i dispatch} -mechanism is not needed at this stage. - -[Conduit_lwt] and [Conduit_async] provide both a [serve] such as our previous -[serve_with_handler] function (but they are more complete). - -{2 Dependencies & eco-system.} - -[Conduit] is a small package, it requires: -{ul -{- [domain-name] to have a representation of a domain-name.} -{- [ipaddr] to have a representation of an IP.} -{- [stdlib-shims] for internal stuffs.}} - -As a protocol implementer, the compatibility with MirageOS require that you: -+ Functorize your code -+ Or use [Conduit] - -In some context, the first option is good - and this is what [mirage-tcpip] does -(when the TCP/IP is a composition of several others protocols...). But from some -high-level libraries such as [Irmin] or [Cohttp], [Conduit] seems the best to {i -de-functorize} the stack. - -Of course, even if [Conduit] was made for MirageOS, it can be use into several -others contexts, hence the existence of [Conduit_lwt] and [Conduit_async]. +Of course, we can not assert that the given [flow] is, in any case, an +[Unix.file_descr], but we can prove that it can be this kind of value - it's a +kind of dynamic-typing. {2 Conclusion.} -A MirageOS project wants to provide the best way to abstract everythings which -is commonly available on an operating-system. At this layer, we can said that -[Conduit] is close to re-implement [/etc/services]! +More generally, in some context, it's useful to be abstract over the protocol +used to communicate with a peer. Specially when you have several ways to +communicate with your peer. An example is Git which can communicate with: -It serves the MirageOS purpose but, moreover, it unlocks the ability to be -abstracted over protocols. This ability is a game between what we can assert -about the definition of a protocol and the type-system. - -This document is like a little HOW-TO but tests are a good example of how to use -[Conduit] too. Then, the documentation of each function give you an example in -which case it could be useful to use them. Feel free to complete or fix some -french^Wenglish issues! \ No newline at end of file +{ul +{- TCP with a [git://] URL.} +{- SSH with a [git@] endpoint.} +{- HTTP with a [http://] URL.} +{- HTTPS with a [https://] URL.}} + +However contents of the transmission is pretty the same between all of these +ways. Instead to duplicate the process to communicate with our peer, it could be +better to use one and a full abstract [flow] and be less-aware about the +underlying protocol used - or, at least, shift this responsability to the final +user. + +An other case is about MirageOS which does not assert that the TCP/IP stack - +and the TCP protocol - is available into your unikernel. Of course, the protocol +can exists but it can be replaced by something else. \ No newline at end of file From 4718b182bc6fc54026de8d4d76e23ebc85c88fcb Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Oct 2020 18:20:09 +0200 Subject: [PATCH 103/140] howto: no need to manually initialize the rng (conduit_lwt_tls does this for us) --- src/core/howto.mld | 4 ---- tests/ping-pong/with_lwt.ml | 2 -- 2 files changed, 6 deletions(-) diff --git a/src/core/howto.mld b/src/core/howto.mld index d71a825d..3eb2fda5 100644 --- a/src/core/howto.mld +++ b/src/core/howto.mld @@ -176,8 +176,6 @@ we will use them to upgrade our protocol (when the scheme is ["pgs"]): {v server.ml v} {[ -let () = Mirage_crypto_rng_unix.initialize () - let load_file filename = let ic = open_in filename in let ln = in_channel_length ic in @@ -227,8 +225,6 @@ And for the client, we just need to update the function [conduit_of_uri]: {[ let tls_config = Tls.Config.client ~authenticator:(fun ~host:_ _ -> Ok None) () -let () = Mirage_crypto_rng_unix.initialize () - let conduit_of_uri uri = let host = Uri.host_with_default ~default:"localhost" uri in let edn = Conduit_lwt.Endpoint.v host in diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 72172fb9..0d82e73f 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -1,7 +1,5 @@ open Rresult -let () = Mirage_crypto_rng_unix.initialize () - let () = Printexc.record_backtrace true let () = Ssl.init () From 8430dccefe0f319b28870e7e3fc94792b9ec2659 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 16 Oct 2020 13:47:44 +0200 Subject: [PATCH 104/140] Lint OPAM files --- conduit-async-ssl.opam | 13 ++++++------- conduit-async-tls.opam | 15 +++++++-------- conduit-async.opam | 21 ++++++++++++++------- conduit-lwt-ssl.opam | 10 +++++----- conduit-lwt-tls.opam | 12 ++++++------ conduit-lwt.opam | 16 ++++++++++++---- conduit-mirage.opam | 8 ++++---- conduit.opam | 31 ++++++------------------------- 8 files changed, 60 insertions(+), 66 deletions(-) diff --git a/conduit-async-ssl.opam b/conduit-async-ssl.opam index 6b4bbca6..7c3d1b87 100644 --- a/conduit-async-ssl.opam +++ b/conduit-async-ssl.opam @@ -11,20 +11,19 @@ tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for Async" +synopsis: "A network connection establishment library using Async and OpenSSL" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.03.0"} - "dune" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} "core" - "conduit-async" - "async" {>= "v0.12.0"} + "conduit-async" {= version} + "async" {>= "v0.12.0"} "async_ssl" - "stdlib-shims" {with-test} ] diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam index fdf51782..5465521b 100644 --- a/conduit-async-tls.opam +++ b/conduit-async-tls.opam @@ -11,20 +11,19 @@ tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for Async" +synopsis: "A network connection establishment library using Async and ocaml-tls" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.03.0"} - "dune" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} "core" - "conduit-async" - "async" {>= "v0.12.0"} - "conduit-tls" - "stdlib-shims" {with-test} + "conduit-async" {= version} + "async" {>= "v0.12.0"} + "conduit-tls" {= version} ] diff --git a/conduit-async.opam b/conduit-async.opam index cc5108b8..7b442961 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -5,26 +5,33 @@ authors: [ "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg" + "Romain Calascibetta" ] license: "ISC" tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library for Async" +synopsis: "A portable network connection establishment library using Async" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.03.0"} - "dune" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} "core" - "conduit" - "async" {>= "v0.12.0"} + "conduit" {= version} + "async" {>= "v0.12.0"} "cstruct" - "stdlib-shims" {with-test} + "base-bigarray" {with-test} + "bigstringaf" {with-test} + "ke" {with-test} + "fmt" {with-test} + "rresult" {with-test} + "conduit-async-tls" {with-test} + "conduit-async-ssl" {with-test} ] diff --git a/conduit-lwt-ssl.opam b/conduit-lwt-ssl.opam index 618bef10..3b47c5ed 100644 --- a/conduit-lwt-ssl.opam +++ b/conduit-lwt-ssl.opam @@ -12,17 +12,17 @@ tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A portable network connection establishment library using Lwt" +synopsis: "A portable network connection establishment library using Lwt and OpenSSL" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "conduit-lwt" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} + "conduit-lwt" {= version} "lwt_ssl" ] diff --git a/conduit-lwt-tls.opam b/conduit-lwt-tls.opam index 7eb7f670..9c9f3610 100644 --- a/conduit-lwt-tls.opam +++ b/conduit-lwt-tls.opam @@ -12,18 +12,18 @@ tags: "org:mirage" homepage: "https://github.com/mirage/ocaml-conduit" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A portable network connection establishment library using Lwt" +synopsis: "A portable network connection establishment library using Lwt and ocaml-tls" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "conduit-lwt" - "conduit-tls" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} + "conduit-lwt" {= version} + "conduit-tls" {= version} "mirage-crypto-rng" {>= "0.8.0"} ] diff --git a/conduit-lwt.opam b/conduit-lwt.opam index 574ec5bb..cf0cccc4 100644 --- a/conduit-lwt.opam +++ b/conduit-lwt.opam @@ -17,13 +17,21 @@ synopsis: "A portable network connection establishment library using Lwt" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-j1"] {with-test} + ["dune" "runtest" "-p" name "-j1"] {with-test} ] depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "conduit" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} + "conduit" {= version} + "cstruct" "lwt" "base-unix" + "base-bigarray" {with-test} + "bigstringaf" {with-test} + "ke" {with-test} + "fmt" {with-test} + "rresult" {with-test} + "conduit-lwt-tls" {with-test} + "conduit-lwt-ssl" {with-test} ] diff --git a/conduit-mirage.opam b/conduit-mirage.opam index 25067d69..6480c57d 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -19,13 +19,13 @@ build: [ ] depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "conduit" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} + "conduit" {= version} "tcpip" "mirage-flow" "mirage-time" - "dns-client" {>= "4.6.0"} + "dns-client" {>= "4.6.0"} "ke" "bigstringaf" ] diff --git a/conduit.opam b/conduit.opam index 1bd6beed..32dcb7fd 100644 --- a/conduit.opam +++ b/conduit.opam @@ -13,39 +13,20 @@ homepage: "https://github.com/mirage/ocaml-conduit" doc: "https://mirage.github.io/ocaml-conduit/" bug-reports: "https://github.com/mirage/ocaml-conduit/issues" dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A network connection establishment library" -description: """ -The `conduit` library takes care of establishing and listening for -TCP and SSL/TLS connections for the Lwt and Async libraries. - -The reason this library exists is to provide a degree of abstraction -from the precise SSL library used, since there are a variety of ways -to bind to a library (e.g. the C FFI, or the Ctypes library), as well -as well as which library is used (just OpenSSL for now). - -By default, OpenSSL is used as the preferred connection library, but -you can force the use of the pure OCaml TLS stack by setting the -environment variable `CONDUIT_TLS=native` when starting your program. - -The useful opam packages available that extend this library are: - -- `conduit`: the main `Conduit` module -- `conduit-lwt`: the portable Lwt implementation -- `conduit-lwt-unix`: the Lwt/Unix implementation -- `conduit-async` the Jane Street Async implementation -- `conduit-mirage`: the MirageOS compatible implementation -""" +synopsis: "A portable network connection establishment library" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} ] depends: [ - "ocaml" {>= "4.07.0"} - "dune" + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} "ipaddr" "domain-name" "stdlib-shims" - "alcotest" {with-test} + "alcotest" {with-test} + "rresult" {with-test} ] From 2109ba345b1fee79630236a54ae777a051009c02 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 16 Oct 2020 13:56:26 +0200 Subject: [PATCH 105/140] Use post tag to be able to install tests --- conduit-async.opam | 4 ++-- conduit-lwt.opam | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/conduit-async.opam b/conduit-async.opam index 7b442961..1fe84238 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -32,6 +32,6 @@ depends: [ "ke" {with-test} "fmt" {with-test} "rresult" {with-test} - "conduit-async-tls" {with-test} - "conduit-async-ssl" {with-test} + "conduit-async-tls" {with-test & post} + "conduit-async-ssl" {with-test & post} ] diff --git a/conduit-lwt.opam b/conduit-lwt.opam index cf0cccc4..85111987 100644 --- a/conduit-lwt.opam +++ b/conduit-lwt.opam @@ -32,6 +32,6 @@ depends: [ "ke" {with-test} "fmt" {with-test} "rresult" {with-test} - "conduit-lwt-tls" {with-test} - "conduit-lwt-ssl" {with-test} + "conduit-lwt-tls" {with-test & post} + "conduit-lwt-ssl" {with-test & post} ] From 2c2c9111e09ca8615f5628e596d9c0dabb466ec4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 19 Oct 2020 13:44:37 +0200 Subject: [PATCH 106/140] Clean tests --- tests/ping-pong/dune | 8 ++++---- tests/ping-pong/test_async.ml | 17 ----------------- tests/ping-pong/test_lwt.ml | 16 ---------------- tests/ping-pong/with_async.ml | 19 ------------------- tests/ping-pong/with_lwt.ml | 25 +------------------------ 5 files changed, 5 insertions(+), 80 deletions(-) diff --git a/tests/ping-pong/dune b/tests/ping-pong/dune index 9af60313..00426674 100644 --- a/tests/ping-pong/dune +++ b/tests/ping-pong/dune @@ -7,7 +7,7 @@ (name with_lwt) (modules with_lwt) (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-lwt - conduit-lwt-tls conduit-lwt-ssl)) + conduit-lwt-tls)) (executable (name test_lwt) @@ -16,7 +16,7 @@ (rule (alias runtest) - (package conduit-lwt) + (package conduit-lwt-tls) (deps (:test test_lwt.exe) with_lwt.exe @@ -32,7 +32,7 @@ (name with_async) (modules with_async) (libraries common fmt.tty logs.fmt mirage-crypto-rng.unix conduit-async - conduit-async-tls conduit-async-ssl)) + conduit-async-tls)) (executable (name test_async) @@ -41,7 +41,7 @@ (rule (alias runtest) - (package conduit-async) + (package conduit-async-tls) (deps (:test test_async.exe) with_async.exe diff --git a/tests/ping-pong/test_async.ml b/tests/ping-pong/test_async.ml index 70aaff8d..a947ec4e 100644 --- a/tests/ping-pong/test_async.ml +++ b/tests/ping-pong/test_async.ml @@ -22,23 +22,6 @@ let () = res := !res && properly_exited status ; Format.printf ">>> with_async.exe: %a.\n%!" pp_process_status status ; - let pid = - Unix.create_process_env "./with_async.exe" - [| - "./with_async.exe"; - "--with-ssl"; - "server.pem"; - "server.key"; - "client0"; - "client1"; - "client2"; - |] - [||] Unix.stdin Unix.stdout Unix.stderr in - let _, status = Unix.waitpid [] pid in - res := !res && properly_exited status ; - Format.printf ">>> with_async.exe --with-ssl: %a.\n%!" pp_process_status - status ; - let pid = Unix.create_process_env "./with_async.exe" [| diff --git a/tests/ping-pong/test_lwt.ml b/tests/ping-pong/test_lwt.ml index c9019529..3b5e0ab9 100644 --- a/tests/ping-pong/test_lwt.ml +++ b/tests/ping-pong/test_lwt.ml @@ -22,22 +22,6 @@ let () = res := !res && properly_exited status ; Format.printf ">>> with_lwt.exe: %a.\n%!" pp_process_status status ; - let pid = - Unix.create_process_env "./with_lwt.exe" - [| - "./with_lwt.exe"; - "--with-ssl"; - "server.pem"; - "server.key"; - "client0"; - "client1"; - "client2"; - |] - [||] Unix.stdin Unix.stdout Unix.stderr in - let _, status = Unix.waitpid [] pid in - res := !res && properly_exited status ; - Format.printf ">>> with_lwt.exe --with-ssl: %a.\n%!" pp_process_status status ; - let pid = Unix.create_process_env "./with_lwt.exe" [| diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index a7d400aa..e9336296 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -1,6 +1,5 @@ open Rresult open Async -open Async_ssl let () = Mirage_crypto_rng_unix.initialize () @@ -25,10 +24,6 @@ let tcp_protocol, tcp_service = let open Conduit_async.TCP in (protocol, service) -let ssl_protocol, ssl_service = - let open Conduit_async_ssl.TCP in - (protocol, service) - let tls_protocol, tls_service = let open Conduit_async_tls.TCP in (protocol, service) @@ -37,12 +32,6 @@ let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt let resolve_ping_pong = Conduit_async.TCP.resolve ~port:5000 -let resolve_ssl_ping_pong = - let context = - Conduit_async_ssl.context ~verify_modes:Ssl.Verify_mode.[ Verify_none ] () - in - Conduit_async_ssl.TCP.resolve ~port:7000 ~context - let resolve_tls_ping_pong = let null ~host:_ _ = Ok None in let config = Tls.Config.client ~authenticator:null () in @@ -50,7 +39,6 @@ let resolve_tls_ping_pong = let resolvers = Conduit.empty - |> Conduit_async.add ~priority:10 ssl_protocol resolve_ssl_ping_pong |> Conduit_async.add ~priority:10 tls_protocol resolve_tls_ping_pong |> Conduit_async.add ~priority:20 tcp_protocol resolve_ping_pong @@ -84,12 +72,6 @@ let run_with_tcp clients = (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 5000)) ~protocol:tcp_protocol ~service:tcp_service clients -let run_with_ssl cert key clients = - let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in - run_with - (ctx, Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 7000)) - ~protocol:ssl_protocol ~service:ssl_service clients - let load_file filename = let open Stdlib in let ic = open_in filename in @@ -117,7 +99,6 @@ let run_with_tls cert key clients = let () = match Array.to_list Stdlib.Sys.argv with - | _ :: "--with-ssl" :: cert :: key :: clients -> run_with_ssl cert key clients | _ :: "--with-tls" :: cert :: key :: clients -> run_with_tls cert key clients | _ :: clients -> run_with_tcp clients | [] -> assert false diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 0d82e73f..573d3a35 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -2,8 +2,6 @@ open Rresult let () = Printexc.record_backtrace true -let () = Ssl.init () - let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt module Lwt = struct @@ -25,10 +23,6 @@ let tls_protocol, tls_service = let open Conduit_lwt_tls.TCP in (protocol, service) -let ssl_protocol, ssl_service = - let open Conduit_lwt_ssl.TCP in - (protocol, service) - (* Resolution *) let resolve_ping_pong = Conduit_lwt.TCP.resolve ~port:4000 @@ -38,15 +32,10 @@ let resolve_tls_ping_pong = let config = Tls.Config.client ~authenticator:null () in Conduit_lwt_tls.TCP.resolve ~port:8000 ~config -let resolve_ssl_ping_pong = - let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in - Conduit_lwt_ssl.TCP.resolve ~port:6000 ~context ?verify:None - let resolvers = Conduit.empty |> Conduit_lwt.add ~priority:20 Conduit_lwt.TCP.protocol resolve_ping_pong |> Conduit_lwt.add ~priority:10 tls_protocol resolve_tls_ping_pong - |> Conduit_lwt.add ~priority:10 ssl_protocol resolve_ssl_ping_pong (* Run *) @@ -92,17 +81,6 @@ let run_with_tcp clients = } ~protocol:Conduit_lwt.TCP.protocol ~service:Conduit_lwt.TCP.service clients -let run_with_ssl cert key clients = - let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Server_context in - Ssl.use_certificate ctx cert key ; - run_with - ( ctx, - { - Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); - capacity = 40; - } ) - ~protocol:ssl_protocol ~service:ssl_service clients - let run_with_tls cert key clients = let ctx = config cert key in run_with @@ -116,6 +94,5 @@ let run_with_tls cert key clients = let () = match Array.to_list Sys.argv with | _ :: "--with-tls" :: cert :: key :: clients -> run_with_tls cert key clients - | _ :: "--with-ssl" :: cert :: key :: clients -> run_with_ssl cert key clients | _ :: clients -> run_with_tcp clients - | _ -> Fmt.epr "%s [--with-tls|--with-ssl] filename...\n%!" Sys.argv.(0) + | _ -> Fmt.epr "%s [--with-tls] filename...\n%!" Sys.argv.(0) From 8273960d724e53808c384746091bbd2a6c218b85 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 19 Oct 2020 13:45:22 +0200 Subject: [PATCH 107/140] Lint OPAM files --- conduit-async.opam | 2 -- conduit-lwt.opam | 2 -- 2 files changed, 4 deletions(-) diff --git a/conduit-async.opam b/conduit-async.opam index 1fe84238..14eb7c04 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -32,6 +32,4 @@ depends: [ "ke" {with-test} "fmt" {with-test} "rresult" {with-test} - "conduit-async-tls" {with-test & post} - "conduit-async-ssl" {with-test & post} ] diff --git a/conduit-lwt.opam b/conduit-lwt.opam index 85111987..2cbce14d 100644 --- a/conduit-lwt.opam +++ b/conduit-lwt.opam @@ -32,6 +32,4 @@ depends: [ "ke" {with-test} "fmt" {with-test} "rresult" {with-test} - "conduit-lwt-tls" {with-test & post} - "conduit-lwt-ssl" {with-test & post} ] From e877c5dd5bded461716598feb548e04edfb4a99f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 20 Oct 2020 11:20:12 +0200 Subject: [PATCH 108/140] Missing mirage-crypto-rng dependency on conduit-async-tls package --- conduit-async-tls.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam index 5465521b..99d21a79 100644 --- a/conduit-async-tls.opam +++ b/conduit-async-tls.opam @@ -26,4 +26,5 @@ depends: [ "conduit-async" {= version} "async" {>= "v0.12.0"} "conduit-tls" {= version} + "mirage-crypto-rng" {>= "0.8.0"} ] From c60090dc3ff1b2c6848e84a1c512af5752cc0c66 Mon Sep 17 00:00:00 2001 From: Gargi Sharma Date: Fri, 30 Oct 2020 16:41:15 +0100 Subject: [PATCH 109/140] Add bench target to Makefile & allow json bench output --- Makefile | 5 +++- bench/cost.ml | 57 +++++++++++++++++++++++++++++++++++++++------- bench/dune | 4 +++- conduit-bench.opam | 33 +++++++++++++++++++++++++++ 4 files changed, 89 insertions(+), 10 deletions(-) create mode 100644 conduit-bench.opam diff --git a/Makefile b/Makefile index 2d83066e..673509cd 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: build clean test doc +.PHONY: build clean test doc bench build: dune build @@ -11,3 +11,6 @@ clean: doc: dune build @doc + +bench: + @dune exec -- ./bench/cost.exe --json \ No newline at end of file diff --git a/bench/cost.ml b/bench/cost.ml index be91e6ce..9e15fb25 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -99,7 +99,42 @@ let fn_fully_abstr flow = Benchmark.V (fun () -> Tuyau.send flow hello_world) let fn_abstr (Tuyau.Flow (flow, (module Flow))) = Benchmark.V (fun () -> Flow.send flow hello_world) -let run () = +type result = { + with_conduit : float; + with_conduit_r2 : float; + without_conduit : float; + without_conduit_r2 : float; +} +[@@deriving to_yojson] + +let print_json est0 est1 r0 r1 = + let with_conduit = est0.(0) in + let with_conduit_r2 = r0 in + let without_conduit = est1.(0) in + let without_conduit_r2 = r1 in + let res = + { with_conduit; with_conduit_r2; without_conduit; without_conduit_r2 } in + let fmt = stdout |> Format.formatter_of_out_channel in + let open Yojson.Safe in + let obj = + `Assoc + [ + ( "results", + `Assoc + [ + ("name", `String "benchmarks"); ("metrics", result_to_yojson res); + ] ); + ] in + pretty_print fmt obj + +let print_stdout est0 est1 r0 r1 = + Fmt.pr "with Conduit:\t\t%fns (r²: %f).\n%!" est0.(0) r0 ; + Fmt.pr "without Conduit:\t%fns (r²: %f).\n%!" est1.(0) r1 ; + if r0 >= 0.99 && r1 >= 0.99 + then Fmt.pr "Overhead:\t\t%fns.\n%!" (est0.(0) -. est1.(0)) + else Fmt.epr "Bad regression coefficients!\n%!" + +let run json = let open Rresult in Tuyau.connect Unix.stderr fake0 >>= fun flow -> Tuyau.send flow hello_world >>= fun _ -> @@ -111,17 +146,23 @@ let run () = Linear_algebra.ols (fun m -> m.(1)) [| (fun m -> m.(0)) |] samples1 ) with | Ok (estimate0, r0), Ok (estimate1, r1) -> - Fmt.pr "with Conduit:\t\t%fns (r²: %f).\n%!" estimate0.(0) r0 ; - Fmt.pr "without Conduit:\t%fns (r²: %f).\n%!" estimate1.(0) r1 ; - if r0 >= 0.99 && r1 >= 0.99 - then Fmt.pr "Overhead:\t\t%fns.\n%!" (estimate0.(0) -. estimate1.(0)) - else Fmt.epr "Bad regression coefficients!\n%!" ; + (match json with + | true -> print_json estimate0 estimate1 r0 r1 + | false -> print_stdout estimate0 estimate1 r0 r1) ; Ok () | Error err, _ -> Error err | _, Error err -> Error err -let () = - match run () with +open Cmdliner + +let json = Arg.(value & flag & info [ "j"; "json" ]) + +let main json = + match run json with | Ok v -> v | Error (`Msg err) -> Fmt.epr "%s: %s.\n%!" Sys.argv.(0) err | Error `Not_found -> assert false + +let cmd = (Term.(const main $ json), Term.info "run benchmarks") + +let () = Term.(exit @@ eval cmd) diff --git a/bench/dune b/bench/dune index 19246a85..5d07c884 100644 --- a/bench/dune +++ b/bench/dune @@ -1,6 +1,8 @@ (executable (name cost) - (libraries conduit unix rresult fmt) + (preprocess + (pps ppx_deriving_yojson)) + (libraries conduit unix rresult fmt cmdliner yojson ppx_deriving_yojson) (foreign_stubs (language c) (names rdtsc))) diff --git a/conduit-bench.opam b/conduit-bench.opam new file mode 100644 index 00000000..03db43f3 --- /dev/null +++ b/conduit-bench.opam @@ -0,0 +1,33 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Thomas Leonard" + "Thomas Gazagnaire" + "Rudi Grinberg" + "Romain Calascibetta" +] +license: "ISC" +tags: "org:mirage" +homepage: "https://github.com/mirage/ocaml-conduit" +doc: "https://mirage.github.io/ocaml-conduit/" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "Conduit benchmarking suite" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0.0"} + "cmdliner" + "conduit" + "fmt" + "ppx_deriving_yojson" + "rresult" + "yojson" +] From 5897dd5edec78bc9ed6cdb0fadbc5aca61f41a7c Mon Sep 17 00:00:00 2001 From: Gargi Sharma Date: Fri, 30 Oct 2020 20:17:54 +0100 Subject: [PATCH 110/140] Pin bench opam package for github actions --- .github/workflows/test.yml | 3 ++- bench/dune | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 1daf0513..07b53c6e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -24,8 +24,9 @@ jobs: opam pin add -n conduit-async-ssl.dev . opam pin add -n conduit-lwt-tls.dev . opam pin add -n conduit-lwt-ssl.dev . + opam pin add -n conduit-bench.dev . opam depext -y conduit conduit-tls conduit-lwt conduit-async conduit-mirage - opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-lwt-ssl conduit-async conduit-async-tls conduit-async-ssl conduit-mirage + opam install --deps-only -t conduit conduit-tls conduit-lwt conduit-lwt-tls conduit-lwt-ssl conduit-async conduit-async-tls conduit-async-ssl conduit-mirage conduit-bench - name: Build run: opam exec -- dune build - name: Test diff --git a/bench/dune b/bench/dune index 5d07c884..fc7cb22e 100644 --- a/bench/dune +++ b/bench/dune @@ -1,5 +1,6 @@ (executable - (name cost) + (public_name cost) + (package conduit-bench) (preprocess (pps ppx_deriving_yojson)) (libraries conduit unix rresult fmt cmdliner yojson ppx_deriving_yojson) From c72831c8462c19f1445aad31158abb3eb261cbb8 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 18 Nov 2020 17:15:00 +0100 Subject: [PATCH 111/140] Bind a protocol when we register a service to be able to abstract the protocol as a Conduit.flow --- src/async-ssl/conduit_async_ssl.ml | 4 +- src/async/conduit_async.ml | 9 ++-- src/async/conduit_async.mli | 4 +- src/core/conduit.ml | 71 ++++++++++++++++++++---------- src/core/conduit.mli | 54 +++++++++++++++++------ src/core/dune | 2 +- src/lwt-ssl/conduit_lwt_ssl.ml | 4 +- src/lwt/conduit_lwt.ml | 15 ++++--- src/lwt/conduit_lwt.mli | 4 +- src/mirage/conduit_mirage_tcp.ml | 10 ++++- src/tls/conduit_tls.ml | 4 +- tests/ping-pong/common.ml | 14 +++--- tests/ping-pong/with_async.ml | 9 ++-- tests/ping-pong/with_lwt.ml | 9 ++-- 14 files changed, 133 insertions(+), 80 deletions(-) diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index 3ab3c1fc..2bc62423 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -284,7 +284,7 @@ let service_with_ssl : writer:(flow -> Writer.t) -> (edn, flow with_ssl) Conduit_async.protocol -> (context * cfg, context * t, flow with_ssl) Conduit_async.Service.service = - fun service ~reader ~writer _ -> + fun service ~reader ~writer protocol -> let module S = (val Conduit_async.Service.impl service) in let module Service = struct include S @@ -294,7 +294,7 @@ let service_with_ssl : let writer = writer end in let module M = Make (Service) in - Conduit_async.Service.register ~service:(module M) + Conduit_async.Service.register ~service:(module M) ~protocol module TCP = struct open Conduit_async.TCP diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index a36bd576..f05992c8 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -16,10 +16,10 @@ let ( >>? ) x f = Async.Deferred.Result.bind x ~f type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service let serve : - type cfg t flow. + type cfg t v. ?timeout:int -> handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, t, flow) service -> + service:(cfg, t, v) service -> cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) = fun ?timeout ~handler ~service cfg -> @@ -34,7 +34,8 @@ let serve : let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in let accept = Svc.accept t >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in + Async.(Deferred.ok (return (`Flow (Service.pack service flow)))) + in let events = match timeout with | None -> [ close; accept ] @@ -245,7 +246,7 @@ module TCP = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end - let service = S.register ~service:(module Service) + let service = S.register ~service:(module Service) ~protocol let resolve ~port = function | Conduit.Endpoint.IP ip -> diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 56726b54..8fdb2cab 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -15,8 +15,8 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service val serve : ?timeout:int -> - handler:('flow -> unit Async.Deferred.t) -> - service:('cfg, 'master, 'flow) service -> + handler:(flow -> unit Async.Deferred.t) -> + service:('cfg, 't, 'v) service -> 'cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) (** [serve ~handler ~service cfg] creates an usual infinite [service] diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 28f719c6..89f4a78a 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -23,6 +23,10 @@ let reword_error f = function Ok x -> Ok x | Error err -> Error (f err) let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt +let src = Logs.Src.create "conduit" + +module Log = (val Logs.src_log src : Logs.LOG) + [@@@warning "-37"] type ('a, 'b, 'c) thd = @@ -148,27 +152,32 @@ module type S = sig ('cfg1, 't1, 'flow1) service -> (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option - val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service + val register : + service:('cfg, 't, 'v) impl -> + protocol:(_, 'v) protocol -> + ('cfg, 't, 'v) service type error = [ `Msg of string ] val pp_error : error Fmt.t val init : - 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result io + 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io val accept : - service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result io + service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io val close : - service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io + service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io + + val pack : (_, _, 'v) service -> 'v -> flow val impl : - ('cfg, 't, 'flow) service -> + ('cfg, 't, 'v) service -> (module SERVICE with type configuration = 'cfg and type t = 't - and type flow = 'flow) + and type flow = 'v) end end @@ -391,8 +400,12 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | [] -> return (List.rev acc) (* XXX(dinosaure): keep order. *) | Map.Value (k, Resolver { resolve; witness; _ }) :: r -> match scheduler witness with - | None -> go acc r + | None -> + Log.warn (fun m -> + m "A resolver with another scheduler exists in the given map.") ; + go acc r | Some Refl.Refl -> ( + Log.debug (fun m -> m "Try a possible protocol.") ; resolve domain_name |> prj >>= function | Some edn -> go (Endpoint (k, edn) :: acc) r | None -> go acc r) in @@ -403,6 +416,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | None, Some _ -> sup | Some _, None -> inf | None, None -> 0 in + Log.debug (fun m -> m "Start to resolve %a." Endpoint.pp domain_name) ; go [] (List.sort compare (Map.bindings m)) let create : resolvers -> Endpoint.t -> (flow, [> error ]) result io = @@ -483,18 +497,24 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : module F = struct type 't t = - | Service : 'cfg key * ('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) thd t + | Svc : 'cfg key * ('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) thd t end module Svc = E0.Make (F) - type ('cfg, 't, 'flow) service = ('cfg, 't, 'flow) thd Svc.s + type ('cfg, 't, 'flow) service = + | Service : + ('cfg, 't, 'flow) thd Svc.s * (_, 'flow) protocol + -> ('cfg, 't, 'flow) service let register : - type cfg t flow. service:(cfg, t, flow) impl -> (cfg, t, flow) service = - fun ~service -> + type cfg t flow. + service:(cfg, t, flow) impl -> + protocol:(_, flow) protocol -> + (cfg, t, flow) service = + fun ~service ~protocol -> let cfg = Map.Key.create "" in - Svc.inj (Service (cfg, service)) + Service (Svc.inj (Svc (cfg, service)), protocol) type error = [ `Msg of string ] @@ -505,36 +525,39 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : (a, b, c) service -> (d, e, f) service -> ((a, d) refl * (b, e) refl * (c, f) refl) option = - fun (module A) (module B) -> + fun (Service ((module A), _)) (Service ((module B), _)) -> match A.Id with B.Id -> Some (Refl, Refl, Refl) | _ -> None let init : type cfg t flow. cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result io = - fun edn ~service:(module Witness) -> - let (Service (_, (module Service))) = Witness.witness in + fun edn ~service:(Service ((module Witness), _)) -> + let (Svc (_, (module Service))) = Witness.witness in Service.init edn >>= function | Ok t -> return (Ok t) | Error err -> return (error_msgf "%a" Service.pp_error err) let accept : - type cfg t flow. - service:(cfg, t, flow) service -> t -> (flow, [> error ]) result io = - fun ~service:(module Witness) t -> - let (Service (_, (module Service))) = Witness.witness in + type cfg t v. + service:(cfg, t, v) service -> t -> (flow, [> error ]) result io = + fun ~service:(Service ((module Witness), protocol)) t -> + let (Svc (_, (module Service))) = Witness.witness in Service.accept t >>= function - | Ok flow -> return (Ok flow) + | Ok flow -> return (Ok (pack protocol flow)) | Error err -> return (error_msgf "%a" Service.pp_error err) let close : type cfg t flow. service:(cfg, t, flow) service -> t -> (unit, [> error ]) result io = - fun ~service:(module Witness) t -> - let (Service (_, (module Service))) = Witness.witness in + fun ~service:(Service ((module Witness), _)) t -> + let (Svc (_, (module Service))) = Witness.witness in Service.close t >>= function | Ok () -> return (Ok ()) | Error err -> return (error_msgf "%a" Service.pp_error err) + let pack : type v. (_, _, v) service -> v -> flow = + fun (Service (_, protocol)) flow -> pack protocol flow + let impl : type cfg t flow. (cfg, t, flow) service -> @@ -542,8 +565,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : with type configuration = cfg and type t = t and type flow = flow) = - fun (module S) -> - let (Service (_, (module Service))) = S.witness in + fun (Service ((module S), _)) -> + let (Svc (_, (module Service))) = S.witness in (module Service) end end diff --git a/src/core/conduit.mli b/src/core/conduit.mli index c5c5ec5c..3fa4e853 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -345,20 +345,24 @@ module type S = sig | _ -> assert false ]} *) - val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service - (** [register ~service] is the service using the implementation [service]. - [service] must define [make] and [accept] function to be able to create - server-side flows. + val register : + service:('cfg, 't, 'v) impl -> + protocol:(_, 'v) protocol -> + ('cfg, 't, 'v) service + (** [register ~service ~protocool] is the service using the implementation [service] + bound with implementation of a [protocol]. [service] must define [make] and [accept] + function to be able to create server-side flows. For instance: {[ - module TCP : SERVICE with type configuration = Unix.sockaddr - and type t = Unix.file_descr - and type flow = Unix.file_descr + 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 ~protocol:(module TCP_protocol) let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = - Service.register ~service:(module TCP) + Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol ]} *) @@ -367,25 +371,49 @@ module type S = sig val pp_error : error Fmt.t val init : - 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result io + 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io (** [init cfg ~service] initialises the service with the configuration [cfg]. *) val accept : - service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result io + service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io (** [accept service t] waits for a connection on the service [t]. The result is a {i flow} connected to the client. *) val close : - service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io + service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io (** [close ~service t] releases the resources associated to the server [t]. *) + val pack : (_, _, 'v) service -> 'v -> flow + (** [pack service v] returns the abstracted value [v] as {!pack} does + for a given protocol {i witness} (bound with the given [service]). + It serves to abstract the flow created (and initialised) by the + service to a {!flow}. + + {[ + let handler (flow : Conduit.flow) = + Conduit.send flow "Hello World!" >>= fun _ -> + ... + + let run ~service cfg = + let module Service = Conduit.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 + async (fun () -> handler flow) ; loop t in + loop t + + let () = run ~service:tcp_service (localhost, 8080) + let () = run ~service:tls_service (certs, (localhost, 8080)) + ]} *) + val impl : - ('cfg, 't, 'flow) service -> + ('cfg, 't, 'v) service -> (module SERVICE with type configuration = 'cfg and type t = 't - and type flow = 'flow) + and type flow = 'v) (** [impl service] is [service]'s underlying implementation. *) end end diff --git a/src/core/dune b/src/core/dune index 7b91c74f..3de45019 100644 --- a/src/core/dune +++ b/src/core/dune @@ -1,7 +1,7 @@ (library (name conduit) (public_name conduit) - (libraries stdlib-shims ipaddr domain-name)) + (libraries stdlib-shims logs ipaddr domain-name)) (documentation (package conduit) diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index 2c011184..e88f97fb 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -116,14 +116,14 @@ let service_with_ssl : file_descr:(flow -> Lwt_unix.file_descr) -> (edn, Lwt_ssl.socket) Conduit_lwt.protocol -> (Ssl.context * cfg, t service, Lwt_ssl.socket) Conduit_lwt.Service.service = - fun service ~file_descr _ -> + fun service ~file_descr protocol -> let module S = (val Conduit_lwt.Service.impl service) in let module M = Service (struct include S let file_descr = file_descr end) in - Conduit_lwt.Service.register ~service:(module M) + Conduit_lwt.Service.register ~service:(module M) ~protocol module TCP = struct let resolve ~port ~context ?verify domain_name = diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index cd8f629a..db6d4c78 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -56,10 +56,10 @@ let io_of_flow flow = let ( >>? ) = Lwt_result.bind let serve : - type cfg service flow. + type cfg service v. ?timeout:int -> handler:(flow -> unit Lwt.t) -> - service:(cfg, service, flow) Service.service -> + service:(cfg, service, v) Service.service -> cfg -> unit Lwt_condition.t * (unit -> unit Lwt.t) = fun ?timeout ~handler ~service cfg -> @@ -69,11 +69,12 @@ let serve : let main () = Service.init cfg ~service >>= function | Error err -> failwith "%a" Service.pp_error err - | Ok service -> ( + | Ok t -> ( let rec loop () = let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = - Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in + Svc.accept t >>? fun flow -> + Lwt.return_ok (`Flow (Service.pack service flow)) in let events = match timeout with | None -> [ stop; accept ] @@ -87,9 +88,9 @@ let serve : | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok (`Stop | `Timeout) -> Svc.close service + | Ok (`Stop | `Timeout) -> Svc.close t | Error err0 -> ( - Svc.close service >>= function + Svc.close t >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function @@ -414,7 +415,7 @@ module TCP = struct include (val repr protocol) - let service = S.register ~service:(module Service) + let service = S.register ~service:(module Service) ~protocol let resolve ~port = function | Conduit.Endpoint.IP ip -> diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 5a106b1b..a42ba0f3 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -24,8 +24,8 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service val serve : ?timeout:int -> - handler:('flow -> unit Lwt.t) -> - service:('cfg, 'service, 'flow) service -> + handler:(flow -> unit Lwt.t) -> + service:('cfg, 'service, 'v) service -> 'cfg -> unit Lwt_condition.t * (unit -> unit Lwt.t) (** [serve ~handler ~service cfg] creates an usual infinite [service] diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index 89e539de..49bc4c4d 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -22,7 +22,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct let ( >>? ) x f = x >>= function Ok x -> f x | Error err -> Lwt.return (Error err) - let src = Logs.Src.create "tuyau-mirage-tcpip" + let src = Logs.Src.create "conduit-mirage-tcpip" module Log = (val Logs.src_log src : Logs.LOG) @@ -76,10 +76,15 @@ module Make (StackV4 : Mirage_stack.V4) = struct type nonrec endpoint = endpoint let connect { stack; keepalive; nodelay; ip; port } = + Log.debug (fun m -> + m "Start to create a connection to <%a:%d>." Ipaddr.V4.pp ip port) ; let tcpv4 = StackV4.tcpv4 stack in StackV4.TCPV4.create_connection tcpv4 ?keepalive (ip, port) >|= R.reword_error error >>? fun flow -> + Log.debug (fun m -> + let ip, port = StackV4.TCPV4.dst flow in + m "Connection created on <%a:%d>." Ipaddr.V4.pp ip port) ; let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in Lwt.return (Ok { flow; nodelay; queue; closed = false }) @@ -269,5 +274,6 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt.return (Ok ())) end - let service = Conduit_mirage.Service.register ~service:(module Service) + let service = + Conduit_mirage.Service.register ~service:(module Service) ~protocol end diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 44f9171a..40abfe04 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -364,8 +364,8 @@ struct t service_with_tls, flow protocol_with_tls ) Conduit.Service.service = - fun service _ -> + fun service protocol -> let module Service = (val Conduit.Service.impl service) in let module M = Make_server (Service) in - Conduit.Service.register ~service:(module M) + Conduit.Service.register ~service:(module M) ~protocol end diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index d3c8b058..bdea5542 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -5,8 +5,8 @@ module type S = sig val serve : ?timeout:int -> - handler:('flow -> unit io) -> - service:('cfg, 'master, 'flow) Service.service -> + handler:(flow -> unit io) -> + service:('cfg, 'master, 'v) Service.service -> 'cfg -> unit condition * (unit -> unit io) end @@ -112,15 +112,11 @@ struct | Ok () -> return () let server : - type cfg service flow. + type cfg service. cfg -> - protocol:(_, flow) Conduit.protocol -> - service:(cfg, service, flow) Conduit.Service.service -> + service:(cfg, service, 'flow) Conduit.Service.service -> unit Condition.t * (unit -> unit IO.t) = - fun cfg ~protocol ~service -> - Conduit.serve - ~handler:(fun flow -> transmission (Conduit.pack protocol flow)) - ~service cfg + fun cfg ~service -> Conduit.serve ~handler:transmission ~service cfg (* part *) diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index e9336296..6a2346a5 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -47,12 +47,11 @@ let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : type cfg service flow. cfg -> - protocol:(_, flow) Conduit_async.protocol -> service:(cfg, service, flow) Conduit_async.Service.service -> string list -> unit = - fun cfg ~protocol ~service clients -> - let stop, server = server (* ~launched ~stop *) cfg ~protocol ~service in + fun cfg ~service clients -> + let stop, server = server (* ~launched ~stop *) cfg ~service in let clients = Async.after Core.Time.Span.(of_sec 0.5) >>= fun () -> (* XXX(dinosaure): [async] tries to go further and fibers @@ -70,7 +69,7 @@ let run_with : let run_with_tcp clients = run_with (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 5000)) - ~protocol:tcp_protocol ~service:tcp_service clients + ~service:tcp_service clients let load_file filename = let open Stdlib in @@ -95,7 +94,7 @@ let run_with_tls cert key clients = let ctx = config cert key in run_with (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 9000), ctx) - ~protocol:tls_protocol ~service:tls_service clients + ~service:tls_service clients let () = match Array.to_list Stdlib.Sys.argv with diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 573d3a35..40777470 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -60,12 +60,11 @@ let config cert key = let run_with : type cfg service flow. cfg -> - protocol:(_, flow) Conduit_lwt.protocol -> service:(cfg, service, flow) Conduit_lwt.Service.service -> string list -> unit = - fun cfg ~protocol ~service clients -> - let stop, server = server cfg ~protocol ~service in + fun cfg ~service clients -> + let stop, server = server cfg ~service in let clients = List.map (client ~resolvers) clients in let clients = Lwt.join clients >>= fun () -> @@ -79,7 +78,7 @@ let run_with_tcp clients = Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); capacity = 40; } - ~protocol:Conduit_lwt.TCP.protocol ~service:Conduit_lwt.TCP.service clients + ~service:Conduit_lwt.TCP.service clients let run_with_tls cert key clients = let ctx = config cert key in @@ -89,7 +88,7 @@ let run_with_tls cert key clients = capacity = 40; }, ctx ) - ~protocol:tls_protocol ~service:tls_service clients + ~service:tls_service clients let () = match Array.to_list Sys.argv with From e4af12adb60fc3c33153aaa6bb29bfc7785cf17a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 12:01:36 +0100 Subject: [PATCH 112/140] Remove module types duplication --- src/core/conduit.ml | 145 +--------- src/core/conduit.mli | 418 +-------------------------- src/core/conduit_intf.ml | 521 ++++++++++++++++++++++++++++++++++ src/core/sigs.ml | 109 ------- tests/ping-pong/with_async.ml | 7 +- tests/ping-pong/with_lwt.ml | 7 +- 6 files changed, 539 insertions(+), 668 deletions(-) create mode 100644 src/core/conduit_intf.ml delete mode 100644 src/core/sigs.ml diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 89f4a78a..212a51bf 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -1,7 +1,5 @@ module Endpoint = Endpoint -module Sigs = Sigs - -type ('a, 'b) refl = Refl : ('a, 'a) refl +include Conduit_intf let strf = Format.asprintf @@ -17,8 +15,6 @@ type _ resolver = } -> ('edn * 's) resolver -type ('a, 'b) value = Value : 'b -> ('a, 'b) value - let reword_error f = function Ok x -> Ok x | Error err -> Error (f err) let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt @@ -52,139 +48,6 @@ type resolvers = Map.t let empty = Map.empty -module type S = sig - module Endpoint : module type of Endpoint - - type input - - type output - - type +'a io - - type scheduler - - type flow = private .. - - type error = [ `Msg of string | `Not_found ] - - val pp_error : error Fmt.t - - val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io - - val send : flow -> output -> (int, [> error ]) result io - - val close : flow -> (unit, [> error ]) result io - - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a io = 'a io - - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a io = 'a io - - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - type ('edn, 'flow) protocol - - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - - module type REPR = sig - type t - - type flow += T of t - end - - val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) - - type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - - val unpack : flow -> unpack - - val impl : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - - val cast : flow -> ('edn, 'flow) protocol -> 'flow option - - val pack : ('edn, 'v) protocol -> 'v -> flow - - type 'edn resolver = Endpoint.t -> 'edn option io - - type nonrec resolvers = resolvers - - val empty : resolvers - - val add : - ('edn, 'flow) protocol -> - ?priority:int -> - 'edn resolver -> - resolvers -> - resolvers - - val resolve : - resolvers -> - ?protocol:('edn, 'v) protocol -> - Endpoint.t -> - (flow, [> error ]) result io - - val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io - - module type SERVICE = Sigs.SERVICE with type +'a io = 'a io - - module Service : sig - type ('cfg, 't, 'flow) impl = - (module SERVICE - with type configuration = 'cfg - and type t = 't - and type flow = 'flow) - - type ('cfg, 't, 'flow) service - - val equal : - ('cfg0, 't0, 'flow0) service -> - ('cfg1, 't1, 'flow1) service -> - (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option - - val register : - service:('cfg, 't, 'v) impl -> - protocol:(_, 'v) protocol -> - ('cfg, 't, 'v) service - - type error = [ `Msg of string ] - - val pp_error : error Fmt.t - - val init : - 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io - - val accept : - service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io - - val close : - service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io - - val pack : (_, _, 'v) service -> 'v -> flow - - val impl : - ('cfg, 't, 'v) service -> - (module SERVICE - with type configuration = 'cfg - and type t = 't - and type flow = 'v) - end -end - -module type IO = Sigs.IO - -module type BUFFER = Sigs.BUFFER - module type BIJECTION = sig type +'a s @@ -241,13 +104,13 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : type output = Output.t module type PROTOCOL = - Sigs.PROTOCOL + PROTOCOL with type input = input and type output = output and type +'a io = 'a io module type FLOW = - Sigs.FLOW + FLOW with type input = input and type output = output and type +'a io = 'a io @@ -486,7 +349,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | Some (Value flow) -> Some flow | None -> None - module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + module type SERVICE = SERVICE with type +'a io = 'a io module Service = struct type ('cfg, 't, 'flow) impl = diff --git a/src/core/conduit.mli b/src/core/conduit.mli index 3fa4e853..45d7ebf5 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -1,427 +1,21 @@ module Endpoint = Endpoint -type ('a, 'b) refl = Refl : ('a, 'a) refl - type resolvers (** Type for resolvers map. *) val empty : resolvers (** [empty] is an empty {!resolvers} map. *) -type ('edn, 'flow) value = Value : 'flow -> ('edn, 'flow) value - -module type S = sig - module Endpoint : module type of Endpoint - - type input - (** The type for payload inputs. *) - - type output - (** The type for payload outputs. *) - - type +'a io - (** The type for I/O effects. *) - - type scheduler - (** The type of I/O monads. *) - - (** {2:client Client-side conduits.} *) - - type flow = private .. - (** The type for generic flows. {!PROTOCOL} implementations are extending (via - {!register}) this type. It allows users to extract the underlying flow - 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))) -> ... - | _ -> ... (* use flow functions for the default case *) - ]} - *) - - type error = [ `Msg of string | `Not_found ] - - val pp_error : error Fmt.t - - val recv : - flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io - (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been - received from the flow [flow] and copied in [input]. *) - - val send : flow -> output -> (int, [> error ]) result io - (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been - sent over the flow [flow]. *) - - val close : flow -> (unit, [> error ]) result io - (** [close flow] closes [flow]. Subsequent calls to {!recv} will return - [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) - - (** {2:registration Protocol registration.} *) - - (** A flow is a system that allows entities to transmit {i payloads}. These - entities do not have to care about the underlying transport mechanism. - flows simply deal with routing and delivering of these payloads. That - abstraction allows these protocols to compose. - - For example, the Transmission Control Protocol (TCP) is representable as a - flow, because it is able to encapsulate some {i payloads} without - interpreting it. A counter-example is the Simple Mail Transfer Protocol - (SMTP) which needs an interpretation of its {i payloads}: tokens such as - [EHLO] or [QUIT] have a direct incidence over the life-cycle of the - connection. - - An other protocol representable as a flow is the Transport Layer Security - (TLS), as it deals only with privacy and data integrity. [Conduit] is able - to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level - protocols can be built in top of these abstract flows: for instance, Secure - Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure - (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these - can be abstracted to work over any flow implementations. *) - module type FLOW = - Sigs.FLOW - with type input = input - and type output = output - and type +'a io = 'a io - - (** A protocol is a {!FLOW} plus [connect]. *) - module type PROTOCOL = - Sigs.PROTOCOL - with type input = input - and type output = output - and type +'a io = 'a io - - type ('edn, 'flow) impl = - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - (** The type to represent a module {!PROTOCOL}. *) - - type ('edn, 'flow) protocol - (** The type for client protocols. ['edn] is the type for endpoint parameters. - ['flow] is the type for underlying flows. - - Endpoints allow users to create flows by either connecting directly to a - remote server or by resolving domain names (with {!connect}). *) - - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - (** [register ~protocol] is the protocol using the implementation [protocol]. - [protocol] must provide a [connect] function to allow client flows to be - created. - - For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow - endpoints, while [Unix.file_descr] would be used for the flow transport. - - {[ - module Conduit_tcp : sig - val t : (Unix.sockaddr, Unix.file_descr) protocol - end = struct - let t = register ~protocol:(module TCP) - end - ]} - - Client endpoints can of course be more complex, for instance to hold TLS - credentials, and [Conduit] allows all these kinds of flow to be used - transparently: - - {[ - module Conduit_tcp_tls : sig - val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol - end = struct - let t = register ~protocol:(module TLS) - end - ]} - - As a protocol implementer, you must {i register} your implementation and - expose the {i witness} of it. Then, users will be able to use it. *) - - (** {2 Injection and Extraction.} - - The goal of [Conduit] is to provide: - {ul - {- A way to manipulate a fully-abstract [flow].} - {- A way to manipulate a concrete and well-know [flow].}} - - [Conduit] provides several mechanisms to be able to manipulate our abstract - type {!flow} and destruct it to a concrete value such as a [Unix.file_descr]. - [Conduit] can assert one assumption: from a given abstracted [flow], it exists - one and only one {!FLOW} implementation. - - As [Conduit] determines this implementation, the user can determine the used - implementation when he wants to {!send} or {!recv} datas. - - So [Conduit] uses or extracts uniqely the implementation registered before - with {!register} and no layer can tweak or update this assertion. - - {!repr}, {!flow}, {!impl} and {!is} can extracts in differents ways the - abstracted {!flow}: - {ul - {- with the {i pattern-matching}} - {- with {i first-class module}} - {- with the function {!is}}} - *) - - module type REPR = sig - type t - - 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: - - {[ - module Conduit_tcp : sig - type t = (Unix.sockaddr, Unix.file_descr) Conduit.value - type Conduit.flow += T of t - val t : (Unix.sockaddr, Unix.file_descr) protocol - end = struct - let t = register ~protocol:(module TCP) - include (val (Conduit.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) -> ... - | _ -> ... - ]} - *) - - type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - - val unpack : flow -> unpack - (** [pack flow] projects the module implementation associated to the given - abstract [flow] such as: +type ('edn, 'flow) value = ('edn, 'flow) Conduit_intf.value = + | Value : 'flow -> ('edn, 'flow) value - {[ - Conduit.connect edn >>= fun flow -> - let Conduit.Flow (flow, (module Flow)) = Conduit.unpack flow in - Flow.send flow "Hello World!" - ]} - *) - - val impl : - ('edn, 'flow) protocol -> - (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) - (** [impl protocol] is [protocol]'s implementation. *) - - val cast : flow -> (_, 'flow) protocol -> 'flow option - (** [cast flow protocol] tries to {i cast} the given [flow] to the concrete - type described by the given [protocol]. - - {[ - match Conduit.is flow Conduit_tcp.t with - | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) - | None -> None - ]} - *) - - val pack : (_, 'v) protocol -> 'v -> flow - (** [pack protocol concrete_flow] abstracts the given [flow] into the - {!flow} type from a given [protocol]. It permits to use [Conduit] with a - concrete value created by the user. - - {[ - 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!" - ]} - *) - - (** {2:resolution Domain name resolvers.} *) - - type 'edn resolver = Endpoint.t -> 'edn option io - (** The type for resolver functions, which resolve domain names to endpoints. - For instance, the DNS resolver function is: - - {[ - let http_resolver : Unix.sockaddr resolver = function - | IP ip -> Some (Ipaddr_unix.to_inet_addr ip, 80) - | Domain domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) - else None - | exception _ -> None - ]} - *) - - type nonrec resolvers = resolvers - - val empty : resolvers - - val add : - ('edn, _) protocol -> - ?priority:int -> - 'edn resolver -> - resolvers -> - resolvers - (** [add protocol ?priority resolver resolvers] adds a new resolver function - [resolver] to [resolvers]. - - When the [resolver] is able to resolve the given domain name, it will try - to connect to the specified client endpoint. Resolvers are iterated in - priority order (lower to higher). - - {[ - let http_resolver = ... - let https_resolver = ... (* deal with client-side certificates here. *) - - let resolvers = - empty - |> add Conduit_tcp.t http_resolver - |> add Conduit_tcp_tls.t https_resolver ~priority:10 - |> add Conduit_tcp_ssl.t https_resolver ~priority:20 - ]} *) - - val resolve : - resolvers -> - ?protocol:('edn, 'v) protocol -> - Endpoint.t -> - (flow, [> error ]) result io - (** [resolve resolvers domain_name] is the flow created by connecting to the - domain name [domain_name], using the resolvers [resolvers]. Each resolver - tries to resolve the given domain-name (they are ordered by the given - priority). The first which connects successfully wins. - - The resolver result is a flow connect to that winning endpoint. - - {[ - let mirage_io = domain_name_exn "mirage.io" - - val resolver_on_my_private_network : Unix.sockaddr resolver - val resolver_on_internet : Unix.sockaddr resolver - val resolver_with_tls : (Unix.sockaddr * Tls.Config.client) resolver - - let resolvers = - empty - |> add tls ~priority:0 resolver_with_tls - |> add tcp ~priority:10 resolver_on_my_private_network - |> 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 -> - let peer = Unix.getpeername file_descr in - ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) - | flow -> - ignore @@ Conduit.send flow "Hello World!" - ]} - *) - - val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io - - (** {2:service Server-side conduits.} *) - - module type SERVICE = Sigs.SERVICE with type +'a io = 'a io - - module Service : sig - type ('cfg, 't, 'flow) impl = - (module SERVICE - with type configuration = 'cfg - and type t = 't - and type flow = 'flow) - - type ('cfg, 't, 'flow) service - (** The type for services, e.g. service-side protocols. ['cfg] is the type - for configuration, ['t] is the type for state states. ['flow] is the type - for underlying flows. *) - - val equal : - ('cfg0, 't0, 'flow0) service -> - ('cfg1, 't1, 'flow1) service -> - (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option - (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are - physically the same. For instance, [Conduit] asserts: - - {[ - let service = Service.register ~service:(module V) ;; - - let () = match Service.equal service service with - | Some (Refl, Refl, Refl) -> ... - | _ -> assert false - ]} *) - - val register : - service:('cfg, 't, 'v) impl -> - protocol:(_, 'v) protocol -> - ('cfg, 't, 'v) service - (** [register ~service ~protocool] is the service using the implementation [service] - bound with implementation of a [protocol]. [service] must define [make] and [accept] - function to be able to create server-side flows. - - 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 ~protocol:(module TCP_protocol) - let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = - Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol - ]} - *) - - type error = [ `Msg of string ] - - val pp_error : error Fmt.t - - val init : - 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io - (** [init cfg ~service] initialises the service with the - configuration [cfg]. *) - - val accept : - service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io - (** [accept service t] waits for a connection on the service [t]. The result - is a {i flow} connected to the client. *) - - val close : - service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io - (** [close ~service t] releases the resources associated to the server [t]. *) - - val pack : (_, _, 'v) service -> 'v -> flow - (** [pack service v] returns the abstracted value [v] as {!pack} does - for a given protocol {i witness} (bound with the given [service]). - It serves to abstract the flow created (and initialised) by the - service to a {!flow}. - - {[ - let handler (flow : Conduit.flow) = - Conduit.send flow "Hello World!" >>= fun _ -> - ... - - let run ~service cfg = - let module Service = Conduit.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 - async (fun () -> handler flow) ; loop t in - loop t - - let () = run ~service:tcp_service (localhost, 8080) - let () = run ~service:tls_service (certs, (localhost, 8080)) - ]} *) - - val impl : - ('cfg, 't, 'v) service -> - (module SERVICE - with type configuration = 'cfg - and type t = 't - and type flow = 'v) - (** [impl service] is [service]'s underlying implementation. *) - end -end +module type S = Conduit_intf.S +(** @inline *) -module type IO = Sigs.IO +module type IO = Conduit_intf.IO (** @inline *) -module type BUFFER = Sigs.BUFFER +module type BUFFER = Conduit_intf.BUFFER (** @inline *) module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml new file mode 100644 index 00000000..2c21478b --- /dev/null +++ b/src/core/conduit_intf.ml @@ -0,0 +1,521 @@ +type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] + +module type FLOW = sig + (** [FLOW] is the signature for flow clients. + + A [flow] is an abstract value over which I/O functions such as {!send}, + {!recv} and {!close} can be used. + + {[ + type input = bytes and output = string + type +'a s = 'a + + let process flow = + let buf = Bytes.create 0x1000 in + match Flow.recv flow buf with + | Ok (`Input len) -> + let str = Bytes.sub_string buf 0 len in + ignore (Flow.send flow str) + | _ -> failwith "Flow.recv" + ]} + + The given flow can be more complex than a simple TCP flow for example. It + can be wrapped into a TLS layer. However, the goal is to be able to implement + a protocol without such complexity. + *) + + type +'a io + + type flow + + (** {3 Input & Output.} + + Depending on the I/O model, the type for inputs and outputs can differ ; + for instance they could allow users the ability to define capabilities on + them such as {i read} or {i write} capabilities. + + However, in most of the current [Conduit] backends: + + {[ + type input = Cstruct.t + type output = Cstruct.t + ]} + *) + + type input + + and output + + (** {3 Errors.} *) + + type error + (** The type for errors. *) + + val pp_error : error Fmt.t + (** [pp_error] is the pretty-printer for {!error}. *) + + val recv : flow -> input -> (int or_end_of_flow, error) result io + (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from + the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, error) result io + (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, error) result io + (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will + return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an + [Error]. *) +end + +module type PROTOCOL = sig + include FLOW + + type endpoint + + val connect : endpoint -> (flow, error) result io +end + +module type SERVICE = sig + type +'a io + + type flow + + type t + + type error + + type configuration + + val init : configuration -> (t, error) result io + + val pp_error : error Fmt.t + + val accept : t -> (flow, error) result io + + val close : t -> (unit, error) result io +end + +module type IO = sig + type +'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t +end + +module type BUFFER = sig + type t +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 + + type input + (** The type for payload inputs. *) + + type output + (** The type for payload outputs. *) + + type +'a io + (** The type for I/O effects. *) + + type scheduler + (** The type of I/O monads. *) + + (** {2:client Client-side conduits.} *) + + type flow = private .. + (** The type for generic flows. {!PROTOCOL} implementations are extending (via + {!register}) this type. It allows users to extract the underlying flow + 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))) -> ... + | _ -> ... (* use flow functions for the default case *) + ]} + *) + + type error = [ `Msg of string | `Not_found ] + + val pp_error : error Fmt.t + + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io + (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been + received from the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, [> error ]) result io + (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, [> error ]) result io + (** [close flow] closes [flow]. Subsequent calls to {!recv} will return + [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) + + (** {2:registration Protocol registration.} *) + + (** A flow is a system that allows entities to transmit {i payloads}. These + entities do not have to care about the underlying transport mechanism. + flows simply deal with routing and delivering of these payloads. That + abstraction allows these protocols to compose. + + For example, the Transmission Control Protocol (TCP) is representable as a + flow, because it is able to encapsulate some {i payloads} without + interpreting it. A counter-example is the Simple Mail Transfer Protocol + (SMTP) which needs an interpretation of its {i payloads}: tokens such as + [EHLO] or [QUIT] have a direct incidence over the life-cycle of the + connection. + + An other protocol representable as a flow is the Transport Layer Security + (TLS), as it deals only with privacy and data integrity. [Conduit] is able + to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level + protocols can be built in top of these abstract flows: for instance, Secure + Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure + (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these + can be abstracted to work over any flow implementations. *) + module type FLOW = + FLOW + with type input = input + and type output = output + and type +'a io = 'a io + + (** A protocol is a {!FLOW} plus [connect]. *) + module type PROTOCOL = + PROTOCOL + with type input = input + and type output = output + and type +'a io = 'a io + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** The type to represent a module {!PROTOCOL}. *) + + type ('edn, 'flow) protocol + (** The type for client protocols. ['edn] is the type for endpoint parameters. + ['flow] is the type for underlying flows. + + Endpoints allow users to create flows by either connecting directly to a + remote server or by resolving domain names (with {!connect}). *) + + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol + (** [register ~protocol] is the protocol using the implementation [protocol]. + [protocol] must provide a [connect] function to allow client flows to be + created. + + For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow + endpoints, while [Unix.file_descr] would be used for the flow transport. + + {[ + module Conduit_tcp : sig + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + end + ]} + + Client endpoints can of course be more complex, for instance to hold TLS + credentials, and [Conduit] allows all these kinds of flow to be used + transparently: + + {[ + module Conduit_tcp_tls : sig + val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TLS) + end + ]} + + As a protocol implementer, you must {i register} your implementation and + expose the {i witness} of it. Then, users will be able to use it. *) + + (** {2 Injection and Extraction.} + + The goal of [Conduit] is to provide: + {ul + {- A way to manipulate a fully-abstract [flow].} + {- A way to manipulate a concrete and well-know [flow].}} + + [Conduit] provides several mechanisms to be able to manipulate our abstract + type {!flow} and destruct it to a concrete value such as a [Unix.file_descr]. + [Conduit] can assert one assumption: from a given abstracted [flow], it exists + one and only one {!FLOW} implementation. + + As [Conduit] determines this implementation, the user can determine the used + implementation when he wants to {!send} or {!recv} datas. + + So [Conduit] uses or extracts uniqely the implementation registered before + with {!register} and no layer can tweak or update this assertion. + + {!repr}, {!flow}, {!impl} and {!is} can extracts in differents ways the + abstracted {!flow}: + {ul + {- with the {i pattern-matching}} + {- with {i first-class module}} + {- with the function {!is}}} + *) + + module type REPR = sig + type t + + 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: + + {[ + module Conduit_tcp : sig + type t = (Unix.sockaddr, Unix.file_descr) Conduit.value + type Conduit.flow += T of t + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + include (val (Conduit.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) -> ... + | _ -> ... + ]} + *) + + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack + + val unpack : flow -> unpack + (** [pack flow] projects the module implementation associated to the given + abstract [flow] such as: + + {[ + Conduit.connect edn >>= fun flow -> + let Conduit.Flow (flow, (module Flow)) = Conduit.unpack flow in + Flow.send flow "Hello World!" + ]} + *) + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** [impl protocol] is [protocol]'s implementation. *) + + val cast : flow -> (_, 'flow) protocol -> 'flow option + (** [cast flow protocol] tries to {i cast} the given [flow] to the concrete + type described by the given [protocol]. + + {[ + match Conduit.is flow Conduit_tcp.t with + | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) + | None -> None + ]} + *) + + val pack : (_, 'v) protocol -> 'v -> flow + (** [pack protocol concrete_flow] abstracts the given [flow] into the + {!flow} type from a given [protocol]. It permits to use [Conduit] with a + concrete value created by the user. + + {[ + 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!" + ]} + *) + + (** {2:resolution Domain name resolvers.} *) + + type 'edn resolver = Endpoint.t -> 'edn option io + (** The type for resolver functions, which resolve domain names to endpoints. + For instance, the DNS resolver function is: + + {[ + let http_resolver : Unix.sockaddr resolver = function + | IP ip -> Some (Ipaddr_unix.to_inet_addr ip, 80) + | Domain domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) + else None + | exception _ -> None + ]} + *) + + type resolvers + + val empty : resolvers + + val add : + ('edn, _) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers + (** [add protocol ?priority resolver resolvers] adds a new resolver function + [resolver] to [resolvers]. + + When the [resolver] is able to resolve the given domain name, it will try + to connect to the specified client endpoint. Resolvers are iterated in + priority order (lower to higher). + + {[ + let http_resolver = ... + let https_resolver = ... (* deal with client-side certificates here. *) + + let resolvers = + empty + |> add Conduit_tcp.t http_resolver + |> add Conduit_tcp_tls.t https_resolver ~priority:10 + |> add Conduit_tcp_ssl.t https_resolver ~priority:20 + ]} *) + + val resolve : + resolvers -> + ?protocol:('edn, 'v) protocol -> + Endpoint.t -> + (flow, [> error ]) result io + (** [resolve resolvers domain_name] is the flow created by connecting to the + domain name [domain_name], using the resolvers [resolvers]. Each resolver + tries to resolve the given domain-name (they are ordered by the given + priority). The first which connects successfully wins. + + The resolver result is a flow connect to that winning endpoint. + + {[ + let mirage_io = domain_name_exn "mirage.io" + + val resolver_on_my_private_network : Unix.sockaddr resolver + val resolver_on_internet : Unix.sockaddr resolver + val resolver_with_tls : (Unix.sockaddr * Tls.Config.client) resolver + + let resolvers = + empty + |> add tls ~priority:0 resolver_with_tls + |> add tcp ~priority:10 resolver_on_my_private_network + |> 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 -> + let peer = Unix.getpeername file_descr in + ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) + | flow -> + ignore @@ Conduit.send flow "Hello World!" + ]} + *) + + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io + + (** {2:service Server-side conduits.} *) + + module type SERVICE = SERVICE with type +'a io = 'a io + + module Service : sig + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + + type ('cfg, 't, 'flow) service + (** The type for services, e.g. service-side protocols. ['cfg] is the type + for configuration, ['t] is the type for state states. ['flow] is the type + for underlying flows. *) + + val equal : + ('cfg0, 't0, 'flow0) service -> + ('cfg1, 't1, 'flow1) service -> + (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option + (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are + physically the same. For instance, [Conduit] asserts: + + {[ + let service = Service.register ~service:(module V) ;; + + let () = match Service.equal service service with + | Some (Refl, Refl, Refl) -> ... + | _ -> assert false + ]} *) + + val register : + service:('cfg, 't, 'v) impl -> + protocol:(_, 'v) protocol -> + ('cfg, 't, 'v) service + (** [register ~service ~protocool] is the service using the implementation [service] + bound with implementation of a [protocol]. [service] must define [make] and [accept] + function to be able to create server-side flows. + + 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 ~protocol:(module TCP_protocol) + let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = + Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol + ]} + *) + + type error = [ `Msg of string ] + + val pp_error : error Fmt.t + + val init : + 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io + (** [init cfg ~service] initialises the service with the + configuration [cfg]. *) + + val accept : + service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io + (** [accept service t] waits for a connection on the service [t]. The result + is a {i flow} connected to the client. *) + + val close : + service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io + (** [close ~service t] releases the resources associated to the server [t]. *) + + val pack : (_, _, 'v) service -> 'v -> flow + (** [pack service v] returns the abstracted value [v] as {!pack} does + for a given protocol {i witness} (bound with the given [service]). + It serves to abstract the flow created (and initialised) by the + service to a {!flow}. + + {[ + let handler (flow : Conduit.flow) = + Conduit.send flow "Hello World!" >>= fun _ -> + ... + + let run ~service cfg = + let module Service = Conduit.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 + async (fun () -> handler flow) ; loop t in + loop t + + let () = run ~service:tcp_service (localhost, 8080) + let () = run ~service:tls_service (certs, (localhost, 8080)) + ]} *) + + val impl : + ('cfg, 't, 'v) service -> + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'v) + (** [impl service] is [service]'s underlying implementation. *) + end +end diff --git a/src/core/sigs.ml b/src/core/sigs.ml deleted file mode 100644 index f0325550..00000000 --- a/src/core/sigs.ml +++ /dev/null @@ -1,109 +0,0 @@ -type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] - -module type FLOW = sig - (** [FLOW] is the signature for flow clients. - - A [flow] is an abstract value over which I/O functions such as {!send}, - {!recv} and {!close} can be used. - - {[ - type input = bytes and output = string - type +'a s = 'a - - let process flow = - let buf = Bytes.create 0x1000 in - match Flow.recv flow buf with - | Ok (`Input len) -> - let str = Bytes.sub_string buf 0 len in - ignore (Flow.send flow str) - | _ -> failwith "Flow.recv" - ]} - - The given flow can be more complex than a simple TCP flow for example. It - can be wrapped into a TLS layer. However, the goal is to be able to implement - a protocol without such complexity. - *) - - type +'a io - - type flow - - (** {3 Input & Output.} - - Depending on the I/O model, the type for inputs and outputs can differ ; - for instance they could allow users the ability to define capabilities on - them such as {i read} or {i write} capabilities. - - However, in most of the current [Conduit] backends: - - {[ - type input = Cstruct.t - type output = Cstruct.t - ]} - *) - - type input - - and output - - (** {3 Errors.} *) - - type error - (** The type for errors. *) - - val pp_error : error Fmt.t - (** [pp_error] is the pretty-printer for {!error}. *) - - val recv : flow -> input -> (int or_end_of_flow, error) result io - (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from - the flow [flow] and copied in [input]. *) - - val send : flow -> output -> (int, error) result io - (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been - sent over the flow [flow]. *) - - val close : flow -> (unit, error) result io - (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will - return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an - [Error]. *) -end - -module type PROTOCOL = sig - include FLOW - - type endpoint - - val connect : endpoint -> (flow, error) result io -end - -module type SERVICE = sig - type +'a io - - type flow - - type t - - type error - - type configuration - - val init : configuration -> (t, error) result io - - val pp_error : error Fmt.t - - val accept : t -> (flow, error) result io - - val close : t -> (unit, error) result io -end - -module type IO = sig - type +'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - - val return : 'a -> 'a t -end - -module type BUFFER = sig - type t -end diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index 6a2346a5..ae12793d 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -38,9 +38,10 @@ let resolve_tls_ping_pong = Conduit_async_tls.TCP.resolve ~port:9000 ~config let resolvers = - Conduit.empty - |> Conduit_async.add ~priority:10 tls_protocol resolve_tls_ping_pong - |> Conduit_async.add ~priority:20 tcp_protocol resolve_ping_pong + let open Conduit_async in + empty + |> add ~priority:10 tls_protocol resolve_tls_ping_pong + |> add ~priority:20 tcp_protocol resolve_ping_pong let localhost = Domain_name.(host_exn (of_string_exn "localhost")) diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 40777470..4ae38ea3 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -33,9 +33,10 @@ let resolve_tls_ping_pong = Conduit_lwt_tls.TCP.resolve ~port:8000 ~config let resolvers = - Conduit.empty - |> Conduit_lwt.add ~priority:20 Conduit_lwt.TCP.protocol resolve_ping_pong - |> Conduit_lwt.add ~priority:10 tls_protocol resolve_tls_ping_pong + let open Conduit_lwt in + empty + |> add ~priority:20 TCP.protocol resolve_ping_pong + |> add ~priority:10 tls_protocol resolve_tls_ping_pong (* Run *) From ef91c5be5f1f07f291a98767d1415d692eb8e0d5 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 12:07:51 +0100 Subject: [PATCH 113/140] Format comments --- .ocamlformat | 1 - src/async/conduit_async.mli | 16 +- src/core/conduit.ml | 4 +- src/core/conduit_intf.ml | 259 +++++++++++++++--------------- src/core/endpoint.mli | 18 +-- src/lwt-ssl/conduit_lwt_ssl.mli | 19 +-- src/lwt-tls/conduit_lwt_tls.mli | 4 +- src/lwt/conduit_lwt.mli | 54 +++---- src/mirage/conduit_mirage_dns.mli | 4 +- 9 files changed, 189 insertions(+), 190 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index e7aa0a4a..d53ab6be 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -6,4 +6,3 @@ nested-match=align sequence-style=separator break-before-in=auto if-then-else=keyword-first -parse-docstrings=false diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 8fdb2cab..ad1e1cf3 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -19,18 +19,16 @@ val serve : service:('cfg, 't, 'v) service -> 'cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) -(** [serve ~handler ~service cfg] creates an usual infinite [service] - loop from the given configuration ['cfg]. It returns the {i promise} - to launch the loop and a condition variable to stop the loop. +(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from + the given configuration ['cfg]. It returns the {i promise} to launch the + loop and a condition variable to stop the loop. {[ - let stop, loop = serve - ~handler ~service:TCP.service cfg in - Async_unix.Signal.handle [ Core.Signal.int ] - ~f:(fun _sig -> Async.Condition.broadcast stop ()) ; + let stop, loop = serve ~handler ~service:TCP.service cfg in + Async_unix.Signal.handle [ Core.Signal.int ] ~f:(fun _sig -> + Async.Condition.broadcast stop ()) ; loop () - ]} -*) + ]} *) val reader_and_writer_of_flow : flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 212a51bf..9d9d747d 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -28,8 +28,8 @@ module Log = (val Logs.src_log src : Logs.LOG) type ('a, 'b, 'c) thd = | Thd : 'b -> ('a, 'b, 'c) thd (** XXX(dinosaure): we must define [(_, _, _) thd] to be able to keep some - existential types (eg. ['cfg] and ['flow] when we use [('cfg, 't, 'flow) - service]) but still to use only on (eg. ['t]). + existential types (eg. ['cfg] and ['flow] when we use + [('cfg, 't, 'flow) service]) but still to use only on (eg. ['t]). We add [warning "-37"] to be able to compile the project. *) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 2c21478b..4d0f4f18 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -4,25 +4,27 @@ module type FLOW = sig (** [FLOW] is the signature for flow clients. A [flow] is an abstract value over which I/O functions such as {!send}, - {!recv} and {!close} can be used. + {!recv} and {!close} can be used. {[ - type input = bytes and output = string + type input = bytes + + and output = string + type +'a s = 'a let process flow = let buf = Bytes.create 0x1000 in match Flow.recv flow buf with | Ok (`Input len) -> - let str = Bytes.sub_string buf 0 len in - ignore (Flow.send flow str) + let str = Bytes.sub_string buf 0 len in + ignore (Flow.send flow str) | _ -> failwith "Flow.recv" ]} The given flow can be more complex than a simple TCP flow for example. It - can be wrapped into a TLS layer. However, the goal is to be able to implement - a protocol without such complexity. - *) + can be wrapped into a TLS layer. However, the goal is to be able to + implement a protocol without such complexity. *) type +'a io @@ -31,16 +33,16 @@ module type FLOW = sig (** {3 Input & Output.} Depending on the I/O model, the type for inputs and outputs can differ ; - for instance they could allow users the ability to define capabilities on - them such as {i read} or {i write} capabilities. + for instance they could allow users the ability to define capabilities on + them such as {i read} or {i write} capabilities. However, in most of the current [Conduit] backends: {[ type input = Cstruct.t + type output = Cstruct.t - ]} - *) + ]} *) type input @@ -55,17 +57,17 @@ module type FLOW = sig (** [pp_error] is the pretty-printer for {!error}. *) val recv : flow -> input -> (int or_end_of_flow, error) result io - (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from - the flow [flow] and copied in [input]. *) + (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been + received from the flow [flow] and copied in [input]. *) val send : flow -> output -> (int, error) result io (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been - sent over the flow [flow]. *) + sent over the flow [flow]. *) val close : flow -> (unit, error) result io (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will - return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an - [Error]. *) + return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an + [Error]. *) end module type PROTOCOL = sig @@ -131,16 +133,15 @@ module type S = sig type flow = private .. (** The type for generic flows. {!PROTOCOL} implementations are extending (via - {!register}) this type. It allows users to extract the underlying flow - implementation: + {!register}) this type. It allows users to extract the underlying flow + 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))) -> ... - | _ -> ... (* use flow functions for the default case *) - ]} - *) + {[ + 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))) -> ... + | _ -> ... (* use flow functions for the default case *) + ]} *) type error = [ `Msg of string | `Not_found ] @@ -149,37 +150,38 @@ module type S = sig val recv : flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been - received from the flow [flow] and copied in [input]. *) + received from the flow [flow] and copied in [input]. *) val send : flow -> output -> (int, [> error ]) result io (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been - sent over the flow [flow]. *) + sent over the flow [flow]. *) val close : flow -> (unit, [> error ]) result io (** [close flow] closes [flow]. Subsequent calls to {!recv} will return - [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) + [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) (** {2:registration Protocol registration.} *) (** A flow is a system that allows entities to transmit {i payloads}. These - entities do not have to care about the underlying transport mechanism. - flows simply deal with routing and delivering of these payloads. That - abstraction allows these protocols to compose. + entities do not have to care about the underlying transport mechanism. + flows simply deal with routing and delivering of these payloads. That + abstraction allows these protocols to compose. For example, the Transmission Control Protocol (TCP) is representable as a - flow, because it is able to encapsulate some {i payloads} without - interpreting it. A counter-example is the Simple Mail Transfer Protocol - (SMTP) which needs an interpretation of its {i payloads}: tokens such as - [EHLO] or [QUIT] have a direct incidence over the life-cycle of the - connection. + flow, because it is able to encapsulate some {i payloads} without + interpreting it. A counter-example is the Simple Mail Transfer Protocol + (SMTP) which needs an interpretation of its {i payloads}: tokens such as + [EHLO] or [QUIT] have a direct incidence over the life-cycle of the + connection. An other protocol representable as a flow is the Transport Layer Security - (TLS), as it deals only with privacy and data integrity. [Conduit] is able - to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level - protocols can be built in top of these abstract flows: for instance, Secure - Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure - (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these - can be abstracted to work over any flow implementations. *) + (TLS), as it deals only with privacy and data integrity. [Conduit] is able + to compose flows together like [TCP ∘ TLS] to make a new flow. + Higher-level protocols can be built in top of these abstract flows: for + instance, Secure Simple Mail Transfer Protocol (SSMTP) or HyperText + Transfer Protocol Secure (HTTPS) can be defined on top of both TCP and + TLS. Using [Conduit], these can be abstracted to work over any flow + implementations. *) module type FLOW = FLOW with type input = input @@ -199,18 +201,18 @@ module type S = sig type ('edn, 'flow) protocol (** The type for client protocols. ['edn] is the type for endpoint parameters. - ['flow] is the type for underlying flows. + ['flow] is the type for underlying flows. Endpoints allow users to create flows by either connecting directly to a - remote server or by resolving domain names (with {!connect}). *) + remote server or by resolving domain names (with {!connect}). *) val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol (** [register ~protocol] is the protocol using the implementation [protocol]. - [protocol] must provide a [connect] function to allow client flows to be - created. + [protocol] must provide a [connect] function to allow client flows to be + created. For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow - endpoints, while [Unix.file_descr] would be used for the flow transport. + endpoints, while [Unix.file_descr] would be used for the flow transport. {[ module Conduit_tcp : sig @@ -221,8 +223,8 @@ module type S = sig ]} Client endpoints can of course be more complex, for instance to hold TLS - credentials, and [Conduit] allows all these kinds of flow to be used - transparently: + credentials, and [Conduit] allows all these kinds of flow to be used + transparently: {[ module Conduit_tcp_tls : sig @@ -233,33 +235,32 @@ module type S = sig ]} As a protocol implementer, you must {i register} your implementation and - expose the {i witness} of it. Then, users will be able to use it. *) + expose the {i witness} of it. Then, users will be able to use it. *) (** {2 Injection and Extraction.} The goal of [Conduit] is to provide: - {ul - {- A way to manipulate a fully-abstract [flow].} - {- A way to manipulate a concrete and well-know [flow].}} - [Conduit] provides several mechanisms to be able to manipulate our abstract - type {!flow} and destruct it to a concrete value such as a [Unix.file_descr]. - [Conduit] can assert one assumption: from a given abstracted [flow], it exists - one and only one {!FLOW} implementation. + - A way to manipulate a fully-abstract [flow]. + - A way to manipulate a concrete and well-know [flow]. - As [Conduit] determines this implementation, the user can determine the used - implementation when he wants to {!send} or {!recv} datas. + [Conduit] provides several mechanisms to be able to manipulate our + abstract type {!flow} and destruct it to a concrete value such as a + [Unix.file_descr]. [Conduit] can assert one assumption: from a given + abstracted [flow], it exists one and only one {!FLOW} implementation. + + As [Conduit] determines this implementation, the user can determine the + used implementation when he wants to {!send} or {!recv} datas. So [Conduit] uses or extracts uniqely the implementation registered before - with {!register} and no layer can tweak or update this assertion. + with {!register} and no layer can tweak or update this assertion. {!repr}, {!flow}, {!impl} and {!is} can extracts in differents ways the - abstracted {!flow}: - {ul - {- with the {i pattern-matching}} - {- with {i first-class module}} - {- with the function {!is}}} - *) + abstracted {!flow}: + + - with the {i pattern-matching} + - with {i first-class module} + - with the function {!is} *) module type REPR = sig type t @@ -269,42 +270,43 @@ module type S = sig 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: + flow (to be able users to {i destruct} {!flow}). [repr] returns a module + which contains extension of {!flow} from your [protocol] such as: {[ module Conduit_tcp : sig type t = (Unix.sockaddr, Unix.file_descr) Conduit.value + type Conduit.flow += T of t + val t : (Unix.sockaddr, Unix.file_descr) protocol end = struct let t = register ~protocol:(module TCP) - include (val (Conduit.repr t)) + + include (val Conduit.repr t) end ]} With this interface, users are able to {i destruct} {!flow} to your - concrete type: + concrete type: {[ Conduit.connect domain_name >>? function | Conduit_tcp.T (Conduit.Value file_descr) -> ... | _ -> ... - ]} - *) + ]} *) type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack val unpack : flow -> unpack (** [pack flow] projects the module implementation associated to the given - abstract [flow] such as: + abstract [flow] such as: {[ Conduit.connect edn >>= fun flow -> - let Conduit.Flow (flow, (module Flow)) = Conduit.unpack flow in + let (Conduit.Flow (flow, (module Flow))) = Conduit.unpack flow in Flow.send flow "Hello World!" - ]} - *) + ]} *) val impl : ('edn, 'flow) protocol -> @@ -313,44 +315,43 @@ module type S = sig val cast : flow -> (_, 'flow) protocol -> 'flow option (** [cast flow protocol] tries to {i cast} the given [flow] to the concrete - type described by the given [protocol]. + type described by the given [protocol]. {[ match Conduit.is flow Conduit_tcp.t with - | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) + | Some (file_descr : Unix.file_descr) -> + Some (Unix.getpeername file_descr) | None -> None - ]} - *) + ]} *) val pack : (_, 'v) protocol -> 'v -> flow - (** [pack protocol concrete_flow] abstracts the given [flow] into the - {!flow} type from a given [protocol]. It permits to use [Conduit] with a - concrete value created by the user. + (** [pack protocol concrete_flow] abstracts the given [flow] into the {!flow} + type from a given [protocol]. It permits to use [Conduit] with a concrete + value created by the user. {[ 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!" - ]} - *) + ]} *) (** {2:resolution Domain name resolvers.} *) type 'edn resolver = Endpoint.t -> 'edn option io (** The type for resolver functions, which resolve domain names to endpoints. - For instance, the DNS resolver function is: - - {[ - let http_resolver : Unix.sockaddr resolver = function - | IP ip -> Some (Ipaddr_unix.to_inet_addr ip, 80) - | Domain domain_name -> match Unix.gethostbyname (Domain_name.to_string domain_name) with - | { Unix.h_addr_list; _ } -> - if Array.length h_addr_list > 0 - then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) - else None - | exception _ -> None - ]} - *) + For instance, the DNS resolver function is: + + {[ + let http_resolver : Unix.sockaddr resolver = function + | IP ip -> Some (Ipaddr_unix.to_inet_addr ip, 80) + | Domain domain_name -> + match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } -> + if Array.length h_addr_list > 0 + then Some (Unix.ADDR_INET (h_addr_list.(0), 80)) + else None + | exception _ -> None + ]} *) type resolvers @@ -363,11 +364,11 @@ module type S = sig resolvers -> resolvers (** [add protocol ?priority resolver resolvers] adds a new resolver function - [resolver] to [resolvers]. + [resolver] to [resolvers]. When the [resolver] is able to resolve the given domain name, it will try - to connect to the specified client endpoint. Resolvers are iterated in - priority order (lower to higher). + to connect to the specified client endpoint. Resolvers are iterated in + priority order (lower to higher). {[ let http_resolver = ... @@ -386,9 +387,9 @@ module type S = sig Endpoint.t -> (flow, [> error ]) result io (** [resolve resolvers domain_name] is the flow created by connecting to the - domain name [domain_name], using the resolvers [resolvers]. Each resolver - tries to resolve the given domain-name (they are ordered by the given - priority). The first which connects successfully wins. + domain name [domain_name], using the resolvers [resolvers]. Each resolver + tries to resolve the given domain-name (they are ordered by the given + priority). The first which connects successfully wins. The resolver result is a flow connect to that winning endpoint. @@ -396,7 +397,9 @@ module type S = sig let mirage_io = domain_name_exn "mirage.io" val resolver_on_my_private_network : Unix.sockaddr resolver + val resolver_on_internet : Unix.sockaddr resolver + val resolver_with_tls : (Unix.sockaddr * Tls.Config.client) resolver let resolvers = @@ -405,14 +408,14 @@ module type S = sig |> add tcp ~priority:10 resolver_on_my_private_network |> add tcp ~priority:20 resolver_on_internet - let () = Conduit.resolve resolvers (Conduit.Endpoint.domain mirage_io) >>? function + let () = + Conduit.resolve resolvers (Conduit.Endpoint.domain mirage_io) + >>? function | TCP.T (Conduit.Value 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!" - ]} - *) + let peer = Unix.getpeername file_descr in + ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) + | flow -> ignore @@ Conduit.send flow "Hello World!" + ]} *) val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io @@ -429,15 +432,15 @@ module type S = sig type ('cfg, 't, 'flow) service (** The type for services, e.g. service-side protocols. ['cfg] is the type - for configuration, ['t] is the type for state states. ['flow] is the type - for underlying flows. *) + for configuration, ['t] is the type for state states. ['flow] is the + type for underlying flows. *) val equal : ('cfg0, 't0, 'flow0) service -> ('cfg1, 't1, 'flow1) service -> (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option - (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are - physically the same. For instance, [Conduit] asserts: + (** [equal svc0 svc1] proves that [svc0] and [svc1] are physically the same. + For instance, [Conduit] asserts: {[ let service = Service.register ~service:(module V) ;; @@ -451,11 +454,12 @@ module type S = sig service:('cfg, 't, 'v) impl -> protocol:(_, 'v) protocol -> ('cfg, 't, 'v) service - (** [register ~service ~protocool] is the service using the implementation [service] - bound with implementation of a [protocol]. [service] must define [make] and [accept] - function to be able to create server-side flows. + (** [register ~service ~protocool] is the service using the implementation + [service] bound with implementation of a [protocol]. [service] must + define [make] and [accept] function to be able to create server-side + flows. - For instance: + For instance: {[ module TCP_service : SERVICE with type configuration = Unix.sockaddr @@ -465,8 +469,7 @@ module type S = sig let tcp_protocol = Conduit.register ~protocol:(module TCP_protocol) let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol - ]} - *) + ]} *) type error = [ `Msg of string ] @@ -474,23 +477,23 @@ module type S = sig val init : 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io - (** [init cfg ~service] initialises the service with the - configuration [cfg]. *) + (** [init cfg ~service] initialises the service with the configuration + [cfg]. *) val accept : service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io (** [accept service t] waits for a connection on the service [t]. The result - is a {i flow} connected to the client. *) + is a {i flow} connected to the client. *) val close : service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io (** [close ~service t] releases the resources associated to the server [t]. *) val pack : (_, _, 'v) service -> 'v -> flow - (** [pack service v] returns the abstracted value [v] as {!pack} does - for a given protocol {i witness} (bound with the given [service]). - It serves to abstract the flow created (and initialised) by the - service to a {!flow}. + (** [pack service v] returns the abstracted value [v] as {!pack} does for a + given protocol {i witness} (bound with the given [service]). It serves + to abstract the flow created (and initialised) by the service to a + {!flow}. {[ let handler (flow : Conduit.flow) = diff --git a/src/core/endpoint.mli b/src/core/endpoint.mli index 59c9fef5..1e9c24f3 100644 --- a/src/core/endpoint.mli +++ b/src/core/endpoint.mli @@ -6,21 +6,19 @@ val pp : Format.formatter -> t -> unit (** Pretty-printer of {!t}. *) val of_string : string -> (t, [> `Msg of string ]) result -(** [of_string str] returns an endpoint from the given [string]. - We tried to parse the given [string] as an {i hostname} and if - it fails, we try to consider it as an IP (V4 or V6). +(** [of_string str] returns an endpoint from the given [string]. We tried to + parse the given [string] as an {i hostname} and if it fails, we try to + consider it as an IP (V4 or V6). - If the given [string] is neither a {i hostname} nor an IP, we - return an error. *) + If the given [string] is neither a {i hostname} nor an IP, we return an + error. *) val v : string -> t -(** An alias of {!of_string}. In the case of an error, we raise - an exception. *) +(** An alias of {!of_string}. In the case of an error, we raise an exception. *) val to_string : t -> string -(** [to_string t] returns a valid string which represents the - endpoint. By {i valid}, we means that the returned [string] - can safely be used with {!v}. *) +(** [to_string t] returns a valid string which represents the endpoint. By + {i valid}, we means that the returned [string] can safely be used with {!v}. *) val domain : [ `host ] Domain_name.t -> t (** [domain domain_name] returns an endpoint from a {i hostname}. *) diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index f2ad0922..adcea331 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -1,14 +1,14 @@ -(** Implementation of the SSL support (according [Lwt_ssl]) with - [conduit-lwt]. +(** Implementation of the SSL support (according [Lwt_ssl]) with [conduit-lwt]. This implementation assumes that underlying protocol used to compose with - SSL must deliver a [Lwt_unix.file_descr] - such as [Conduit_lwt.TCP]. - From that, we are able to compose your protocol with [Lwt_ssl] such as: + SSL must deliver a [Lwt_unix.file_descr] - such as [Conduit_lwt.TCP]. From + that, we are able to compose your protocol with [Lwt_ssl] such as: {[ let ssl_protocol = protocol_with_ssl TCP.protocol - let ssl_service = service_with_ssl TCP.service - ~file_descr:TCP.file_descr ssl_protocol + + let ssl_service = + service_with_ssl TCP.service ~file_descr:TCP.file_descr ssl_protocol ]} Then, TCP + SSL is available as any others [conduit] protocols or services @@ -23,7 +23,8 @@ {b NOTE}: [verify] is called after a call to [flow] (which should do the [connect] call). So, nothing was exchanged between you and your peer at this time - even the handshake. It permits to fill the SSL socket with some - information such as the hostname of the peer with [Ssl.set_client_SNI_hostname]. *) + information such as the hostname of the peer with + [Ssl.set_client_SNI_hostname]. *) open Conduit_lwt @@ -49,8 +50,8 @@ val endpoint : [Lwt_unix.file_descr] from it. [verify] is the function called just after the initialization of the - underlying ['flow]. It permits to request a verification such as the {i - hostname} with your peer. *) + underlying ['flow]. It permits to request a verification such as the + {i hostname} with your peer. *) val protocol_with_ssl : ('edn, 'flow) protocol -> (('edn, 'flow) endpoint, Lwt_ssl.socket) protocol diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 56a21c78..9e8c554d 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -2,8 +2,8 @@ [conduit-lwt]. This implementation is a {i specialization} of [conduit-tls] with - [conduit-lwt]. Underlying protocol or service can be anything into the - scope of [conduit-lwt]. + [conduit-lwt]. Underlying protocol or service can be anything into the scope + of [conduit-lwt]. For more details about behaviours, you should look into [conduit-tls]. *) diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index a42ba0f3..4a035685 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -8,16 +8,16 @@ include val io_of_flow : flow -> Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel -(** [io_of_flow flow] creates an input flow and an output flow according - to [Lwt_io]. This function, even if it creates something more usable - is {b deprecated}. Indeed, [Lwt_io] has its own way to schedule [read] - and [write] - you should be aware about that more specially when you - use [Conduit_tls] or [Conduit_lwt_ssl]. +(** [io_of_flow flow] creates an input flow and an output flow according to + [Lwt_io]. This function, even if it creates something more usable is + {b deprecated}. Indeed, [Lwt_io] has its own way to schedule [read] and + [write] - you should be aware about that more specially when you use + [Conduit_tls] or [Conduit_lwt_ssl]. Due to a specific behavior, [Lwt_io] does not fit with some specific - protocols - non thread-safe protocols, {i send-first} protocols, etc. - From these reasons, and even if {!TCP} try to the best to fit under - an [Lwt_io], you should not use this function. *) + protocols - non thread-safe protocols, {i send-first} protocols, etc. From + these reasons, and even if {!TCP} try to the best to fit under an [Lwt_io], + you should not use this function. *) type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service (** The type for lwt services. *) @@ -28,22 +28,21 @@ val serve : service:('cfg, 'service, 'v) service -> 'cfg -> unit Lwt_condition.t * (unit -> unit Lwt.t) -(** [serve ~handler ~service cfg] creates an usual infinite [service] - loop from the given configuration ['cfg]. It returns the {i promise} to launch - the loop and a condition variable to stop the loop. +(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from + the given configuration ['cfg]. It returns the {i promise} to launch the + loop and a condition variable to stop the loop. {[ - let stop, loop = serve - ~handler ~service:TCP.service cfg in + let stop, loop = serve ~handler ~service:TCP.service cfg in Lwt.both - (Lwt_unix.sleep 10. >>= fun () -> - Lwt_condition.broadcast stop () ; - Lwt.return ()) + ( Lwt_unix.sleep 10. >>= fun () -> + Lwt_condition.broadcast stop () ; + Lwt.return () ) (loop ()) ]} - In your example, we want to launch a server only for 10 seconds. To help the user, - the option [?timeout] allows us to wait less than [timeout] seconds. *) + In your example, we want to launch a server only for 10 seconds. To help the + user, the option [?timeout] allows us to wait less than [timeout] seconds. *) module TCP : sig (** Implementation of TCP protocol as a client. @@ -51,15 +50,15 @@ module TCP : sig Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. This is a description of what they currently do. - {b NOTE}: [recv] wants to fill the given buffer as much as possible until it - has reached {i end-of-input}. In other words, [recv] can do a multiple call - to [Lwt_unix.recv] to fill the given buffer. + {b NOTE}: [recv] wants to fill the given buffer as much as possible until + it has reached {i end-of-input}. In other words, [recv] can do a multiple + call to [Lwt_unix.recv] to fill the given buffer. - {b NOTE}: [send] tries to send as much as it can the given buffer. However, - if internal call of [Lwt_unix.send] returns something smaller than what we - requested, we stop the process and return how many byte(s) we sended. In - other word, [send] can do a multiple call to [Lwt_unix.send] until we fully - sended what we wanted. *) + {b NOTE}: [send] tries to send as much as it can the given buffer. + However, if internal call of [Lwt_unix.send] returns something smaller + than what we requested, we stop the process and return how many byte(s) we + sended. In other word, [send] can do a multiple call to [Lwt_unix.send] + until we fully sended what we wanted. *) module Protocol : sig include @@ -83,7 +82,8 @@ module TCP : sig communicate over TCP. *) val peer : flow -> Unix.sockaddr - (** [peer flow] retunrs the address of the peer connected to the given [flow]. *) + (** [peer flow] retunrs the address of the peer connected to the given + [flow]. *) val sock : flow -> Unix.sockaddr (** [sock flow] returns the current addres to which the socket is bound. *) diff --git a/src/mirage/conduit_mirage_dns.mli b/src/mirage/conduit_mirage_dns.mli index 73246255..f63fb17c 100644 --- a/src/mirage/conduit_mirage_dns.mli +++ b/src/mirage/conduit_mirage_dns.mli @@ -1,5 +1,5 @@ -(** MirageOS-functor to be able to resolve a domain-name - such as [gethostbyname] with [ocaml-dns]. *) +(** MirageOS-functor to be able to resolve a domain-name such as [gethostbyname] + with [ocaml-dns]. *) module Make (R : Mirage_random.S) From f82baca02de2b2f3b578909fe3dcf2064f6d2ee5 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 12:28:02 +0100 Subject: [PATCH 114/140] Remove labels and rename Service.service to Service.t --- bench/cost.ml | 6 +-- src/async-ssl/conduit_async_ssl.ml | 8 ++-- src/async-ssl/conduit_async_ssl.mli | 4 +- src/async-tls/conduit_async_tls.mli | 4 +- src/async/conduit_async.ml | 12 +++--- src/async/conduit_async.mli | 12 +++--- src/core/conduit.ml | 46 +++++++++----------- src/core/conduit_intf.ml | 67 +++++++++++++---------------- src/core/howto.mld | 24 ++++------- src/core/readme.mld | 4 +- src/lwt-ssl/conduit_lwt_ssl.ml | 8 ++-- src/lwt-ssl/conduit_lwt_ssl.mli | 4 +- src/lwt-tls/conduit_lwt_tls.mli | 4 +- src/lwt/conduit_lwt.ml | 16 +++---- src/lwt/conduit_lwt.mli | 8 ++-- src/mirage/conduit_mirage.ml | 6 +-- src/mirage/conduit_mirage.mli | 2 +- src/mirage/conduit_mirage_tcp.ml | 5 +-- src/mirage/conduit_mirage_tcp.mli | 2 +- src/tls/conduit_tls.ml | 8 ++-- src/tls/conduit_tls.mli | 4 +- tests/flow.ml | 4 +- tests/ping-pong/common.ml | 8 ++-- tests/ping-pong/with_async.ml | 17 +++----- tests/ping-pong/with_lwt.ml | 19 ++++---- tests/resolvers.ml | 6 +-- 26 files changed, 140 insertions(+), 168 deletions(-) diff --git a/bench/cost.ml b/bench/cost.ml index 9e15fb25..0794b878 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -86,11 +86,11 @@ module Fake_protocol2 = struct let close _ = Ok () end -let fake0 = Tuyau.register ~protocol:(module Fake_protocol0) +let fake0 = Tuyau.register (module Fake_protocol0) -let fake1 = Tuyau.register ~protocol:(module Fake_protocol1) +let fake1 = Tuyau.register (module Fake_protocol1) -let fake2 = Tuyau.register ~protocol:(module Fake_protocol2) +let fake2 = Tuyau.register (module Fake_protocol2) let hello_world = "Hello World!\n" diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index 2bc62423..c2faad3a 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -189,7 +189,7 @@ let protocol_with_ssl : let writer = writer end in let module M = Protocol (Flow) in - Conduit_async.register ~protocol:(module M) + Conduit_async.register (module M) module Make (Service : sig include Conduit_async.SERVICE @@ -279,11 +279,11 @@ end let service_with_ssl : type cfg edn t flow. - (cfg, t, flow) Conduit_async.Service.service -> + (cfg, t, flow) Conduit_async.Service.t -> reader:(flow -> Reader.t) -> writer:(flow -> Writer.t) -> (edn, flow with_ssl) Conduit_async.protocol -> - (context * cfg, context * t, flow with_ssl) Conduit_async.Service.service = + (context * cfg, context * t, flow with_ssl) Conduit_async.Service.t = fun service ~reader ~writer protocol -> let module S = (val Conduit_async.Service.impl service) in let module Service = struct @@ -294,7 +294,7 @@ let service_with_ssl : let writer = writer end in let module M = Make (Service) in - Conduit_async.Service.register ~service:(module M) ~protocol + Conduit_async.Service.register (module M) protocol module TCP = struct open Conduit_async.TCP diff --git a/src/async-ssl/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli index dbed373b..4cf95e96 100644 --- a/src/async-ssl/conduit_async_ssl.mli +++ b/src/async-ssl/conduit_async_ssl.mli @@ -50,11 +50,11 @@ val protocol_with_ssl : (context * 'edn, 'flow with_ssl) protocol val service_with_ssl : - ('cfg, 't, 'flow) Service.service -> + ('cfg, 't, 'flow) Service.t -> reader:('flow -> Reader.t) -> writer:('flow -> Writer.t) -> ('edn, 'flow with_ssl) protocol -> - (context * 'cfg, context * 't, 'flow with_ssl) Service.service + (context * 'cfg, context * 't, 'flow with_ssl) Service.t (** {2 Composition between Host's TCP/IP stack protocol and SSL.} *) diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index fa752572..12ac4902 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -15,12 +15,12 @@ val protocol_with_tls : type 'service service_with_tls val service_with_tls : - ('cfg, 't, 'flow) Service.service -> + ('cfg, 't, 'flow) Service.t -> ('edn, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) - Service.service + Service.t (** {2 Composition between Host's TCP/IP stack protocol and TLS.} *) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index f05992c8..3c399bbb 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -13,21 +13,21 @@ let failwith fmt = Format.kasprintf failwith fmt let ( >>? ) x f = Async.Deferred.Result.bind x ~f -type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t let serve : type cfg t v. ?timeout:int -> handler:(flow -> unit Async.Deferred.t) -> - service:(cfg, t, v) service -> + (cfg, t, v) service -> cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) = - fun ?timeout ~handler ~service cfg -> + fun ?timeout ~handler service cfg -> let open Async in let stop = Async.Condition.create () in let module Svc = (val Service.impl service) in let main () = - Service.init cfg ~service >>= function + Service.init service cfg >>= function | Error err -> failwith "%a" Service.pp_error err | Ok t -> ( let rec loop () = @@ -180,7 +180,7 @@ module TCP = struct Writer.close writer >>= fun () -> Async.return (Ok ())) end - let protocol = register ~protocol:(module Protocol) + let protocol = register (module Protocol) type configuration = | Listen : int option * ('a, 'b) Tcp.Where_to_listen.t -> configuration @@ -246,7 +246,7 @@ module TCP = struct Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end - let service = S.register ~service:(module Service) ~protocol + let service = S.register (module Service) protocol let resolve ~port = function | Conduit.Endpoint.IP ip -> diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index ad1e1cf3..1f800696 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -10,21 +10,21 @@ include and type output = Cstruct.t and type +'a io = 'a Async.Deferred.t -type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t (** The type for async services. *) val serve : ?timeout:int -> handler:(flow -> unit Async.Deferred.t) -> - service:('cfg, 't, 'v) service -> + ('cfg, 't, 'v) service -> 'cfg -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) -(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from - the given configuration ['cfg]. It returns the {i promise} to launch the - loop and a condition variable to stop the loop. +(** [serve ~handler t cfg] creates an infinite service loop from the given + configuration ['cfg]. It returns the {i promise} to launch the loop and a + condition variable to stop the loop. {[ - let stop, loop = serve ~handler ~service:TCP.service cfg in + let stop, loop = serve ~handler TCP.service cfg in Async_unix.Signal.handle [ Core.Signal.int ] ~f:(fun _sig -> Async.Condition.broadcast stop ()) ; loop () diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 9d9d747d..d17baa52 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -171,9 +171,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | Ok _ as v -> v | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let register : - type edn flow. protocol:(edn, flow) impl -> (edn, flow) protocol = - fun ~protocol -> + let register : type edn flow. (edn, flow) impl -> (edn, flow) protocol = + fun protocol -> let key = Map.Key.create "" in Ptr.inj (Protocol (key, protocol)) @@ -365,17 +364,15 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : module Svc = E0.Make (F) - type ('cfg, 't, 'flow) service = + type ('cfg, 't, 'flow) t = | Service : ('cfg, 't, 'flow) thd Svc.s * (_, 'flow) protocol - -> ('cfg, 't, 'flow) service + -> ('cfg, 't, 'flow) t let register : - type cfg t flow. - service:(cfg, t, flow) impl -> - protocol:(_, flow) protocol -> - (cfg, t, flow) service = - fun ~service ~protocol -> + type cfg s flow. + (cfg, s, flow) impl -> (_, flow) protocol -> (cfg, s, flow) t = + fun service protocol -> let cfg = Map.Key.create "" in Service (Svc.inj (Svc (cfg, service)), protocol) @@ -385,48 +382,45 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let equal : type a b c d e f. - (a, b, c) service -> - (d, e, f) service -> + (a, b, c) t -> + (d, e, f) t -> ((a, d) refl * (b, e) refl * (c, f) refl) option = fun (Service ((module A), _)) (Service ((module B), _)) -> match A.Id with B.Id -> Some (Refl, Refl, Refl) | _ -> None let init : - type cfg t flow. - cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result io = - fun edn ~service:(Service ((module Witness), _)) -> + type cfg s flow. (cfg, s, flow) t -> cfg -> (s, [> error ]) result io = + fun (Service ((module Witness), _)) cfg -> let (Svc (_, (module Service))) = Witness.witness in - Service.init edn >>= function + Service.init cfg >>= function | Ok t -> return (Ok t) | Error err -> return (error_msgf "%a" Service.pp_error err) let accept : - type cfg t v. - service:(cfg, t, v) service -> t -> (flow, [> error ]) result io = - fun ~service:(Service ((module Witness), protocol)) t -> + type cfg s v. (cfg, s, v) t -> s -> (flow, [> error ]) result io = + fun (Service ((module Witness), protocol)) t -> let (Svc (_, (module Service))) = Witness.witness in Service.accept t >>= function | Ok flow -> return (Ok (pack protocol flow)) | Error err -> return (error_msgf "%a" Service.pp_error err) let close : - type cfg t flow. - service:(cfg, t, flow) service -> t -> (unit, [> error ]) result io = - fun ~service:(Service ((module Witness), _)) t -> + type cfg s flow. (cfg, s, flow) t -> s -> (unit, [> error ]) result io = + fun (Service ((module Witness), _)) t -> let (Svc (_, (module Service))) = Witness.witness in Service.close t >>= function | Ok () -> return (Ok ()) | Error err -> return (error_msgf "%a" Service.pp_error err) - let pack : type v. (_, _, v) service -> v -> flow = + let pack : type v. (_, _, v) t -> v -> flow = fun (Service (_, protocol)) flow -> pack protocol flow let impl : - type cfg t flow. - (cfg, t, flow) service -> + type cfg s flow. + (cfg, s, flow) t -> (module SERVICE with type configuration = cfg - and type t = t + and type t = s and type flow = flow) = fun (Service ((module S), _)) -> let (Svc (_, (module Service))) = S.witness in diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 4d0f4f18..078ec4fd 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -206,10 +206,9 @@ module type S = sig Endpoints allow users to create flows by either connecting directly to a remote server or by resolving domain names (with {!connect}). *) - val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol - (** [register ~protocol] is the protocol using the implementation [protocol]. - [protocol] must provide a [connect] function to allow client flows to be - created. + val register : ('edn, 'flow) impl -> ('edn, 'flow) protocol + (** [register i] is the protocol using the implementation [i]. [protocol] must + provide a [connect] function to allow client flows to be created. For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow endpoints, while [Unix.file_descr] would be used for the flow transport. @@ -218,7 +217,7 @@ module type S = sig module Conduit_tcp : sig val t : (Unix.sockaddr, Unix.file_descr) protocol end = struct - let t = register ~protocol:(module TCP) + let t = register (module TCP) end ]} @@ -230,7 +229,7 @@ module type S = sig module Conduit_tcp_tls : sig val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol end = struct - let t = register ~protocol:(module TLS) + let t = register (module TLS) end ]} @@ -281,7 +280,7 @@ module type S = sig val t : (Unix.sockaddr, Unix.file_descr) protocol end = struct - let t = register ~protocol:(module TCP) + let t = register (module TCP) include (val Conduit.repr t) end @@ -430,34 +429,30 @@ module type S = sig and type t = 't and type flow = 'flow) - type ('cfg, 't, 'flow) service + type ('cfg, 't, 'flow) t (** The type for services, e.g. service-side protocols. ['cfg] is the type - for configuration, ['t] is the type for state states. ['flow] is the + for configuration, ['s] is the type for server states. ['flow] is the type for underlying flows. *) val equal : - ('cfg0, 't0, 'flow0) service -> - ('cfg1, 't1, 'flow1) service -> + ('cfg0, 't0, 'flow0) t -> + ('cfg1, 't1, 'flow1) t -> (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option (** [equal svc0 svc1] proves that [svc0] and [svc1] are physically the same. For instance, [Conduit] asserts: {[ - let service = Service.register ~service:(module V) ;; + let service = Service.register (module V) protocol ;; let () = match Service.equal service service with | Some (Refl, Refl, Refl) -> ... | _ -> assert false ]} *) - val register : - service:('cfg, 't, 'v) impl -> - protocol:(_, 'v) protocol -> - ('cfg, 't, 'v) service - (** [register ~service ~protocool] is the service using the implementation - [service] bound with implementation of a [protocol]. [service] must - define [make] and [accept] function to be able to create server-side - flows. + val register : ('cfg, 't, 'v) impl -> (_, 'v) protocol -> ('cfg, 't, 'v) t + (** [register i p] is the service using the implementation [i] using the + protocol [p]. [i] should define a [make] and an [accept] function to + create server-side flows. For instance: @@ -466,30 +461,26 @@ module type S = sig and type t = Unix.file_descr and type flow = Unix.file_descr - let tcp_protocol = Conduit.register ~protocol:(module TCP_protocol) + let tcp_protocol = Conduit.register (module TCP_protocol) let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service = - Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol + Conduit.Service.register (module TCP_service) tcp_protocol ]} *) type error = [ `Msg of string ] val pp_error : error Fmt.t - val init : - 'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io - (** [init cfg ~service] initialises the service with the configuration - [cfg]. *) + val init : ('cfg, 't, 'v) t -> 'cfg -> ('t, [> error ]) result io + (** [init t cfg] initialises the service with the configuration [cfg]. *) - val accept : - service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io - (** [accept service t] waits for a connection on the service [t]. The result - is a {i flow} connected to the client. *) + val accept : ('cfg, 's, 'v) t -> 's -> (flow, [> error ]) result io + (** [accept t s] waits for a connection on the server [s]. The result is a + {i flow} connected to the client. *) - val close : - service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io - (** [close ~service t] releases the resources associated to the server [t]. *) + val close : ('cfg, 's, 'v) t -> 's -> (unit, [> error ]) result io + (** [close t s] releases the resources associated to the server [s]. *) - val pack : (_, _, 'v) service -> 'v -> flow + val pack : (_, _, 'v) t -> 'v -> flow (** [pack service v] returns the abstracted value [v] as {!pack} does for a given protocol {i witness} (bound with the given [service]). It serves to abstract the flow created (and initialised) by the service to a @@ -500,7 +491,7 @@ module type S = sig Conduit.send flow "Hello World!" >>= fun _ -> ... - let run ~service cfg = + let run service cfg = let module Service = Conduit.Service.impl service in Service.init cfg >>? fun t -> let rec loop t = @@ -509,12 +500,12 @@ module type S = sig async (fun () -> handler flow) ; loop t in loop t - let () = run ~service:tcp_service (localhost, 8080) - let () = run ~service:tls_service (certs, (localhost, 8080)) + let () = run tcp_service (localhost, 8080) + let () = run tls_service (certs, (localhost, 8080)) ]} *) val impl : - ('cfg, 't, 'v) service -> + ('cfg, 't, 'v) t -> (module SERVICE with type configuration = 'cfg and type t = 't diff --git a/src/core/howto.mld b/src/core/howto.mld index 3eb2fda5..fa452384 100644 --- a/src/core/howto.mld +++ b/src/core/howto.mld @@ -89,13 +89,11 @@ let fiber ~uri = let cfg : Conduit_lwt.TCP.configuration = { Conduit_lwt.TCP.sockaddr= Unix.(ADDR_INET (inet_addr_of_string host, port)) ; capacity= 40 } in - let _always, run = server cfg - ~protocol:Conduit_lwt.TCP.protocol - ~service:Conduit_lwt.TCP.service in + let _always, run = server cfg Conduit_lwt.TCP.service in run () let () = - let uri = Uri.of_string Sys.argv.(1) in + let uri = Uri.of_string Sys.argv.(1) in Lwt_main.run (fiber ~uri) ]} @@ -202,20 +200,16 @@ let fiber ~uri = let _always, run = match Uri.scheme uri with | None | Some "pg" -> let port = Option.value ~default:8080 (Uri.port uri) in - server (cfg ~port) - ~protocol:Conduit_lwt.TCP.protocol - ~service:Conduit_lwt.TCP.service + server (cfg ~port) Conduit_lwt.TCP.service | Some "pgs" -> let port = Option.value ~default:4343 (Uri.port uri) in let cfg = cfg ~port, config "server.pem" "server.key" in - server cfg - ~protocol:Conduit_lwt_tls.TCP.protocol - ~service:Conduit_lwt_tls.TCP.service + server cfg Conduit_lwt_tls.TCP.service | Some scheme -> invalid_arg "Invalid scheme: %s" scheme in run () let () = - let uri = Uri.of_string Sys.argv.(1) in + let uri = Uri.of_string Sys.argv.(1) in Lwt_main.run (fiber ~uri) ]} @@ -231,14 +225,14 @@ let conduit_of_uri uri = let resolvers = match Uri.scheme uri with | Some "pg" -> let open Conduit_lwt.TCP in - let port = Option.value ~default:8080 (Uri.port uri) in + let port = Option.value ~default:8080 (Uri.port uri) in let resolvers = Conduit.empty |> Conduit_lwt.add protocol (TCP.resolve ~port) in resolvers | Some "pgs" -> let open Conduit_lwt_tls.TCP in - let port = Option.value ~default:4343 (Uri.port uri) in + let port = Option.value ~default:4343 (Uri.port uri) in let resolvers = Conduit.empty |> Conduit_lwt.add protocol (resolve ~port ~config:tls_config) in @@ -246,8 +240,8 @@ let conduit_of_uri uri = | None -> let module TCP = Conduit_lwt.TCP in let module TLS = Conduit_lwt_tls.TCP in - let u_port = Option.value ~default:8080 (Uri.port uri) in - let s_port = Option.value ~default:4343 (Uri.port uri) in + let u_port = Option.value ~default:8080 (Uri.port uri) in + let s_port = Option.value ~default:4343 (Uri.port uri) in let resolvers = Conduit.empty |> Conduit_lwt.add ~priority:10 TLS.protocol diff --git a/src/core/readme.mld b/src/core/readme.mld index 84d6089e..3c192d90 100644 --- a/src/core/readme.mld +++ b/src/core/readme.mld @@ -68,7 +68,7 @@ interface {!Conduit.S.PROTOCOL}. We concretely define the flow as an Now, the protocol must be registered into [Conduit] with: {[ -let tcp = Conduit.register ~protocol:(module TCP) +let tcp = Conduit.register (module TCP) ]} The registration gives to us a {i type-witness} which is a small representation @@ -155,7 +155,7 @@ injected}. Assume that we used our TCP/IP implementation, to permit the {i destruction}, we must add: {[ -let tcp = Conduit.register ~protocol:(module TCP) +let tcp = Conduit.register (module TCP) include (val Conduit.repr tcp) ]} diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index e88f97fb..7537eba4 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -71,7 +71,7 @@ let protocol_with_ssl : fun protocol -> let module Flow = (val Conduit_lwt.impl protocol) in let module M = Protocol (Flow) in - Conduit_lwt.register ~protocol:(module M) + Conduit_lwt.register (module M) type 't service = { service : 't; context : Ssl.context } @@ -112,10 +112,10 @@ end let service_with_ssl : type cfg edn t flow. - (cfg, t, flow) Conduit_lwt.Service.service -> + (cfg, t, flow) Conduit_lwt.Service.t -> file_descr:(flow -> Lwt_unix.file_descr) -> (edn, Lwt_ssl.socket) Conduit_lwt.protocol -> - (Ssl.context * cfg, t service, Lwt_ssl.socket) Conduit_lwt.Service.service = + (Ssl.context * cfg, t service, Lwt_ssl.socket) Conduit_lwt.Service.t = fun service ~file_descr protocol -> let module S = (val Conduit_lwt.Service.impl service) in let module M = Service (struct @@ -123,7 +123,7 @@ let service_with_ssl : let file_descr = file_descr end) in - Conduit_lwt.Service.register ~service:(module M) ~protocol + Conduit_lwt.Service.register (module M) protocol module TCP = struct let resolve ~port ~context ?verify domain_name = diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index adcea331..7fbd6c98 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -62,10 +62,10 @@ type 't service (** The type for SSL services. *) val service_with_ssl : - ('cfg, 't, 'flow) Service.service -> + ('cfg, 't, 'flow) Service.t -> file_descr:('flow -> Lwt_unix.file_descr) -> ('edn, Lwt_ssl.socket) protocol -> - (Ssl.context * 'cfg, 't service, Lwt_ssl.socket) Service.service + (Ssl.context * 'cfg, 't service, Lwt_ssl.socket) Service.t (** [service_with_ssl ~key service ~file_descr ssl_protocol] returns a representation of the given service with SSL. The service deliver an SSL flow which must be described by a [Lwt_ssl.socket Witness.protocol] (eg. diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 9e8c554d..0cdde867 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -25,12 +25,12 @@ val protocol_with_tls : type 'service service_with_tls val service_with_tls : - ('cfg, 't, 'flow) Service.service -> + ('cfg, 't, 'flow) Service.t -> ('edn, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) - Service.service + Service.t module TCP : sig open Conduit_lwt.TCP diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index db6d4c78..badb46e5 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -6,10 +6,10 @@ module IO = struct let return x = Lwt.return x end -include Conduit.Make (IO) (Cstruct) (Cstruct) -module S = Service +module Conduit = Conduit.Make (IO) (Cstruct) (Cstruct) +include Conduit -type ('a, 'b, 'c) service = ('a, 'b, 'c) S.service +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt @@ -59,15 +59,15 @@ let serve : type cfg service v. ?timeout:int -> handler:(flow -> unit Lwt.t) -> - service:(cfg, service, v) Service.service -> + (cfg, service, v) Service.t -> cfg -> unit Lwt_condition.t * (unit -> unit Lwt.t) = - fun ?timeout ~handler ~service cfg -> + fun ?timeout ~handler service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in let main () = - Service.init cfg ~service >>= function + Service.init service cfg >>= function | Error err -> failwith "%a" Service.pp_error err | Ok t -> ( let rec loop () = @@ -411,11 +411,11 @@ module TCP = struct Lwt.return_ok () end - let protocol = register ~protocol:(module Protocol) + let protocol = register (module Protocol) include (val repr protocol) - let service = S.register ~service:(module Service) ~protocol + let service = Conduit.Service.register (module Service) protocol let resolve ~port = function | Conduit.Endpoint.IP ip -> diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 4a035685..cb006311 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -19,21 +19,21 @@ val io_of_flow : these reasons, and even if {!TCP} try to the best to fit under an [Lwt_io], you should not use this function. *) -type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service +type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t (** The type for lwt services. *) val serve : ?timeout:int -> handler:(flow -> unit Lwt.t) -> - service:('cfg, 'service, 'v) service -> + ('cfg, 'service, 'v) service -> 'cfg -> unit Lwt_condition.t * (unit -> unit Lwt.t) -(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from +(** [serve ~handler service cfg] creates an usual infinite [service] loop from the given configuration ['cfg]. It returns the {i promise} to launch the loop and a condition variable to stop the loop. {[ - let stop, loop = serve ~handler ~service:TCP.service cfg in + let stop, loop = serve ~handler TCP.service cfg in Lwt.both ( Lwt_unix.sleep 10. >>= fun () -> Lwt_condition.broadcast stop () ; diff --git a/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml index 9595ada2..b4645c60 100644 --- a/src/mirage/conduit_mirage.ml +++ b/src/mirage/conduit_mirage.ml @@ -15,15 +15,15 @@ let ( >>? ) = Lwt_result.bind let serve : type cfg service flow. handler:(flow -> unit Lwt.t) -> - service:(cfg, service, flow) Service.service -> + (cfg, service, flow) Service.t -> cfg -> unit Lwt_condition.t * unit Lwt.t = - fun ~handler ~service cfg -> + fun ~handler service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in let module Svc = (val Service.impl service) in let main = - Service.init cfg ~service >>= function + Service.init service cfg >>= function | Error err -> failwith "%a" Service.pp_error err | Ok service -> ( let rec loop () = diff --git a/src/mirage/conduit_mirage.mli b/src/mirage/conduit_mirage.mli index f0556b8f..e7d4b6b5 100644 --- a/src/mirage/conduit_mirage.mli +++ b/src/mirage/conduit_mirage.mli @@ -8,6 +8,6 @@ include val serve : handler:('flow -> unit Lwt.t) -> - service:('cfg, 'master, 'flow) Service.service -> + ('cfg, _, 'flow) Service.t -> 'cfg -> unit Lwt_condition.t * unit Lwt.t diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index 49bc4c4d..ec442e39 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -204,7 +204,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct StackV4.TCPV4.close t.flow >>= fun () -> Lwt.return_ok ()) end - let protocol = Conduit_mirage.register ~protocol:(module Protocol) + let protocol = Conduit_mirage.register (module Protocol) type nonrec configuration = StackV4.t configuration @@ -274,6 +274,5 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt.return (Ok ())) end - let service = - Conduit_mirage.Service.register ~service:(module Service) ~protocol + let service = Conduit_mirage.Service.register (module Service) protocol end diff --git a/src/mirage/conduit_mirage_tcp.mli b/src/mirage/conduit_mirage_tcp.mli index 2a4a2bb7..0a1bb09d 100644 --- a/src/mirage/conduit_mirage_tcp.mli +++ b/src/mirage/conduit_mirage_tcp.mli @@ -25,5 +25,5 @@ module Make (StackV4 : Mirage_stack.V4) : sig type service - val service : (StackV4.t configuration, service, protocol) Service.service + val service : (StackV4.t configuration, service, protocol) Service.t end diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 40abfe04..c780f054 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -316,7 +316,7 @@ struct fun protocol -> let module Protocol = (val Conduit.impl protocol) in let module M = Make_protocol (Protocol) in - Conduit.register ~protocol:(module M) + Conduit.register (module M) type 'service service_with_tls = { service : 'service; @@ -358,14 +358,14 @@ struct let service_with_tls : type cfg edn t flow. - (cfg, t, flow) Conduit.Service.service -> + (cfg, t, flow) Conduit.Service.t -> (edn, flow protocol_with_tls) Conduit.protocol -> ( cfg * Tls.Config.server, t service_with_tls, flow protocol_with_tls ) - Conduit.Service.service = + Conduit.Service.t = fun service protocol -> let module Service = (val Conduit.Service.impl service) in let module M = Make_server (Service) in - Conduit.Service.register ~service:(module M) ~protocol + Conduit.Service.register (module M) protocol end diff --git a/src/tls/conduit_tls.mli b/src/tls/conduit_tls.mli index 10959659..7b8df5ea 100644 --- a/src/tls/conduit_tls.mli +++ b/src/tls/conduit_tls.mli @@ -65,10 +65,10 @@ module Make type 'service service_with_tls val service_with_tls : - ('cfg, 't, 'flow) Conduit.Service.service -> + ('cfg, 't, 'flow) Conduit.Service.t -> ('edn, 'flow protocol_with_tls) Conduit.protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) - Conduit.Service.service + Conduit.Service.t end diff --git a/tests/flow.ml b/tests/flow.ml index 91c363a3..4955ee6a 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -81,7 +81,7 @@ module Memory_flow0 = struct Ok () end -let memory0 = Conduit.register ~protocol:(module Memory_flow0) +let memory0 = Conduit.register (module Memory_flow0) let test_input_string = Alcotest.test_case "input string" `Quick @@ fun () -> @@ -198,7 +198,7 @@ module Memory_flow1 = struct Ok () end -let memory1 = Conduit.register ~protocol:(module Memory_flow1) +let memory1 = Conduit.register (module Memory_flow1) let test_input_strings = Alcotest.test_case "input strings" `Quick @@ fun () -> diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index bdea5542..ad7d0d32 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -6,7 +6,7 @@ module type S = sig val serve : ?timeout:int -> handler:(flow -> unit io) -> - service:('cfg, 'master, 'v) Service.service -> + ('cfg, 's, 'flow) Service.t -> 'cfg -> unit condition * (unit -> unit io) end @@ -112,11 +112,11 @@ struct | Ok () -> return () let server : - type cfg service. + type cfg s. + (cfg, s, 'flow) Conduit.Service.t -> cfg -> - service:(cfg, service, 'flow) Conduit.Service.service -> unit Condition.t * (unit -> unit IO.t) = - fun cfg ~service -> Conduit.serve ~handler:transmission ~service cfg + fun service cfg -> Conduit.serve ~handler:transmission service cfg (* part *) diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index ae12793d..b38b1fd4 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -47,12 +47,9 @@ let localhost = Domain_name.(host_exn (of_string_exn "localhost")) let run_with : type cfg service flow. - cfg -> - service:(cfg, service, flow) Conduit_async.Service.service -> - string list -> - unit = - fun cfg ~service clients -> - let stop, server = server (* ~launched ~stop *) cfg ~service in + (cfg, service, flow) Conduit_async.Service.t -> cfg -> string list -> unit = + fun service cfg clients -> + let stop, server = server (* ~launched ~stop *) service cfg in let clients = Async.after Core.Time.Span.(of_sec 0.5) >>= fun () -> (* XXX(dinosaure): [async] tries to go further and fibers @@ -68,9 +65,9 @@ let run_with : Core.never_returns (Scheduler.go ()) let run_with_tcp clients = - run_with + run_with tcp_service (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 5000)) - ~service:tcp_service clients + clients let load_file filename = let open Stdlib in @@ -93,9 +90,9 @@ let config cert key = let run_with_tls cert key clients = let ctx = config cert key in - run_with + run_with tls_service (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 9000), ctx) - ~service:tls_service clients + clients let () = match Array.to_list Stdlib.Sys.argv with diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index 4ae38ea3..f094abbe 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -59,13 +59,10 @@ let config cert key = | _ -> Fmt.failwith "Invalid key or certificate" let run_with : - type cfg service flow. - cfg -> - service:(cfg, service, flow) Conduit_lwt.Service.service -> - string list -> - unit = - fun cfg ~service clients -> - let stop, server = server cfg ~service in + type cfg s flow. + (cfg, s, flow) Conduit_lwt.Service.t -> cfg -> string list -> unit = + fun service cfg clients -> + let stop, server = server service cfg in let clients = List.map (client ~resolvers) clients in let clients = Lwt.join clients >>= fun () -> @@ -74,22 +71,22 @@ let run_with : Lwt_main.run (Lwt.join [ server (); clients ]) let run_with_tcp clients = - run_with + run_with Conduit_lwt.TCP.service { Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); capacity = 40; } - ~service:Conduit_lwt.TCP.service clients + clients let run_with_tls cert key clients = let ctx = config cert key in - run_with + run_with tls_service ( { Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); capacity = 40; }, ctx ) - ~service:tls_service clients + clients let () = match Array.to_list Sys.argv with diff --git a/tests/resolvers.ml b/tests/resolvers.ml index 8b0ddd8c..cf87479c 100644 --- a/tests/resolvers.ml +++ b/tests/resolvers.ml @@ -47,11 +47,11 @@ module Dummy_unit = Dummy (struct type t = unit end) -let dummy_int = Conduit.register ~protocol:(module Dummy_int) +let dummy_int = Conduit.register (module Dummy_int) -let dummy_string = Conduit.register ~protocol:(module Dummy_string) +let dummy_string = Conduit.register (module Dummy_string) -let dummy_unit = Conduit.register ~protocol:(module Dummy_unit) +let dummy_unit = Conduit.register (module Dummy_unit) let ( <.> ) f g x = f (g x) From 2b59b5e4e26c730b38adabfb6e0800180fb215e1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 15:21:04 +0100 Subject: [PATCH 115/140] 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 3a9476c1fde55bb90400ac44432ecd21782d6f41 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 15:51:05 +0100 Subject: [PATCH 116/140] Remove Comduit.pack and Conduit.unpack These functions introduce complexity without clear gain. --- bench/cost.ml | 15 ++++++++++++--- src/core/conduit.ml | 7 ------- src/core/conduit_intf.ml | 26 +------------------------- 3 files changed, 13 insertions(+), 35 deletions(-) diff --git a/bench/cost.ml b/bench/cost.ml index 0794b878..606dfef8 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -92,12 +92,21 @@ let fake1 = Tuyau.register (module Fake_protocol1) let fake2 = Tuyau.register (module Fake_protocol2) +module R0 = (val Tuyau.repr fake0) + +module R1 = (val Tuyau.repr fake1) + +module R2 = (val Tuyau.repr fake2) + let hello_world = "Hello World!\n" let fn_fully_abstr flow = Benchmark.V (fun () -> Tuyau.send flow hello_world) -let fn_abstr (Tuyau.Flow (flow, (module Flow))) = - Benchmark.V (fun () -> Flow.send flow hello_world) +let fn_abstr = function + | R0.T flow -> Benchmark.V (fun () -> Fake_protocol0.send flow hello_world) + | R1.T flow -> Benchmark.V (fun () -> Fake_protocol1.send flow hello_world) + | R2.T flow -> Benchmark.V (fun () -> Fake_protocol2.send flow hello_world) + | _ -> assert false type result = { with_conduit : float; @@ -139,7 +148,7 @@ let run json = Tuyau.connect Unix.stderr fake0 >>= fun flow -> Tuyau.send flow hello_world >>= fun _ -> let samples0 = Benchmark.run (fn_fully_abstr flow) in - let samples1 = Benchmark.run (fn_abstr (Tuyau.unpack flow)) in + let samples1 = Benchmark.run (fn_abstr flow) in match ( Linear_algebra.ols (fun m -> m.(1)) [| (fun m -> m.(0)) |] samples0, diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 93a20710..1c9f5417 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -352,13 +352,6 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) >>? 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 (Value (flow, Flow (_, m))) = Flw.prj flow in - Flow (flow, m) - let impl : type edn flow. (edn, flow) protocol -> diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 752b4ecd..56bd5c37 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -304,18 +304,6 @@ module type S = sig match flow with Conduit_tcp.T fd -> Unix.set_nonblock fd | _ -> () ]} *) - type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack - - val unpack : flow -> unpack - (** [pack flow] projects the module implementation associated to the given - abstract [flow] such as: - - {[ - connect edn >>= fun flow -> - let (Flow (flow, (module Flow))) = unpack flow in - Flow.send flow "Hello World!" - ]} *) - val impl : ('edn, 'flow) protocol -> ('edn, 'flow) impl (** [impl protocol] is [protocol]'s implementation. *) @@ -325,22 +313,10 @@ module type S = sig {[ match cast flow Conduit_tcp.t with - | Some (file_descr : Unix.file_descr) -> - Some (Unix.getpeername file_descr) + | Some (fd : Unix.file_descr) -> Some (Unix.getpeername fd) | None -> None ]} *) - val pack : (_, 'v) protocol -> 'v -> flow - (** [pack protocol concrete_flow] abstracts the given [flow] into the {!flow} - type from a given [protocol]. It permits to use [Conduit] with a concrete - value created by the user. - - {[ - let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let flow = pack Conduit_tcp.t socket in - send flow "Hello World!" - ]} *) - (** {2:resolution Domain name resolvers.} *) type 'edn resolver = Endpoint.t -> 'edn option io From 5b03c98d7cae7123410b09c7c97ebd3f09488026 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Sun, 29 Nov 2020 16:09:16 +0100 Subject: [PATCH 117/140] 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; ] ); ] From 06057f459fb4d698df427850571fdcd2edd4f8e1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 23:11:28 +0100 Subject: [PATCH 118/140] Rename Service.close into Service.stop --- src/async-ssl/conduit_async_ssl.ml | 4 ++-- src/async/conduit_async.ml | 6 +++--- src/core/conduit.ml | 4 ++-- src/core/conduit_intf.ml | 6 +++--- src/lwt-ssl/conduit_lwt_ssl.ml | 4 ++-- src/lwt/conduit_lwt.ml | 6 +++--- src/mirage/conduit_mirage.ml | 4 ++-- src/mirage/conduit_mirage_tcp.ml | 2 +- src/tls/conduit_tls.ml | 4 ++-- tests/flow.ml | 2 +- 10 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index c2faad3a..bace1f20 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -271,8 +271,8 @@ struct connection = conn; }) - let close (_, t) = - Service.close t >>= function + let stop (_, t) = + Service.stop t >>= function | Error err -> Async.return (Error (Service err)) | Ok _ as v -> Async.return v end diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 3c399bbb..0c5a53c4 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -48,9 +48,9 @@ let serve : | Ok (`Flow flow) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok (`Stop | `Timeout) -> Svc.close t + | Ok (`Stop | `Timeout) -> Svc.stop t | Error err0 -> ( - Svc.close t >>= function + Svc.stop t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in loop () >>= function @@ -242,7 +242,7 @@ module TCP = struct Async.return (Ok flow) | `Socket_closed -> Async.return (Error Socket_closed) - let close (Socket (socket, _)) = + let stop (Socket (socket, _)) = Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) end diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 1c9f5417..bd99049a 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -419,11 +419,11 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | Ok flow -> return (Ok (pack protocol flow)) | Error err -> return (error_msgf "%a" Service.pp_error err) - let close : + let stop : type cfg s flow. (cfg, s, flow) t -> s -> (unit, [> error ]) result io = fun (Service ((module Witness), _)) t -> let (Svc (_, (module Service))) = Witness.witness in - Service.close t >>= function + Service.stop t >>= function | Ok () -> return (Ok ()) | Error err -> return (error_msgf "%a" Service.pp_error err) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 56bd5c37..1e52c71f 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -95,7 +95,7 @@ module type SERVICE = sig val accept : t -> (flow, error) result io - val close : t -> (unit, error) result io + val stop : t -> (unit, error) result io end module type IO = sig @@ -464,8 +464,8 @@ module type S = sig (** [accept t s] waits for a connection on the server [s]. The result is a {i flow} connected to the client. *) - val close : ('cfg, 's, 'v) t -> 's -> (unit, [> error ]) result io - (** [close t s] releases the resources associated to the server [s]. *) + val stop : ('cfg, 's, 'v) t -> 's -> (unit, [> error ]) result io + (** [stop t s] releases the resources associated to the server [s]. *) val pack : (_, _, 'v) t -> 'v -> flow (** [pack service v] returns the abstracted value [v] as {!pack} does for a diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index 7537eba4..aa98b886 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -106,8 +106,8 @@ struct Lwt_unix.close (Service.file_descr flow) >>= fun () -> Lwt.fail exn in Lwt.try_bind accept process error - let close { service; _ } = - Service.close service >|= reword_error (fun err -> `Service err) + let stop { service; _ } = + Service.stop service >|= reword_error (fun err -> `Service err) end let service_with_ssl : diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index badb46e5..35c9ee32 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -88,9 +88,9 @@ let serve : | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok (`Stop | `Timeout) -> Svc.close t + | Ok (`Stop | `Timeout) -> Svc.stop t | Error err0 -> ( - Svc.close t >>= function + Svc.stop t >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function @@ -405,7 +405,7 @@ module TCP = struct Lwt.return_error `Firewall_rules_forbid_connection | exn -> Lwt.fail exn - let close _service = + let stop _service = (* XXX(dinosaure): it seems that on MacOS, try to close the [master] socket raises an error. *) Lwt.return_ok () diff --git a/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml index b4645c60..a8a610e9 100644 --- a/src/mirage/conduit_mirage.ml +++ b/src/mirage/conduit_mirage.ml @@ -35,9 +35,9 @@ let serve : | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok `Stop -> Svc.close service + | Ok `Stop -> Svc.stop service | Error err0 -> ( - Svc.close service >>= function + Svc.stop service >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index ec442e39..7d17bc13 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -267,7 +267,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct Lwt_mutex.unlock mutex ; accept t) - let close ({ stack; mutex; _ } as t) = + let stop ({ stack; mutex; _ } as t) = Lwt_mutex.with_lock mutex (fun () -> StackV4.disconnect stack >>= fun () -> t.closed <- true ; diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index c780f054..2c8fcbb2 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -352,8 +352,8 @@ struct Log.info (fun m -> m "A TLS flow is coming.") ; return (Ok { tls = Some tls; closed = false; raw; queue; flow }) - let close { service; _ } = - Service.close service >>| reword_error service_error + let stop { service; _ } = + Service.stop service >>| reword_error service_error end let service_with_tls : diff --git a/tests/flow.ml b/tests/flow.ml index 985a6b18..f3c653f4 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -288,7 +288,7 @@ module Dummy_service = struct let accept T = Ok Flow - let close T = Ok () + let stop T = Ok () end let dummy_protocol = Conduit.register (module Dummy_protocol) From 260f246d1e39b0b50efb3d6e5fcffac6ed2547e6 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 23:22:12 +0100 Subject: [PATCH 119/140] Rename Service.pack to Service.flow Also do not use this in the main loops for lwt and async serve function. --- src/async/conduit_async.ml | 12 +++++------- src/core/conduit.ml | 11 ++++------- src/core/conduit_intf.ml | 13 +++++-------- src/lwt/conduit_lwt.ml | 11 +++++------ 4 files changed, 19 insertions(+), 28 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 3c399bbb..cf65091c 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -25,7 +25,6 @@ let serve : fun ?timeout ~handler service cfg -> let open Async in let stop = Async.Condition.create () in - let module Svc = (val Service.impl service) in let main () = Service.init service cfg >>= function | Error err -> failwith "%a" Service.pp_error err @@ -33,9 +32,8 @@ let serve : let rec loop () = let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in let accept = - Svc.accept t >>? fun flow -> - Async.(Deferred.ok (return (`Flow (Service.pack service flow)))) - in + Service.accept service t >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in let events = match timeout with | None -> [ close; accept ] @@ -48,14 +46,14 @@ let serve : | Ok (`Flow flow) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok (`Stop | `Timeout) -> Svc.close t + | Ok (`Stop | `Timeout) -> Service.close service t | Error err0 -> ( - Svc.close t >>= function + Service.close service t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in loop () >>= function | Ok () -> Async.return () - | Error err -> failwith "%a" Svc.pp_error err) in + | Error err -> failwith "%a" Service.pp_error err) in (stop, main) let reader_and_writer_of_flow flow = diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 1c9f5417..a6d80915 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -317,9 +317,6 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | Error _err -> go r) in go l - let pack : type edn v. (edn, v) protocol -> v -> flow = - fun { flow = (module Witness); _ } flow -> Witness.T flow - let resolve : type edn v. resolvers -> @@ -413,10 +410,10 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let accept : type cfg s v. (cfg, s, v) t -> s -> (flow, [> error ]) result io = - fun (Service ((module Witness), protocol)) t -> + fun (Service ((module Witness), { flow = (module Flow); _ })) t -> let (Svc (_, (module Service))) = Witness.witness in Service.accept t >>= function - | Ok flow -> return (Ok (pack protocol flow)) + | Ok flow -> return (Ok (Flow.T flow)) | Error err -> return (error_msgf "%a" Service.pp_error err) let close : @@ -427,8 +424,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : | Ok () -> return (Ok ()) | Error err -> return (error_msgf "%a" Service.pp_error err) - let pack : type v. (_, _, v) t -> v -> flow = - fun (Service (_, protocol)) flow -> pack protocol flow + let flow : type v. (_, _, v) t -> v -> flow = + fun (Service (_, { flow = (module Witness); _ })) flow -> Witness.T flow let impl : type cfg s flow. diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 56bd5c37..498180f1 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -467,11 +467,8 @@ module type S = sig val close : ('cfg, 's, 'v) t -> 's -> (unit, [> error ]) result io (** [close t s] releases the resources associated to the server [s]. *) - val pack : (_, _, 'v) t -> 'v -> flow - (** [pack service v] returns the abstracted value [v] as {!pack} does for a - given protocol {i witness} (bound with the given [service]). It serves - to abstract the flow created (and initialised) by the service to a - {!flow}. + val flow : (_, _, 'v) t -> 'v -> flow + (** [flow t s] is the [s] seen as a an abstract {!flow}. {[ let handler (flow : flow) = @@ -479,11 +476,11 @@ module type S = sig ... let run service cfg = - let module Service = Service.impl service in + let module S = Service.impl service in Service.init cfg >>? fun t -> let rec loop t = - Service.accept t >>? fun flow -> - let flow = Service.pack service flow in + S.accept t >>? fun flow -> + let flow = Service.flow service flow in async (fun () -> handler flow) ; loop t in loop t diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index badb46e5..08c66e6f 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -65,7 +65,6 @@ let serve : fun ?timeout ~handler service cfg -> let open Lwt.Infix in let stop = Lwt_condition.create () in - let module Svc = (val Service.impl service) in let main () = Service.init service cfg >>= function | Error err -> failwith "%a" Service.pp_error err @@ -73,8 +72,8 @@ let serve : let rec loop () = let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in let accept = - Svc.accept t >>? fun flow -> - Lwt.return_ok (`Flow (Service.pack service flow)) in + Service.accept service t >>? fun flow -> Lwt.return_ok (`Flow flow) + in let events = match timeout with | None -> [ stop; accept ] @@ -88,14 +87,14 @@ let serve : | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok (`Stop | `Timeout) -> Svc.close t + | Ok (`Stop | `Timeout) -> Service.close service t | Error err0 -> ( - Svc.close t >>= function + Service.close service t >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" Svc.pp_error err) in + | Error err -> failwith "%a" Service.pp_error err) in (stop, main) module TCP = struct From 54f77d3129d7e6d4d100cdaedfe3d8c77d566bab Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sun, 29 Nov 2020 23:28:30 +0100 Subject: [PATCH 120/140] Conduit.connect: swap argument order to use a "t-first" convention --- bench/cost.ml | 2 +- src/core/conduit.ml | 4 ++-- src/core/conduit_intf.ml | 2 +- tests/flow.ml | 8 ++++---- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/bench/cost.ml b/bench/cost.ml index 606dfef8..6fbc59fa 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -145,7 +145,7 @@ let print_stdout est0 est1 r0 r1 = let run json = let open Rresult in - Tuyau.connect Unix.stderr fake0 >>= fun flow -> + Tuyau.connect fake0 Unix.stderr >>= fun flow -> Tuyau.send flow hello_world >>= fun _ -> let samples0 = Benchmark.run (fn_fully_abstr flow) in let samples1 = Benchmark.run (fn_abstr flow) in diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 1c9f5417..4de71a2c 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -346,8 +346,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : go l let connect : - type edn v. edn -> (edn, v) protocol -> (flow, [> error ]) result io = - fun edn { protocol = (module Witness); _ } -> + type edn v. (edn, v) protocol -> edn -> (flow, [> error ]) result io = + fun { protocol = (module Witness); _ } edn -> let (Protocol (_, (module Flow), (module Protocol))) = Witness.witness in Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) >>? fun flow -> return (Ok (Flow.T flow)) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 56bd5c37..5a0e802c 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -398,7 +398,7 @@ module type S = sig | flow -> ignore @@ send flow "Hello World!" ]} *) - val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io + val connect : ('edn, _) protocol -> 'edn -> (flow, [> error ]) result io (** {2:service Server-side conduits.} *) diff --git a/tests/flow.ml b/tests/flow.ml index 985a6b18..e481f743 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -86,7 +86,7 @@ let memory0 = Conduit.register (module Memory_flow0) let test_input_string = Alcotest.test_case "input string" `Quick @@ fun () -> let open Rresult in - let flow = Conduit.connect ("Hello World!", Bytes.empty) memory0 in + let flow = Conduit.connect memory0 ("Hello World!", Bytes.empty) in Alcotest.(check bool) "connect" (R.is_ok flow) true ; let flow = R.get_ok flow in let buf0 = Bytes.create 12 in @@ -105,7 +105,7 @@ let test_output_string = Alcotest.test_case "output string" `Quick @@ fun () -> let open Rresult in let buf = Bytes.create 12 in - let flow = Conduit.connect ("", buf) memory0 in + let flow = Conduit.connect memory0 ("", buf) in Alcotest.(check bool) "connect" (R.is_ok flow) true ; let flow = R.get_ok flow in let res0 = Conduit.send flow "Hell" in @@ -204,7 +204,7 @@ let test_input_strings = Alcotest.test_case "input strings" `Quick @@ fun () -> let open Rresult in let flow = - Conduit.connect ([ ""; "123"; "45"; "6789"; "0" ], [ Bytes.empty ]) memory1 + Conduit.connect memory1 ([ ""; "123"; "45"; "6789"; "0" ], [ Bytes.empty ]) in Alcotest.(check bool) "connect" (R.is_ok flow) true ; let flow = R.get_ok flow in @@ -229,7 +229,7 @@ let test_output_strings = Alcotest.test_case "output strings" `Quick @@ fun () -> let open Rresult in let bufs = [ Bytes.create 4; Bytes.empty; Bytes.create 2; Bytes.create 6 ] in - let flow = Conduit.connect ([], bufs) memory1 in + let flow = Conduit.connect memory1 ([], bufs) in Alcotest.(check bool) "connect" (R.is_ok flow) true ; let flow = R.get_ok flow in let res0 = Conduit.send flow "Hello" in From 916c95405c1accec9be2828e230142dfb6b56db5 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Mon, 30 Nov 2020 10:57:43 +0100 Subject: [PATCH 121/140] Fix tests about the renaming of Service.{close,stop} --- src/async/conduit_async.ml | 4 ++-- src/lwt/conduit_lwt.ml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index bc5c3cd5..bc2ebbd9 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -46,9 +46,9 @@ let serve : | Ok (`Flow flow) -> Async.don't_wait_for (handler flow) ; Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok (`Stop | `Timeout) -> Svc.stop t + | Ok (`Stop | `Timeout) -> Service.stop service t | Error err0 -> ( - Svc.stop t >>= function + Service.stop service t >>= function | Ok () -> Async.return (Error err0) | Error _err1 -> Async.return (Error err0)) in loop () >>= function diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 47a3c2f5..16b799b4 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -87,9 +87,9 @@ let serve : | Ok (`Flow flow) -> Lwt.async (fun () -> handler flow) ; Lwt.pause () >>= loop - | Ok (`Stop | `Timeout) -> Svc.stop t + | Ok (`Stop | `Timeout) -> Service.stop service t | Error err0 -> ( - Svc.stop t >>= function + Service.stop service t >>= function | Ok () -> Lwt.return_error err0 | Error _err1 -> Lwt.return_error err0) in loop () >>= function From 1dd5602e112c82ad5c19015684c236f00a09997c Mon Sep 17 00:00:00 2001 From: dinosaure Date: Mon, 30 Nov 2020 14:56:02 +0100 Subject: [PATCH 122/140] Better not found error --- bench/cost.ml | 2 +- src/core/conduit.ml | 31 ++++++++++++++++--------------- src/core/conduit_intf.ml | 2 +- tests/flow.ml | 4 ++-- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/bench/cost.ml b/bench/cost.ml index 6fbc59fa..479ec263 100644 --- a/bench/cost.ml +++ b/bench/cost.ml @@ -170,7 +170,7 @@ let main json = match run json with | Ok v -> v | Error (`Msg err) -> Fmt.epr "%s: %s.\n%!" Sys.argv.(0) err - | Error `Not_found -> assert false + | Error (`Not_found _edn) -> assert false let cmd = (Term.(const main $ json), Term.info "run benchmarks") diff --git a/src/core/conduit.ml b/src/core/conduit.ml index edff3ea3..5d23829f 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -236,24 +236,25 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let resolve = inj <.> resolve in Map.add key (Resolver { priority; resolve; witness }) - type error = [ `Msg of string | `Not_found ] + type error = [ `Msg of string | `Not_found of Endpoint.t ] let pf ppf fmt = Format.fprintf ppf fmt let pp_error ppf = function | `Msg err -> pf ppf "%s" err - | `Not_found -> pf ppf "Not found" + | `Not_found edn -> pf ppf "%a not found" Endpoint.pp edn let flow_of_endpoint : - type edn. edn key -> edn -> (flow, [> error ]) result io = - fun key edn -> + type edn. edn:Endpoint.t -> edn key -> edn -> (flow, [> error ]) result io + = + fun ~edn key v -> let rec go = function - | [] -> return (Error `Not_found) + | [] -> return (Error (`Not_found edn)) | 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 + Protocol.connect v >>= function | Ok flow -> return (Ok (Flow.T flow)) | Error _err -> go r) in go (Ptr.bindings ()) @@ -307,12 +308,12 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : go [] (List.sort compare (Map.bindings m)) let create : resolvers -> Endpoint.t -> (flow, [> error ]) result io = - fun m domain_name -> - resolve m domain_name >>= fun l -> + fun m edn -> + resolve m edn >>= fun l -> let rec go = function - | [] -> return (Error `Not_found) - | Endpoint (key, edn) :: r -> ( - flow_of_endpoint key edn >>= function + | [] -> return (Error (`Not_found edn)) + | Endpoint (key, v) :: r -> ( + flow_of_endpoint ~edn key v >>= function | Ok flow -> return (Ok flow) | Error _err -> go r) in go l @@ -323,16 +324,16 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : ?protocol:(edn, v) protocol -> Endpoint.t -> (flow, [> error ]) result io = - fun m ?protocol domain_name -> + fun m ?protocol edn -> match protocol with - | None -> create m domain_name + | None -> create m edn | 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 -> + resolve m edn >>= fun l -> let rec go = function - | [] -> return (Error `Not_found) + | [] -> return (Error (`Not_found edn)) | Endpoint (key, edn) :: r -> match Map.Key.(key == key') with | None -> go r diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 840ca164..403a830b 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -141,7 +141,7 @@ module type S = sig | _ -> ... (* use flow functions for the default case *) ]} *) - type error = [ `Msg of string | `Not_found ] + type error = [ `Msg of string | `Not_found of Endpoint.t ] val pp_error : error Fmt.t diff --git a/tests/flow.ml b/tests/flow.ml index a4d588be..51ff2195 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -24,11 +24,11 @@ let send = Alcotest.int let error = let pp ppf = function | #Rresult.R.msg as v -> Rresult.R.pp_msg ppf v - | `Not_found -> Fmt.string ppf "`Not_found" in + | `Not_found edn -> Fmt.pf ppf "%a not found" Conduit.Endpoint.pp edn in let equal a b = match (a, b) with | `Msg a, `Msg b -> a = b - | `Not_found, `Not_found -> true + | `Not_found a, `Not_found b -> Conduit.Endpoint.equal a b | _ -> false in Alcotest.testable pp equal From 921ce803f4c3e7bcc02fed746ea08339ac31aa04 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Mon, 30 Nov 2020 14:57:45 +0100 Subject: [PATCH 123/140] Delete the useless scheduler type --- src/core/conduit_intf.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 840ca164..82009bcf 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -124,9 +124,6 @@ module type S = sig type +'a io (** The type for I/O effects. *) - type scheduler - (** The type of I/O monads. *) - (** {2:client Client-side conduits.} *) type flow = private .. From 9d03e80c01d038f5ee0531e6d16a12642b32c599 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Mon, 30 Nov 2020 15:17:34 +0100 Subject: [PATCH 124/140] Add configuration function to help to make required value to initialize a service --- src/async-ssl/conduit_async_ssl.ml | 3 +++ src/async-ssl/conduit_async_ssl.mli | 6 ++++++ src/async-tls/conduit_async_tls.ml | 3 +++ src/async-tls/conduit_async_tls.mli | 6 ++++++ src/async/conduit_async.ml | 2 ++ src/async/conduit_async.mli | 3 +++ src/lwt-ssl/conduit_lwt_ssl.ml | 3 +++ src/lwt-ssl/conduit_lwt_ssl.mli | 6 ++++++ src/lwt-tls/conduit_lwt_tls.ml | 3 +++ src/lwt-tls/conduit_lwt_tls.mli | 6 ++++++ src/lwt/conduit_lwt.ml | 2 ++ src/lwt/conduit_lwt.mli | 2 ++ src/mirage/conduit_mirage_tcp.ml | 3 +++ src/mirage/conduit_mirage_tcp.mli | 7 +++++++ 14 files changed, 55 insertions(+) diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml index bace1f20..070b23ba 100644 --- a/src/async-ssl/conduit_async_ssl.ml +++ b/src/async-ssl/conduit_async_ssl.ml @@ -306,6 +306,9 @@ module TCP = struct service_with_ssl service ~reader:Protocol.reader ~writer:Protocol.writer protocol + let configuration ~context ?backlog listen = + (context, configuration ?backlog listen) + let resolve ~port ~context domain_name = resolve ~port domain_name >>| function | Some edn -> Some (context, edn) diff --git a/src/async-ssl/conduit_async_ssl.mli b/src/async-ssl/conduit_async_ssl.mli index 4cf95e96..434d3dfc 100644 --- a/src/async-ssl/conduit_async_ssl.mli +++ b/src/async-ssl/conduit_async_ssl.mli @@ -69,5 +69,11 @@ module TCP : sig Protocol.flow with_ssl ) service + val configuration : + context:context -> + ?backlog:int -> + ('a, 'litening_on) Tcp.Where_to_listen.t -> + context * configuration + val resolve : port:int -> context:context -> (context * endpoint) resolver end diff --git a/src/async-tls/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml index 9179385a..8886ba88 100644 --- a/src/async-tls/conduit_async_tls.ml +++ b/src/async-tls/conduit_async_tls.ml @@ -8,6 +8,9 @@ module TCP = struct let service = service_with_tls service protocol + let configuration ~config:tls_config ?backlog listen = + (configuration ?backlog listen, tls_config) + let resolve ~port ~config domain_name = resolve ~port domain_name >>| function | Some edn -> Some (edn, config) diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index 12ac4902..ef002271 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -36,6 +36,12 @@ module TCP : sig Protocol.flow protocol_with_tls ) service + val configuration : + config:Tls.Config.server -> + ?backlog:int -> + ('a, 'listening_on) Async_unix.Tcp.Where_to_listen.t -> + configuration * Tls.Config.server + val resolve : port:int -> config:Tls.Config.client -> diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index bc2ebbd9..5ab51150 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -246,6 +246,8 @@ module TCP = struct let service = S.register (module Service) protocol + let configuration ?backlog listen = Listen (backlog, listen) + let resolve ~port = function | Conduit.Endpoint.IP ip -> let inet_addr = diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 1f800696..9636d474 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -61,5 +61,8 @@ module TCP : sig val service : (configuration, Service.t, Protocol.flow) service + val configuration : + ?backlog:int -> ('a, 'listening_on) Tcp.Where_to_listen.t -> configuration + val resolve : port:int -> endpoint resolver end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml index aa98b886..c3474004 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.ml +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -132,6 +132,9 @@ module TCP = struct | Some edn -> Some (endpoint ~context ~file_descr ?verify edn) | None -> None + let configuration ~context ?capacity sockaddr = + (context, Conduit_lwt.TCP.configuration ?capacity sockaddr) + open Conduit_lwt.TCP type verify = diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli index d91f37f3..f650d3ce 100644 --- a/src/lwt-ssl/conduit_lwt_ssl.mli +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -97,5 +97,11 @@ module TCP : sig ?verify:verify -> (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver + val configuration : + context:Ssl.context -> + ?capacity:int -> + Lwt_unix.sockaddr -> + Ssl.context * configuration + type Conduit_lwt.flow += T of Lwt_ssl.socket end diff --git a/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml index f32e11d7..855b8fb4 100644 --- a/src/lwt-tls/conduit_lwt_tls.ml +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -16,4 +16,7 @@ module TCP = struct resolve ~port domain_name >|= function | Some edn -> Some (edn, config) | None -> None + + let configuration ~config:tls_config ?capacity sockaddr = + (configuration ?capacity sockaddr, tls_config) end diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index 1e455e3f..f81e4f22 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -52,4 +52,10 @@ module TCP : sig port:int -> config:Tls.Config.client -> (Lwt_unix.sockaddr * Tls.Config.client) resolver + + val configuration : + config:Tls.Config.server -> + ?capacity:int -> + Lwt_unix.sockaddr -> + configuration * Tls.Config.server end diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index 16b799b4..fb397f76 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -416,6 +416,8 @@ module TCP = struct let service = Conduit.Service.register (module Service) protocol + let configuration ?(capacity = 40) sockaddr = { capacity; sockaddr } + let resolve ~port = function | Conduit.Endpoint.IP ip -> Lwt.return_some (Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port)) diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 4a63e392..2eecf4e8 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -116,5 +116,7 @@ module TCP : sig val service : (configuration, Service.t, Protocol.flow) service + val configuration : ?capacity:int -> Lwt_unix.sockaddr -> configuration + val resolve : port:int -> Lwt_unix.sockaddr resolver end diff --git a/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml index 7d17bc13..cf3f8db2 100644 --- a/src/mirage/conduit_mirage_tcp.ml +++ b/src/mirage/conduit_mirage_tcp.ml @@ -275,4 +275,7 @@ module Make (StackV4 : Mirage_stack.V4) = struct end let service = Conduit_mirage.Service.register (module Service) protocol + + let configuration stackv4 ?keepalive ?(nodelay = false) ~port = + { stack = stackv4; keepalive; nodelay; port } end diff --git a/src/mirage/conduit_mirage_tcp.mli b/src/mirage/conduit_mirage_tcp.mli index 0a1bb09d..4cfc1b34 100644 --- a/src/mirage/conduit_mirage_tcp.mli +++ b/src/mirage/conduit_mirage_tcp.mli @@ -26,4 +26,11 @@ module Make (StackV4 : Mirage_stack.V4) : sig type service val service : (StackV4.t configuration, service, protocol) Service.t + + val configuration : + StackV4.t -> + ?keepalive:Mirage_protocols.Keepalive.t -> + ?nodelay:bool -> + port:int -> + StackV4.t configuration end From 71c411f2191ed4c58a1ddd2bfcb486e02979e61a Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Tue, 1 Dec 2020 15:06:54 +0100 Subject: [PATCH 125/140] core: expand aliases exposed in _intf file This ensures that the OCaml toplevel is able to introspect these signatures directly and prevents references to module types in `Conduit_intf` from escaping to the user. Fixes https://github.com/mirage/ocaml-conduit/issues/356. --- src/core/conduit.mli | 22 +--------------------- src/core/conduit_intf.ml | 31 +++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 21 deletions(-) diff --git a/src/core/conduit.mli b/src/core/conduit.mli index b8754784..851cafe3 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -1,22 +1,2 @@ -module Endpoint = Endpoint - -type resolvers -(** Type for resolvers map. *) - -val empty : resolvers -(** [empty] is an empty {!resolvers} map. *) - -module type S = Conduit_intf.S +include Conduit_intf.Conduit (** @inline *) - -module type IO = Conduit_intf.IO -(** @inline *) - -module type BUFFER = Conduit_intf.BUFFER -(** @inline *) - -module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : - S - with type input = Input.t - and type output = Output.t - and type +'a io = 'a IO.t diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 2c74033a..5bc9fa63 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -494,3 +494,34 @@ module type S = sig (** [impl service] is [service]'s underlying implementation. *) end end + +module type Conduit = sig + module Endpoint = Endpoint + + type resolvers + (** Type for resolvers map. *) + + val empty : resolvers + (** [empty] is an empty {!resolvers} map. *) + + module type S = sig + include S + (** @inline *) + end + + module type IO = sig + include IO + (** @inline *) + end + + module type BUFFER = sig + include BUFFER + (** @inline *) + end + + module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : + S + with type input = Input.t + and type output = Output.t + and type +'a io = 'a IO.t +end From f770ce07a67ba3862a45a1e648e681368cc99155 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 1 Dec 2020 21:33:37 +0100 Subject: [PATCH 126/140] specialise partial applications when possible so users can write: ``` let send = Conduit.send flow ... send buf ``` and `send` will be compiled optimally. --- src/core/conduit.ml | 52 +++++++++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 23 deletions(-) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 5d23829f..05f22d33 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -175,17 +175,19 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : * - performance is intrinsic with [caml_hash] *) - let recv flow input = + let recv flow = 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)) + fun input -> + Protocol.recv flow input >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) - let send flow output = + let send flow = 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)) + fun output -> + Protocol.send flow output >>| function + | Ok _ as v -> v + | Error err -> Error (`Msg (strf "%a" Protocol.pp_error err)) let close flow = let (Value (flow, Flow (_, (module Protocol)))) = Flw.prj flow in @@ -345,10 +347,11 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let connect : type edn v. (edn, v) protocol -> edn -> (flow, [> error ]) result io = - fun { protocol = (module Witness); _ } edn -> + fun { 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 (Flow.T flow)) + fun edn -> + Protocol.connect edn >>| reword_error (msgf "%a" Protocol.pp_error) + >>? fun flow -> return (Ok (Flow.T flow)) let impl : type edn flow. @@ -403,27 +406,30 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let init : type cfg s flow. (cfg, s, flow) t -> cfg -> (s, [> error ]) result io = - fun (Service ((module Witness), _)) cfg -> + fun (Service ((module Witness), _)) -> let (Svc (_, (module Service))) = Witness.witness in - Service.init cfg >>= function - | Ok t -> return (Ok t) - | Error err -> return (error_msgf "%a" Service.pp_error err) + fun cfg -> + Service.init cfg >>= function + | Ok t -> return (Ok t) + | Error err -> return (error_msgf "%a" Service.pp_error err) let accept : type cfg s v. (cfg, s, v) t -> s -> (flow, [> error ]) result io = - fun (Service ((module Witness), { flow = (module Flow); _ })) t -> + fun (Service ((module Witness), { flow = (module Flow); _ })) -> let (Svc (_, (module Service))) = Witness.witness in - Service.accept t >>= function - | Ok flow -> return (Ok (Flow.T flow)) - | Error err -> return (error_msgf "%a" Service.pp_error err) + fun t -> + Service.accept t >>= function + | Ok flow -> return (Ok (Flow.T flow)) + | Error err -> return (error_msgf "%a" Service.pp_error err) let stop : type cfg s flow. (cfg, s, flow) t -> s -> (unit, [> error ]) result io = - fun (Service ((module Witness), _)) t -> + fun (Service ((module Witness), _)) -> let (Svc (_, (module Service))) = Witness.witness in - Service.stop t >>= function - | Ok () -> return (Ok ()) - | Error err -> return (error_msgf "%a" Service.pp_error err) + fun t -> + Service.stop t >>= function + | Ok () -> return (Ok ()) + | Error err -> return (error_msgf "%a" Service.pp_error err) let flow : type v. (_, _, v) t -> v -> flow = fun (Service (_, { flow = (module Witness); _ })) flow -> Witness.T flow From 0205b79456250012d279747b85efb4b16cd1e03f Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:26:51 +0100 Subject: [PATCH 127/140] Remove unused Conduit_lwt_flow module --- src/mirage/conduit_lwt_flow.ml | 41 --------------------------------- src/mirage/conduit_lwt_flow.mli | 18 --------------- 2 files changed, 59 deletions(-) delete mode 100644 src/mirage/conduit_lwt_flow.ml delete mode 100644 src/mirage/conduit_lwt_flow.mli diff --git a/src/mirage/conduit_lwt_flow.ml b/src/mirage/conduit_lwt_flow.ml deleted file mode 100644 index 7ef5eee4..00000000 --- a/src/mirage/conduit_lwt_flow.ml +++ /dev/null @@ -1,41 +0,0 @@ -open Lwt.Infix - -type flow = Conduit_lwt.flow - -type error = Conduit_lwt.error - -type write_error = [ Mirage_flow.write_error | Conduit_lwt.error ] - -let pp_error = Conduit_lwt.pp_error - -let pp_write_error ppf = function - | #Mirage_flow.write_error as err -> Mirage_flow.pp_write_error ppf err - | #Conduit_lwt.error as err -> Conduit_lwt.pp_error ppf err - -let read flow = - let raw = Cstruct.create 0x1000 in - Conduit_lwt.recv flow raw >>= function - | Ok `End_of_flow -> Lwt.return_ok `Eof - | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) - | Error _ as err -> Lwt.return err - -let write flow raw = - let rec go x = - if Cstruct.len x = 0 - then Lwt.return_ok () - else - Conduit_lwt.send flow x >>= function - | Error _ as err -> Lwt.return err - | Ok len -> go (Cstruct.shift x len) in - go raw - -let writev flow cs = - let rec go = function - | [] -> Lwt.return_ok () - | x :: r -> ( - write flow x >>= function - | Ok () -> go r - | Error _ as err -> Lwt.return err) in - go cs - -let close flow = Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit diff --git a/src/mirage/conduit_lwt_flow.mli b/src/mirage/conduit_lwt_flow.mli deleted file mode 100644 index be564f6a..00000000 --- a/src/mirage/conduit_lwt_flow.mli +++ /dev/null @@ -1,18 +0,0 @@ -(** An implementation of [conduit-lwt] according the interface [Mirage_flow.S]. - This module is {b deprecated} when the current implementation of [read] has - another behaviour: - - [conduit] provides: - - {[ val read : flow -> Cstruct.t -> (int or_eoi, error) result Lwt.t ]} - - where [mirage-flow] expects: - - {[ val read : flow -> (Cstruct.t or_eoi, error) result Lwt.t ]} - - This current implementation allocates an {b arbitrary} 4096 bytes buffer to - fit under the [mirage-flow] interface. [conduit] did the choice to follow - the POSIX interface and let the end-user to allocate by himself the input - buffer. *) - -include Mirage_flow.S with type flow = Conduit_lwt.flow From 9f2fa3e423457acd9a4e1ddba744557e48e0532b Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:33:04 +0100 Subject: [PATCH 128/140] Update behavior of the LWT UNIX TCP/IP stack to call only one time syscalls --- src/lwt/conduit_lwt.ml | 96 ++++++++++++----------------------------- src/lwt/conduit_lwt.mli | 29 ++++++------- 2 files changed, 41 insertions(+), 84 deletions(-) diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index fb397f76..a11ae406 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -15,12 +15,11 @@ let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt let io_of_flow flow = let open Lwt.Infix in - let mutex = Lwt_mutex.create () in let ic_closed = ref false and oc_closed = ref false in let close () = if !ic_closed && !oc_closed then - Lwt_mutex.with_lock mutex (fun () -> close flow) >>= function + close flow >>= function | Ok () -> Lwt.return_unit | Error err -> failwith "%a" pp_error err else Lwt.return_unit in @@ -30,26 +29,22 @@ let io_of_flow flow = let oc_close () = oc_closed := true ; close () in - let rec rrecv buf off len = + let rrecv buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - Lwt_mutex.with_lock mutex (fun () -> recv flow raw) >>= function - | Ok (`Input 0) -> - if len = 0 - then Lwt.return 0 - else Lwt_unix.yield () >>= fun () -> rrecv buf off len + recv flow raw >>= function | Ok (`Input len) -> Lwt.return len | Ok `End_of_flow -> Lwt.return 0 - | Error err -> failwith "%a" pp_error err in + | Error err -> + ic_closed := true ; + failwith "%a" pp_error err in let ic = Lwt_io.make ~close:ic_close ~mode:Lwt_io.input rrecv in - let rec ssend buf off len = + let ssend buf off len = let raw = Cstruct.of_bigarray buf ~off ~len in - Lwt_mutex.with_lock mutex (fun () -> send flow raw) >>= function - | Ok 0 -> - if len = 0 - then Lwt.return 0 - else Lwt_unix.yield () >>= fun () -> ssend buf off len + send flow raw >>= function | Ok len -> Lwt.return len - | Error err -> failwith "%a" pp_error err in + | Error err -> + oc_closed := true ; + failwith "%a" pp_error err in let oc = Lwt_io.make ~close:oc_close ~mode:Lwt_io.output ssend in (ic, oc) @@ -200,40 +195,18 @@ module TCP = struct (* | EINPROGRESS: TODO *) in go () - (* XXX(dinosaure): [recv] wants to fill [raw] as much as possible until - it has reached [`End_of_file]. *) - let rec recv ({ socket; closed; _ } as t) raw = + let rec recv ({ socket; closed; _ } as t) + ({ Cstruct.buffer; off; len } as raw) = if closed then Lwt.return_ok `End_of_flow else - let rec process filled raw = - let max = Cstruct.len raw in - Lwt_unix.read socket t.linger 0 (min max (Bytes.length t.linger)) - >>= fun len -> - if len = 0 - then - Lwt.return_ok (if filled = 0 then `End_of_flow else `Input filled) - else ( - Cstruct.blit_from_bytes t.linger 0 raw 0 len ; - if len = Bytes.length t.linger && max > Bytes.length t.linger - then - if Lwt_unix.readable t.socket - then process (filled + len) (Cstruct.shift raw len) - else - Lwt.return_ok - (if filled + len = 0 - then `End_of_flow - else `Input (filled + len)) - else - Lwt.return_ok - (if filled + len = 0 - then `End_of_flow - else `Input (filled + len))) in - Lwt.catch (fun () -> - if Lwt_unix.readable t.socket - then process 0 raw - else Lwt.return_ok (`Input 0)) - @@ function + let process () = + Lwt_bytes.read socket buffer off len >>= function + | 0 -> + Lwt_unix.shutdown socket SHUTDOWN_RECEIVE ; + Lwt.return (Ok `End_of_flow) + | len -> Lwt.return (Ok (`Input len)) in + Lwt.catch process @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> recv t raw | Unix.(Unix_error (EINTR, _, _)) -> recv t raw | Unix.(Unix_error (EFAULT, _, _)) -> Lwt.return_error `Bad_address @@ -243,38 +216,23 @@ module TCP = struct (* | EBADF: impossible *) | exn -> Lwt.fail exn - (* XXX(dinosaure): [send] tries to send as much as it can [raw]. However, - if [send] returns something smaller that what we requested, we stop - the process and return how many byte(s) we sended. - - Try to send into a closed socket is an error. *) - let rec send ({ socket; closed; _ } as t) raw = + let rec send ({ socket; closed; _ } as t) + ({ Cstruct.buffer; off; len } as raw) = if closed then Lwt.return_error `Closed_by_peer else - let rec process pushed raw = - if Cstruct.len raw = 0 - then Lwt.return_ok pushed - else - let max = Cstruct.len raw in - let len0 = min (Bytes.length t.linger) max in - Cstruct.blit_to_bytes raw 0 t.linger 0 len0 ; - Lwt_unix.write socket t.linger 0 len0 >>= fun len1 -> - if len1 = len0 && len0 = max - then Lwt.return_ok (pushed + len1) - else process (pushed + len1) (Cstruct.shift raw len1) in - Lwt.catch (fun () -> process 0 raw) @@ function + let process () = + Lwt_bytes.write socket buffer off len >|= fun len -> Ok len in + Lwt.catch process @@ function | Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> send t raw | Unix.(Unix_error (EINTR, _, _)) -> send t raw | Unix.(Unix_error (EACCES, _, _)) -> Lwt.return_error `Operation_not_permitted | Unix.(Unix_error (ECONNRESET, _, _)) -> - Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; - t.closed <- true ; + Lwt_unix.shutdown socket SHUTDOWN_SEND ; Lwt.return_error `Closed_by_peer | Unix.(Unix_error (EPIPE, _, _)) -> - Lwt_unix.shutdown t.socket Unix.SHUTDOWN_ALL ; - t.closed <- true ; + Lwt_unix.shutdown socket SHUTDOWN_SEND ; Lwt.return_error `Closed_by_peer | Unix.(Unix_error (EDESTADDRREQ, _, _)) | Unix.(Unix_error (ENOTCONN, _, _)) -> diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index 2eecf4e8..a328f46e 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -11,13 +11,8 @@ val io_of_flow : (** [io_of_flow flow] creates an input flow and an output flow according to [Lwt_io]. This function, even if it creates something more usable is {b deprecated}. Indeed, [Lwt_io] has its own way to schedule [read] and - [write] - you should be aware about that more specially when you use - [Conduit_tls] or [Conduit_lwt_ssl]. - - Due to a specific behavior, [Lwt_io] does not fit with some specific - protocols - non thread-safe protocols, {i send-first} protocols, etc. From - these reasons, and even if {!TCP} try to the best to fit under an [Lwt_io], - you should not use this function. *) + [write]. It assumes (but it can not check) that [Conduit.recv flow] and + [Conduit.send flow] are {i thread-safe}. They can be called concurrently. *) type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t (** The type for lwt services. *) @@ -50,15 +45,19 @@ module TCP : sig Behaviours of [Protocol] differs from {i syscall} provided by [Lwt_unix]. This is a description of what they currently do. - {b NOTE}: [recv] wants to fill the given buffer as much as possible until - it has reached {i end-of-input}. In other words, [recv] can do a multiple - call to [Lwt_unix.recv] to fill the given buffer. + {b NOTE}: [recv] does one and unique call of [Lwt_unix.read]. It returns + what [Lwt_unix.read] returns with a special case when it returns [0]. In + that case, we returns [`End_of_flow]. Any errors (exception) are handled + and, in that case, we {i shutdown} the underlying socket. + + {b NOTE}: [close] calls [Lwt_unix.close] only one and unique time. Then, + all subsequent calls of [recv] returns [`End_of_flow] and all subsequent + calls of [send] returns an error. - {b NOTE}: [send] tries to send as much as it can the given buffer. - However, if internal call of [Lwt_unix.send] returns something smaller - than what we requested, we stop the process and return how many byte(s) we - sended. In other word, [send] can do a multiple call to [Lwt_unix.send] - until we fully sended what we wanted. *) + {b NOTE}: [send] tries to send in one call to [Lwt_unix.write] the given + buffer. It returns how many bytes was transmitted, as [Lwt_unix.write]. It + handles exception and {i shutdown} the connection when we got [ECONNRESET] + or [EPIPE]. *) module Protocol : sig include From 3fa1343a214f8175483e5b8c97b59a1204e3bc6a Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:34:10 +0100 Subject: [PATCH 129/140] Avoid the recursion on the Async TCP/IP stack to call only one time syscalls --- src/async/conduit_async.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index 5ab51150..d501f034 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -149,7 +149,7 @@ module TCP = struct (* XXX(dinosaure): as [lwt] and seems required for [conduit-tls], [recv] wants to read as much as possible. Due to underlying non-blocking socket, even if we reached [`Eof], we must retry to read until we have something or the underlying socket was closed. *) - let rec recv (Socket { socket; reader; _ } as flow) raw = + let recv (Socket { reader; _ }) raw = Monitor.try_with (fun () -> Reader.read_bigsubstring reader (of_cstruct raw)) >>= function @@ -157,10 +157,7 @@ module TCP = struct Reader.close reader >>= fun () -> Async.return (Error (Core.Error.of_exn err)) | Ok (`Ok n) -> Async.return (Ok (`Input n)) - | Ok `Eof -> ( - Fd.ready_to (Socket.fd socket) `Read >>= function - | `Bad_fd | `Closed -> Async.return (Ok `End_of_flow) - | `Ready -> Scheduler.yield () >>= fun () -> recv flow raw) + | Ok `Eof -> Async.return (Ok `End_of_flow) let send (Socket { writer; _ }) raw = Writer.write_bigsubstring writer (of_cstruct raw) ; From 2bf766ca9a123d5563dd1a118cab9c7ccf8a2cd9 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:34:42 +0100 Subject: [PATCH 130/140] Avoid the case (`Input 0) which should never appear --- tests/ping-pong/common.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index ad7d0d32..149c315f 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -73,7 +73,6 @@ struct | None -> ( Conduit.recv flow tmp >>? function | `End_of_flow -> IO.return (Ok `Close) - | `Input 0 -> IO.yield () >>= go | `Input len -> Ke.Rke.N.push queue ~blit ~length:Cstruct.len ~off:0 ~len tmp ; go ()) in From 89f6cd838f1a77d5be6477556ace50d8822f5984 Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Wed, 2 Dec 2020 19:56:54 +0100 Subject: [PATCH 131/140] Re-export module types within S under Conduit.* --- src/core/conduit_intf.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 5bc9fa63..53a02b9e 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -524,4 +524,21 @@ module type Conduit = sig with type input = Input.t and type output = Output.t and type +'a io = 'a IO.t + + (** General module types re-exported for convenience. *) + + module type FLOW = sig + include FLOW + (** @inline *) + end + + module type PROTOCOL = sig + include PROTOCOL + (** @inline *) + end + + module type SERVICE = sig + include SERVICE + (** @inline *) + end end From 444350a7056169308ad7c14812d67c7659d20f84 Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Wed, 2 Dec 2020 20:02:44 +0100 Subject: [PATCH 132/140] Re-export Conduit.Refl constructor --- src/core/conduit_intf.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 53a02b9e..7f8a32a1 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -498,6 +498,8 @@ end module type Conduit = sig module Endpoint = Endpoint + type nonrec ('a, 'b) refl = ('a, 'b) refl + type resolvers (** Type for resolvers map. *) From 372bf50f0cb3fad51d37f9e040d3e2d1cf409f0e Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 21:26:52 +0100 Subject: [PATCH 133/140] Re-export refl to be usable outside of conduit --- src/core/conduit.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core/conduit.mli b/src/core/conduit.mli index 851cafe3..55d18cf3 100644 --- a/src/core/conduit.mli +++ b/src/core/conduit.mli @@ -1,2 +1,4 @@ +type ('a, 'b) refl = ('a, 'b) Conduit_intf.refl = Refl : ('a, 'a) refl + include Conduit_intf.Conduit (** @inline *) From fc0888c2651cc8b8b528e08e84212552be2f12b1 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 21:28:58 +0100 Subject: [PATCH 134/140] Delete multiple defintion of refl --- src/core/conduit_intf.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 7f8a32a1..53a02b9e 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -498,8 +498,6 @@ end module type Conduit = sig module Endpoint = Endpoint - type nonrec ('a, 'b) refl = ('a, 'b) refl - type resolvers (** Type for resolvers map. *) From 838df810550bc894e065b948fa55f0dbe4bee9d3 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:45:56 +0100 Subject: [PATCH 135/140] Copy/paste tls.lwt with minor update and provide a thread-safe implementation of the TLS layer --- src/tls/conduit_tls.ml | 733 ++++++++++++++++++++++------------------ src/tls/conduit_tls.mli | 52 +-- 2 files changed, 418 insertions(+), 367 deletions(-) diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml index 2c8fcbb2..8a6935af 100644 --- a/src/tls/conduit_tls.ml +++ b/src/tls/conduit_tls.ml @@ -1,371 +1,452 @@ -module Ke = Ke.Rke +[@@@warning "-32"] -let option_fold ~none ~some = function Some x -> some x | None -> none +exception Tls_alert of Tls.Packet.alert_type -(* NOTE(dinosaure): we use an unbound queue where TLS can produce - something bigger than the given input. It seems hard to limit - the internal queue and arbitrary limit (like a queue two times - larger than the input) is not good. By this fact, we use [Ke.Rke] - even if it an infinitely grow. *) +exception Tls_failure of Tls.Engine.failure + +module type IO = sig + type +'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t + + val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t + + val fail : exn -> 'a t +end + +module type S0 = sig + type +'a io + + type file_descr + + val read : file_descr -> Cstruct.t -> int io + + val write : file_descr -> Cstruct.t -> int io + + val write_full : file_descr -> Cstruct.t -> unit io + + val close : file_descr -> unit io + + type endpoint + + type error + + val pp_error : Format.formatter -> error -> unit + + val connect : endpoint -> (file_descr, error) result io +end module Make - (IO : Conduit.IO) + (IO : IO) (Conduit : Conduit.S - with type input = Cstruct.t - and type output = Cstruct.t - and type +'a io = 'a IO.t) = + with type 'a io = 'a IO.t + and type input = Cstruct.t + and type output = Cstruct.t) = struct - let return x = IO.return x - let ( >>= ) x f = IO.bind x f - let ( >>| ) x f = x >>= fun x -> return (f x) + let return x = IO.return x - let ( >>? ) x f = - x >>= function Ok x -> f x | Error err -> return (Error err) + let ( >|= ) x f = x >>= fun x -> return (f x) - let reword_error : ('e0 -> 'e1) -> ('a, 'e0) result -> ('a, 'e1) result = - fun f -> function Ok v -> Ok v | Error err -> Error (f err) + let return_unit = return () - let src = Logs.Src.create "conduit-tls" + let[@inline never] fail exn = IO.fail exn - module Log = (val Logs.src_log src : Logs.LOG) + let safely th = + IO.catch (fun () -> th >>= fun _ -> return_unit) (fun _ -> return_unit) type 'flow protocol_with_tls = { - mutable tls : Tls.Engine.state option; - mutable closed : bool; - raw : Cstruct.t; - flow : 'flow; - queue : (char, Bigarray.int8_unsigned_elt) Ke.t; + fd : 'flow; + mutable state : [ `Active of Tls.Engine.state | `Eof | `Error of exn ]; + mutable linger : Cstruct.t option; + recv_buf : Cstruct.t; } - let underlying { flow; _ } = flow + module Make_drain_handshake (Protocol : S0 with type 'a io = 'a IO.t) : sig + val drain_handshake : + Protocol.file_descr protocol_with_tls -> + Protocol.file_descr protocol_with_tls IO.t + + val read_react : + Protocol.file_descr protocol_with_tls -> + [> `Eof | `Ok of Cstruct.t option ] IO.t + + val write_t : + Protocol.file_descr protocol_with_tls -> Cstruct.t -> unit IO.t + end = struct + let read_t, write_t = + let recording_errors op t cs = + IO.catch + (fun () -> op t.fd cs) + (fun exn -> + (match t.state with + | `Error _ | `Eof -> () + | `Active _ -> t.state <- `Error exn) ; + fail exn) in + (recording_errors Protocol.read, recording_errors Protocol.write_full) + + let when_some f = function None -> return_unit | Some x -> f x + + let rec read_react t = + let handle tls buf = + match Tls.Engine.handle_tls tls buf with + | `Ok (state', `Response resp, `Data data) -> + let state' = + match state' with + | `Ok tls -> `Active tls + | `Eof -> `Eof + | `Alert a -> `Error (Tls_alert a) in + t.state <- state' ; + safely (resp |> when_some (write_t t)) >|= fun () -> `Ok data + | `Fail (alert, `Response resp) -> + t.state <- `Error (Tls_failure alert) ; + write_t t resp >>= fun () -> read_react t in + + match t.state with + | `Error e -> fail e + | `Eof -> return `Eof + | `Active _ -> ( + read_t t t.recv_buf >>= fun n -> + match (t.state, n) with + | `Active _, 0 -> + t.state <- `Eof ; + return `Eof + | `Active tls, n -> handle tls (Cstruct.sub t.recv_buf 0 n) + | `Error e, _ -> fail e + | `Eof, _ -> return `Eof) + + (* + * XXX bad XXX + * This is a point that should particularly be protected from concurrent r/w. + * Doing this before a `t` is returned is safe; redoing it during rekeying is + * not, as the API client already sees the `t` and can mistakenly interleave + * writes while this is in progress. + * *) + let rec drain_handshake t = + let push_linger t mcs = + let open Tls.Utils.Cs in + match (mcs, t.linger) with + | None, _ -> () + | scs, None -> t.linger <- scs + | Some cs, Some l -> t.linger <- Some (l <+> cs) in + match t.state with + | `Active tls when not (Tls.Engine.handshake_in_progress tls) -> return t + | _ -> ( + read_react t >>= function + | `Eof -> fail End_of_file + | `Ok cs -> + push_linger t cs ; + drain_handshake t) + end - let handshake { tls; _ } = - match tls with - | Some tls -> Tls.Engine.handshake_in_progress tls - | None -> false + module type PROTOCOL = + Conduit.PROTOCOL + with type 'a io = 'a IO.t + and type input = Cstruct.t + and type output = Cstruct.t - module Make_protocol (Flow : Conduit.PROTOCOL) = struct - type input = Conduit.input + module Make_S0_from_PROTOCOL (Protocol : PROTOCOL) = struct + exception Local_failure of string - type output = Conduit.output + let failwithf fmt = + Format.kasprintf (fun err -> fail (Local_failure err)) fmt - type +'a io = 'a Conduit.io + type +'a io = 'a IO.t - type endpoint = Flow.endpoint * Tls.Config.client + type file_descr = Protocol.flow - type flow = Flow.flow protocol_with_tls + let read file_descr buf = + Protocol.recv file_descr buf >>= function + | Ok (`Input len) -> return len + | Ok `End_of_flow -> return 0 + | Error err -> failwithf "%a" Protocol.pp_error err - type error = - [ `Msg of string - | `Flow of Flow.error - | `TLS of Tls.Engine.failure - | `Closed_by_peer ] - - let pp_error : error Fmt.t = - fun ppf -> function - | `Msg err -> Fmt.string ppf err - | `Flow err -> Flow.pp_error ppf err - | `TLS failure -> Fmt.string ppf (Tls.Engine.string_of_failure failure) - | `Closed_by_peer -> Fmt.string ppf "Closed by peer" - - let flow_error err = `Flow err - - let flow_wr_opt : - Flow.flow -> Cstruct.t option -> (unit, error) result Conduit.io = - fun flow -> function - | None -> return (Ok ()) - | Some raw -> - Log.debug (fun m -> m "~> Send %d bytes" (Cstruct.len raw)) ; - let rec go raw = - Flow.send flow raw >>| reword_error flow_error >>? fun len -> - let raw = Cstruct.shift raw len in - if Cstruct.len raw = 0 then return (Ok ()) else go raw in - go raw - - let blit src src_off dst dst_off len = - let src = Cstruct.to_bigarray src in - Bigstringaf.blit src ~src_off dst ~dst_off ~len - - let queue_wr_opt queue = function - | None -> () - | Some raw -> - Log.debug (fun m -> - m "Fill the queue with %d byte(s)." (Cstruct.len raw)) ; - Ke.N.push queue ~blit ~length:Cstruct.len ~off:0 raw - - let handle_tls : - Tls.Engine.state -> - (char, Bigarray.int8_unsigned_elt) Ke.t -> - Flow.flow -> - Cstruct.t -> - (Tls.Engine.state option, error) result IO.t = - fun tls queue flow raw -> - match Tls.Engine.handle_tls tls raw with - | `Fail (failure, `Response resp) -> - Log.debug (fun m -> m "|- TLS state: Fail") ; - flow_wr_opt flow (Some resp) >>? fun () -> - return (Error (`TLS failure)) - | `Ok (`Alert _alert, `Response resp, `Data data) -> - Log.debug (fun m -> m "|- TLS state: Alert") ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) - | `Ok (`Eof, `Response resp, `Data data) -> - Log.debug (fun m -> m "|- TLS state: EOF") ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> return (Ok None) - | `Ok (`Ok tls, `Response resp, `Data data) -> - (* XXX(dinosaure): it seems that decoding TLS inputs can produce - something bigger than expected. For example, decoding 4096 bytes - can produce 4119 byte(s). *) - Log.debug (fun m -> m "|- TLS state: Ok.") ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) - - let handle_handshake : - Tls.Engine.state -> - (char, Bigarray.int8_unsigned_elt) Ke.t -> - Flow.flow -> - Cstruct.t -> - (Tls.Engine.state option, error) result IO.t = - fun tls queue flow raw0 -> - let rec go tls raw1 = - match Tls.Engine.can_handle_appdata tls with - | true -> - Log.debug (fun m -> m "Start to talk with TLS (handshake is done).") ; - handle_tls tls queue flow raw1 - | false -> ( - assert (Tls.Engine.handshake_in_progress tls = true) ; - Log.debug (fun m -> m "Process TLS handshake.") ; - - (* XXX(dinosaure): assertion, [Tls.Engine.handle_tls] consumes all - bytes of [raw1] and [raw1] is physically a subset of [raw0] (or - is [raw0]). we can re-use [raw0] for [Flow.recv] safely. *) - match Tls.Engine.handle_tls tls raw1 with - | `Ok (`Ok tls, `Response resp, `Data data) -> - Log.debug (fun m -> - m "-- TLS state: OK (data: %d byte(s))" - (option_fold ~none:0 ~some:Cstruct.len data)) ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> - if Tls.Engine.handshake_in_progress tls - then ( - Log.debug (fun m -> - m "<- Read the TLS flow (while handshake).") ; - Flow.recv flow raw0 >>| reword_error flow_error >>? function - | `End_of_flow -> - Log.warn (fun m -> - m - "Got EOF from underlying connection while \ - handshake.") ; - return (Ok None) - | `Input 0 -> - Log.debug (fun m -> - m "Underlying connection asks to re-schedule.") ; - return (Ok (Some tls)) - | `Input len -> - Log.debug (fun m -> - let uid = - Hashtbl.hash - (Cstruct.to_string (Cstruct.sub raw0 0 len)) in - m - "<~ [%04x] Got %d bytes (handshake in progress: \ - true)." - uid len) ; - go tls (Cstruct.sub raw0 0 len)) - else ( - Log.debug (fun m -> m "Handshake is done.") ; - return (Ok (Some tls))) - | `Ok (`Eof, `Response resp, `Data data) -> - Log.debug (fun m -> m "-- TLS state: EOF") ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> return (Ok None) - | `Fail (failure, `Response resp) -> - Log.debug (fun m -> m "-- TLS state: Fail") ; - flow_wr_opt flow (Some resp) >>? fun () -> - return (Error (`TLS failure)) - | `Ok (`Alert _alert, `Response resp, `Data data) -> - Log.debug (fun m -> m "-- TLS state: Alert") ; - queue_wr_opt queue data ; - flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls))) + let write file_descr buf = + Protocol.send file_descr buf >>= function + | Ok len -> return len + | Error err -> failwithf "%a" Protocol.pp_error err + + let rec write_full file_descr = function + | cs when Cstruct.len cs = 0 -> return () + | cs -> ( + Protocol.send file_descr cs >>= function + | Ok len -> write_full file_descr (Cstruct.shift cs len) + | Error err -> failwithf "%a" Protocol.pp_error err) + + let close file_descr = + Protocol.close file_descr >>= function + | Ok () -> return () + | Error err -> failwithf "%a" Protocol.pp_error err + + type endpoint = Protocol.endpoint + + type error = Protocol.error + + let pp_error = Protocol.pp_error + + let connect = Protocol.connect + end + + module Make0 (Protocol : S0 with type 'a io = 'a IO.t) = struct + type t = Protocol.file_descr protocol_with_tls + + include Make_drain_handshake (Protocol) + + let rec read t buf = + let writeout res = + let open Cstruct in + let rlen = len res in + let n = min (len buf) rlen in + blit res 0 buf 0 n ; + t.linger <- (if n < rlen then Some (sub res n (rlen - n)) else None) ; + return n in + + match t.linger with + | Some res -> writeout res + | None -> ( + read_react t >>= function + | `Eof -> return 0 + | `Ok None -> read t buf + | `Ok (Some res) -> writeout res) + + let writev t css = + match t.state with + | `Error err -> fail err + | `Eof -> fail @@ Invalid_argument "tls: closed socket" + | `Active tls -> + match Tls.Engine.send_application_data tls css with + | Some (tls, tlsdata) -> + t.state <- `Active tls ; + write_t t tlsdata + | None -> fail @@ Invalid_argument "tls: write: socket not ready" + + let write t cs = writev t [ cs ] + + let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t = + match t.state with + | `Error err -> fail err + | `Eof -> fail @@ Invalid_argument "tls: closed socket" + | `Active tls -> + match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with + | None -> fail @@ Invalid_argument "tls: can't renegotiate" + | Some (tls', buf) -> + if drop then t.linger <- None ; + t.state <- `Active tls' ; + write_t t buf >>= fun () -> + drain_handshake t >>= fun _ -> return_unit + + let key_update ?request t = + match t.state with + | `Error err -> fail err + | `Eof -> fail @@ Invalid_argument "tls: closed socket" + | `Active tls -> + match Tls.Engine.key_update ?request tls with + | Error _ -> fail @@ Invalid_argument "tls: can't update key" + | Ok (tls', buf) -> + t.state <- `Active tls' ; + write_t t buf + + let close_tls t = + match t.state with + | `Active tls -> + let _, buf = Tls.Engine.send_close_notify tls in + t.state <- `Eof ; + write_t t buf + | _ -> return_unit + + let close t = safely (close_tls t) >>= fun () -> Protocol.close t.fd + + let client_of_fd config ?host fd = + let config' = + match host with + | None -> config + | Some host -> Tls.Config.peer config host in + let t = + { state = `Eof; fd; linger = None; recv_buf = Cstruct.create 0x1000 } in - go tls raw0 - - let connect (edn, config) = - Flow.connect edn >>| reword_error flow_error >>? fun flow -> - let raw = Cstruct.create 0x1000 in - let queue = Ke.create ~capacity:0x1000 Bigarray.Char in - let tls, buf = Tls.Engine.client config in - let rec go buf = - Log.debug (fun m -> m "Start handshake.") ; - Flow.send flow buf >>| reword_error flow_error >>? fun len -> - let buf = Cstruct.shift buf len in - if Cstruct.len buf = 0 - then return (Ok { tls = Some tls; closed = false; raw; queue; flow }) - else go buf in - go buf - - let blit src src_off dst dst_off len = - let dst = Cstruct.to_bigarray dst in - Bigstringaf.blit src ~src_off dst ~dst_off ~len - - let rec recv t raw = - Log.debug (fun m -> m "<~ Start to receive.") ; - match Ke.N.peek t.queue with - | [] -> ( - Log.debug (fun m -> m "<~ TLS queue is empty.") ; - match t.tls with - | None -> - Log.debug (fun m -> m "<~ Connection is close.") ; - return (Ok `End_of_flow) - | Some tls -> ( - Log.debug (fun m -> m "<- Read the TLS flow.") ; - Flow.recv t.flow t.raw >>| reword_error flow_error >>? function - | `End_of_flow -> - Log.warn (fun m -> - m "<- Connection closed by underlying protocol.") ; - t.tls <- None ; - return (Ok `End_of_flow) - | `Input 0 -> - Log.debug (fun m -> m "We must re-schedule, nothing to read.") ; - return (Ok (`Input 0)) - | `Input len -> - Log.debug (fun m -> m "<- Got %d byte(s)." len) ; - let handle raw = - if Tls.Engine.handshake_in_progress tls - then handle_handshake tls t.queue t.flow raw - else handle_tls tls t.queue t.flow raw in - Log.debug (fun m -> - let uid = - Hashtbl.hash - (Cstruct.to_string (Cstruct.sub t.raw 0 len)) in - m "<~ [%04x] Got %d bytes (handshake in progress: %b)." - uid len - (Tls.Engine.handshake_in_progress tls)) ; - handle (Cstruct.sub t.raw 0 len) >>? fun tls -> - t.tls <- tls ; - recv t raw)) - | _ -> - let max = Cstruct.len raw in - let len = min (Ke.length t.queue) max in - Ke.N.keep_exn t.queue ~blit ~length:Cstruct.len ~off:0 ~len raw ; - Ke.N.shift_exn t.queue len ; - return (Ok (`Input len)) - - let rec send t raw = - Log.debug (fun m -> m "~> Start to send %d bytes." (Cstruct.len raw)) ; - match t.tls with - | None -> return (Error `Closed_by_peer) - | Some tls when Tls.Engine.can_handle_appdata tls -> ( - let raw = [ raw ] in - match Tls.Engine.send_application_data tls raw with - | Some (tls, resp) -> - t.tls <- Some tls ; - flow_wr_opt t.flow (Some resp) >>? fun () -> - return (Ok (Cstruct.lenv raw)) - | None -> return (Ok (Cstruct.lenv raw))) - | Some tls -> ( - Flow.recv t.flow t.raw >>| reword_error flow_error >>? function - | `End_of_flow -> - Log.debug (fun m -> m "[-] Underlying flow already closed.") ; - t.tls <- None ; - return (Error `Closed_by_peer) - | `Input 0 -> - Log.debug (fun m -> m "[-] Underlying flow re-schedule.") ; - return (Ok 0) - | `Input len -> ( - let res = - handle_handshake tls t.queue t.flow (Cstruct.sub t.raw 0 len) - in - res >>= function - | Ok tls -> - t.tls <- tls ; - send t raw (* recall to finish handshake. *) - | Error _ as err -> - Log.err (fun m -> m "[-] Got an error during handshake.") ; - return err)) - - let close t = - Log.debug (fun m -> m "!- Asking to close the TLS connection") ; - if not t.closed - then ( - match t.tls with - | None -> - Log.debug (fun m -> - m "!- TLS state already reached EOF, close the connection.") ; - Flow.close t.flow >>| reword_error flow_error >>= fun res -> - Log.debug (fun m -> m "!- Underlying flow properly closed.") ; - t.closed <- true ; - return res - | Some tls -> - let _tls, resp = Tls.Engine.send_close_notify tls in - t.tls <- None ; - Log.debug (fun m -> m "!- Close the connection.") ; - flow_wr_opt t.flow (Some resp) >>? fun () -> - Flow.close t.flow >>| reword_error flow_error >>? fun () -> - t.closed <- true ; - return (Ok ())) - else return (Ok ()) + let tls, init = Tls.Engine.client config' in + let t = { t with state = `Active tls } in + write_t t init >>= fun () -> drain_handshake t + + (* + let accept conf fd = + Lwt_unix.accept fd >>= fun (fd', addr) -> + Lwt.catch (fun () -> server_of_fd conf fd' >|= fun t -> (t, addr)) + (fun exn -> safely (Lwt_unix.close fd') >>= fun () -> fail exn) + + let connect conf (host, port) = + resolve host (string_of_int port) >>= fun addr -> + let fd = Lwt_unix.(socket (Unix.domain_of_sockaddr addr) SOCK_STREAM 0) in + Lwt.catch (fun () -> Lwt_unix.connect fd addr >>= fun () -> client_of_fd conf ~host fd) + (fun exn -> safely (Lwt_unix.close fd) >>= fun () -> fail exn) + *) + + let read_bytes t bs off len = read t (Cstruct.of_bigarray ~off ~len bs) + + let write_bytes t bs off len = write t (Cstruct.of_bigarray ~off ~len bs) + + let epoch t = + match t.state with + | `Active tls -> ( + match Tls.Engine.epoch tls with + | `InitialEpoch -> assert false (* can never occur! *) + | `Epoch data -> `Ok data) + | `Eof -> `Error + | `Error _ -> `Error end - let protocol_with_tls : - type edn flow. - (edn, flow) Conduit.protocol -> - (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol = - fun protocol -> - let module Protocol = (val Conduit.impl protocol) in - let module M = Make_protocol (Protocol) in - Conduit.register (module M) - - type 'service service_with_tls = { - service : 'service; - tls : Tls.Config.server; - } + type 'edn endpoint = 'edn * Tls.Config.client - module Make_server (Service : Conduit.SERVICE) = struct - type +'a io = 'a Conduit.io + module Make1 (Protocol : sig + include PROTOCOL - type configuration = Service.configuration * Tls.Config.server + val host_of_endpoint : endpoint -> string option + end) = + struct + module M0 = Make_S0_from_PROTOCOL (Protocol) + include Make0 (M0) + + type flow = t + + type nonrec endpoint = Protocol.endpoint endpoint + + type input = Cstruct.t + + and output = Cstruct.t + + type +'a io = 'a IO.t + + type error = + [ `Tls_alert of Tls.Packet.alert_type + | `Tls_failure of Tls.Engine.failure + | `Msg of string ] + + let pp_error _ppf _err = assert false + + let recv flow buf = + IO.catch (fun () -> + read flow buf >>= function + | 0 -> return (Ok `End_of_flow) + | n -> return (Ok (`Input n))) + @@ function + | Tls_alert alert -> return (Error (`Tls_alert alert)) + | Tls_failure failure -> return (Error (`Tls_failure failure)) + | M0.Local_failure err -> return (Error (`Msg err)) + | exn -> fail exn + + let send flow buf = + IO.catch (fun () -> + write flow buf >>= fun () -> return (Ok (Cstruct.len buf))) + @@ function + | Tls_alert alert -> return (Error (`Tls_alert alert)) + | Tls_failure failure -> return (Error (`Tls_failure failure)) + | M0.Local_failure err -> return (Error (`Msg err)) + | exn -> fail exn + + let close flow = + IO.catch (fun () -> close flow >>= fun () -> return (Ok ())) @@ function + | Tls_alert alert -> return (Error (`Tls_alert alert)) + | Tls_failure failure -> return (Error (`Tls_failure failure)) + | M0.Local_failure err -> return (Error (`Msg err)) + | exn -> fail exn + + let connect (edn, conf) = + Protocol.connect edn >>= function + | Ok file_descr -> + client_of_fd conf ?host:(Protocol.host_of_endpoint edn) file_descr + >>= fun flow -> return (Ok flow) + | Error err -> + let msg = Format.asprintf "%a" Protocol.pp_error err in + return (Error (`Msg msg)) + end + + module Make2 + (Protocol : PROTOCOL) + (Service : Conduit.SERVICE + with type +'a io = 'a IO.t + and type flow = Protocol.flow) = + struct + module M0 = Make_S0_from_PROTOCOL (Protocol) + + type +'a io = 'a IO.t - type flow = Service.flow protocol_with_tls + let ( >>= ) = IO.bind - type error = [ `Service of Service.error ] + let return = IO.return - let pp_error : error Fmt.t = - fun ppf -> function `Service err -> Service.pp_error ppf err + type t = Service.t * Tls.Config.server - let service_error err = `Service err + type error = Service.error - type t = Service.t service_with_tls + type configuration = Service.configuration * Tls.Config.server + + type flow = M0.file_descr protocol_with_tls + + let pp_error = Service.pp_error + + let init (cfg, tls) = + Service.init cfg >>= function + | Ok t -> return (Ok (t, tls)) + | Error _ as err -> return err - let init (edn, tls) = - Service.init edn >>| reword_error service_error >>? fun service -> - Log.info (fun m -> m "Start a TLS service.") ; - return (Ok { service; tls }) + include Make_drain_handshake (M0) - let accept { service; tls } = - Service.accept service >>| reword_error service_error >>? fun flow -> - let tls = Tls.Engine.server tls in - let raw = Cstruct.create 0x1000 in - let queue = Ke.create ~capacity:0x1000 Bigarray.Char in - Log.info (fun m -> m "A TLS flow is coming.") ; - return (Ok { tls = Some tls; closed = false; raw; queue; flow }) + let server_of_fd config fd = + drain_handshake + { + state = `Active (Tls.Engine.server config); + fd; + linger = None; + recv_buf = Cstruct.create 0x1000; + } - let stop { service; _ } = - Service.stop service >>| reword_error service_error + let accept (t, tls) = + Service.accept t >>= function + | Ok fd -> server_of_fd tls fd >>= fun flow -> return (Ok flow) + | Error _ as err -> return err + + let stop (t, _) = Service.stop t end + let underlying ({ fd; _ } : 'flow protocol_with_tls) = fd + + let handshake ({ state; _ } : 'flow protocol_with_tls) = + match state with + | `Active state -> Tls.Engine.handshake_in_progress state + | _ -> false + + let protocol_with_tls : + type edn flow. + ?host_of_endpoint:(edn -> string option) -> + (edn, flow) Conduit.protocol -> + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol = + fun ?(host_of_endpoint = fun _ -> None) protocol -> + let module Protocol0 = (val Conduit.impl protocol) in + let module Protocol1 = struct + include Protocol0 + + let host_of_endpoint = host_of_endpoint + end in + let module Protocol2 = Make1 (Protocol1) in + Conduit.register (module Protocol2) + + type 't service_with_tls = 't * Tls.Config.server + let service_with_tls : - type cfg edn t flow. + type cfg t flow edn. (cfg, t, flow) Conduit.Service.t -> - (edn, flow protocol_with_tls) Conduit.protocol -> + (edn, flow) Conduit.protocol -> + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol -> ( cfg * Tls.Config.server, t service_with_tls, flow protocol_with_tls ) Conduit.Service.t = - fun service protocol -> - let module Service = (val Conduit.Service.impl service) in - let module M = Make_server (Service) in - Conduit.Service.register (module M) protocol + fun service p0 p1 -> + let module Service0 = (val Conduit.Service.impl service) in + let module Protocol0 = (val Conduit.impl p0) in + let module Service1 = Make2 (Protocol0) (Service0) in + Conduit.Service.register (module Service1) p1 end diff --git a/src/tls/conduit_tls.mli b/src/tls/conduit_tls.mli index 7b8df5ea..a53ea229 100644 --- a/src/tls/conduit_tls.mli +++ b/src/tls/conduit_tls.mli @@ -1,49 +1,17 @@ -(** Common TLS implementation with Conduit. +module type IO = sig + type +'a t - The current implementation of the TLS layer over an underlying protocol - respects some assumptions and it has a specific behaviour which is decribed - here: + val bind : 'a t -> ('a -> 'b t) -> 'b t - The {i handshake} is not done when we initialize the flow. Only a call to - [recv] or [send] really starts the handshake with your peer. In that - context, a concurrent call of these actions should put some trouble into the - handshake and they must be protected by an exclusion. + val return : 'a -> 'a t - In other words due to the non-atomicity of [recv] and [send], while the - handshake, you should ensure to finish a call of one of them before to call - the other. A mutex should be used in this context to protect the mutual - exclusion between [recv] and [send]. In others words, such process is safe: + val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t - {[ - let* _ = Conduit.send tls_flow raw in - let* _ = Conduit.recv tls_flow raw in - ]} - - Where such process is not safe: - - {[ - async (fun () -> Conduit.send tls_flow raw) ; - async (fun () -> Conduit.recv tls_flow raw) - ]} - - The non-atomicity of [send] and [recv] is due to the underlying handshake of - TLS which can appear everytime. By this fact, [send] or [recv] (depends - which is executed first) can start an handshake process which can call - several times underlying [Flow.send] and [Flow.recv] processes (no 0-RTT). - If you use [async], the scheduler can misleading/misorder handshake started - with one to the other call to [send] and [recv]. - - A solution such as a {i mutex} to ensure the exclusivity between [send] and - [recv] can be used - it does not exists at this layer where such abstraction - is not available. - - This design appear when you use [LWT] or [ASYNC] which can do a concurrence - between {i promises}. Without such {i scheduler}, the process is sequential - and the OCaml {i scheduler} should not re-order sub-processes of - [Conduit.send] and [Conduit.recv]. *) + val fail : exn -> 'a t +end module Make - (IO : Conduit.IO) + (IO : IO) (Conduit : Conduit.S with type input = Cstruct.t and type output = Cstruct.t @@ -57,6 +25,7 @@ module Make (** [handshake flow] returns [true] if {i handshake} is processing. *) val protocol_with_tls : + ?host_of_endpoint:('edn -> string option) -> ('edn, 'flow) Conduit.protocol -> ('edn * Tls.Config.client, 'flow protocol_with_tls) Conduit.protocol (** From a given protocol [witness], it creates a new {i witness} of the @@ -66,7 +35,8 @@ module Make val service_with_tls : ('cfg, 't, 'flow) Conduit.Service.t -> - ('edn, 'flow protocol_with_tls) Conduit.protocol -> + ('edn, 'flow) Conduit.protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) Conduit.protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) From edaef88b6fd0a413e25d8f5727edc81bbead3230 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Wed, 2 Dec 2020 13:46:37 +0100 Subject: [PATCH 136/140] Update Conduit_{async,lwt}_tls.TCP with the new way to make a service --- src/async-tls/conduit_async_tls.ml | 20 ++++++++++++++++++-- src/async-tls/conduit_async_tls.mli | 4 +++- src/lwt-tls/conduit_lwt_tls.ml | 16 ++++++++++++++-- src/lwt-tls/conduit_lwt_tls.mli | 4 +++- 4 files changed, 38 insertions(+), 6 deletions(-) diff --git a/src/async-tls/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml index 8886ba88..14680f5b 100644 --- a/src/async-tls/conduit_async_tls.ml +++ b/src/async-tls/conduit_async_tls.ml @@ -1,12 +1,28 @@ open Async -include Conduit_tls.Make (Conduit_async.IO) (Conduit_async) + +module IO = struct + type +'a t = 'a Async.Deferred.t + + let bind x f = Async.Deferred.bind x ~f + + let return = Async.Deferred.return + + let catch f ferr = + Async.try_with ~extract_exn:true f >>= function + | Ok v -> return v + | Error exn -> ferr exn + + let fail exn = raise exn +end + +include Conduit_tls.Make (IO) (Conduit_async) module TCP = struct open Conduit_async.TCP let protocol = protocol_with_tls protocol - let service = service_with_tls service protocol + let service = service_with_tls service Conduit_async.TCP.protocol protocol let configuration ~config:tls_config ?backlog listen = (configuration ?backlog listen, tls_config) diff --git a/src/async-tls/conduit_async_tls.mli b/src/async-tls/conduit_async_tls.mli index ef002271..1e2e624e 100644 --- a/src/async-tls/conduit_async_tls.mli +++ b/src/async-tls/conduit_async_tls.mli @@ -9,6 +9,7 @@ val underlying : 'flow protocol_with_tls -> 'flow val handshake : 'flow protocol_with_tls -> bool val protocol_with_tls : + ?host_of_endpoint:('edn -> string option) -> ('edn, 'flow) protocol -> ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol @@ -16,7 +17,8 @@ type 'service service_with_tls val service_with_tls : ('cfg, 't, 'flow) Service.t -> - ('edn, 'flow protocol_with_tls) protocol -> + ('edn, 'flow) protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) diff --git a/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml index 855b8fb4..21e4aab3 100644 --- a/src/lwt-tls/conduit_lwt_tls.ml +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -1,4 +1,16 @@ -include Conduit_tls.Make (Conduit_lwt.IO) (Conduit_lwt) +module IO = struct + type +'a t = 'a Lwt.t + + let bind = Lwt.bind + + let return = Lwt.return + + let fail = Lwt.fail + + let catch = Lwt.catch +end + +include Conduit_tls.Make (IO) (Conduit_lwt) let () = Mirage_crypto_rng_lwt.initialize () @@ -9,7 +21,7 @@ module TCP = struct include (val Conduit_lwt.repr protocol) - let service = service_with_tls service protocol + let service = service_with_tls service Conduit_lwt.TCP.protocol protocol let resolve ~port ~config domain_name = let open Lwt.Infix in diff --git a/src/lwt-tls/conduit_lwt_tls.mli b/src/lwt-tls/conduit_lwt_tls.mli index f81e4f22..74dbefed 100644 --- a/src/lwt-tls/conduit_lwt_tls.mli +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -19,6 +19,7 @@ val handshake : 'flow protocol_with_tls -> bool it returns [false]. *) val protocol_with_tls : + ?host_of_endpoint:('edn -> string option) -> ('edn, 'flow) protocol -> ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol @@ -26,7 +27,8 @@ type 'service service_with_tls val service_with_tls : ('cfg, 't, 'flow) Service.t -> - ('edn, 'flow protocol_with_tls) protocol -> + ('edn, 'flow) protocol -> + ('edn * Tls.Config.client, 'flow protocol_with_tls) protocol -> ( 'cfg * Tls.Config.server, 't service_with_tls, 'flow protocol_with_tls ) From 6dd33d46da4bd5026175b25de8aa9cc2db8adc1d Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Wed, 2 Dec 2020 22:34:32 +0100 Subject: [PATCH 137/140] Add a test that Service.equal is reflexive This is a regression test for the issue introduced by https://github.com/mirage/ocaml-conduit/pull/357 and fixed by https://github.com/mirage/ocaml-conduit/pull/361. --- tests/flow.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/flow.ml b/tests/flow.ml index 51ff2195..e76e7194 100644 --- a/tests/flow.ml +++ b/tests/flow.ml @@ -6,6 +6,7 @@ module Unix_scheduler = struct let return x = x end +module Conduit_lib = Conduit module Conduit = Conduit.Make (Unix_scheduler) (Bytes) (String) let recv = @@ -305,6 +306,13 @@ let test_type_equality = | Ok (Repr.T Dummy_flow.Flow) -> Alcotest.(check pass) "type equality" () () | _ -> Alcotest.failf "Invalid flow value" +let test_service_equality = + Alcotest.test_case "service equality" `Quick @@ fun () -> + match Conduit.Service.equal dummy_service dummy_service with + | Some (Conduit_lib.Refl, _, _) -> + Alcotest.(check pass) "Service.equal is reflexive" () () + | _ -> Alcotest.failf "Service not equal to itself" + let tests = [ ( "flow", @@ -314,5 +322,6 @@ let tests = test_input_strings; test_output_strings; test_type_equality; + test_service_equality; ] ); ] From 052a2c43c57df5acdc489354010eccca1fd832cb Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Wed, 2 Dec 2020 22:37:05 +0100 Subject: [PATCH 138/140] Gitignore opam/ when it is a symlink The `opam/` pattern doesn't apply to local switches created with `opam link` (which are not directories). --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 443bd4aa..ebac51b4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ _build/ -_opam/ +_opam sandbox/ .*.swp *.install From 9a544cb675b698929f382c673b64867588b1781f Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Wed, 2 Dec 2020 20:44:27 +0100 Subject: [PATCH 139/140] Remove unused Conduit.S.resolvers type --- src/core/conduit.ml | 6 ++++-- src/core/conduit_intf.ml | 3 ++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/core/conduit.ml b/src/core/conduit.ml index 05f22d33..c820c13d 100644 --- a/src/core/conduit.ml +++ b/src/core/conduit.ml @@ -70,6 +70,10 @@ end) : BIJECTION with type +'a s = 'a Functor.t = struct external prj : ('a, t) app -> 'a s = "%identity" end +module type S = sig + include S with type resolvers := resolvers +end + module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : S with type input = Input.t @@ -222,8 +226,6 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) : let ( <.> ) f g x = f (g x) - type nonrec resolvers = resolvers - let empty = empty let add : diff --git a/src/core/conduit_intf.ml b/src/core/conduit_intf.ml index 53a02b9e..a023b77e 100644 --- a/src/core/conduit_intf.ml +++ b/src/core/conduit_intf.ml @@ -335,6 +335,7 @@ module type S = sig type resolvers val empty : resolvers + (** [empty] is equal to {!Conduit.empty}. *) val add : ('edn, _) protocol -> @@ -505,7 +506,7 @@ module type Conduit = sig (** [empty] is an empty {!resolvers} map. *) module type S = sig - include S + include S with type resolvers := resolvers (** @inline *) end From e4274233481ff6b1068b846a0f0bfddb285eac06 Mon Sep 17 00:00:00 2001 From: Craig Ferguson Date: Fri, 4 Dec 2020 14:53:03 +0100 Subject: [PATCH 140/140] Avoid shutdown race condition on service startup Fix https://github.com/mirage/ocaml-conduit/issues/352. The `lwt` and `async` service loops previously took condition variables that were used as a shutdown signal. This resulted in a race condition: the shutdown signal can be broadcast before the server is waiting on it. Fixed by having the service loops take switches as configuration instead. --- src/async/conduit_async.ml | 66 +++++++++++++++++----------------- src/async/conduit_async.mli | 23 +++++++----- src/lwt/conduit_lwt.ml | 68 +++++++++++++++++------------------ src/lwt/conduit_lwt.mli | 25 +++++++------ tests/ping-pong/common.ml | 20 +++++------ tests/ping-pong/with_async.ml | 24 +++++++------ tests/ping-pong/with_lwt.ml | 17 +++------ 7 files changed, 121 insertions(+), 122 deletions(-) diff --git a/src/async/conduit_async.ml b/src/async/conduit_async.ml index d501f034..0e593f8c 100644 --- a/src/async/conduit_async.ml +++ b/src/async/conduit_async.ml @@ -18,43 +18,43 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t let serve : type cfg t v. ?timeout:int -> + ?stop:unit Async.Deferred.t -> handler:(flow -> unit Async.Deferred.t) -> (cfg, t, v) service -> cfg -> - unit Async.Condition.t * (unit -> unit Async.Deferred.t) = - fun ?timeout ~handler service cfg -> + unit Async.Deferred.t = + fun ?timeout ?(stop = Async.Deferred.never ()) ~handler service cfg -> let open Async in - let stop = Async.Condition.create () in - let main () = - Service.init service cfg >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok t -> ( - let rec loop () = - let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in - let accept = - Service.accept service t >>? fun flow -> - Async.(Deferred.ok (return (`Flow flow))) in - let events = - match timeout with - | None -> [ close; accept ] - | Some t -> - let t = Core.Time.Span.of_int_sec t in - let timeout = Async.after t >>| fun () -> Ok `Timeout in - [ close; accept; timeout ] in - - Async.Deferred.any events >>= function - | Ok (`Flow flow) -> - Async.don't_wait_for (handler flow) ; - Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () - | Ok (`Stop | `Timeout) -> Service.stop service t - | Error err0 -> ( - Service.stop service t >>= function - | Ok () -> Async.return (Error err0) - | Error _err1 -> Async.return (Error err0)) in - loop () >>= function - | Ok () -> Async.return () - | Error err -> failwith "%a" Service.pp_error err) in - (stop, main) + let timeout = + match timeout with + | None -> Deferred.never + | Some t -> fun () -> after (Core.Time.Span.of_int_sec t) in + Service.init service cfg >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok t -> ( + let rec loop () = + let accept = Service.accept service t in + Deferred.choose + [ + choice accept (Result.map (fun f -> `Flow f)); + choice (timeout ()) (fun () -> Ok `Timeout); + ] + >>? function + | `Flow flow -> + don't_wait_for (handler flow) ; + Scheduler.yield () >>= loop + | `Timeout -> return (Ok `Timeout) in + let stop_result = + Deferred.choose + [ choice stop (fun () -> Ok `Stopped); choice (loop ()) (fun r -> r) ] + >>= function + | Ok (`Timeout | `Stopped) -> Service.stop service t + | Error _ as err0 -> ( + Service.stop service t >>= function Ok () | Error _ -> return err0) + in + stop_result >>= function + | Ok () -> return () + | Error err -> failwith "%a" Service.pp_error err) let reader_and_writer_of_flow flow = let open Async in diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli index 9636d474..dbdad70a 100644 --- a/src/async/conduit_async.mli +++ b/src/async/conduit_async.mli @@ -15,20 +15,25 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t val serve : ?timeout:int -> + ?stop:unit Async.Deferred.t -> handler:(flow -> unit Async.Deferred.t) -> ('cfg, 't, 'v) service -> 'cfg -> - unit Async.Condition.t * (unit -> unit Async.Deferred.t) -(** [serve ~handler t cfg] creates an infinite service loop from the given - configuration ['cfg]. It returns the {i promise} to launch the loop and a - condition variable to stop the loop. + unit Async.Deferred.t +(** [serve ~handler t cfg] launches a service loop from the given configuration + ['cfg]. By default, the service loop runs indefinitely. + + - If passed, [~stop] terminates the loop as soon as possible after it is + determined. {[ - let stop, loop = serve ~handler TCP.service cfg in - Async_unix.Signal.handle [ Core.Signal.int ] ~f:(fun _sig -> - Async.Condition.broadcast stop ()) ; - loop () - ]} *) + let stop, signal_stop = Ivar.(let v = create () in (read v, fill v)) i + let loop = serve ~stop ~handler TCP.service cfg in + Async_unix.Signal.handle [ Core.Signal.int ] ~f:(fun _ -> signal_stop ()); + loop + ]} + - If passed, [~timeout] specifies a maximum time to wait between accepting + connections. *) val reader_and_writer_of_flow : flow -> (Async.Reader.t * Async.Writer.t) Async.Deferred.t diff --git a/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml index a11ae406..d7b19842 100644 --- a/src/lwt/conduit_lwt.ml +++ b/src/lwt/conduit_lwt.ml @@ -53,44 +53,44 @@ let ( >>? ) = Lwt_result.bind let serve : type cfg service v. ?timeout:int -> + ?stop:Lwt_switch.t -> handler:(flow -> unit Lwt.t) -> (cfg, service, v) Service.t -> cfg -> - unit Lwt_condition.t * (unit -> unit Lwt.t) = - fun ?timeout ~handler service cfg -> + unit Lwt.t = + fun ?timeout ?stop ~handler service cfg -> let open Lwt.Infix in - let stop = Lwt_condition.create () in - let main () = - Service.init service cfg >>= function - | Error err -> failwith "%a" Service.pp_error err - | Ok t -> ( - let rec loop () = - let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in - let accept = - Service.accept service t >>? fun flow -> Lwt.return_ok (`Flow flow) - in - let events = - match timeout with - | None -> [ stop; accept ] - | Some t -> - let timeout = - Lwt_unix.sleep (float_of_int t) >>= fun () -> - Lwt.return_ok `Timeout in - [ stop; accept; timeout ] in - - Lwt.pick events >>= function - | Ok (`Flow flow) -> - Lwt.async (fun () -> handler flow) ; - Lwt.pause () >>= loop - | Ok (`Stop | `Timeout) -> Service.stop service t - | Error err0 -> ( - Service.stop service t >>= function - | Ok () -> Lwt.return_error err0 - | Error _err1 -> Lwt.return_error err0) in - loop () >>= function - | Ok () -> Lwt.return_unit - | Error err -> failwith "%a" Service.pp_error err) in - (stop, main) + let timeout () = + match timeout with + | None -> Lwt.wait () |> fst + | Some t -> Lwt_unix.sleep (float_of_int t) in + Service.init service cfg >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok t -> ( + let switched_off = + let t, u = Lwt.wait () in + Lwt_switch.add_hook stop (fun () -> + Lwt.wakeup_later u (Ok `Stopped) ; + Lwt.return_unit) ; + t in + let rec loop () = + let accept = + Service.accept service t >>? fun flow -> Lwt.return_ok (`Flow flow) + in + Lwt.pick [ accept; (timeout () >|= fun () -> Ok `Timeout) ] >>? function + | `Flow flow -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | `Timeout -> Lwt.return (Ok `Timeout) in + let stop_result = + Lwt.pick [ switched_off; loop () ] >>= function + | Ok (`Timeout | `Stopped) -> Service.stop service t + | Error _ as err0 -> ( + Service.stop service t >>= function + | Ok () | Error _ -> Lwt.return err0) in + stop_result >>= function + | Ok () -> Lwt.return_unit + | Error err -> failwith "%a" Service.pp_error err) module TCP = struct open Lwt.Infix diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli index a328f46e..f00e4127 100644 --- a/src/lwt/conduit_lwt.mli +++ b/src/lwt/conduit_lwt.mli @@ -19,25 +19,24 @@ type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t val serve : ?timeout:int -> + ?stop:Lwt_switch.t -> handler:(flow -> unit Lwt.t) -> ('cfg, 'service, 'v) service -> 'cfg -> - unit Lwt_condition.t * (unit -> unit Lwt.t) -(** [serve ~handler service cfg] creates an usual infinite [service] loop from - the given configuration ['cfg]. It returns the {i promise} to launch the - loop and a condition variable to stop the loop. + unit Lwt.t +(** [serve ~handler service cfg] launches a [service] loop from the given + configuration ['cfg]. By default, the service loop runs indefinitely. + + - If passed, [~stop] is a switch that terminates the service loop, for + example to limit execution time to 10 seconds: {[ - let stop, loop = serve ~handler TCP.service cfg in - Lwt.both - ( Lwt_unix.sleep 10. >>= fun () -> - Lwt_condition.broadcast stop () ; - Lwt.return () ) - (loop ()) + let stop = Lwt_switch.create () in + let loop = serve ~stop ~handler TCP.service cfg in + Lwt.both (Lwt_unix.sleep 10. >>= fun () -> Lwt_switch.turn_off stop) loop ]} - - In your example, we want to launch a server only for 10 seconds. To help the - user, the option [?timeout] allows us to wait less than [timeout] seconds. *) + - If passed, [~timeout] specifies a maximum time to wait between accepting + connections. *) module TCP : sig (** Implementation of TCP protocol as a client. diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml index 149c315f..38f48c55 100644 --- a/tests/ping-pong/common.ml +++ b/tests/ping-pong/common.ml @@ -1,18 +1,19 @@ module type S = sig include Conduit.S - type 'a condition + type switch val serve : ?timeout:int -> + ?stop:switch -> handler:(flow -> unit io) -> ('cfg, 's, 'flow) Service.t -> 'cfg -> - unit condition * (unit -> unit io) + unit io end -module type CONDITION = sig - type 'a t +module type SWITCH = sig + type t end module type IO = sig @@ -25,10 +26,10 @@ let ( <.> ) f g x = f (g x) module Make (IO : IO) - (Condition : CONDITION) + (Switch : SWITCH) (Conduit : S with type +'a io = 'a IO.t - and type 'a condition = 'a Condition.t + and type switch := Switch.t and type input = Cstruct.t and type output = Cstruct.t) = struct @@ -112,10 +113,9 @@ struct let server : type cfg s. - (cfg, s, 'flow) Conduit.Service.t -> - cfg -> - unit Condition.t * (unit -> unit IO.t) = - fun service cfg -> Conduit.serve ~handler:transmission service cfg + ?stop:Switch.t -> (cfg, s, 'flow) Conduit.Service.t -> cfg -> unit IO.t = + fun ?stop service cfg -> + Conduit.serve ?stop ~handler:transmission service cfg (* part *) diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml index b38b1fd4..5552350a 100644 --- a/tests/ping-pong/with_async.ml +++ b/tests/ping-pong/with_async.ml @@ -3,6 +3,10 @@ open Async let () = Mirage_crypto_rng_unix.initialize () +module Stop = struct + type t = unit Deferred.t +end + include Common.Make (struct type +'a t = 'a Async.Deferred.t @@ -13,12 +17,8 @@ include Common.Make let yield () = Async.Deferred.return () end) - (Async.Condition) - (struct - type 'a condition = 'a Async.Condition.t - - include Conduit_async - end) + (Stop) + (Conduit_async) let tcp_protocol, tcp_service = let open Conduit_async.TCP in @@ -49,7 +49,11 @@ let run_with : type cfg service flow. (cfg, service, flow) Conduit_async.Service.t -> cfg -> string list -> unit = fun service cfg clients -> - let stop, server = server (* ~launched ~stop *) service cfg in + let stop, signal_stop = + let open Async.Ivar in + let v = create () in + (read v, fill v) in + let server = server (* ~launched *) ~stop service cfg in let clients = Async.after Core.Time.Span.(of_sec 0.5) >>= fun () -> (* XXX(dinosaure): [async] tries to go further and fibers @@ -57,11 +61,9 @@ let run_with : * We waiting a bit to ensure that the server is launched * before clients. *) let clients = List.map (client ~resolvers) clients in - Async.Deferred.all_unit clients >>= fun () -> - Condition.broadcast stop () ; - Async.return () in + Async.Deferred.all_unit clients >>| signal_stop in Async.don't_wait_for - (Async.Deferred.all_unit [ server (); clients ] >>| fun () -> shutdown 0) ; + (Async.Deferred.all_unit [ server; clients ] >>| fun () -> shutdown 0) ; Core.never_returns (Scheduler.go ()) let run_with_tcp clients = diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml index f094abbe..202b1ef9 100644 --- a/tests/ping-pong/with_lwt.ml +++ b/tests/ping-pong/with_lwt.ml @@ -10,12 +10,7 @@ module Lwt = struct let yield = Lwt_unix.yield end -include Common.Make (Lwt) (Lwt_condition) - (struct - type 'a condition = 'a Lwt_condition.t - - include Conduit_lwt - end) +include Common.Make (Lwt) (Lwt_switch) (Conduit_lwt) (* Composition *) @@ -62,13 +57,11 @@ let run_with : type cfg s flow. (cfg, s, flow) Conduit_lwt.Service.t -> cfg -> string list -> unit = fun service cfg clients -> - let stop, server = server service cfg in + let stop = Lwt_switch.create () in + let server = server ~stop service cfg in let clients = List.map (client ~resolvers) clients in - let clients = - Lwt.join clients >>= fun () -> - Lwt_condition.broadcast stop () ; - Lwt.return_unit in - Lwt_main.run (Lwt.join [ server (); clients ]) + let clients = Lwt.join clients >>= fun () -> Lwt_switch.turn_off stop in + Lwt_main.run (Lwt.join [ server; clients ]) let run_with_tcp clients = run_with Conduit_lwt.TCP.service