Adapt to conduit 2.3

lib/mirage.ml

@@ -195,6 +195,10 @@ let http_server = Mirage_impl_http.cohttp_server
 let cohttp_server = Mirage_impl_http.cohttp_server
 let httpaf_server = Mirage_impl_http.httpaf_server
 
+type http_client = Mirage_impl_http.http_client
+let http_client = Mirage_impl_http.http_client
+let cohttp_client = Mirage_impl_http.cohttp_client
+
 let default_argv = Mirage_impl_argv.default_argv
 let no_argv = Mirage_impl_argv.no_argv
 

lib/mirage.mli

@@ -567,7 +567,8 @@ val nocrypto: job impl
 
 type conduit
 val conduit: conduit typ
-val conduit_direct: ?tls:bool -> stackv4 impl -> conduit impl
+val conduit_direct:
+  ?tls:bool -> ?random:random impl -> stackv4 impl -> conduit impl
 
 (** {2 HTTP configuration} *)
 
@@ -583,6 +584,13 @@ val cohttp_server: conduit impl -> http impl
 val httpaf_server: conduit impl -> http impl
 (** [httpaf_server] starts a http/af server. *)
 
+type http_client
+val http_client: http_client typ
+
+val cohttp_client:
+  ?pclock:pclock impl -> resolver impl -> conduit impl -> http_client impl
+(** [cohttp_server] starts a Cohttp server. *)
+
 (** {2 Argv configuration} *)
 
 val default_argv: Functoria_app.argv impl

lib/mirage_impl_conduit.ml

@@ -1,34 +1,38 @@
 open Functoria
-open Mirage_impl_conduit_connector
+open Mirage_impl_stack
+open Mirage_impl_misc
+open Mirage_impl_random
 
 type conduit = Conduit
 let conduit = Type Conduit
 
-let conduit_with_connectors connectors = impl @@ object
+let pkg = package ~min:"2.3.0" ~max:"3.0.0" "conduit-mirage"
+
+let tcp = impl @@ object
     inherit base_configurable
-    method ty = conduit
-    method name = Functoria_app.Name.create "conduit" ~prefix:"conduit"
-    method module_name = "Conduit_mirage"
+    method ty = stackv4 @-> conduit
+    method name = Functoria_app.Name.create "conduit_tcp" ~prefix:"conduit_tcp"
+    method module_name = "Conduit_mirage.TCP"
     method! packages = Mirage_key.pure [ pkg ]
-    method! deps = List.map abstract connectors
+    method! connect _i _ = function
+      | [ stack ] -> Fmt.strf "Lwt.return %s@;" stack
+      | _ -> failwith (connect_err "tcp_conduit" 1)
+  end
 
-    method! connect _i _ connectors =
-      let pp_connector = Fmt.fmt "%s >>=@ " in
-      let pp_connectors = Fmt.list ~sep:Fmt.nop pp_connector in
-      Fmt.strf
-        "Lwt.return Conduit_mirage.empty >>=@ \
-         %a\
-         fun t -> Lwt.return t"
-        pp_connectors connectors
+let tls random = impl @@ object
+    inherit base_configurable
+    method ty = conduit @-> conduit
+    method name = Functoria_app.Name.create "conduit_tls" ~prefix:"conduit_tls"
+    method module_name = "Conduit_mirage.TLS"
+    method! deps = [ abstract random ]
+    method! packages =
+      Mirage_key.pure [
+          package ~min:"0.12.0" ~max:"0.13.0" "tls-mirage"; pkg]
+    method! connect _i _ = function
+      | [ stack; _random ] -> Fmt.strf "Lwt.return %s@;" stack
+      | _ -> failwith (connect_err "tls_conduit" 1)
   end
 
-let conduit_direct ?(tls=false) s =
-  (* TCP must be before tls in the list. *)
-  let connectors = [tcp_conduit_connector $ s] in
-  let connectors =
-    if tls then
-      connectors @ [tls_conduit_connector]
-    else
-      connectors
-  in
-  conduit_with_connectors connectors
+let conduit_direct ?tls:(use_tls=false) ?(random=default_random) s =
+  if use_tls then tls random $ (tcp $ s)
+  else tcp $ s

lib/mirage_impl_conduit.mli

@@ -1,8 +1,13 @@
+open Functoria
+
 type conduit
 
-val conduit : conduit Functoria.typ
+val pkg : package
+
+val conduit : conduit typ
 
 val conduit_direct :
-     ?tls:bool
-  -> Mirage_impl_stack.stackv4 Functoria.impl
-  -> conduit Functoria.impl
+  ?tls:bool ->
+  ?random:Mirage_impl_random.random impl
+  -> Mirage_impl_stack.stackv4 impl
+  -> conduit impl

lib/mirage_impl_http.ml

@@ -1,22 +1,46 @@
 open Functoria
+open Mirage_impl_pclock
 open Mirage_impl_misc
+open Mirage_impl_conduit
+open Mirage_impl_resolver
 
 type http = HTTP
 let http = Type HTTP
 
-let cohttp_server conduit = impl @@ object
+type http_client = HTTP_client
+let http_client = Type HTTP_client
+
+let cohttp_server = impl @@ object
     inherit base_configurable
-    method ty = http
+    method ty = conduit @-> http
     method name = "http"
-    method module_name = "Cohttp_mirage.Server_with_conduit"
+    method module_name = "Cohttp_mirage.Server.Make"
     method! packages =
-      Mirage_key.pure [ package ~min:"2.1.0" ~max:"3.0.0" "cohttp-mirage" ]
-    method! deps = [ abstract conduit ]
+      Mirage_key.pure [ package ~min:"3.0.0" ~max:"4.0.0" "cohttp-mirage" ]
     method! connect _i modname = function
-      | [ conduit ] -> Fmt.strf "%s.connect %s" modname conduit
+      | [ conduit ] -> Fmt.strf "Lwt.return (%s.listen %s)" modname conduit
       | _ -> failwith (connect_err "http" 1)
   end
 
+let cohttp_server conduit = cohttp_server $ conduit
+
+let cohttp_client = impl @@ object
+    inherit base_configurable
+    method ty = pclock @-> resolver @-> conduit @-> http_client
+    method name = "http_client"
+    method module_name = "Cohttp_mirage.Client.Make"
+    method! packages =
+      Mirage_key.pure [ package ~min:"3.0.0" ~max:"4.0.0" "cohttp-mirage" ]
+    method! connect _i modname = function
+      | [ _pclock; resolver; conduit ] ->
+         Fmt.strf "Lwt.return (%s.ctx %s %s)" modname resolver conduit
+      | _ -> failwith (connect_err "http" 2)
+  end
+
+
+let cohttp_client ?(pclock = default_posix_clock) resolver conduit =
+  cohttp_client $ pclock $ resolver $ conduit
+
 let httpaf_server conduit = impl @@ object
     inherit base_configurable
     method ty = http

lib/mirage_impl_http.mli

@@ -1,9 +1,19 @@
+open Functoria
+
 type http
 
-val http : http Functoria.typ
+val http : http typ
+
+val cohttp_server : Mirage_impl_conduit.conduit impl -> http impl
+
+val httpaf_server : Mirage_impl_conduit.conduit impl -> http impl
+
+type http_client
 
-val cohttp_server :
-  Mirage_impl_conduit.conduit Functoria.impl -> http Functoria.impl
+val http_client : http_client typ
 
-val httpaf_server :
-  Mirage_impl_conduit.conduit Functoria.impl -> http Functoria.impl
+val cohttp_client :
+  ?pclock:Mirage_impl_pclock.pclock impl ->
+  Mirage_impl_resolver.resolver impl ->
+  Mirage_impl_conduit.conduit impl ->
+  http_client impl

lib/mirage_impl_resolver.ml

@@ -17,7 +17,7 @@ let resolver_unix_system = impl @@ object
     method module_name = "Resolver_lwt"
     method! packages =
       Key.(if_ is_unix)
-        [ Mirage_impl_conduit_connector.pkg ;
+        [ Mirage_impl_conduit.pkg ;
           package ~min:"2.0.2" ~max:"3.0.0" "conduit-lwt-unix"; ]
         []
     method! configure i =
@@ -31,16 +31,16 @@ let resolver_dns_conf ~ns ~ns_port = impl @@ object
     inherit base_configurable
     method ty = random @-> time @-> mclock @-> stackv4 @-> resolver
     method name = "resolver"
-    method module_name = "Resolver_mirage.Make_with_stack"
+    method module_name = "Resolver_mirage.Make"
     method! packages =
-      Key.pure [ Mirage_impl_conduit_connector.pkg ]
+      Key.pure [ Mirage_impl_conduit.pkg ]
     method! keys = [ Key.abstract ns ; Key.abstract ns_port ]
     method! connect _ modname = function
       | [ _r ; _t ; _m ; stack ] ->
         Fmt.strf
           "let ns = %a in@;\
            let ns_port = %a in@;\
-           let res = %s.R.init ~ns ~ns_port ~stack:%s () in@;\
+           let res = %s.v ~ns ~ns_port %s in@;\
            Lwt.return res@;"
           pp_key ns pp_key ns_port modname stack
       | _ -> failwith (connect_err "resolver" 3)