Update to MirageOS 3

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>

src/bin/bind.ml

@@ -8,15 +8,28 @@ module Log = (val Logs.src_log src : Logs.LOG)
 open Lwt.Infix
 open Vmnet
 
-let errorf fmt = Fmt.kstrf (fun e -> Lwt.return (`Error (`Msg e))) fmt
-let error_of_failure f =
-  Lwt.catch f (fun e -> Lwt_result.fail (`Msg (Printexc.to_string e)))
-
 let is_windows = Sys.os_type = "Win32"
 
+let failf fmt = Fmt.kstrf (fun e -> Lwt_result.fail (`Msg e)) fmt
+
 module Make(Socket: Sig.SOCKETS) = struct
 
-  module Channel = Channel.Make(Socket.Stream.Unix)
+  module Channel = Mirage_channel_lwt.Make(Socket.Stream.Unix)
+
+  let err_eof = Lwt_result.fail (`Msg "error: got EOF")
+  let err_read e = failf "error while reading: %a" Channel.pp_error e
+  let err_flush e = failf "error while flushing: %a" Channel.pp_write_error e
+
+  let with_read x f =
+    x >>= function
+    | Error e      -> err_read e
+    | Ok `Eof      -> err_eof
+    | Ok (`Data x) -> f x
+
+  let with_flush x f =
+    x >>= function
+    | Error e -> err_flush e
+    | Ok ()   -> f ()
 
   type t = {
     fd: Socket.Stream.Unix.flow;
@@ -33,32 +46,28 @@ module Make(Socket: Sig.SOCKETS) = struct
   let of_fd fd =
     let buf = Cstruct.create Init.sizeof in
     let (_: Cstruct.t) = Init.marshal Init.default buf in
-    error_of_failure (fun () ->
-        let c = Channel.create fd in
-        Channel.write_buffer c buf;
-        Channel.flush c >>= fun () ->
-        Channel.read_exactly ~len:Init.sizeof c >>= fun bufs ->
-        let buf = Cstruct.concat bufs in
-        let open Lwt_result.Infix in
-        Lwt.return (Init.unmarshal buf)
-        >>= fun (init, _) ->
-        Log.info (fun f ->
-            f "Client.negotiate: received %s" (Init.to_string init));
-        Lwt_result.return { fd; c }
-      )
+    let c = Channel.create fd in
+    Channel.write_buffer c buf;
+    with_flush (Channel.flush c) @@ fun () ->
+    with_read (Channel.read_exactly ~len:Init.sizeof c) @@ fun bufs ->
+    let buf = Cstruct.concat bufs in
+    let init, _ = Init.unmarshal buf in
+    Log.info (fun f ->
+        f "Client.negotiate: received %s" (Init.to_string init));
+    Lwt_result.return { fd; c }
 
   let bind_ipv4 t (ipv4, port, stream) =
     let buf = Cstruct.create Command.sizeof in
     let (_: Cstruct.t) =
       Command.marshal (Command.Bind_ipv4(ipv4, port, stream)) buf
     in
     Channel.write_buffer t.c buf;
-    Channel.flush t.c >>= fun () ->
+    with_flush (Channel.flush t.c) @@ fun () ->
     let rawfd = Socket.Stream.Unix.unsafe_get_raw_fd t.fd in
     let result = String.make 8 '\000' in
     let n, _, fd = Fd_send_recv.recv_fd rawfd result 0 8 [] in
 
-    (if n <> 8 then errorf "Message only contained %d bytes" n else
+    (if n <> 8 then failf "Message only contained %d bytes" n else
        let buf = Cstruct.create 8 in
        Cstruct.blit_from_string result 0 buf 0 8;
        Log.debug (fun f ->
@@ -67,15 +76,15 @@ module Make(Socket: Sig.SOCKETS) = struct
            f "received result bytes: %s which is %s" (String.escaped result)
              (Buffer.contents b));
        match Cstruct.LE.get_uint64 buf 0 with
-       | 0L  -> Lwt.return (`Ok fd)
-       | 48L -> errorf "EADDRINUSE"
-       | 49L -> errorf "EADDRNOTAVAIL"
-       | n   -> errorf "Failed to bind: unrecognised errno: %Ld" n
+       | 0L  -> Lwt_result.return fd
+       | 48L -> failf "EADDRINUSE"
+       | 49L -> failf "EADDRNOTAVAIL"
+       | n   -> failf "Failed to bind: unrecognised errno: %Ld" n
     ) >>= function
-    | `Error x ->
+    | Error x ->
       Unix.close fd;
       Lwt_result.fail x
-    | `Ok x ->
+    | Ok x ->
       Lwt_result.return x
 
   (* This implementation is OSX-only *)

src/bin/connect.ml

@@ -30,16 +30,15 @@ module Make_unix(Host: Sig.HOST) = struct
         Cstruct.of_string (Printf.sprintf "00000003.%08lx\n" vsock_port)
       in
       write flow address >>= function
-      | `Ok () -> Lwt.return flow
-      | `Eof ->
+      | Ok () -> Lwt.return flow
+      | Error `Closed ->
         Log.err (fun f -> f "vsock connect write got Eof");
         close flow >>= fun () ->
         Lwt.fail End_of_file
-      | `Error e ->
-        let msg = error_message e in
-        Log.err (fun f -> f "vsock connect write got %s" msg);
+      | Error e ->
+        Log.err (fun f -> f "vsock connect write got %a" pp_write_error e);
         close flow >>= fun () ->
-        Lwt.fail_with msg
+        Fmt.kstrf Lwt.fail_with "%a" pp_write_error e
 end
 
 module Make_hvsock(Host: Sig.HOST) = struct
@@ -83,8 +82,10 @@ module Make_hvsock(Host: Sig.HOST) = struct
   let writev t = F.writev t.flow
   let shutdown_read t = F.shutdown_read t.flow
   let shutdown_write t = F.shutdown_write t.flow
-  let error_message = F.error_message
+  let pp_error = F.pp_error
+  let pp_write_error = F.pp_write_error
   type 'a io = 'a F.io
   type buffer = F.buffer
   type error = F.error
+  type write_error = F.write_error
 end

src/bin/jbuild

@@ -4,6 +4,7 @@
   ((name main)
    (libraries   (
      cmdliner ofs logs.fmt hostnet hvsock hvsock.lwt-unix
-     datakit-server.fs9p win-eventlog asl fd-send-recv
+     datakit-server-9p win-eventlog asl fd-send-recv duration
+     mirage-clock-unix mirage-random
    ))
    (preprocess  no_preprocessing)))

src/bin/main.ml

@@ -54,8 +54,8 @@ module Main(Host: Sig.HOST) = struct
   module Bind = Bind.Make(Host.Sockets)
   module Dns_policy = Hostnet_dns.Policy(Host.Files)
   module Config = Active_config.Make(Host.Time)(Host.Sockets.Stream.Unix)
-  module Forward_unix = Forward.Make(Connect_unix)(Bind)
-  module Forward_hvsock = Forward.Make(Connect_hvsock)(Bind)
+  module Forward_unix = Forward.Make(Mclock)(Connect_unix)(Bind)
+  module Forward_hvsock = Forward.Make(Mclock)(Connect_hvsock)(Bind)
   module HV = Flow_lwt_hvsock.Make(Host.Time)(Host.Fn)
   module Hosts = Hosts.Make(Host.Files)
 
@@ -98,10 +98,10 @@ module Main(Host: Sig.HOST) = struct
           (* no need to add more delay *)
         | Unix.Unix_error(_, _, _) ->
           HV.Hvsock.close socket >>= fun () ->
-          Host.Time.sleep 1.
+          Host.Time.sleep_ns (Duration.of_sec 1)
         | _ ->
           HV.Hvsock.close socket >>= fun () ->
-          Host.Time.sleep 1.
+          Host.Time.sleep_ns (Duration.of_sec 1)
         )
       >>= fun () ->
       aux ()
@@ -161,10 +161,11 @@ module Main(Host: Sig.HOST) = struct
              database key slirp/max-connections instead"));
     Host.Sockets.set_max_connections max_connections;
     let uri = Uri.of_string port_control_url in
+    Mclock.connect () >>= fun clock ->
     match Uri.scheme uri with
     | Some "hyperv-connect" ->
       let module Ports = Active_list.Make(Forward_hvsock) in
-      let fs = Ports.make () in
+      let fs = Ports.make clock in
       Ports.set_context fs "";
       let module Server = Protocol_9p.Server.Make(Log9P)(HV)(Ports) in
       let sockaddr = hvsock_addr_of_uri ~default_serviceid:ports_serviceid uri in
@@ -178,7 +179,7 @@ module Main(Host: Sig.HOST) = struct
           | Ok server -> Server.after_disconnect server)
     | _ ->
       let module Ports = Active_list.Make(Forward_unix) in
-      let fs = Ports.make () in
+      let fs = Ports.make clock in
       Ports.set_context fs vsock_path;
       let module Server =
         Protocol_9p.Server.Make(Log9P)(Host.Sockets.Stream.Unix)(Ports)
@@ -276,6 +277,8 @@ module Main(Host: Sig.HOST) = struct
       List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," host_names
     in
 
+    Mclock.connect () >>= fun clock ->
+
     let hardcoded_configuration =
       let server_macaddr = Slirp.default_server_macaddr in
       let peer_ip = Ipaddr.V4.of_string_exn "192.168.65.2" in
@@ -301,7 +304,8 @@ module Main(Host: Sig.HOST) = struct
         client_uuids;
         bridge_connections = true;
         mtu = 1500;
-        host_names }
+        host_names;
+        clock }
     in
 
     let config = match db_path with
@@ -325,14 +329,15 @@ module Main(Host: Sig.HOST) = struct
     match Uri.scheme uri with
     | Some "hyperv-connect" ->
       let module Slirp_stack =
-        Slirp.Make(Config)(Vmnet.Make(HV))(Dns_policy)(Host)(Vnet)
+        Slirp.Make(Config)(Vmnet.Make(HV))(Dns_policy)
+          (Mclock)(Stdlibrandom)(Host)(Vnet)
       in
       let sockaddr =
         hvsock_addr_of_uri ~default_serviceid:ethernet_serviceid
           (Uri.of_string socket_url)
       in
       ( match config with
-      | Some config -> Slirp_stack.create ~host_names config
+      | Some config -> Slirp_stack.create ~host_names clock config
       | None -> Lwt.return hardcoded_configuration
       ) >>= fun stack_config ->
       hvsock_connect_forever socket_url sockaddr (fun fd ->
@@ -347,11 +352,11 @@ module Main(Host: Sig.HOST) = struct
     | _ ->
       let module Slirp_stack =
         Slirp.Make(Config)(Vmnet.Make(Host.Sockets.Stream.Unix))(Dns_policy)
-          (Host)(Vnet)
+          (Mclock)(Stdlibrandom)(Host)(Vnet)
       in
       unix_listen socket_url >>= fun server ->
       ( match config with
-      | Some config -> Slirp_stack.create ~host_names config
+      | Some config -> Slirp_stack.create ~host_names clock config
       | None -> Lwt.return hardcoded_configuration
       ) >>= fun stack_config ->
       Host.Sockets.Stream.Unix.listen server (fun conn ->

src/hostnet/arp.ml

@@ -23,6 +23,7 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *
  *)
+open Lwt.Infix
 
 let src =
   let src = Logs.Src.create "arp" ~doc:"fixed ARP table" in
@@ -31,7 +32,7 @@ let src =
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make(Ethif: V1_LWT.ETHIF) = struct
+module Make (Ethif: Mirage_protocols_lwt.ETHIF) = struct
 
   module Table = Map.Make(Ipaddr.V4)
 
@@ -40,10 +41,9 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
   type buffer = Cstruct.t
   type macaddr = Macaddr.t
   type t = { ethif: Ethif.t; mutable table: macaddr Table.t }
-  type error = unit
-  type id = unit
+  type error = Mirage_protocols.Arp.error
+  let pp_error = Mirage_protocols.Arp.pp_error
   type repr = string
-  type result = [ `Ok of macaddr | `Timeout ]
 
   let to_repr t =
     let pp_one (ip, mac) =
@@ -74,11 +74,11 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
 
   let query t ip =
     if Table.mem ip t.table
-    then Lwt.return (`Ok (Table.find ip t.table))
+    then Lwt.return (Ok (Table.find ip t.table))
     else begin
       Log.warn (fun f ->
           f "ARP table has no entry for %s" (Ipaddr.V4.to_string ip));
-      Lwt.return `Timeout
+      Lwt.return (Error `Timeout)
     end
 
   type arp = {
@@ -89,32 +89,8 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
     tpa: Ipaddr.V4.t;
   }
 
-  let rec input t frame =
-    let open Arpv4_wire in
-    match get_arp_op frame with
-    |1 -> (* Request *)
-      let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
-      if Table.mem req_ipv4 t.table then begin
-        Log.debug (fun f ->
-            f "ARP responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
-        let sha = Table.find req_ipv4 t.table in
-        let tha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
-        (* the requested address *)
-        let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
-        (* the requesting host IPv4 *)
-        let tpa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
-        output t { op=`Reply; sha; tha; spa; tpa }
-      end else Lwt.return_unit
-    |2 -> (* Reply *)
-       (* the requested address *)
-      let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
-      Log.debug (fun f -> f "ARP ignoring reply %s" (Ipaddr.V4.to_string spa));
-      Lwt.return_unit
-    |n ->
-      Log.debug (fun f -> f "ARP: Unknown message %d ignored" n);
-      Lwt.return_unit
 
-  and output t arp =
+  let output t arp =
     let open Arpv4_wire in
     (* Obtain a buffer to write into *)
     let buf = Io_page.to_cstruct (Io_page.get 1) in
@@ -129,9 +105,9 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
       |`Reply -> 2
       |`Unknown n -> n
     in
-    Wire_structs.set_ethernet_dst dmac 0 buf;
-    Wire_structs.set_ethernet_src smac 0 buf;
-    Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *)
+    Ethif_wire.set_ethernet_dst dmac 0 buf;
+    Ethif_wire.set_ethernet_src smac 0 buf;
+    Ethif_wire.set_ethernet_ethertype buf 0x0806; (* ARP *)
     let arpbuf = Cstruct.shift buf 14 in
     set_arp_htype arpbuf 1;
     set_arp_ptype arpbuf 0x0800; (* IPv4 *)
@@ -143,9 +119,38 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
     set_arp_tha dmac 0 arpbuf;
     set_arp_tpa arpbuf tpa;
     (* Resize buffer to sizeof arp packet *)
-    let buf = Cstruct.sub buf 0 (sizeof_arp + Wire_structs.sizeof_ethernet) in
+    let buf = Cstruct.sub buf 0 (sizeof_arp + Ethif_wire.sizeof_ethernet) in
     Ethif.write t.ethif buf
 
+  let input t frame =
+    let open Arpv4_wire in
+    match get_arp_op frame with
+    |1 -> (* Request *)
+      let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
+      if Table.mem req_ipv4 t.table then begin
+        Log.debug (fun f ->
+            f "ARP responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
+        let sha = Table.find req_ipv4 t.table in
+        let tha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
+        (* the requested address *)
+        let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
+        (* the requesting host IPv4 *)
+        let tpa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
+        output t { op=`Reply; sha; tha; spa; tpa } >|= function
+        | Ok ()   -> ()
+        | Error e ->
+          Log.err (fun f ->
+              f "error while reading ARP packet: %a" Ethif.pp_error e);
+      end else Lwt.return_unit
+    |2 -> (* Reply *)
+       (* the requested address *)
+      let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
+      Log.debug (fun f -> f "ARP ignoring reply %s" (Ipaddr.V4.to_string spa));
+      Lwt.return_unit
+    |n ->
+      Log.debug (fun f -> f "ARP: Unknown message %d ignored" n);
+      Lwt.return_unit
+
   type ethif = Ethif.t
 
   let connect ~table ethif =
@@ -154,7 +159,7 @@ module Make(Ethif: V1_LWT.ETHIF) = struct
         Table.add ip mac acc
       ) Table.empty table
     in
-    Lwt.return (`Ok { table; ethif })
+    { table; ethif }
 
   let disconnect _t = Lwt.return_unit
 end

src/hostnet/arp.mli

@@ -2,13 +2,12 @@
     rely on the dynamic version which can fail with `No_route_to_host` if
     the other side doesn't respond *)
 
-module Make(Ethif: V1_LWT.ETHIF): sig
-  include V1_LWT.ARP
+module Make(Ethif: Mirage_protocols_lwt.ETHIF): sig
+  include Mirage_protocols_lwt.ARP
 
   type ethif = Ethif.t
 
   val connect:
-    table:(ipaddr * macaddr) list -> ethif
-    -> [ `Ok of t | `Error of error ] Lwt.t
+    table:(ipaddr * macaddr) list -> ethif -> t
     (** Construct a static ARP table *)
 end