Update pgx_lwt_mirage to modern mirage dependencies (#117)

* Adapt to conduit 2.3 * more version dependency upgrades for pgx_lwt_mirage * compat with recent dns-client-mirage * call pgx_lwt_mirage make functor with pclock and dual-stack modules Co-authored-by: Thomas Gazagnaire <thomas@gazagnaire.org>
arenadotio · Mar 10, 2022 · 3f2c0fc · 3f2c0fc
1 parent 5cc53c7
commit 3f2c0fc
Show file tree

Hide file tree

Showing 7 changed files with 78 additions and 74 deletions.
diff --git a/dune-project b/dune-project
@@ -172,14 +172,14 @@
   logs
   mirage-channel
   (conduit-mirage
-   (and
-    (>= 2.2.0)
-    (< 2.3.0)))
-  dns-client
+    (>= 2.3.0))
+  (dns-client
+    (>= 6.0.0))
   mirage-random
   mirage-time
   mirage-clock
-  mirage-stack
+  (tcpip
+    (>= 7.0.0))
   (pgx
    (= :version))
   (pgx_lwt

diff --git a/pgx_lwt_mirage.opam b/pgx_lwt_mirage.opam
@@ -14,12 +14,12 @@ depends: [
   "ocaml" {>= "4.08"}
   "logs"
   "mirage-channel"
-  "conduit-mirage" {>= "2.2.0" & < "2.3.0"}
-  "dns-client"
+  "conduit-mirage" {>= "2.3.0"}
+  "dns-client" {>= "6.0.0"}
   "mirage-random"
   "mirage-time"
   "mirage-clock"
-  "mirage-stack"
+  "tcpip" {>= "7.0.0"}
   "pgx" {= version}
   "pgx_lwt" {= version}
 ]

diff --git a/pgx_lwt_mirage/src/dune b/pgx_lwt_mirage/src/dune
@@ -10,6 +10,6 @@ let () = Jbuild_plugin.V1.send @@ {|
 
 (library
  (public_name pgx_lwt_mirage)
- (libraries pgx_lwt lwt logs.lwt pgx mirage-channel conduit-mirage dns-client mirage-random mirage-time mirage-clock mirage-stack)
+ (libraries pgx_lwt lwt logs.lwt pgx mirage-channel conduit-mirage dns-client mirage-random mirage-time mirage-clock tcpip)
  |} ^ preprocess ^ {|)
 |}
diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.ml b/pgx_lwt_mirage/src/pgx_lwt_mirage.ml
@@ -18,81 +18,84 @@
  *)
 
 open Lwt.Infix
-module Channel = Mirage_channel.Make (Conduit_mirage.Flow)
 
 (* Defining this inline so we can use older lwt versions. *)
 let ( let* ) = Lwt.bind
 let ( let+ ) t f = Lwt.map f t
 
-module Thread = struct
-  type sockaddr =
-    | Unix of string
-    | Inet of string * int
-
-  type in_channel = Channel.t
-  type out_channel = Channel.t
-
-  let output_char oc c =
-    Channel.write_char oc c;
-    Lwt.return_unit
-  ;;
-
-  let output_string oc s =
-    Channel.write_string oc s 0 (String.length s);
-    Lwt.return_unit
-  ;;
-
-  let flush oc =
-    Channel.flush oc
-    >>= function
-    | Ok () -> Lwt.return_unit
-    | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
-  ;;
-
-  let input_char ic =
-    Channel.read_char ic
-    >>= function
-    | Ok (`Data c) -> Lwt.return c
-    | Ok `Eof -> Lwt.fail End_of_file
-    | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
-  ;;
-
-  let really_input ic buf off len =
-    Channel.read_exactly ~len ic
-    >>= function
-    | Ok (`Data bufs) ->
-      let content = Cstruct.copyv bufs in
-      Bytes.blit_string content 0 buf off len;
-      Lwt.return_unit
-    | Ok `Eof -> Lwt.fail End_of_file
-    | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
-  ;;
-
-  let close_in oc =
-    Channel.close oc
-    >>= function
-    | Ok () -> Lwt.return_unit
-    | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
-  ;;
-
-  let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available."
-end
-
 module Make
     (RANDOM : Mirage_random.S)
     (TIME : Mirage_time.S)
     (MCLOCK : Mirage_clock.MCLOCK)
-    (STACK : Mirage_stack.V4) =
+    (PCLOCK : Mirage_clock.PCLOCK)
+    (STACK : Tcpip.Stack.V4V6) =
 struct
-  module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (STACK)
+  module Channel = Mirage_channel.Make (STACK.TCP)
+
+  module Thread = struct
+    type sockaddr =
+      | Unix of string
+      | Inet of string * int
+
+    type in_channel = Channel.t
+    type out_channel = Channel.t
+
+    let output_char oc c =
+      Channel.write_char oc c;
+      Lwt.return_unit
+    ;;
+
+    let output_string oc s =
+      Channel.write_string oc s 0 (String.length s);
+      Lwt.return_unit
+    ;;
+
+    let flush oc =
+      Channel.flush oc
+      >>= function
+      | Ok () -> Lwt.return_unit
+      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
+    ;;
+
+    let input_char ic =
+      Channel.read_char ic
+      >>= function
+      | Ok (`Data c) -> Lwt.return c
+      | Ok `Eof -> Lwt.fail End_of_file
+      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
+    ;;
+
+    let really_input ic buf off len =
+      Channel.read_exactly ~len ic
+      >>= function
+      | Ok (`Data bufs) ->
+        let content = Cstruct.copyv bufs in
+        Bytes.blit_string content 0 buf off len;
+        Lwt.return_unit
+      | Ok `Eof -> Lwt.fail End_of_file
+      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
+    ;;
+
+    let close_in oc =
+      Channel.close oc
+      >>= function
+      | Ok () -> Lwt.return_unit
+      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
+    ;;
+
+    let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available."
+  end
+
+  module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK)
 
   type sockaddr = Thread.sockaddr =
     | Unix of string
     | Inet of string * int
 
+  module TCP = Conduit_mirage.TCP (STACK)
+
   let connect_stack stack sockaddr =
     let dns = Dns.create stack in
-    let* conduit = Conduit_mirage.(with_tcp empty (stackv4 (module STACK)) stack) in
     let* client =
       match sockaddr with
       | Unix _ -> Lwt.fail_with "Running under MirageOS. Unix sockets are not available."
@@ -106,7 +109,7 @@ struct
           | Ok ipaddr -> Lwt.return (`TCP (Ipaddr.V4 ipaddr, port))
           | Error (`Msg msg) -> Lwt.fail_with msg))
     in
-    let+ flow = Conduit_mirage.connect conduit client in
+    let+ flow = TCP.connect stack client in
     let ch = Channel.create flow in
     ch, ch
   ;;

diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.mli b/pgx_lwt_mirage/src/pgx_lwt_mirage.mli
@@ -20,7 +20,8 @@
 module Make
     (RANDOM : Mirage_random.S)
     (TIME : Mirage_time.S)
-    (CLOCK : Mirage_clock.MCLOCK)
-    (STACK : Mirage_stack.V4) : sig
+    (MCLOCK : Mirage_clock.MCLOCK)
+    (PCLOCK : Mirage_clock.PCLOCK)
+    (STACK : Tcpip.Stack.V4V6) : sig
   val connect : STACK.t -> (module Pgx_lwt.S)
 end
diff --git a/unikernel/config.ml b/unikernel/config.ml
@@ -9,7 +9,7 @@ let packages =
   ]
 ;;
 
-let stack = generic_stackv4 default_network
+let stack = generic_stackv4v6 default_network
 
 let database =
   let doc = Key.Arg.info ~doc:"database to use" [ "db"; "pgdatabase" ] in
@@ -47,7 +47,7 @@ let server =
       ; Key.abstract database
       ]
     ~packages
-    (random @-> time @-> pclock @-> mclock @-> stackv4 @-> job)
+    (random @-> time @-> pclock @-> mclock @-> stackv4v6 @-> job)
 ;;
 
 let () =

diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml
@@ -5,9 +5,9 @@ module Make
     (TIME : Mirage_time.S)
     (PCLOCK : Mirage_clock.PCLOCK)
     (MCLOCK : Mirage_clock.MCLOCK)
-    (STACK : Mirage_stack.V4) =
+    (STACK : Tcpip.Stack.V4V6) =
 struct
-  module Pgx_mirage = Pgx_lwt_mirage.Make (RANDOM) (TIME) (MCLOCK) (STACK)
+  module Pgx_mirage = Pgx_lwt_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK)
   module Logs_reporter = Mirage_logs.Make (PCLOCK)
 
   type user =