From ed9629d9e84efc94e180e7de3f0988bf4c13bc52 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 5 May 2020 15:59:44 +0200 Subject: [PATCH 01/71] 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 02/71] 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 03/71] 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 04/71] 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 05/71] 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 06/71] 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 07/71] 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 08/71] 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 09/71] 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 10/71] 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 11/71] 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 12/71] 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 13/71] 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 14/71] 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 15/71] 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 16/71] 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 17/71] 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 18/71] 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 19/71] 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 20/71] 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 21/71] 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 22/71] 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 23/71] 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 24/71] 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 25/71] ('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 26/71] 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 27/71] 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 28/71] 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 29/71] 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 30/71] 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 31/71] 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 32/71] 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 33/71] 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 34/71] 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 35/71] 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 36/71] 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 37/71] 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 38/71] 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 39/71] 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 40/71] 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 41/71] 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 42/71] 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 43/71] 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 44/71] 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 3f6438249a5832c6da2a810db56f4ff9cef16f5a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 24 Jun 2020 11:01:14 +0200 Subject: [PATCH 45/71] 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 46/71] 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 47/71] 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 48/71] 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 49/71] 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 50/71] 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 51/71] 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 52/71] 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 53/71] 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 54/71] 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 55/71] 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 56/71] 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 57/71] 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 58/71] 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 59/71] 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 60/71] 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 61/71] 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 62/71] 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 63/71] 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 64/71] 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 65/71] 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 66/71] 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 67/71] 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 68/71] 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 69/71] 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 70/71] 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 71/71] 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) ;;