Mirage logs no clock

lib/devices/arp.ml

@@ -1,20 +1,20 @@
 open Functoria.DSL
 open Ethernet
-open Time
 open Misc
 
 type arpv4 = Arpv4
 
 let arpv4 = typ Arpv4
 
-let arp_conf =
+let arp_conf eth =
   let packages =
     [ package ~min:"3.0.0" ~max:"4.0.0" ~sublibs:[ "mirage" ] "arp" ]
   in
   let connect _ modname = function
-    | [ eth; _time ] -> code ~pos:__POS__ "%s.connect %s" modname eth
-    | _ -> connect_err "arp" 2
+    | [ eth ] -> code ~pos:__POS__ "%s.connect %s" modname eth
+    | _ -> connect_err "arp" 1
   in
-  impl ~packages ~connect "Arp.Make" (ethernet @-> time @-> arpv4)
+  let extra_deps = [ dep eth ] in
+  impl ~packages ~extra_deps ~connect "Arp" arpv4
 
-let arp ?(time = default_time) (eth : ethernet impl) = arp_conf $ eth $ time
+let arp (eth : ethernet impl) = arp_conf eth

lib/devices/arp.mli

@@ -3,4 +3,4 @@ open Functoria
 type arpv4
 
 val arpv4 : arpv4 typ
-val arp : ?time:Time.time impl -> Ethernet.ethernet impl -> arpv4 impl
+val arp : Ethernet.ethernet impl -> arpv4 impl

lib/devices/ethernet.ml

@@ -1,17 +1,17 @@
 open Functoria.DSL
 open Misc
-open Network
 
 type ethernet = ETHERNET
 
 let ethernet = typ ETHERNET
 
-let etif_conf =
+let etif_conf network =
   let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "ethernet" ] in
   let connect _ m = function
     | [ eth ] -> code ~pos:__POS__ "%s.connect %s" m eth
     | _ -> connect_err "etif" 1
   in
-  impl ~packages ~connect "Ethernet.Make" (network @-> ethernet)
+  let extra_deps = [ dep network ] in
+  impl ~packages ~extra_deps ~connect "Ethernet" ethernet
 
-let etif network = etif_conf $ network
+let etif network = etif_conf network

lib/devices/icmp.ml

@@ -8,12 +8,15 @@ type icmpv4 = v4 icmp
 let icmp = typ ICMP
 let icmpv4 : icmpv4 typ = icmp
 
-let icmpv4_direct () =
-  let packages_v = right_tcpip_library ~sublibs:[ "icmpv4" ] "tcpip" in
+let icmpv4_impl ip =
+  let packages_v =
+    Key.(if_ is_unix)
+      (right_tcpip_library ~sublibs:[ "icmpv4" ; "icmpv4-unix" ] "tcpip")
+      (right_tcpip_library ~sublibs:[ "icmpv4" ; "icmpv4-direct" ] "tcpip")
+  in
   let connect _ modname = function
     | [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
     | _ -> connect_err "icmpv4" 1
   in
-  impl ~packages_v ~connect "Icmpv4.Make" (ip @-> icmp)
-
-let direct_icmpv4 ip = icmpv4_direct () $ ip
+  let extra_deps = [ dep ip ] in
+  impl ~extra_deps ~packages_v ~connect "Icmpv4" icmp

lib/devices/icmp.mli

@@ -3,4 +3,4 @@ open Functoria
 type icmpv4
 
 val icmpv4 : icmpv4 typ
-val direct_icmpv4 : Ip.ipv4 impl -> icmpv4 impl
+val icmpv4_impl : Ip.ipv4 impl -> icmpv4 impl

lib/devices/ip.ml

@@ -30,26 +30,48 @@ type ipv4_config = {
 (* convenience function for linking tcpip.unix for checksums *)
 let right_tcpip_library ?libs ~sublibs pkg =
   let min = "7.0.0" and max = "9.0.0" in
-  Key.pure [ package ~min ~max ?libs ~sublibs pkg ]
+  [ package ~min ~max ?libs ~sublibs pkg ]
 
-let ipv4_keyed_conf ~ip ?gateway ?no_init () =
-  let packages_v = right_tcpip_library ~sublibs:[ "ipv4" ] "tcpip" in
+let ipv4_keyed_conf ~ip ?gateway ?no_init random mclock ?ethif ?arp () =
+  let packages_v =
+    Key.pure (right_tcpip_library ~sublibs:[ "ipv4" ; "ipv4-direct" ] "tcpip")
+  in
   let runtime_args = runtime_args_opt [ no_init; gateway; Some ip ] in
   let err () = connect_err "ipv4 keyed" 5 ~max:7 in
+  let ethernet = match ethif with None -> assert false | Some x -> x in
+  let arp = match arp with None -> assert false | Some x -> x in
   let connect _ modname = function
     | _random :: _mclock :: etif :: arp :: rest ->
         let no_init, rest = pop ~err no_init rest in
         let gateway, rest = pop ~err gateway rest in
         let ip, rest = pop ~err (Some ip) rest in
         let () = match rest with [] -> () | _ -> err () in
-        code ~pos:__POS__ "%s.connect@[%a%a%a@ %s@ %s@]" modname
+        code ~pos:__POS__ "%s.connect@[%a%a%a@ ~ethernet:%s@ ~arp:%s ()@]" modname
           (pp_label "no_init") no_init (pp_label "cidr") ip (pp_opt "gateway")
           gateway etif arp
     | _ -> err ()
   in
-  impl ~packages_v ~runtime_args ~connect "Static_ipv4.Make"
-    (random @-> mclock @-> ethernet @-> arpv4 @-> ipv4)
+  let extra_deps = [ dep random ; dep mclock ; dep ethernet ; dep arp ] in
+  impl ~extra_deps ~packages_v ~runtime_args ~connect "Ipv4" ipv4
 
+let ipv4_unix ~ip ?gateway ?no_init () =
+  let packages_v =
+    Key.pure (right_tcpip_library ~sublibs:[ "ipv4" ; "ipv4-unix" ] "tcpip")
+  in
+  let runtime_args = runtime_args_opt [ no_init; gateway; Some ip ] in
+  let err () = connect_err "ipv4 unix" 1 ~max:3 in
+  let connect _ modname rest =
+    let no_init, rest = pop ~err no_init rest in
+    let gateway, rest = pop ~err gateway rest in
+    let ip, rest = pop ~err (Some ip) rest in
+    let () = match rest with [] -> () | _ -> err () in
+    code ~pos:__POS__ "%s.connect@[%a%a%a@ ()@]" modname
+      (pp_label "no_init") no_init (pp_label "cidr") ip (pp_opt "gateway")
+      gateway
+  in
+  impl ~packages_v ~runtime_args ~connect "Ipv4" ipv4
+
+(* XXX *)
 let ipv4_dhcp_conf =
   let packages =
     [ package ~min:"1.3.0" ~max:"2.0.0" ~sublibs:[ "mirage" ] "charrua-client" ]
@@ -68,15 +90,22 @@ let ipv4_of_dhcp ?(random = default_random) ?(clock = default_monotonic_clock)
   ipv4_dhcp_conf $ random $ clock $ time $ net $ ethif $ arp
 
 let create_ipv4 ?group ?config ?no_init ?(random = default_random)
-    ?(clock = default_monotonic_clock) etif arp =
+    ?(clock = default_monotonic_clock) ?ethif ?arp () =
   let network, gateway =
     match config with
     | None -> (Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24", None)
     | Some { network; gateway } -> (network, gateway)
   in
   let ip = Runtime_arg.V4.network ?group network
   and gateway = Runtime_arg.V4.gateway ?group gateway in
-  ipv4_keyed_conf ~ip ~gateway ?no_init () $ random $ clock $ etif $ arp
+  let choose target =
+    match target with
+    | (`Unix | `MacOSX) -> `Unix
+    | _ -> `Direct
+  in
+  let p = Key.(pure choose $ Key.(value target)) in
+  match_impl p [ (`Unix, ipv4_unix ~ip ~gateway ?no_init ()) ]
+    ~default:(ipv4_keyed_conf ~ip ~gateway ?no_init random clock ?ethif ?arp ())
 
 type ipv6_config = {
   network : Ipaddr.V6.Prefix.t;
@@ -98,9 +127,13 @@ let ipv4_qubes ?(random = default_random) ?(clock = default_monotonic_clock) db
     ethernet arp =
   ipv4_qubes_conf $ db $ random $ clock $ ethernet $ arp
 
-let ipv6_conf ?ip ?gateway ?handle_ra ?no_init () =
-  let packages_v = right_tcpip_library ~sublibs:[ "ipv6" ] "tcpip" in
+let ipv6_conf ?ip ?gateway ?handle_ra ?no_init ?netif ?ethif random time mclock =
+  let packages_v =
+    Key.pure (right_tcpip_library ~sublibs:[ "ipv6" ; "ipv6-direct" ] "tcpip")
+  in
   let runtime_args = runtime_args_opt [ ip; gateway; handle_ra; no_init ] in
+  let network = match netif with None -> assert false | Some x -> x in
+  let ethernet = match ethif with None -> assert false | Some x -> x in
   let err () = connect_err "ipv6" 5 ~max:9 in
   let connect _ modname = function
     | netif :: etif :: _random :: _time :: _clock :: rest ->
@@ -109,16 +142,34 @@ let ipv6_conf ?ip ?gateway ?handle_ra ?no_init () =
         let handle_ra, rest = pop ~err handle_ra rest in
         let no_init, rest = pop ~err no_init rest in
         let () = match rest with [] -> () | _ -> err () in
-        code ~pos:__POS__ "%s.connect@[%a%a%a%a@ %s@ %s@]" modname
+        code ~pos:__POS__ "%s.connect@[%a%a%a%a@ ~net:%s@ ~ethernet:%s ()@]" modname
           (pp_label "no_init") no_init (pp_label "handle_ra") handle_ra
           (pp_opt "cidr") ip (pp_opt "gateway") gateway netif etif
     | _ -> err ()
   in
-  impl ~packages_v ~runtime_args ~connect "Ipv6.Make"
-    (network @-> ethernet @-> random @-> time @-> mclock @-> ipv6)
+  let extra_deps = [ dep network ; dep ethernet ; dep random ; dep time ; dep mclock ] in
+  impl ~extra_deps ~packages_v ~runtime_args ~connect "Ipv6" ipv6
+
+let ipv6_unix ?ip ?gateway ?handle_ra ?no_init () =
+  let packages_v =
+    Key.pure (right_tcpip_library ~sublibs:[ "ipv6" ; "ipv6-unix" ] "tcpip")
+  in
+  let runtime_args = runtime_args_opt [ ip; gateway; handle_ra; no_init ] in
+  let err () = connect_err "ipv6" 5 ~max:9 in
+  let connect _ modname rest =
+    let ip, rest = pop ~err ip rest in
+    let gateway, rest = pop ~err gateway rest in
+    let handle_ra, rest = pop ~err handle_ra rest in
+    let no_init, rest = pop ~err no_init rest in
+    let () = match rest with [] -> () | _ -> err () in
+    code ~pos:__POS__ "%s.connect@[%a%a%a%a@ ()@]" modname
+      (pp_label "no_init") no_init (pp_label "handle_ra") handle_ra
+      (pp_opt "cidr") ip (pp_opt "gateway") gateway
+  in
+  impl ~packages_v ~runtime_args ~connect "Ipv6" ipv6
 
 let create_ipv6 ?(random = default_random) ?(time = default_time)
-    ?(clock = default_monotonic_clock) ?group ?config ?no_init netif etif =
+    ?(clock = default_monotonic_clock) ?group ?config ?no_init ?netif ?ethif () =
   let network, gateway =
     match config with
     | None -> (None, None)
@@ -127,15 +178,21 @@ let create_ipv6 ?(random = default_random) ?(time = default_time)
   let ip = Runtime_arg.V6.network ?group network
   and gateway = Runtime_arg.V6.gateway ?group gateway
   and handle_ra = Runtime_arg.V6.accept_router_advertisements ?group () in
-  ipv6_conf ~ip ~gateway ~handle_ra ?no_init ()
-  $ netif
-  $ etif
-  $ random
-  $ time
-  $ clock
-
-let ipv4v6_conf ?ipv4_only ?ipv6_only () =
-  let packages_v = right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
+    let choose target =
+    match target with
+    | (`Unix | `MacOSX) -> `Unix
+    | _ -> `Direct
+  in
+  let p = Key.(pure choose $ Key.(value target)) in
+  match_impl p [ (`Unix, ipv6_unix ~ip ~gateway ~handle_ra ?no_init ()) ]
+    ~default:(ipv6_conf ~ip ~gateway ~handle_ra ?no_init ?netif ?ethif random time clock)
+
+let ipv4v6_conf ?ipv4_only ?ipv6_only ipv4 ipv6 =
+  let packages_v =
+    Key.(if_ is_unix)
+      (right_tcpip_library ~sublibs:[ "ipv4v6" ; "ipv4v6-unix" ] "tcpip")
+      (right_tcpip_library ~sublibs:[ "ipv4v6" ; "ipv4v6-direct" ] "tcpip")
+  in
   let runtime_args = runtime_args_opt [ ipv4_only; ipv6_only ] in
   let err () = connect_err "ipv4v6" 2 ~max:4 in
   let connect _ modname = function
@@ -148,11 +205,11 @@ let ipv4v6_conf ?ipv4_only ?ipv6_only () =
           ipv6
     | _ -> err ()
   in
-  impl ~packages_v ~runtime_args ~connect "Tcpip_stack_direct.IPV4V6"
-    (ipv4 @-> ipv6 @-> ipv4v6)
+  let extra_deps = [ dep ipv4 ; dep ipv6 ] in
+  impl ~extra_deps ~packages_v ~runtime_args ~connect "Ipv4v6" ipv4v6
 
 let keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 =
-  ipv4v6_conf ~ipv4_only ~ipv6_only () $ ipv4 $ ipv6
+  ipv4v6_conf ~ipv4_only ~ipv6_only ipv4 ipv6
 
 let create_ipv4v6 ?group ipv4 ipv6 =
   let ipv4_only = Runtime_arg.ipv4_only ?group ()

lib/devices/ip.mli

@@ -35,8 +35,9 @@ val create_ipv4 :
   ?no_init:bool runtime_arg ->
   ?random:random impl ->
   ?clock:mclock impl ->
-  ethernet impl ->
-  arpv4 impl ->
+  ?ethif:ethernet impl ->
+  ?arp:arpv4 impl ->
+  unit ->
   ipv4 impl
 
 val create_ipv6 :
@@ -46,8 +47,9 @@ val create_ipv6 :
   ?group:string ->
   ?config:ipv6_config ->
   ?no_init:bool runtime_arg ->
-  network impl ->
-  ethernet impl ->
+  ?netif:network impl ->
+  ?ethif:ethernet impl ->
+  unit ->
   ipv6 impl
 
 val ipv4_of_dhcp :
@@ -77,4 +79,4 @@ val keyed_ipv4v6 :
   ipv4v6 impl
 
 val right_tcpip_library :
-  ?libs:string list -> sublibs:string list -> string -> package list value
+  ?libs:string list -> sublibs:string list -> string -> package list

lib/devices/mclock.ml

@@ -7,7 +7,7 @@ let mclock = typ MCLOCK
 let default_monotonic_clock =
   let packages_v =
     Key.(if_ is_unix)
-      [ package ~min:"4.1.0" ~max:"5.0.0" "mirage-clock-unix" ]
-      [ package ~min:"4.2.0" ~max:"5.0.0" "mirage-clock-solo5" ]
+      [ package ~sublibs:["unix"] "mirage-clock" ]
+      [ package ~sublibs:["solo5"] "mirage-clock" ]
   in
   impl ~packages_v "Mclock" mclock

lib/devices/network.ml

@@ -12,13 +12,11 @@ let network_conf ?(intf : string runtime_arg option) name =
   let runtime_args = Option.to_list (Option.map Runtime_arg.v intf) in
   let packages_v =
     Key.match_ Key.(value target) @@ function
-    | `Unix -> [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-net-unix" ]
-    | `MacOSX -> [ package ~min:"1.8.0" ~max:"2.0.0" "mirage-net-macosx" ]
-    | `Xen -> [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen" ]
-    | `Qubes ->
-        [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen"; Qubesdb.pkg ]
-    | #Key.mode_solo5 ->
-        [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-net-solo5" ]
+    | `Unix -> [ package ~sublibs:["unix"] ~min:"4.0.0" ~max:"5.0.0" "mirage-net" ]
+    | `MacOSX -> failwith "NYI"
+    | `Xen -> failwith "NYI"
+    | `Qubes -> failwith "NYI"
+    | #Key.mode_solo5 -> [ package ~sublibs:["solo5"] ~min:"4.0.0" ~max:"5.0.0" "mirage-net" ]
   in
   let connect _ modname = function
     | [] -> code ~pos:__POS__ "%s.connect %S" modname name
@@ -29,7 +27,7 @@ let network_conf ?(intf : string runtime_arg option) name =
     add_new_network name;
     ok ()
   in
-  impl ~runtime_args ~packages_v ~connect ~configure "Netif" network
+  impl ~runtime_args ~packages_v ~connect ~configure "Mirage_net" network
 
 let netif ?group dev =
   if_impl Key.is_solo5 (network_conf dev)

lib/devices/pclock.ml

@@ -7,7 +7,7 @@ let pclock = typ PCLOCK
 let default_posix_clock =
   let packages_v =
     Key.(if_ is_unix)
-      [ package ~min:"3.0.0" ~max:"5.0.0" "mirage-clock-unix" ]
-      [ package ~min:"4.2.0" ~max:"5.0.0" "mirage-clock-solo5" ]
+      [ package ~sublibs:["unix"] "mirage-clock" ]
+      [ package ~sublibs:["solo5"] "mirage-clock" ]
   in
   impl ~packages_v "Pclock" pclock

lib/devices/random.ml

@@ -6,20 +6,18 @@ type random = RANDOM
 
 let random = typ RANDOM
 
-let rng ?(time = default_time) ?(mclock = default_monotonic_clock) () =
+let rng =
   let packages =
     [
       package ~min:"0.8.0" ~max:"0.12.0" "mirage-crypto-rng-mirage";
-      package ~min:"3.0.0" ~max:"4.0.0" "mirage-random";
     ]
   in
   let connect _ modname _ =
     (* here we could use the boot argument (--prng) to select the RNG! *)
     code ~pos:__POS__ "%s.initialize (module Mirage_crypto_rng.Fortuna)" modname
   in
-  impl ~packages ~connect "Mirage_crypto_rng_mirage.Make"
-    (Time.time @-> Mclock.mclock @-> random)
-  $ time
-  $ mclock
+  impl
+    ~extra_deps:[dep default_time ; dep default_monotonic_clock]
+    ~packages ~connect "Mirage_crypto_rng_mirage" random
 
-let default_random = rng ()
+let default_random = rng

lib/devices/random.mli

@@ -1,9 +1,7 @@
 open Functoria
-open Time
-open Mclock
 
 type random
 
 val random : random typ
-val rng : ?time:time impl -> ?mclock:mclock impl -> unit -> random impl
+val rng : random impl
 val default_random : random impl