From 4ce66c3dbdde8b546973afeaf5f7c6712a3f1db7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 19 Mar 2019 21:16:27 +0100 Subject: [PATCH 1/7] use udns --- mirage-conduit.opam | 2 +- mirage/conduit_mirage.ml | 7 +-- mirage/conduit_mirage.mli | 2 +- mirage/dune | 4 +- mirage/resolver_mirage.ml | 111 ++++++++++++++++--------------------- mirage/resolver_mirage.mli | 41 +++----------- 6 files changed, 63 insertions(+), 104 deletions(-) diff --git a/mirage-conduit.opam b/mirage-conduit.opam index 339b2b92..2a073f7c 100644 --- a/mirage-conduit.opam +++ b/mirage-conduit.opam @@ -14,7 +14,7 @@ depends: [ "mirage-stack-lwt" {>= "1.3.0"} "mirage-time-lwt" {>= "1.1.0"} "mirage-flow-lwt" {>= "1.2.0"} - "mirage-dns" {>= "3.0.0"} + "dns-client" {>= "4.0.0"} "conduit-lwt" "vchan" {>= "3.0.0"} "xenstore" diff --git a/mirage/conduit_mirage.ml b/mirage/conduit_mirage.ml index 37b8f478..4e0cdd59 100644 --- a/mirage/conduit_mirage.ml +++ b/mirage/conduit_mirage.ml @@ -327,19 +327,18 @@ let rec server (e:Conduit.endp): server Lwt.t = match e with | `TLS (x, y) -> server y >>= fun s -> tls_server x s | `Unknown s -> err_unknown s -module Context (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) = struct +module Context (R: Mirage_random.C) (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) = struct type t = Resolver_lwt.t * conduit - module DNS = Dns_resolver_mirage.Make(T)(S) - module RES = Resolver_mirage.Make(DNS) + module RES = Resolver_mirage.Make_with_stack(R)(T)(S) let conduit = empty let stackv4 = stackv4 (module S: Mirage_stack_lwt.V4 with type t = S.t) let create ?(tls=false) stack = let res = Resolver_lwt.init () in - RES.register ~stack res; + RES.R.register ~stack res; with_tcp conduit stackv4 stack >>= fun conduit -> if tls then with_tls conduit >|= fun conduit -> diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 2d7798a4..5a9af307 100644 --- a/mirage/conduit_mirage.mli +++ b/mirage/conduit_mirage.mli @@ -131,7 +131,7 @@ end include S (** {2 Context for MirageOS conduit resolvers} *) -module Context (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4): sig +module Context (R: Mirage_random.C) (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4): sig type t = Resolver_lwt.t * conduit (** The type for contexts of conduit resolvers. *) diff --git a/mirage/dune b/mirage/dune index bdb0615a..38b103eb 100644 --- a/mirage/dune +++ b/mirage/dune @@ -6,5 +6,5 @@ (wrapped false) (optional) (libraries conduit conduit-lwt mirage-stack-lwt mirage-time-lwt - mirage-flow-lwt mirage-dns ipaddr-sexp - vchan tls tls.mirage xenstore.client)) + mirage-random mirage-flow-lwt 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 index 8bd91975..48b6bf91 100644 --- a/mirage/resolver_mirage.ml +++ b/mirage/resolver_mirage.ml @@ -63,63 +63,50 @@ let localhost = (fun ~port -> `TCP (Ipaddr.(V4 V4.localhost), port)); static hosts +module Make_with_stack (R: Mirage_random.C) (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) = struct + include Resolver_lwt -module type S = sig - module DNS : Dns_resolver_mirage.S - val default_ns : Ipaddr.V4.t - val vchan_resolver : tld:string -> Resolver_lwt.rewrite_fn - val dns_stub_resolver: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> DNS.t -> Resolver_lwt.rewrite_fn - val register: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:DNS.stack -> - Resolver_lwt.t -> unit - val init: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:DNS.stack -> unit -> Resolver_lwt.t -end - -module Make(DNS:Dns_resolver_mirage.S) = struct - module DNS = DNS - - 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)) - - let default_ns = Ipaddr.V4.of_string_exn "8.8.8.8" - - let dns_stub_resolver ?(ns=default_ns) ?(ns_port=53) dns service uri - : Conduit.endp Lwt.t = - let host = get_host uri in - let port = get_port service uri in - (match Ipaddr.of_string host with - | Error _ -> DNS.gethostbyname ~server:ns ~dns_port:ns_port dns host - | Ok addr -> Lwt.return [addr]) >>= fun res -> - List.filter (function Ipaddr.V4 _ -> true | _ -> false) res - |> function - | [] -> Lwt.return (`Unknown ("name resolution failed")) - | addr::_ -> Lwt.return (`TCP (addr,port)) - - let register ?(ns=default_ns) ?(ns_port=53) ?stack res = + 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)(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 _ -> + let hostname = Domain_name.(host_exn (of_string_exn hostn)) in + DNS.gethostbyname dns hostname) >|= 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 dns = DNS.create s in - let f = dns_stub_resolver ~ns ~ns_port dns in - Resolver_lwt.add_rewrite ~host:"" ~f res - | None -> () + | 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; @@ -127,13 +114,9 @@ module Make(DNS:Dns_resolver_mirage.S) = struct 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 - -module Make_with_stack (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) = struct - module R = Make(Dns_resolver_mirage.Make(T)(S)) - include Resolver_lwt + 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 index e7f833c3..b9cb6eab 100644 --- a/mirage/resolver_mirage.mli +++ b/mirage/resolver_mirage.mli @@ -26,40 +26,17 @@ val static : (string, (port:int -> Conduit.endp)) Hashtbl.t -> Resolver_lwt.t maps [localhost] to [127.0.0.1], and fails on all other hostnames. *) val localhost : Resolver_lwt.t -(** Module allowing to build a {!Resolver_lwt} than can perform DNS lookups. *) -module type S = sig - module DNS : Dns_resolver_mirage.S - - (** Default resolver to use, which is [8.8.8.8] (Google DNS). *) - val default_ns : Ipaddr.V4.t - - val vchan_resolver : tld:string -> Resolver_lwt.rewrite_fn - - (** [dns_stub_resolver ?ns ?dns_port dns] will return a resolver that uses - the stub resolver [ns] on port [ns_port] to resolve URIs via - the [dns] network interface. *) - val dns_stub_resolver: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> DNS.t -> Resolver_lwt.rewrite_fn - - (** [register ?ns ?ns_port ?stack res] TODO *) - val register: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:DNS.stack -> - Resolver_lwt.t -> unit - - (** [init ?ns ?ns_port ?stack ()] TODO *) - val init: - ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:DNS.stack -> unit -> Resolver_lwt.t -end - -(** Given a DNS resolver {{:https://github.com/mirage/ocaml-dns}implementation}, - provide a {!Resolver_lwt} that can perform DNS lookups to return - endpoints. *) -module Make(DNS:Dns_resolver_mirage.S) : S with module DNS = DNS - (** Provides a DNS-enabled {!Resolver_lwt} given a network stack. See {!Make}. *) -module Make_with_stack (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) : sig +module Make_with_stack (R: Mirage_random.C) (T: Mirage_time_lwt.S) (S: Mirage_stack_lwt.V4) : sig include Resolver_lwt.S with type t = Resolver_lwt.t - module R : S with type DNS.stack = S.t + + module R : sig + val register : ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:S.t -> Resolver_lwt.t -> unit + + (** [init ?ns ?ns_port ?stack ()] TODO *) + val init: + ?ns:Ipaddr.V4.t -> ?ns_port:int -> ?stack:S.t -> unit -> t + end end From 44e9bd360649f5a8ced02d4a64aafa7dccffd46e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 18:54:41 +0200 Subject: [PATCH 2/7] travis: add a job which builds mirage-conduit --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 416b0726..0a98b69e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,6 +9,7 @@ env: - PINS="conduit:. mirage-conduit:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." - TESTS=true matrix: + - OCAML_VERSION=4.07 PACKAGE=mirage-conduit DISTRO=alpine - OCAML_VERSION=4.07 PACKAGE=conduit-lwt-unix DISTRO=debian-stable DEPOPTS="ssl tls" - OCAML_VERSION=4.06 PACKAGE=conduit-lwt-unix DISTRO=debian-unstable DEPOPTS="ssl tls" - OCAML_VERSION=4.05 PACKAGE=conduit-async DISTRO=debian-unstable DEPOPTS=async_ssl From bdc2464cb4582aba87c874c84bad422cc5a27d8c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 19:14:50 +0200 Subject: [PATCH 3/7] mirage-conduit: add synopsis to opam --- mirage-conduit.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/mirage-conduit.opam b/mirage-conduit.opam index 2a073f7c..31cdb9ec 100644 --- a/mirage-conduit.opam +++ b/mirage-conduit.opam @@ -28,3 +28,4 @@ build: [ ["dune" "runtest" "-p" name] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-conduit.git" +synopsis: "A network connection establishment library for MirageOS" From 854e2825e0876cbbd61910d148e84ec94bc87421 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 19:47:43 +0200 Subject: [PATCH 4/7] fix mirage-conduit --- mirage-conduit.opam | 6 ++++++ mirage/dune | 1 - 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/mirage-conduit.opam b/mirage-conduit.opam index 31cdb9ec..9cb58abb 100644 --- a/mirage-conduit.opam +++ b/mirage-conduit.opam @@ -14,6 +14,7 @@ depends: [ "mirage-stack-lwt" {>= "1.3.0"} "mirage-time-lwt" {>= "1.1.0"} "mirage-flow-lwt" {>= "1.2.0"} + "mirage-random" {>= "1.2.0"} "dns-client" {>= "4.0.0"} "conduit-lwt" "vchan" {>= "3.0.0"} @@ -21,6 +22,11 @@ depends: [ "tls" {>= "0.8.0"} "ipaddr" {>= "3.0.0"} "ipaddr-sexp" + + #these are required for tls.mirage, which mirage-conduit depends on + "mirage-kv-lwt" {>= "2.0.0"} + "mirage-clock" {>= "2.0.0"} + "ptime" ] build: [ ["dune" "subst"] {pinned} diff --git a/mirage/dune b/mirage/dune index 38b103eb..608186d9 100644 --- a/mirage/dune +++ b/mirage/dune @@ -4,7 +4,6 @@ (preprocess (pps ppx_sexp_conv)) (modules conduit_mirage resolver_mirage conduit_xenstore) (wrapped false) - (optional) (libraries conduit conduit-lwt mirage-stack-lwt mirage-time-lwt mirage-random mirage-flow-lwt dns-client.mirage ipaddr-sexp vchan tls tls.mirage xenstore.client uri.services)) From 700d50b48cda4f97bf0780ce3ffe13e915bc19b8 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 19:47:50 +0200 Subject: [PATCH 5/7] remove .merlin file --- .merlin | 6 ------ 1 file changed, 6 deletions(-) delete mode 100644 .merlin diff --git a/.merlin b/.merlin deleted file mode 100644 index d1d14618..00000000 --- a/.merlin +++ /dev/null @@ -1,6 +0,0 @@ -PKG ppx_driver.ocamlbuild -PKG sexplib stringext uri cstruct ipaddr lwt vchan async_ssl ssl tls tls.lwt -PKG dns.mirage mirage-types mirage logs -B _build/** -S lib/ -S tests/** \ No newline at end of file From 4d65ef52c4a97f173badacb358b18200e65186b9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 19:49:49 +0200 Subject: [PATCH 6/7] rename mirage-conduit to conduit-mirage --- .travis.yml | 4 ++-- appveyor.yml | 4 ++-- mirage-conduit.opam => conduit-mirage.opam | 2 +- conduit.opam | 2 +- mirage/dune | 2 +- tests/mirage/simple/dune | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) rename mirage-conduit.opam => conduit-mirage.opam (93%) diff --git a/.travis.yml b/.travis.yml index 0a98b69e..63c4eea0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,10 +6,10 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/ma script: bash ./.travis-docker.sh env: global: - - PINS="conduit:. mirage-conduit:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." + - PINS="conduit:. conduit-mirage:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." - TESTS=true matrix: - - OCAML_VERSION=4.07 PACKAGE=mirage-conduit DISTRO=alpine + - OCAML_VERSION=4.07 PACKAGE=conduit-mirage DISTRO=alpine - OCAML_VERSION=4.07 PACKAGE=conduit-lwt-unix DISTRO=debian-stable DEPOPTS="ssl tls" - OCAML_VERSION=4.06 PACKAGE=conduit-lwt-unix DISTRO=debian-unstable DEPOPTS="ssl tls" - OCAML_VERSION=4.05 PACKAGE=conduit-async DISTRO=debian-unstable DEPOPTS=async_ssl diff --git a/appveyor.yml b/appveyor.yml index 9f81340b..1fb33a33 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -5,9 +5,9 @@ environment: CYG_ROOT: "C:\\cygwin" CYG_BASH: "%CYG_ROOT%\\bin\\bash -lc" TESTS: "false" - PINS: "conduit:. mirage-conduit:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." + PINS: "conduit:. conduit-mirage:. conduit-async:. conduit-lwt:. conduit-lwt-unix:." PACKAGE: "conduit" - DEPOPTS: "mirage-conduit conduit-async conduit-lwt conduit-lwt-unix" + DEPOPTS: "conduit-mirage conduit-async conduit-lwt conduit-lwt-unix" install: - appveyor DownloadFile https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/appveyor-opam.sh diff --git a/mirage-conduit.opam b/conduit-mirage.opam similarity index 93% rename from mirage-conduit.opam rename to conduit-mirage.opam index 9cb58abb..616afa97 100644 --- a/mirage-conduit.opam +++ b/conduit-mirage.opam @@ -23,7 +23,7 @@ depends: [ "ipaddr" {>= "3.0.0"} "ipaddr-sexp" - #these are required for tls.mirage, which mirage-conduit depends on + #these are required for tls.mirage, which conduit-mirage depends on "mirage-kv-lwt" {>= "2.0.0"} "mirage-clock" {>= "2.0.0"} "ptime" diff --git a/conduit.opam b/conduit.opam index 13ad637f..003e9c5a 100644 --- a/conduit.opam +++ b/conduit.opam @@ -44,5 +44,5 @@ The useful opam packages available that extend this library are: - `conduit-lwt`: the portable Lwt implementation - `conduit-lwt-unix`: the Lwt/Unix implementation - `conduit-async` the Jane Street Async implementation -- `mirage-conduit`: the MirageOS compatible implementation +- `conduit-mirage`: the MirageOS compatible implementation """ diff --git a/mirage/dune b/mirage/dune index 608186d9..c8590670 100644 --- a/mirage/dune +++ b/mirage/dune @@ -1,6 +1,6 @@ (library (name conduit_mirage) - (public_name mirage-conduit) + (public_name conduit-mirage) (preprocess (pps ppx_sexp_conv)) (modules conduit_mirage resolver_mirage conduit_xenstore) (wrapped false) diff --git a/tests/mirage/simple/dune b/tests/mirage/simple/dune index 32a44aa7..9ad161ba 100644 --- a/tests/mirage/simple/dune +++ b/tests/mirage/simple/dune @@ -1,4 +1,4 @@ (test (name test) - (libraries mirage-conduit) - (package mirage-conduit)) + (libraries conduit-mirage) + (package conduit-mirage)) From ab9e442b1de8df357284fa9544605fd44d6a7ce0 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Aug 2019 19:57:49 +0200 Subject: [PATCH 7/7] conduit-mirage: conflict with mirage-conduit --- conduit-mirage.opam | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/conduit-mirage.opam b/conduit-mirage.opam index 616afa97..9f98cf50 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -28,6 +28,10 @@ depends: [ "mirage-clock" {>= "2.0.0"} "ptime" ] +conflicts: [ + "mirage-conduit" +] + build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs]