diff --git a/dune-project b/dune-project index 21fed8b..5326a5a 100644 --- 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 index 2365e00..12ce80e 100644 --- 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 index af51bf5..c8a831c 100644 --- 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 index e054ef6..3796948 100644 --- 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 index 70feb44..62bfd24 100644 --- 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 index 1d69ba5..4586d67 100644 --- 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 index f462a82..f28f806 100644 --- 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 =