diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c6bbd044..1daf0513 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -6,23 +6,27 @@ 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: Deps 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 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: Build run: opam exec -- dune build - name: Test - run: opam exec -- dune runtest + run: opam exec -- dune runtest --no-buffer --verbose -j 1 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/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000..e7aa0a4a --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,9 @@ +version = 0.15.0 +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 +parse-docstrings=false 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 diff --git a/async/conduit_async.ml b/async/conduit_async.ml deleted file mode 100644 index 74aadb8b..00000000 --- a/async/conduit_async.ml +++ /dev/null @@ -1,23 +0,0 @@ -(* - * 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 diff --git a/async/dune b/async/dune deleted file mode 100644 index 1f2100ad..00000000 --- a/async/dune +++ /dev/null @@ -1,23 +0,0 @@ -(library - (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 - - (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)) - - (select v2.mli from - (async_ssl -> v2_real.mli) - (!async_ssl -> v2_dummy.mli)) - - (select v3.mli from - (async_ssl -> v3_real.mli) - (!async_ssl -> v3_dummy.mli)))) 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 ] 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 new file mode 100644 index 00000000..be91e6ce --- /dev/null +++ b/bench/cost.ml @@ -0,0 +1,127 @@ +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) + +module Fake_protocol0 = struct + type input = bytes + + and output = string + + and +'a io = '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 _ _ = + for _ = 0 to 500 do + () + done ; + Ok 0 + + let close _ = Ok () +end + +module Fake_protocol1 = struct + type input = bytes + + and output = string + + and +'a io = '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 io = '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 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 + Tuyau.connect Unix.stderr fake0 >>= fun flow -> + Tuyau.send flow hello_world >>= fun _ -> + let samples0 = Benchmark.run (fn_fully_abstr flow) in + let samples1 = Benchmark.run (fn_abstr (Tuyau.unpack flow)) in + + 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 () = + 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/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/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 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/conduit-async-ssl.opam b/conduit-async-ssl.opam new file mode 100644 index 00000000..6b4bbca6 --- /dev/null +++ b/conduit-async-ssl.opam @@ -0,0 +1,30 @@ +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" + "async" {>= "v0.12.0"} + "async_ssl" + "stdlib-shims" {with-test} +] diff --git a/conduit-async-tls.opam b/conduit-async-tls.opam new file mode 100644 index 00000000..fdf51782 --- /dev/null +++ b/conduit-async-tls.opam @@ -0,0 +1,30 @@ +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" + "async" {>= "v0.12.0"} + "conduit-tls" + "stdlib-shims" {with-test} +] diff --git a/conduit-async.opam b/conduit-async.opam index b1442bea..cc5108b8 100644 --- a/conduit-async.opam +++ b/conduit-async.opam @@ -1,29 +1,30 @@ 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"} + "cstruct" + "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-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-tls.opam b/conduit-lwt-tls.opam new file mode 100644 index 00000000..7566c892 --- /dev/null +++ b/conduit-lwt-tls.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" + "conduit-tls" +] diff --git a/conduit-lwt-unix.opam b/conduit-lwt-unix.opam deleted file mode 100644 index b7a131de..00000000 --- a/conduit-lwt-unix.opam +++ /dev/null @@ -1,31 +0,0 @@ -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" -depends: [ - "ocaml" {>= "4.07.0"} - "dune" - "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.12.2"} - "ssl" {< "0.5.9"} -] -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..574ec5bb 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" +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" -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] + ["dune" "runtest" "-j1"] {with-test} +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" + "conduit" + "lwt" + "base-unix" ] -dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" -synopsis: "A portable network connection establishment library using Lwt" diff --git a/conduit-mirage.opam b/conduit-mirage.opam index b4200b12..25067d69 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -1,39 +1,31 @@ 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" + "tcpip" + "mirage-flow" + "mirage-time" + "dns-client" {>= "4.6.0"} + "ke" + "bigstringaf" +] 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..ec0b1703 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,16 @@ 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" + "alcotest" {with-test} +] 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) diff --git a/lib/conduit.ml b/lib/conduit.ml deleted file mode 100644 index 0a602618..00000000 --- a/lib/conduit.ml +++ /dev/null @@ -1,35 +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 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 -end diff --git a/lib/conduit.mli b/lib/conduit.mli deleted file mode 100644 index 37456a45..00000000 --- a/lib/conduit.mli +++ /dev/null @@ -1,67 +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. - * -*) - -(** 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 -end 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 deleted file mode 100644 index 556194f8..00000000 --- a/lib/dune +++ /dev/null @@ -1,10 +0,0 @@ -(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)) 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/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 deleted file mode 100644 index 8dade88d..00000000 --- a/lwt-unix/conduit_lwt_unix.ml +++ /dev/null @@ -1,419 +0,0 @@ -(* - * 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) diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli deleted file mode 100644 index e5db5d08..00000000 --- a/lwt-unix/conduit_lwt_unix.mli +++ /dev/null @@ -1,217 +0,0 @@ -(* - * 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 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/dune b/lwt-unix/dune deleted file mode 100644 index 3e64fd7c..00000000 --- a/lwt-unix/dune +++ /dev/null @@ -1,18 +0,0 @@ -(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)) - )) 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 diff --git a/lwt/dune b/lwt/dune deleted file mode 100644 index 94c64fa4..00000000 --- a/lwt/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name conduit_lwt) - (public_name conduit-lwt) - (preprocess (pps ppx_sexp_conv)) - (wrapped false) - (modules resolver_lwt) - (libraries conduit lwt)) 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 diff --git a/mirage/conduit_mirage.ml b/mirage/conduit_mirage.ml deleted file mode 100644 index b9db6b34..00000000 --- a/mirage/conduit_mirage.ml +++ /dev/null @@ -1,348 +0,0 @@ -(* - * 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 diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli deleted file mode 100644 index 1774eb86..00000000 --- a/mirage/conduit_mirage.mli +++ /dev/null @@ -1,143 +0,0 @@ -(* - * 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 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 deleted file mode 100644 index 82cb38c9..00000000 --- a/mirage/dune +++ /dev/null @@ -1,9 +0,0 @@ -(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)) 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 diff --git a/src/async-ssl/conduit_async_ssl.ml b/src/async-ssl/conduit_async_ssl.ml new file mode 100644 index 00000000..3ab3c1fc --- /dev/null +++ b/src/async-ssl/conduit_async_ssl.ml @@ -0,0 +1,313 @@ +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 io = '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 connect + ( { + version; + options; + name; + hostname; + allowed_ciphers; + ca_file; + ca_path; + crt_file; + key_file; + session; + verify_modes; + verify; + }, + edn ) = + Protocol.connect 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_flow) + | `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. + reader:(flow -> Reader.t) -> + writer:(flow -> Writer.t) -> + (edn, flow) Conduit_async.protocol -> + (context * edn, flow with_ssl) Conduit_async.protocol = + fun ~reader ~writer protocol -> + let module F = (val Conduit_async.impl protocol) in + let module Flow = struct + include F + + let reader = reader + + let writer = writer + end in + let module M = Protocol (Flow) in + Conduit_async.register ~protocol:(module M) + +module Make (Service : sig + include Conduit_async.SERVICE + + val reader : flow -> Reader.t + + val writer : flow -> Writer.t +end) = +struct + type +'a io = '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 configuration = context * Service.configuration + + type t = context * Service.t + + type flow = Service.flow with_ssl + + 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.init 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 cfg edn t flow. + (cfg, t, flow) Conduit_async.Service.service -> + reader:(flow -> Reader.t) -> + writer:(flow -> Writer.t) -> + (edn, flow with_ssl) Conduit_async.protocol -> + (context * cfg, context * t, flow with_ssl) Conduit_async.Service.service = + fun service ~reader ~writer _ -> + 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) + +module TCP = struct + open Conduit_async.TCP + + let protocol = + protocol_with_ssl ~reader:Protocol.reader ~writer:Protocol.writer protocol + + let service = + service_with_ssl service ~reader:Protocol.reader ~writer:Protocol.writer + protocol + + 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 new file mode 100644 index 00000000..d6867818 --- /dev/null +++ b/src/async-ssl/conduit_async_ssl.mli @@ -0,0 +1,69 @@ +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 : + reader:('flow -> Reader.t) -> + writer:('flow -> Writer.t) -> + ('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) 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) protocol + + val service : + ( context * Service.configuration, + context * Service.t, + Protocol.flow with_ssl ) + service + + val resolve : port:int -> context:context -> (context * endpoint) resolver +end 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/src/async-tls/conduit_async_tls.ml b/src/async-tls/conduit_async_tls.ml new file mode 100644 index 00000000..9179385a --- /dev/null +++ b/src/async-tls/conduit_async_tls.ml @@ -0,0 +1,15 @@ +open Async +include Conduit_tls.Make (Conduit_async.IO) (Conduit_async) + +module TCP = struct + open Conduit_async.TCP + + let protocol = protocol_with_tls protocol + + let service = service_with_tls service protocol + + 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 new file mode 100644 index 00000000..fd5dcc77 --- /dev/null +++ b/src/async-tls/conduit_async_tls.mli @@ -0,0 +1,39 @@ +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 : + ('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 + +module TCP : sig + open Conduit_async.TCP + + val protocol : + (endpoint * Tls.Config.client, Protocol.flow protocol_with_tls) protocol + + val service : + ( configuration * Tls.Config.server, + Service.t service_with_tls, + Protocol.flow protocol_with_tls ) + service + + val resolve : + port:int -> + config:Tls.Config.client -> + (endpoint * Tls.Config.client) resolver +end 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/src/async/conduit_async.ml b/src/async/conduit_async.ml new file mode 100644 index 00000000..0e363b82 --- /dev/null +++ b/src/async/conduit_async.ml @@ -0,0 +1,259 @@ +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) +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. + ?timeout:int -> + handler:(flow -> unit Async.Deferred.t) -> + service:(cfg, t, flow) service -> + cfg -> + 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 () = + Service.init cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok t -> ( + let rec loop () = + let close = Async.Condition.wait stop >>| fun () -> Ok `Stop in + let accept = + Svc.accept t >>? fun flow -> + Async.(Deferred.ok (return (`Flow flow))) in + let events = + match timeout with + | None -> [ close; accept ] + | Some t -> + let t = Core.Time.Span.of_int_sec t in + let timeout = Async.after t >>| fun () -> Ok `Timeout in + [ close; accept; timeout ] in + + Async.Deferred.any events >>= function + | Ok (`Flow flow) -> + Async.don't_wait_for (handler flow) ; + Async.Scheduler.yield () >>= fun () -> (loop [@tailcall]) () + | Ok (`Stop | `Timeout) -> Svc.close t + | Error err0 -> ( + Svc.close t >>= function + | Ok () -> Async.return (Error err0) + | Error _err1 -> Async.return (Error err0)) in + loop () >>= function + | Ok () -> Async.return () + | Error err -> failwith "%a" Svc.pp_error err) in + (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 : int option * ('a, 'b) Tcp.Where_to_listen.t -> configuration + + module Service = 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 = + | Socket : + ([ `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 (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 ?backlog in + close_socket_on_error ~process:`Make socket ~f >>? fun socket -> + Async.return (Ok (Socket (socket, addr))) + + let accept (Socket (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 (Socket (socket, _)) = + Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ()) + end + + let service = S.register ~service:(module Service) + + let resolve ~port domain_name = + Monitor.try_with (fun () -> + Unix.Inet_addr.of_string_or_getbyname + (Domain_name.to_string domain_name)) + >>= function + | Ok inet_addr -> + let inet_addr = Socket.Address.Inet.create inet_addr ~port in + Async.return (Some (Inet inet_addr)) + | _ -> Async.return None +end diff --git a/src/async/conduit_async.mli b/src/async/conduit_async.mli new file mode 100644 index 00000000..c05af020 --- /dev/null +++ b/src/async/conduit_async.mli @@ -0,0 +1,53 @@ +(** Conduit with Async. *) + +open Async_unix + +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 io = 'a Async.Deferred.t + +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 -> + 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 + +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 : + int option * ('a, 'b) Async.Tcp.Where_to_listen.t + -> configuration + + module Service : SERVICE with type configuration = configuration + + val service : (configuration, Service.t, Protocol.flow) service + + val resolve : port:int -> endpoint resolver +end 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/src/core/README.md b/src/core/README.md new file mode 100644 index 00000000..e44605de --- /dev/null +++ b/src/core/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/src/core/conduit.ml b/src/core/conduit.ml new file mode 100644 index 00000000..aa6cbc7e --- /dev/null +++ b/src/core/conduit.ml @@ -0,0 +1,546 @@ +module Sigs = Sigs + +type ('a, 'b) refl = Refl : ('a, 'a) refl + +let strf = Format.asprintf + +type _ witness = .. + +type (+'a, 's) app + +type _ resolver = + | Resolver : { + priority : int option; + resolve : [ `host ] Domain_name.t -> ('edn option, 's) app; + witness : 's witness; + } + -> ('edn * 's) resolver + +type ('a, 'b) value = Value : 'b -> ('a, 'b) value + +let reword_error f = function Ok x -> Ok x | Error err -> Error (f err) + +let msgf fmt = Fmt.kstrf (fun err -> `Msg err) fmt + +[@@@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 + +module Map = + E1.Make + (struct + type _ t = string + end) + (struct + type 'a t = 'a resolver + end) + +type resolvers = Map.t + +let empty = Map.empty + +module type S = sig + type input + + type output + + type +'a io + + type scheduler + + type flow = private .. + + type error = [ `Msg of string | `Not_found ] + + val pp_error : error Fmt.t + + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io + + val send : flow -> output -> (int, [> error ]) result io + + val close : flow -> (unit, [> error ]) result io + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a io = 'a io + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a io = 'a io + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + type ('edn, 'flow) protocol + + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol + + module type REPR = sig + type t + + type flow += T of t + end + + val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack + + val unpack : flow -> unpack + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + val cast : flow -> ('edn, 'flow) protocol -> 'flow option + + val pack : ('edn, 'v) protocol -> 'v -> flow + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + + type nonrec resolvers = resolvers + + val empty : resolvers + + val add : + ('edn, 'flow) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers + + val resolve : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result io + + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io + + module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + + module Service : sig + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + + type ('cfg, 't, 'flow) service + + val equal : + ('cfg0, 't0, 'flow0) service -> + ('cfg1, 't1, 'flow1) service -> + (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option + + val register : service:('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) service + + type error = [ `Msg of string ] + + val pp_error : error Fmt.t + + val init : + 'cfg -> service:('cfg, 't, 'flow) service -> ('t, [> error ]) result io + + val accept : + service:('cfg, 't, 'flow) service -> 't -> ('flow, [> error ]) result io + + val close : + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io + + val impl : + ('cfg, 't, 'flow) service -> + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + end +end + +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 io = 'a IO.t = struct + module Bijection = Higher (IO) + + type scheduler = Bijection.t + + let inj = Bijection.inj + + let prj = Bijection.prj + + let return = IO.return + + 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 io = 'a IO.t + + type _ witness += Witness : scheduler witness + + let witness : scheduler witness = Witness + + type input = Input.t + + type output = Output.t + + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a io = 'a io + + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a io = 'a io + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + + type 'edn key = ('edn * scheduler) Map.key + + type 'edn resolver = [ `host ] Domain_name.t -> 'edn option io + + 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 + + (* 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.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 : 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 + | 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) + + type nonrec resolvers = resolvers + + let empty = empty + + let add : + type edn flow. + (edn, flow) protocol -> + ?priority:int -> + edn resolver -> + resolvers -> + resolvers = + fun (module Witness) ?priority 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 io = + 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 io + = + 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 inf = -1 + + and sup = 1 + + 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. *) + | 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; _ })) = + 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 : + resolvers -> [ `host ] Domain_name.t -> (flow, [> error ]) result io = + 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 pack : type edn v. (edn, v) protocol -> v -> flow = + fun (module Witness) flow -> Witness.T (Value flow) + + let resolve : + type edn v. + resolvers -> + ?protocol:(edn, v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result io = + 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 connect : + 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 unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack + + let unpack : flow -> unpack = + fun flow -> + let (Ptr.Value (flow, Protocol (_, (module Protocol))) : Ptr.v) = + Ptr.prj flow in + let (Value flow) = flow in + Flow (flow, (module Protocol)) + + let 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 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 type SERVICE = Sigs.SERVICE with type +'a io = 'a io + + module Service = struct + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + + module F = struct + type 't t = + | Service : 'cfg key * ('cfg, 't, 'flow) impl -> ('cfg, 't, 'flow) thd t + end + + module Svc = E0.Make (F) + + type ('cfg, 't, 'flow) service = ('cfg, 't, 'flow) thd Svc.s + + let register : + 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)) + + type error = [ `Msg of string ] + + 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 = + fun edn ~service:(module Witness) -> + let (Service (_, (module Service))) = Witness.witness in + Service.init edn >>= function + | Ok t -> return (Ok t) + | Error err -> return (error_msgf "%a" Service.pp_error err) + + let accept : + type cfg t flow. + service:(cfg, t, flow) service -> t -> (flow, [> error ]) result io = + fun ~service:(module Witness) t -> + let (Service (_, (module Service))) = Witness.witness in + 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 io = + 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 -> + (module SERVICE + with type configuration = cfg + and type t = t + and type flow = flow) = + fun (module S) -> + let (Service (_, (module Service))) = S.witness in + (module Service) + end +end diff --git a/src/core/conduit.mli b/src/core/conduit.mli new file mode 100644 index 00000000..f2f93b6c --- /dev/null +++ b/src/core/conduit.mli @@ -0,0 +1,398 @@ +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 io + (** The type for I/O effects. *) + + type scheduler + (** The type of I/O monads. *) + + (** {2:client Client-side conduits.} *) + + type flow = private .. + (** The type for generic flows. {!PROTOCOL} implementations are extending (via + {!register}) this type. It allows users to extract the underlying flow + implementation: + + {[ + Conduit.connect domain_name >>? function + | Conduit_lwt_unix_tcp.T Conduit.(Value (file_descr : Lwt_unix.file_descr)) -> ... + | Conduit_lwt_unix_tls.T Conduit.(Value (fd, (tls : Tls.Engine.state))) -> ... + | _ -> ... (* use flow functions for the default case *) + ]} + *) + + type error = [ `Msg of string | `Not_found ] + + val pp_error : error Fmt.t + + val recv : + flow -> input -> ([ `Input of int | `End_of_flow ], [> error ]) result io + (** [recv flow input] is [Ok (`Input len)] iff [n] bytes of data has been + received from the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, [> error ]) result io + (** [send flow output] is [Ok n] iff [n] bytes of date from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, [> error ]) result io + (** [close flow] closes [flow]. Subsequent calls to {!recv} will return + [Ok `End_of_flow]. Subsequent calls to {!send} will return an [Error]. *) + + (** {2:registration Protocol registration.} *) + + (** A flow is a system that allows entities to transmit {i payloads}. These + entities do not have to care about the underlying transport mechanism. + flows simply deal with routing and delivering of these payloads. That + abstraction allows these protocols to compose. + + For example, the Transmission Control Protocol (TCP) is representable as a + flow, because it is able to encapsulate some {i payloads} without + interpreting it. A counter-example is the Simple Mail Transfer Protocol + (SMTP) which needs an interpretation of its {i payloads}: tokens such as + [EHLO] or [QUIT] have a direct incidence over the life-cycle of the + connection. + + An other protocol representable as a flow is the Transport Layer Security + (TLS), as it deals only with privacy and data integrity. [Conduit] is able + to compose flows together like [TCP ∘ TLS] to make a new flow. Higher-level + protocols can be built in top of these abstract flows: for instance, Secure + Simple Mail Transfer Protocol (SSMTP) or HyperText Transfer Protocol Secure + (HTTPS) can be defined on top of both TCP and TLS. Using [Conduit], these + can be abstracted to work over any flow implementations. *) + module type FLOW = + Sigs.FLOW + with type input = input + and type output = output + and type +'a io = 'a io + + (** A protocol is a {!FLOW} plus [connect]. *) + module type PROTOCOL = + Sigs.PROTOCOL + with type input = input + and type output = output + and type +'a io = 'a io + + type ('edn, 'flow) impl = + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** The type to represent a module {!PROTOCOL}. *) + + type ('edn, 'flow) protocol + (** The type for client protocols. ['edn] is the type for endpoint parameters. + ['flow] is the type for underlying flows. + + Endpoints allow users to create flows by either connecting directly to a + remote server or by resolving domain names (with {!connect}). *) + + val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol + (** [register ~protocol] is the protocol using the implementation [protocol]. + [protocol] must provide a [connect] function to allow client flows to be + created. + + For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow + endpoints, while [Unix.file_descr] would be used for the flow transport. + + {[ + module Conduit_tcp : sig + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + end + ]} + + Client endpoints can of course be more complex, for instance to hold TLS + credentials, and [Conduit] allows all these kinds of flow to be used + transparently: + + {[ + module Conduit_tcp_tls : sig + val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TLS) + end + ]} + + As a protocol implementer, you must {i register} your implementation and + expose the {i witness} of it. Then, users will be able to use it. *) + + (** {2 Injection and Extraction.} + + The goal of [Conduit] is to provide: + {ul + {- A way to manipulate a fully-abstract [flow].} + {- A way to manipulate a concrete and well-know [flow].}} + + [Conduit] provides several mechanisms to be able to manipulate our abstract + type {!flow} and destruct it to a concrete value such as a [Unix.file_descr]. + [Conduit] can assert one assumption: from a given abstracted [flow], it exists + one and only one {!FLOW} implementation. + + As [Conduit] determines this implementation, the user can determine the used + implementation when he wants to {!send} or {!recv} datas. + + So [Conduit] uses or extracts uniqely the implementation registered before + with {!register} and no layer can tweak or update this assertion. + + {!repr}, {!flow}, {!impl} and {!is} can extracts in differents ways the + abstracted {!flow}: + {ul + {- with the {i pattern-matching}} + {- with {i first-class module}} + {- with the function {!is}}} + *) + + module type REPR = sig + type t + + type flow += T of t + end + + val repr : ('edn, 'v) protocol -> (module REPR with type t = ('edn, 'v) value) + (** As a protocol implementer, you should expose the concrete type of your + flow (to be able users to {i destruct} {!flow}). [repr] returns a module + which contains extension of {!flow} from your [protocol] such as: + + {[ + module Conduit_tcp : sig + type t = (Unix.sockaddr, Unix.file_descr) Conduit.value + type Conduit.flow += T of t + val t : (Unix.sockaddr, Unix.file_descr) protocol + end = struct + let t = register ~protocol:(module TCP) + include (val (Conduit.repr t)) + end + ]} + + With this interface, users are able to {i destruct} {!flow} to your + concrete type: + + {[ + Conduit.connect domain_name >>? function + | Conduit_tcp.T (Conduit.Value file_descr) -> ... + | _ -> ... + ]} + *) + + type unpack = Flow : 'flow * (module FLOW with type flow = 'flow) -> unpack + + val unpack : flow -> unpack + (** [pack flow] projects the module implementation associated to the given + abstract [flow] such as: + + {[ + Conduit.connect edn >>= fun flow -> + let Conduit.Flow (flow, (module Flow)) = Conduit.unpack flow in + Flow.send flow "Hello World!" + ]} + *) + + val impl : + ('edn, 'flow) protocol -> + (module PROTOCOL with type endpoint = 'edn and type flow = 'flow) + (** [impl protocol] is [protocol]'s implementation. *) + + val cast : flow -> (_, 'flow) protocol -> 'flow option + (** [cast flow protocol] tries to {i cast} the given [flow] to the concrete + type described by the given [protocol]. + + {[ + match Conduit.is flow Conduit_tcp.t with + | Some (file_descr : Unix.file_descr) -> Some (Unix.getpeername file_descr) + | None -> None + ]} + *) + + val pack : (_, 'v) protocol -> 'v -> flow + (** [pack protocol concrete_flow] abstracts the given [flow] into the + {!flow} type from a given [protocol]. It permits to use [Conduit] with a + concrete value created by the user. + + {[ + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let flow = Conduit.pack Conduit_tcp.t socket in + Conduit.send flow "Hello World!" + ]} + *) + + (** {2:resolution Domain name resolvers.} *) + + type 'edn resolver = [ `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: + + {[ + 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 nonrec resolvers = resolvers + + val empty : resolvers + + val add : + ('edn, _) protocol -> + ?priority:int -> + 'edn resolver -> + resolvers -> + resolvers + (** [add protocol ?priority resolver resolvers] adds a new resolver function + [resolver] to [resolvers]. + + When the [resolver] is able to resolve the given domain name, it will try + to connect to the specified client endpoint. Resolvers are iterated in + priority order (lower to higher). + + {[ + let http_resolver = ... + let https_resolver = ... (* deal with client-side certificates here. *) + + let resolvers = + empty + |> add Conduit_tcp.t http_resolver + |> add Conduit_tcp_tls.t https_resolver ~priority:10 + |> add Conduit_tcp_ssl.t https_resolver ~priority:20 + ]} *) + + val resolve : + resolvers -> + ?protocol:('edn, 'v) protocol -> + [ `host ] Domain_name.t -> + (flow, [> error ]) result io + (** [resolve resolvers domain_name] is the flow created by connecting to the + domain name [domain_name], using the resolvers [resolvers]. Each resolver + tries to resolve the given domain-name (they are ordered by the given + priority). The first which connects successfully wins. + + The resolver result is a flow connect to that winning endpoint. + + {[ + let mirage_io = domain_name_exn "mirage.io" + + val resolver_on_my_private_network : Unix.sockaddr resolver + val resolver_on_internet : Unix.sockaddr resolver + val resolver_with_tls : (Unix.sockaddr * Tls.Config.client) resolver + + let resolvers = + empty + |> add tls ~priority:0 resolver_with_tls + |> add tcp ~priority:10 resolver_on_my_private_network + |> add tcp ~priority:20 resolver_on_internet + + let () = Conduit.resolve resolvers mirage_io >>? function + | TCP.T (Conduit.Value file_descr) as flow -> + let peer = Unix.getpeername file_descr in + ignore @@ Conduit.send flow ("Hello " ^ string_of_sockaddr peer) + | flow -> + ignore @@ Conduit.send flow "Hello World!" + ]} + *) + + val connect : 'edn -> ('edn, _) protocol -> (flow, [> error ]) result io + + (** {2:service Server-side conduits.} *) + + module type SERVICE = Sigs.SERVICE with type +'a io = 'a io + + module Service : sig + type ('cfg, 't, 'flow) impl = + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + + type ('cfg, 't, 'flow) service + (** The type for services, e.g. service-side protocols. ['cfg] is the type + for configuration, ['t] is the type for state states. ['flow] is the type + for underlying flows. *) + + val equal : + ('cfg0, 't0, 'flow0) service -> + ('cfg1, 't1, 'flow1) service -> + (('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option + (** [equal svc0 svc1 ] proves that [svc0] and [svc1] are + physically the same. For instance, [Conduit] asserts: + + {[ + let service = Service.register ~service:(module V) ;; + + let () = match Service.equal service service with + | Some (Refl, Refl, Refl) -> ... + | _ -> assert false + ]} *) + + val register : service:('cfg, 't, '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 ] + + val pp_error : error Fmt.t + + 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 io + (** [accept service t] waits for a connection on the service [t]. The result + is a {i flow} connected to the client. *) + + val close : + service:('cfg, 't, 'flow) service -> 't -> (unit, [> error ]) result io + (** [close ~service t] releases the resources associated to the server [t]. *) + + val impl : + ('cfg, 't, 'flow) service -> + (module SERVICE + with type configuration = 'cfg + and type t = 't + and type flow = 'flow) + (** [impl service] is [service]'s underlying implementation. *) + end +end + +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 io = 'a IO.t diff --git a/src/core/dune b/src/core/dune new file mode 100644 index 00000000..994bc5be --- /dev/null +++ b/src/core/dune @@ -0,0 +1,4 @@ +(library + (name conduit) + (public_name conduit) + (libraries stdlib-shims domain-name)) diff --git a/src/core/e0.ml b/src/core/e0.ml new file mode 100644 index 00000000..1bdb5ecf --- /dev/null +++ b/src/core/e0.ml @@ -0,0 +1,181 @@ +(* (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 type S1 = sig + type 'a t +end + +module Make (Key : S1) = 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 epsilon _ = raise_notrace Not_found + + let handlers = Tbl.create ~epsilon 16 + + let witnesses = Hashtbl.create ~random:false 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 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 + Tbl.add handlers uid handler ; + Hashtbl.add witnesses uid key + end + + let inj (type a) (k : a Key.t) : a s = + (module Injection (struct + type t = a + + 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 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 + + let bindings : unit -> k list = + fun () -> Hashtbl.fold (fun _ v a -> v :: a) witnesses [] +end diff --git a/src/core/e0.mli b/src/core/e0.mli new file mode 100644 index 00000000..b3dc6ddb --- /dev/null +++ b/src/core/e0.mli @@ -0,0 +1,38 @@ +type ('a, 'b) refl = Refl : ('a, 'a) refl + +module type S1 = sig + type 'a t +end + +module Make (Key : S1) : 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/src/core/e1.ml b/src/core/e1.ml new file mode 100644 index 00000000..4f1a9a8f --- /dev/null +++ b/src/core/e1.ml @@ -0,0 +1,117 @@ +(* (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 type S1 = sig + type 'a t +end + +module Make (K : S1) (V : S1) = 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/src/core/e1.mli b/src/core/e1.mli new file mode 100644 index 00000000..7bb12573 --- /dev/null +++ b/src/core/e1.mli @@ -0,0 +1,59 @@ +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 type S1 = sig + type 'a t +end + +module Make (K : S1) (V : S1) : 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/src/core/index.mld b/src/core/index.mld new file mode 100644 index 00000000..20dc4422 --- /dev/null +++ b/src/core/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 diff --git a/src/core/sigs.ml b/src/core/sigs.ml new file mode 100644 index 00000000..f0325550 --- /dev/null +++ b/src/core/sigs.ml @@ -0,0 +1,109 @@ +type 'x or_end_of_flow = [ `End_of_flow | `Input of 'x ] + +module type FLOW = sig + (** [FLOW] is the signature for flow clients. + + A [flow] is an abstract value over which I/O functions such as {!send}, + {!recv} and {!close} can be used. + + {[ + type input = bytes and output = string + type +'a s = 'a + + let process flow = + let buf = Bytes.create 0x1000 in + match Flow.recv flow buf with + | Ok (`Input len) -> + let str = Bytes.sub_string buf 0 len in + ignore (Flow.send flow str) + | _ -> failwith "Flow.recv" + ]} + + The given flow can be more complex than a simple TCP flow for example. It + can be wrapped into a TLS layer. However, the goal is to be able to implement + a protocol without such complexity. + *) + + type +'a io + + type flow + + (** {3 Input & Output.} + + Depending on the I/O model, the type for inputs and outputs can differ ; + for instance they could allow users the ability to define capabilities on + them such as {i read} or {i write} capabilities. + + However, in most of the current [Conduit] backends: + + {[ + type input = Cstruct.t + type output = Cstruct.t + ]} + *) + + type input + + and output + + (** {3 Errors.} *) + + type error + (** The type for errors. *) + + val pp_error : error Fmt.t + (** [pp_error] is the pretty-printer for {!error}. *) + + val recv : flow -> input -> (int or_end_of_flow, error) result io + (** [recv flow input] is [Ok (`Input len)] iff [len] bytes of data has been received from + the flow [flow] and copied in [input]. *) + + val send : flow -> output -> (int, error) result io + (** [send t output] is [Ok len] iff [len] bytes of data from [output] has been + sent over the flow [flow]. *) + + val close : flow -> (unit, error) result io + (** [close flow] closes [flow]. Subsequent calls to {!recv} on [flow] will + return [`End_of_flow]. Subsequent calls to {!send} on [t] will return an + [Error]. *) +end + +module type PROTOCOL = sig + include FLOW + + type endpoint + + val connect : endpoint -> (flow, error) result io +end + +module type SERVICE = sig + type +'a io + + type flow + + type t + + type error + + type configuration + + val init : configuration -> (t, error) result io + + val pp_error : error Fmt.t + + val accept : t -> (flow, error) result io + + val close : t -> (unit, error) result io +end + +module type IO = sig + type +'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t +end + +module type BUFFER = sig + type t +end diff --git a/src/lwt-ssl/conduit_lwt_ssl.ml b/src/lwt-ssl/conduit_lwt_ssl.ml new file mode 100644 index 00000000..df41048f --- /dev/null +++ b/src/lwt-ssl/conduit_lwt_ssl.ml @@ -0,0 +1,146 @@ +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) + +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.PROTOCOL) = struct + type input = Cstruct.t + + type output = Cstruct.t + + type +'a io = '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 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) + + 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_flow + | 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. + (edn, flow) Conduit_lwt.protocol -> + ((edn, flow) endpoint, Lwt_ssl.socket) Conduit_lwt.protocol = + fun protocol -> + let module Flow = (val Conduit_lwt.impl protocol) in + let module M = Protocol (Flow) in + Conduit_lwt.register ~protocol:(module M) + +type 't service = { service : 't; context : Ssl.context } + +module Service (Service : sig + include Conduit_lwt.SERVICE + + val file_descr : flow -> Lwt_unix.file_descr +end) = +struct + type +'a io = 'a Lwt.t + + type configuration = Ssl.context * Service.configuration + + type t = Service.t service + + type flow = Lwt_ssl.socket + + type error = [ `Service of Service.error ] + + let pp_error ppf (`Service err) = Service.pp_error ppf err + + let init (context, edn) = + Service.init edn >|= reword_error (fun err -> `Service err) + >>? fun service -> Lwt.return_ok { service; context } + + 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 + let error exn = + Lwt_unix.close (Service.file_descr flow) >>= fun () -> Lwt.fail exn in + Lwt.try_bind accept process error + + let close { service; _ } = + Service.close service >|= reword_error (fun err -> `Service err) +end + +let service_with_ssl : + type cfg edn t flow. + (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 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 = Service (struct + include S + + let file_descr = file_descr + end) in + Conduit_lwt.Service.register ~service:(module M) + +module TCP = struct + let resolve ~port ~context ?verify domain_name = + let file_descr = Conduit_lwt.TCP.Protocol.file_descr in + Conduit_lwt.TCP.resolve ~port domain_name >|= function + | Some edn -> Some (endpoint ~context ~file_descr ?verify edn) + | None -> None + + open Conduit_lwt.TCP + + type verify = + Ssl.context -> + Protocol.flow -> + (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t + + let protocol = protocol_with_ssl protocol + + let service = + service_with_ssl service ~file_descr:Protocol.file_descr protocol +end diff --git a/src/lwt-ssl/conduit_lwt_ssl.mli b/src/lwt-ssl/conduit_lwt_ssl.mli new file mode 100644 index 00000000..282545b2 --- /dev/null +++ b/src/lwt-ssl/conduit_lwt_ssl.mli @@ -0,0 +1,100 @@ +(** 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 + +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 : + ('edn, 'flow) protocol -> (('edn, 'flow) endpoint, Lwt_ssl.socket) protocol +(** [protocol_with_ssl ~key protocol] returns a representation of the given + protocol with SSL. *) + +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 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. + {!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.TCP + + val protocol : + ((Lwt_unix.sockaddr, Protocol.flow) endpoint, Lwt_ssl.socket) protocol + + val service : + ( Ssl.context * configuration, + Service.t service, + Lwt_ssl.socket ) + Conduit_lwt.service + + type verify = + Ssl.context -> + Protocol.flow -> + (Lwt_ssl.socket, [ `Verify of string ]) result Lwt.t + + val resolve : + port:int -> + context:Ssl.context -> + ?verify:verify -> + (Lwt_unix.sockaddr, Protocol.flow) endpoint resolver +end 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/src/lwt-tls/conduit_lwt_tls.ml b/src/lwt-tls/conduit_lwt_tls.ml new file mode 100644 index 00000000..7fa71c8e --- /dev/null +++ b/src/lwt-tls/conduit_lwt_tls.ml @@ -0,0 +1,17 @@ +include Conduit_tls.Make (Conduit_lwt.IO) (Conduit_lwt) + +module TCP = struct + open Conduit_lwt.TCP + + let protocol = protocol_with_tls protocol + + include (val Conduit_lwt.repr protocol) + + let service = service_with_tls service protocol + + let resolve ~port ~config domain_name = + let open Lwt.Infix in + 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 new file mode 100644 index 00000000..5cefa735 --- /dev/null +++ b/src/lwt-tls/conduit_lwt_tls.mli @@ -0,0 +1,60 @@ +(** 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 + +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 : + ('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 + +module TCP : sig + open Conduit_lwt.TCP + + val protocol : + ( Lwt_unix.sockaddr * Tls.Config.client, + Protocol.flow protocol_with_tls ) + protocol + + type t = + ( Lwt_unix.sockaddr * Tls.Config.client, + Protocol.flow protocol_with_tls ) + Conduit.value + + type Conduit_lwt.flow += T of t + + val service : + ( configuration * Tls.Config.server, + Service.t service_with_tls, + Protocol.flow protocol_with_tls ) + service + + val resolve : + port:int -> + config:Tls.Config.client -> + (Lwt_unix.sockaddr * Tls.Config.client) resolver +end 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/src/lwt/conduit_lwt.ml b/src/lwt/conduit_lwt.ml new file mode 100644 index 00000000..30ff0f1a --- /dev/null +++ b/src/lwt/conduit_lwt.ml @@ -0,0 +1,412 @@ +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) +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 + +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 service flow. + ?timeout:int -> + handler:(flow -> unit Lwt.t) -> + service:(cfg, service, flow) Service.service -> + cfg -> + 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 () = + Service.init cfg ~service >>= function + | Error err -> failwith "%a" Service.pp_error err + | Ok service -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in + let events = + match timeout with + | None -> [ stop; accept ] + | Some t -> + let timeout = + Lwt_unix.sleep (float_of_int t) >>= fun () -> + Lwt.return_ok `Timeout in + [ stop; accept; timeout ] in + + Lwt.pick events >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | Ok (`Stop | `Timeout) -> Svc.close service + | Error err0 -> ( + Svc.close service >>= 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 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 Service = 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 service = + let process () = + Lwt_unix.accept service >>= fun (socket, sockaddr) -> + let linger = Bytes.create 0x1000 in + Lwt.return_ok { Protocol.socket; sockaddr; linger; closed = false } + in + Lwt.catch process @@ function + | 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 + | 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 _service = + (* 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 = S.register ~service:(module Service) + + let resolve ~port domain_name = + Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> Lwt.return_none +end diff --git a/src/lwt/conduit_lwt.mli b/src/lwt/conduit_lwt.mli new file mode 100644 index 00000000..11048501 --- /dev/null +++ b/src/lwt/conduit_lwt.mli @@ -0,0 +1,119 @@ +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 io = 'a Lwt.t + +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 : + ?timeout:int -> + handler:('flow -> unit Lwt.t) -> + service:('cfg, 'service, 'flow) service -> + 'cfg -> + unit Lwt_condition.t * (unit -> unit Lwt.t) +(** [serve ~handler ~service cfg] creates an usual infinite [service] + loop from the given configuration ['cfg]. It returns the {i promise} to launch + the loop and a condition variable to stop the loop. + + {[ + let stop, loop = serve + ~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. To help the user, + the option [?timeout] allows us to wait less than [timeout] seconds. *) + +(** Common interface to properly expose a protocol. + + If a protocol wants to be fully-compatible with [conduit], + it should expose such implementation which is an aggregate + of {i types witnesses}. +*) + +module TCP : sig + (** Implementation of TCP protocol as a client. + + 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 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, Service.t, Protocol.flow) service + + val resolve : port:int -> Lwt_unix.sockaddr resolver +end 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/src/mirage/conduit_lwt_flow.ml b/src/mirage/conduit_lwt_flow.ml new file mode 100644 index 00000000..7ef5eee4 --- /dev/null +++ b/src/mirage/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_flow -> Lwt.return_ok `Eof + | Ok (`Input len) -> Lwt.return_ok (`Data (Cstruct.sub raw 0 len)) + | Error _ as err -> Lwt.return err + +let write flow raw = + let rec go x = + if Cstruct.len x = 0 + then Lwt.return_ok () + else + Conduit_lwt.send flow x >>= function + | Error _ as err -> Lwt.return err + | Ok len -> go (Cstruct.shift x len) in + go raw + +let writev flow cs = + let rec go = function + | [] -> Lwt.return_ok () + | x :: r -> ( + write flow x >>= function + | Ok () -> go r + | Error _ as err -> Lwt.return err) in + go cs + +let close flow = Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit diff --git a/src/mirage/conduit_lwt_flow.mli b/src/mirage/conduit_lwt_flow.mli new file mode 100644 index 00000000..f9714023 --- /dev/null +++ b/src/mirage/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/src/mirage/conduit_mirage.ml b/src/mirage/conduit_mirage.ml new file mode 100644 index 00000000..9595ada2 --- /dev/null +++ b/src/mirage/conduit_mirage.ml @@ -0,0 +1,46 @@ +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 ( >>? ) = Lwt_result.bind + +let serve : + type cfg service flow. + handler:(flow -> unit Lwt.t) -> + service:(cfg, service, 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 service -> ( + let rec loop () = + let stop = Lwt_condition.wait stop >>= fun () -> Lwt.return_ok `Stop in + let accept = + Svc.accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in + + Lwt.pick [ stop; accept ] >>= function + | Ok (`Flow flow) -> + Lwt.async (fun () -> handler flow) ; + Lwt.pause () >>= loop + | Ok `Stop -> Svc.close service + | Error err0 -> ( + Svc.close service >>= 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) diff --git a/src/mirage/conduit_mirage.mli b/src/mirage/conduit_mirage.mli new file mode 100644 index 00000000..f0556b8f --- /dev/null +++ b/src/mirage/conduit_mirage.mli @@ -0,0 +1,13 @@ +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 io = 'a Lwt.t + +val serve : + handler:('flow -> unit Lwt.t) -> + service:('cfg, 'master, 'flow) Service.service -> + 'cfg -> + unit Lwt_condition.t * unit Lwt.t diff --git a/src/mirage/conduit_mirage_dns.ml b/src/mirage/conduit_mirage_dns.ml new file mode 100644 index 00000000..52aaf4d3 --- /dev/null +++ b/src/mirage/conduit_mirage_dns.ml @@ -0,0 +1,25 @@ +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 : + S.t -> + ?keepalive:Mirage_protocols.Keepalive.t -> + ?nodelay:bool -> + t -> + ?nameserver:Transport.ns_addr -> + port:int -> + (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver = + fun stack ?keepalive ?(nodelay = false) t ?nameserver ~port domain_name -> + gethostbyname ?nameserver t domain_name >>= function + | Ok ip -> + 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 new file mode 100644 index 00000000..acbbd1b4 --- /dev/null +++ b/src/mirage/conduit_mirage_dns.mli @@ -0,0 +1,16 @@ +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 : + S.t -> + ?keepalive:Mirage_protocols.Keepalive.t -> + ?nodelay:bool -> + t -> + ?nameserver:Transport.ns_addr -> + port:int -> + (S.t, Ipaddr.V4.t) Conduit_mirage_tcp.endpoint Conduit_mirage.resolver +end diff --git a/src/mirage/conduit_mirage_flow.ml b/src/mirage/conduit_mirage_flow.ml new file mode 100644 index 00000000..e68d3e16 --- /dev/null +++ b/src/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/src/mirage/conduit_mirage_flow.mli b/src/mirage/conduit_mirage_flow.mli new file mode 100644 index 00000000..1135b37d --- /dev/null +++ b/src/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/src/mirage/conduit_mirage_tcp.ml b/src/mirage/conduit_mirage_tcp.ml new file mode 100644 index 00000000..89e539de --- /dev/null +++ b/src/mirage/conduit_mirage_tcp.ml @@ -0,0 +1,273 @@ +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 io = 'a Conduit_mirage.io + + 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 connect { 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_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 + 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_flow)) + 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_flow + | 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 protocol = Conduit_mirage.register ~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 io = 'a Conduit_mirage.io + + type error = Connection_aborted + + let pp_error : error Fmt.t = + fun ppf -> function + | Connection_aborted -> Fmt.string ppf "Connection aborted" + + type flow = protocol + + type nonrec configuration = configuration + + type t = service + + let init { 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 service = Conduit_mirage.Service.register ~service:(module Service) +end diff --git a/src/mirage/conduit_mirage_tcp.mli b/src/mirage/conduit_mirage_tcp.mli new file mode 100644 index 00000000..2a4a2bb7 --- /dev/null +++ b/src/mirage/conduit_mirage_tcp.mli @@ -0,0 +1,29 @@ +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 protocol : + ((StackV4.t, Ipaddr.V4.t) endpoint, protocol) Conduit_mirage.protocol + + val dst : protocol -> Ipaddr.V4.t * int + + type service + + val service : (StackV4.t configuration, service, protocol) Service.service +end diff --git a/src/mirage/dune b/src/mirage/dune new file mode 100644 index 00000000..1c16ad79 --- /dev/null +++ b/src/mirage/dune @@ -0,0 +1,23 @@ +(library + (name conduit_mirage) + (public_name conduit-mirage) + (modules conduit_mirage) + (libraries cstruct conduit lwt)) + +(library + (name conduit_mirage_tcp) + (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 mirage-time conduit-mirage conduit-mirage.tcp dns-client.mirage)) + +(library + (name conduit_mirage_flow) + (public_name conduit-mirage.flow) + (modules conduit_mirage_flow) + (libraries conduit-mirage mirage-flow)) diff --git a/src/tls/conduit_tls.ml b/src/tls/conduit_tls.ml new file mode 100644 index 00000000..59c4c14a --- /dev/null +++ b/src/tls/conduit_tls.ml @@ -0,0 +1,359 @@ +module Ke = Ke.Rke + +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 + (IO : Conduit.IO) + (Conduit : Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a io = 'a IO.t) = +struct + let return x = IO.return x + + let ( >>= ) x f = IO.bind x f + + let ( >>| ) x f = x >>= fun x -> return (f x) + + let ( >>? ) 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 : Conduit.PROTOCOL) = struct + type input = Conduit.input + + type output = Conduit.output + + type +'a io = 'a Conduit.io + + 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.io = + fun flow -> function + | None -> return (Ok ()) + | Some raw -> + Log.debug (fun m -> m "~> Send %d bytes" (Cstruct.len raw)) ; + let rec go raw = + Flow.send flow raw >>| reword_error flow_error >>? fun len -> + let raw = Cstruct.shift raw len in + if Cstruct.len raw = 0 then return (Ok ()) else go raw in + go raw + + let blit src src_off dst dst_off len = + let src = Cstruct.to_bigarray src in + Bigstringaf.blit src ~src_off dst ~dst_off ~len + + let queue_wr_opt queue = function + | None -> () + | Some raw -> + Log.debug (fun m -> + m "Fill the queue with %d byte(s)." (Cstruct.len raw)) ; + Ke.N.push queue ~blit ~length:Cstruct.len ~off:0 raw + + let handle_tls : + Tls.Engine.state -> + (char, Bigarray.int8_unsigned_elt) Ke.t -> + Flow.flow -> + Cstruct.t -> + (Tls.Engine.state option, error) result IO.t = + fun tls queue flow raw -> + match Tls.Engine.handle_tls tls raw with + | `Fail (failure, `Response resp) -> + Log.debug (fun m -> m "|- TLS state: Fail") ; + flow_wr_opt flow (Some resp) >>? fun () -> + return (Error (`TLS failure)) + | `Ok (`Alert _alert, `Response resp, `Data data) -> + Log.debug (fun m -> m "|- TLS state: Alert") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) + | `Ok (`Eof, `Response resp, `Data data) -> + Log.debug (fun m -> m "|- TLS state: EOF") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok None) + | `Ok (`Ok tls, `Response resp, `Data data) -> + (* XXX(dinosaure): it seems that decoding TLS inputs can produce + something bigger than expected. For example, decoding 4096 bytes + can produce 4119 byte(s). *) + Log.debug (fun m -> m "|- TLS state: Ok") ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> return (Ok (Some tls)) + + let handle_handshake : + Tls.Engine.state -> + (char, Bigarray.int8_unsigned_elt) Ke.t -> + Flow.flow -> + Cstruct.t -> + (Tls.Engine.state option, error) result IO.t = + fun tls queue flow raw0 -> + let rec go tls raw1 = + match Tls.Engine.can_handle_appdata tls with + | true -> + Log.debug (fun m -> m "Start to talk with TLS (handshake is done).") ; + handle_tls tls queue flow raw1 + | false -> ( + assert (Tls.Engine.handshake_in_progress tls = true) ; + Log.debug (fun m -> m "Process TLS handshake.") ; + + (* XXX(dinosaure): assertion, [Tls.Engine.handle_tls] consumes all + bytes of [raw1] and [raw1] is physically a subset of [raw0] (or + is [raw0]). we can re-use [raw0] for [Flow.recv] safely. *) + match Tls.Engine.handle_tls tls raw1 with + | `Ok (`Ok tls, `Response resp, `Data data) -> + Log.debug (fun m -> + m "-- TLS state: OK (data: %d byte(s))" + (option_fold ~none:0 ~some:Cstruct.len data)) ; + queue_wr_opt queue data ; + flow_wr_opt flow resp >>? fun () -> + if Tls.Engine.handshake_in_progress tls + then ( + Log.debug (fun m -> m "<- Read the TLS flow") ; + Flow.recv flow raw0 >>| reword_error flow_error >>? function + | `End_of_flow -> + Log.warn (fun m -> + m + "Got EOF from underlying connection while \ + handshake.") ; + return (Ok None) + | `Input 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 connect (edn, config) = + Flow.connect edn >>| reword_error flow_error >>? fun flow -> + let raw = Cstruct.create 0x1000 in + let queue = Ke.create ~capacity:0x1000 Bigarray.Char in + let tls, buf = Tls.Engine.client config in + let rec go buf = + Log.debug (fun m -> m "Start handshake.") ; + Flow.send flow buf >>| reword_error flow_error >>? fun len -> + let buf = Cstruct.shift buf len in + if Cstruct.len buf = 0 + then return (Ok { tls = Some tls; closed = false; raw; queue; flow }) + else go buf in + go buf + + let blit src src_off dst dst_off len = + let dst = Cstruct.to_bigarray dst in + Bigstringaf.blit src ~src_off dst ~dst_off ~len + + let rec recv t raw = + Log.debug (fun m -> m "<~ Start to receive.") ; + match Ke.N.peek t.queue with + | [] -> ( + Log.debug (fun m -> m "<~ TLS queue is empty.") ; + match t.tls with + | None -> + Log.debug (fun m -> m "<~ Connection is close.") ; + return (Ok `End_of_flow) + | Some tls -> ( + Log.debug (fun m -> m "<- Read the TLS flow.") ; + Flow.recv t.flow t.raw >>| reword_error flow_error >>? function + | `End_of_flow -> + Log.warn (fun m -> + m "<- Connection closed by underlying protocol.") ; + t.tls <- None ; + return (Ok `End_of_flow) + | `Input 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_flow -> + 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. + (edn, flow) Conduit.protocol -> + (edn * Tls.Config.client, flow protocol_with_tls) Conduit.protocol = + fun protocol -> + let module Protocol = (val Conduit.impl protocol) in + let module M = Make_protocol (Protocol) in + Conduit.register ~protocol:(module M) + + type 'service service_with_tls = { + service : 'service; + tls : Tls.Config.server; + } + + module Make_server (Service : Conduit.SERVICE) = struct + type +'a io = 'a Conduit.io + + type configuration = Service.configuration * 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 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 }) + + 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 cfg edn t flow. + (cfg, t, flow) Conduit.Service.service -> + (edn, flow protocol_with_tls) Conduit.protocol -> + ( cfg * Tls.Config.server, + t service_with_tls, + flow protocol_with_tls ) + Conduit.Service.service = + fun service _ -> + let module Service = (val Conduit.Service.impl service) in + let module M = Make_server (Service) in + Conduit.Service.register ~service:(module M) +end diff --git a/src/tls/conduit_tls.mli b/src/tls/conduit_tls.mli new file mode 100644 index 00000000..6ee9bb7a --- /dev/null +++ b/src/tls/conduit_tls.mli @@ -0,0 +1,69 @@ +(** 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 + (IO : Conduit.IO) + (Conduit : Conduit.S + with type input = Cstruct.t + and type output = Cstruct.t + and type +'a io = 'a IO.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 : + ('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. *) + + type 'service service_with_tls + + val service_with_tls : + ('cfg, 't, 'flow) Conduit.Service.service -> + ('edn, 'flow protocol_with_tls) Conduit.protocol -> + ( 'cfg * Tls.Config.server, + 't service_with_tls, + 'flow protocol_with_tls ) + Conduit.Service.service +end diff --git a/src/tls/dune b/src/tls/dune new file mode 100644 index 00000000..03c57e9f --- /dev/null +++ b/src/tls/dune @@ -0,0 +1,4 @@ +(library + (name conduit_tls) + (public_name conduit-tls) + (libraries stdlib-shims logs bigstringaf ke tls conduit)) 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/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/dune b/tests/dune new file mode 100644 index 00000000..2a0f6c3a --- /dev/null +++ b/tests/dune @@ -0,0 +1,4 @@ +(test + (name tests) + (package conduit) + (libraries alcotest rresult conduit)) diff --git a/tests/flow.ml b/tests/flow.ml new file mode 100644 index 00000000..91c363a3 --- /dev/null +++ b/tests/flow.ml @@ -0,0 +1,259 @@ +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 io = '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 io = '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 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 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/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/client0 b/tests/ping-pong/client0 new file mode 100644 index 00000000..f68190ac --- /dev/null +++ b/tests/ping-pong/client0 @@ -0,0 +1 @@ +ping diff --git a/tests/ping-pong/client1 b/tests/ping-pong/client1 new file mode 100644 index 00000000..8e554694 --- /dev/null +++ b/tests/ping-pong/client1 @@ -0,0 +1 @@ +pong diff --git a/tests/ping-pong/client2 b/tests/ping-pong/client2 new file mode 100644 index 00000000..c137d8fe --- /dev/null +++ b/tests/ping-pong/client2 @@ -0,0 +1,4 @@ +ping +ping +pong +ping diff --git a/tests/ping-pong/common.ml b/tests/ping-pong/common.ml new file mode 100644 index 00000000..78816a80 --- /dev/null +++ b/tests/ping-pong/common.ml @@ -0,0 +1,138 @@ +module type S = sig + include Conduit.S + + type 'a condition + + val serve : + ?timeout:int -> + handler:('flow -> unit io) -> + service:('cfg, 'master, 'flow) Service.service -> + 'cfg -> + unit condition * (unit -> unit io) +end + +module type CONDITION = sig + type 'a t +end + +let ( <.> ) f g x = f (g x) + +module Make + (IO : Conduit.IO) + (Condition : CONDITION) + (Conduit : S + 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 = IO.return + + let ( >>= ) = IO.bind + + let ( >>? ) x f = + x >>= function Ok x -> f x | Error err -> IO.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 -> IO.return (Ok (`Line line)) + | None -> ( + Conduit.recv flow tmp >>? function + | `End_of_flow -> IO.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 service flow. + cfg -> + protocol:(_, flow) Conduit.protocol -> + service:(cfg, service, flow) Conduit.Service.service -> + unit Condition.t * (unit -> unit IO.t) = + fun cfg ~protocol ~service -> + Conduit.serve + ~handler:(fun flow -> transmission (Conduit.pack protocol flow)) + ~service cfg + + (* 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 () -> IO.return () + | Error `Closed_by_peer -> IO.return () + | Error (#Conduit.error as err) -> + Fmt.epr "client: %a.\n%!" Conduit.pp_error err ; + IO.return () +end 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/ping-pong/server.key b/tests/ping-pong/server.key new file mode 100644 index 00000000..a5fe9dd8 --- /dev/null +++ b/tests/ping-pong/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/ping-pong/server.pem b/tests/ping-pong/server.pem new file mode 100644 index 00000000..f0d0c86d --- /dev/null +++ b/tests/ping-pong/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/ping-pong/test_async.ml b/tests/ping-pong/test_async.ml new file mode 100644 index 00000000..70aaff8d --- /dev/null +++ b/tests/ping-pong/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/ping-pong/test_lwt.ml b/tests/ping-pong/test_lwt.ml new file mode 100644 index 00000000..c9019529 --- /dev/null +++ b/tests/ping-pong/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 "./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 ">>> with_lwt.exe: %a.\n%!" pp_process_status status ; + + let pid = + Unix.create_process_env "./with_lwt.exe" + [| + "./with_lwt.exe"; + "--with-ssl"; + "server.pem"; + "server.key"; + "client0"; + "client1"; + "client2"; + |] + [||] Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + res := !res && properly_exited status ; + Format.printf ">>> with_lwt.exe --with-ssl: %a.\n%!" pp_process_status status ; + + let pid = + Unix.create_process_env "./with_lwt.exe" + [| + "./with_lwt.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_lwt.exe --with-tls: %a.\n%!" pp_process_status status ; + + if !res then exit exit_success else exit exit_failure diff --git a/tests/ping-pong/with_async.ml b/tests/ping-pong/with_async.ml new file mode 100644 index 00000000..323f24e1 --- /dev/null +++ b/tests/ping-pong/with_async.ml @@ -0,0 +1,121 @@ +open Rresult +open Async +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) + +let ssl_protocol, ssl_service = + let open Conduit_async_ssl.TCP in + (protocol, service) + +let tls_protocol, tls_service = + let open Conduit_async_tls.TCP in + (protocol, service) + +let failwith fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt + +let resolve_ping_pong = Conduit_async.TCP.resolve ~port:5000 + +let resolve_ssl_ping_pong = + let context = + Conduit_async_ssl.context ~verify_modes:Ssl.Verify_mode.[ Verify_none ] () + in + Conduit_async_ssl.TCP.resolve ~port:7000 ~context + +let resolve_tls_ping_pong = + let null ~host:_ _ = Ok None in + let config = Tls.Config.client ~authenticator:null () in + Conduit_async_tls.TCP.resolve ~port:9000 ~config + +let resolvers = + Conduit.empty + |> Conduit_async.add ~priority:10 ssl_protocol resolve_ssl_ping_pong + |> Conduit_async.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_async.add ~priority:20 tcp_protocol resolve_ping_pong + +let localhost = Domain_name.(host_exn (of_string_exn "localhost")) + +let run_with : + type cfg service flow. + cfg -> + protocol:(_, flow) Conduit_async.protocol -> + service:(cfg, service, flow) Conduit_async.Service.service -> + string list -> + unit = + fun cfg ~protocol ~service clients -> + let stop, server = server (* ~launched ~stop *) cfg ~protocol ~service in + let clients = + 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) ; + Core.never_returns (Scheduler.go ()) + +let run_with_tcp clients = + run_with + (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 5000)) + ~protocol:tcp_protocol ~service:tcp_service clients + +let run_with_ssl cert key clients = + let ctx = Conduit_async_ssl.context ~crt_file:cert ~key_file:key () in + run_with + (ctx, Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 7000)) + ~protocol:ssl_protocol ~service:ssl_service clients + +let load_file filename = + let open Stdlib in + let ic = open_in filename in + 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 + (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port 9000), ctx) + ~protocol:tls_protocol ~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 diff --git a/tests/ping-pong/with_lwt.ml b/tests/ping-pong/with_lwt.ml new file mode 100644 index 00000000..1425e723 --- /dev/null +++ b/tests/ping-pong/with_lwt.ml @@ -0,0 +1,117 @@ +open Rresult + +let () = Mirage_crypto_rng_unix.initialize () + +let () = Printexc.record_backtrace true + +let () = Ssl.init () + +let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt + +include Common.Make (Lwt) (Lwt_condition) + (struct + type 'a condition = 'a Lwt_condition.t + + include Conduit_lwt + end) + +(* Composition *) + +let tls_protocol, tls_service = + let open Conduit_lwt_tls.TCP in + (protocol, service) + +let ssl_protocol, ssl_service = + let open Conduit_lwt_ssl.TCP in + (protocol, service) + +(* Resolution *) + +let resolve_ping_pong = Conduit_lwt.TCP.resolve ~port:4000 + +let resolve_tls_ping_pong = + let null ~host:_ _ = Ok None in + let config = Tls.Config.client ~authenticator:null () in + Conduit_lwt_tls.TCP.resolve ~port:8000 ~config + +let resolve_ssl_ping_pong = + let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in + Conduit_lwt_ssl.TCP.resolve ~port:6000 ~context ?verify:None + +let resolvers = + Conduit.empty + |> Conduit_lwt.add ~priority:20 Conduit_lwt.TCP.protocol resolve_ping_pong + |> Conduit_lwt.add ~priority:10 tls_protocol resolve_tls_ping_pong + |> Conduit_lwt.add ~priority:10 ssl_protocol resolve_ssl_ping_pong + +(* Run *) + +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 cfg service flow. + cfg -> + protocol:(_, flow) Conduit_lwt.protocol -> + service:(cfg, service, flow) Conduit_lwt.Service.service -> + string list -> + unit = + fun cfg ~protocol ~service clients -> + let stop, server = server cfg ~protocol ~service in + let clients = List.map (client ~resolvers) clients in + let clients = + Lwt.join clients >>= fun () -> + Lwt_condition.broadcast stop () ; + Lwt.return_unit in + Lwt_main.run (Lwt.join [ server (); clients ]) + +let run_with_tcp clients = + run_with + { + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 4000); + capacity = 40; + } + ~protocol:Conduit_lwt.TCP.protocol ~service:Conduit_lwt.TCP.service clients + +let run_with_ssl cert key clients = + let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Server_context in + Ssl.use_certificate ctx cert key ; + run_with + ( ctx, + { + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 6000); + capacity = 40; + } ) + ~protocol:ssl_protocol ~service:ssl_service clients + +let run_with_tls cert key clients = + let ctx = config cert key in + run_with + ( { + Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); + capacity = 40; + }, + ctx ) + ~protocol:tls_protocol ~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/resolvers.ml b/tests/resolvers.ml new file mode 100644 index 00000000..9051845d --- /dev/null +++ b/tests/resolvers.ml @@ -0,0 +1,164 @@ +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 io = '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 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) 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 <