Update Mirage with the effect/value distinction in 'connect'

lib/mirage.ml

@@ -911,7 +911,7 @@ module Project = struct
       method! build = build
       method! configure = configure
       method! clean = clean
-      method! connect _ _mod _names = "Lwt.return_unit"
+      method! connect _ _mod _names = `Val "()"
       method! deps = List.map abstract jobs
     end
 

lib/mirage_impl_argv.ml

@@ -8,7 +8,7 @@ let argv_unix = impl @@ object
     method module_name = "Bootvar"
     method! packages =
       Key.pure [ package ~min:"0.1.0" ~max:"0.2.0" "mirage-bootvar-unix" ]
-    method! connect _ _ _ = "Bootvar.argv ()"
+    method! connect _ _ _ = `Eff "Bootvar.argv ()"
   end
 
 let argv_solo5 = impl @@ object
@@ -18,15 +18,15 @@ let argv_solo5 = impl @@ object
     method module_name = "Bootvar"
     method! packages =
       Key.pure [ package ~min:"0.3.0" ~max:"0.4.0" "mirage-bootvar-solo5" ]
-    method! connect _ _ _ = "Bootvar.argv ()"
+    method! connect _ _ _ = `Eff "Bootvar.argv ()"
   end
 
 let no_argv = impl @@ object
     inherit base_configurable
     method ty = Functoria_app.argv
     method name = "argv_empty"
     method module_name = "Mirage_runtime"
-    method! connect _ _ _ = "Lwt.return [|\"\"|]"
+    method! connect _ _ _ = `Val "()"
   end
 
 let argv_xen = impl @@ object
@@ -36,12 +36,14 @@ let argv_xen = impl @@ object
     method module_name = "Bootvar"
     method! packages =
       Key.pure [ package ~min:"0.5.0" ~max:"0.6.0" "mirage-bootvar-xen" ]
-    method! connect _ _ _ = Fmt.strf
-      (* Some hypervisor configurations try to pass some extra arguments.
-       * They means well, but we can't do much with them,
-       * and they cause Functoria to abort. *)
-      "let filter (key, _) = List.mem key (List.map snd Key_gen.runtime_keys) in@ \
-       Bootvar.argv ~filter ()"
+    method! connect _ _ _ =
+      `Eff
+        (Fmt.strf
+           (* Some hypervisor configurations try to pass some extra arguments.
+            * They means well, but we can't do much with them,
+            * and they cause Functoria to abort. *)
+           "let filter (key, _) = List.mem key (List.map snd Key_gen.runtime_keys) in@ \
+            Bootvar.argv ~filter ()")
   end
 
 let default_argv =

lib/mirage_impl_arpv4.ml

@@ -15,7 +15,7 @@ let arp_conf = object
   method! packages =
     Key.pure [ package ~min:"1.0.0" ~max:"2.0.0" "arp-mirage" ]
   method! connect _ modname = function
-    | [ eth ; _time ] -> Fmt.strf "%s.connect %s" modname eth
+    | [ eth ; _time ] -> `Eff (Fmt.strf "%s.connect %s" modname eth)
     | _ -> failwith (connect_err "arp" 3)
 end
 

lib/mirage_impl_block.ml

@@ -45,7 +45,7 @@ class xenstore_conf id =
       | _ -> R.error_msg "XenStore IDs are only valid ways of specifying block \
                           devices when the target is Xen or Qubes."
     method! connect _ s _ =
-      Fmt.strf "%s.connect %S" s id
+      `Eff (Fmt.strf "%s.connect %S" s id)
   end
 
 let block_of_xenstore_id id = impl (new xenstore_conf id)
@@ -89,8 +89,9 @@ class block_conf file =
       match get_target i with
       | `Muen -> failwith "Block devices not supported on Muen target."
       | `Unix | `MacOSX | `Virtio | `Hvt | `Xen | `Qubes | `Genode ->
-        Fmt.strf "%s.connect %S" s
-          (self#connect_name (get_target i) @@ Info.build_dir i)
+         `Eff
+           (Fmt.strf "%s.connect %S" s
+              (self#connect_name (get_target i) @@ Info.build_dir i))
   end
 
 let block_of_file file = impl (new block_conf file)
@@ -105,7 +106,7 @@ class ramdisk_conf rname =
       Key.pure [ package "mirage-block-ramdisk" ]
 
     method! connect _i modname _names =
-      Fmt.strf "%s.connect ~name:%S" modname rname
+      `Eff (Fmt.strf "%s.connect ~name:%S" modname rname)
   end
 
 
@@ -136,7 +137,7 @@ let archive_conf = impl @@ object
     method! packages =
       Key.pure [ package ~min:"0.9.0" ~max:"0.10.0" "tar-mirage" ]
     method! connect _ modname = function
-      | [ block ] -> Fmt.strf "%s.connect %s" modname block
+      | [ block ] -> `Eff (Fmt.strf "%s.connect %s" modname block)
       | _ -> failwith (connect_err "archive" 1)
   end
 

lib/mirage_impl_conduit.ml

@@ -18,11 +18,12 @@ let conduit_with_connectors connectors = impl @@ object
       | _nocrypto :: 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
+        `Eff
+          (Fmt.strf
+             "Lwt.return Conduit_mirage.empty >>=@ \
+              %a\
+              fun t -> Lwt.return t"
+             pp_connectors connectors)
       | [] -> failwith "The conduit with connectors expects at least one argument"
   end
 

lib/mirage_impl_conduit_connector.ml

@@ -15,7 +15,7 @@ let tcp_conduit_connector = impl @@ object
     method module_name = "Conduit_mirage.With_tcp"
     method! packages = Mirage_key.pure [ pkg ]
     method! connect _ modname = function
-      | [ stack ] -> Fmt.strf "Lwt.return (%s.connect %s)@;" modname stack
+      | [ stack ] -> `Eff (Fmt.strf "Lwt.return (%s.connect %s)@;" modname stack)
       | _ -> failwith (connect_err "tcp conduit" 1)
   end
 
@@ -30,5 +30,5 @@ let tls_conduit_connector = impl @@ object
         pkg
       ]
     method! deps = [ abstract nocrypto ]
-    method! connect _ _ _ = "Lwt.return Conduit_mirage.with_tls"
+    method! connect _ _ _ = `Val "Conduit_mirage.with_tls"
   end

lib/mirage_impl_console.ml

@@ -13,7 +13,7 @@ let console_unix str = impl @@ object
     method module_name = "Console_unix"
     method! packages =
       Key.pure [ package ~min:"2.2.0" ~max:"3.0.0" "mirage-console-unix" ]
-    method! connect _ modname _args = Fmt.strf "%s.connect %S" modname str
+    method! connect _ modname _args = `Eff (Fmt.strf "%s.connect %S" modname str)
   end
 
 let console_xen str = impl @@ object
@@ -24,7 +24,7 @@ let console_xen str = impl @@ object
     method module_name = "Console_xen"
     method! packages =
       Key.pure [ package ~min:"2.2.0" ~max:"3.0.0" "mirage-console-xen" ]
-    method! connect _ modname _args = Fmt.strf "%s.connect %S" modname str
+    method! connect _ modname _args = `Eff (Fmt.strf "%s.connect %S" modname str)
   end
 
 let console_solo5 str = impl @@ object
@@ -35,7 +35,7 @@ let console_solo5 str = impl @@ object
     method module_name = "Console_solo5"
     method! packages =
       Key.pure [ package ~min:"0.3.0" ~max:"0.4.0" "mirage-console-solo5" ]
-    method! connect _ modname _args = Fmt.strf "%s.connect %S" modname str
+    method! connect _ modname _args = `Eff (Fmt.strf "%s.connect %S" modname str)
   end
 
 let custom_console str =

lib/mirage_impl_ethernet.ml

@@ -14,7 +14,7 @@ let ethernet_conf = object
   method! packages =
     Key.pure [ package ~min:"1.0.0" ~max:"2.0.0" "ethernet" ]
   method! connect _ modname = function
-    | [ eth ] -> Fmt.strf "%s.connect %s" modname eth
+    | [ eth ] -> `Eff (Fmt.strf "%s.connect %s" modname eth)
     | _ -> failwith (connect_err "ethernet" 1)
 end
 

lib/mirage_impl_fs.ml

@@ -22,7 +22,7 @@ let fat_conf = impl @@ object
     method! connect _ modname l =
       match l with
       | [block_name] ->
-        Fmt.strf "%s.connect %s" modname block_name
+         `Eff (Fmt.strf "%s.connect %s" modname block_name)
       | _ ->
         failwith (connect_err "fat" 1)
   end
@@ -94,7 +94,7 @@ let kv_ro_of_fs_conf =
     method! packages =
       Key.pure [package ~min:"1.0.0" ~max:"2.0.0" "mirage-fs-lwt"]
     method! connect _ modname = function
-      | [fs] -> Fmt.strf "%s.connect %s" modname fs
+      | [fs] -> `Eff (Fmt.strf "%s.connect %s" modname fs)
       | _ -> failwith (connect_err "kv_ro_of_fs" 1)
   end
 

lib/mirage_impl_gui.ml

@@ -18,10 +18,11 @@ let gui_qubes = impl @@ object
     | `Qubes -> R.ok ()
     | _ -> R.error_msg "Qubes GUI invoked for non-Qubes target."
   method! connect _ modname _args =
-    Fmt.strf
-      "@[<v 2>\
-       %s.connect ~domid:0 () >>= fun gui ->@ \
-       Lwt.async (fun () -> %s.listen gui);@ \
-       Lwt.return (`Ok gui)@]"
-      modname modname
+    `Eff
+      (Fmt.strf
+         "@[<v 2>\
+          %s.connect ~domid:0 () >>= fun gui ->@ \
+          Lwt.async (fun () -> %s.listen gui);@ \
+          Lwt.return (`Ok gui)@]"
+         modname modname)
 end

lib/mirage_impl_http.ml

@@ -13,7 +13,7 @@ let cohttp_server conduit = impl @@ object
       Mirage_key.pure [ package ~min:"2.0.0" ~max:"3.0.0" "cohttp-mirage" ]
     method! deps = [ abstract conduit ]
     method! connect _i modname = function
-      | [ conduit ] -> Fmt.strf "%s.connect %s" modname conduit
+      | [ conduit ] -> `Eff (Fmt.strf "%s.connect %s" modname conduit)
       | _ -> failwith (connect_err "http" 1)
   end
 
@@ -26,6 +26,6 @@ let httpaf_server conduit = impl @@ object
       Mirage_key.pure [ package "httpaf-mirage" ]
     method! deps = [ abstract conduit ]
     method! connect _i modname = function
-      | [ conduit ] -> Fmt.strf "%s.connect %s" modname conduit
+      | [ conduit ] -> `Eff (Fmt.strf "%s.connect %s" modname conduit)
       | _ -> failwith (connect_err "httpaf" 1)
   end

lib/mirage_impl_icmp.ml

@@ -15,7 +15,7 @@ let icmpv4_direct_conf () = object
   method module_name = "Icmpv4.Make"
   method! packages = right_tcpip_library ~sublibs:["icmpv4"] "tcpip"
   method! connect _ modname = function
-    | [ ip ] -> Fmt.strf "%s.connect %s" modname ip
+    | [ ip ] -> `Eff (Fmt.strf "%s.connect %s" modname ip)
     | _  -> failwith (connect_err "icmpv4" 1)
 end
 

lib/mirage_impl_ip.ml

@@ -51,13 +51,14 @@ let ipv4_keyed_conf ?network ?gateway () = impl @@ object
     method! keys = network @?? gateway @?? []
     method! connect _ modname = function
     | [ _random ; mclock ; etif ; arp ] ->
-      Fmt.strf
-        "let (network, ip) = %a in @ \
-         %s.connect@[@ ~ip ~network %a@ %s@ %s@ %s@]"
-        (Fmt.option pp_key) network
-        modname
-        (opt_key "gateway") gateway
-        mclock etif arp
+       `Eff
+          (Fmt.strf
+             "let (network, ip) = %a in @ \
+              %s.connect@[@ ~ip ~network %a@ %s@ %s@ %s@]"
+             (Fmt.option pp_key) network
+             modname
+             (opt_key "gateway") gateway
+             mclock etif arp)
       | _ -> failwith (connect_err "ipv4 keyed" 4)
   end
 
@@ -71,7 +72,7 @@ let dhcp_conf = impl @@ object
     method module_name = "Dhcp_client_mirage.Make"
     method! packages = charrua_pkg
     method! connect _ modname = function
-      | [ _random; _time; network ] -> Fmt.strf "%s.connect %s " modname network
+      | [ _random; _time; network ] -> `Eff (Fmt.strf "%s.connect %s " modname network)
       | _ -> failwith (connect_err "dhcp" 3)
   end
 
@@ -83,8 +84,8 @@ let ipv4_dhcp_conf = impl @@ object
     method! packages = charrua_pkg
     method! connect _ modname = function
       | [ dhcp ; _random ; mclock ; ethernet ; arp ] ->
-        Fmt.strf "%s.connect@[@ %s@ %s@ %s@ %s@]"
-          modname dhcp mclock ethernet arp
+         `Eff (Fmt.strf "%s.connect@[@ %s@ %s@ %s@ %s@]"
+                 modname dhcp mclock ethernet arp)
       | _ -> failwith (connect_err "ipv4 dhcp" 5)
   end
 
@@ -126,7 +127,7 @@ let ipv4_qubes_conf = impl @@ object
       Key.pure [ package ~min:"0.6" ~max:"0.7" "mirage-qubes-ipv4" ]
     method! connect _ modname = function
       | [  db ; _random ; mclock ;etif; arp ] ->
-        Fmt.strf "%s.connect@[@ %s@ %s@ %s@ %s@]" modname db mclock etif arp
+         `Eff (Fmt.strf "%s.connect@[@ %s@ %s@ %s@ %s@]" modname db mclock etif arp)
       | _ -> failwith (connect_err "qubes ipv4" 5)
   end
 
@@ -144,12 +145,13 @@ let ipv6_conf ?addresses ?netmasks ?gateways () = impl @@ object
     method! keys = addresses @?? netmasks @?? gateways @?? []
     method! connect _ modname = function
       | [ etif ; _random ; _time ; clock ] ->
-        Fmt.strf "%s.connect@[@ %a@ %a@ %a@ %s@ %s@]"
-          modname
-          (opt_key "ip") addresses
-          (opt_key "netmask") netmasks
-          (opt_key "gateways") gateways
-          etif clock
+         `Eff
+           (Fmt.strf "%s.connect@[@ %a@ %a@ %a@ %s@ %s@]"
+              modname
+              (opt_key "ip") addresses
+              (opt_key "netmask") netmasks
+              (opt_key "gateways") gateways
+              etif clock)
       | _ -> failwith (connect_err "ipv6" 3)
   end
 

lib/mirage_impl_kv_ro.ml

@@ -18,7 +18,7 @@ let crunch dirname = impl @@ object
         package ~min:"2.0.0" ~max:"3.0.0" "io-page";
         package ~min:"2.0.0" ~max:"3.0.0" ~build:true "crunch"
       ]
-    method! connect _ modname _ = Fmt.strf "%s.connect ()" modname
+    method! connect _ modname _ = `Eff (Fmt.strf "%s.connect ()" modname)
     method! build _i =
       let dir = Fpath.(v dirname) in
       let file = Fpath.(v name + "ml") in
@@ -43,7 +43,7 @@ let direct_kv_ro_conf dirname = impl @@ object
       Key.pure [ package ~min:"1.5.0" ~max:"2.0.0" "mirage-fs-unix" ]
     method! connect i _modname _names =
       let path = Fpath.(Info.build_dir i / dirname) in
-      Fmt.strf "Kvro_fs_unix.connect \"%a\"" Fpath.pp path
+      `Eff (Fmt.strf "Kvro_fs_unix.connect \"%a\"" Fpath.pp path)
   end
 
 let direct_kv_ro dirname =

lib/mirage_impl_mclock.ml

@@ -12,7 +12,7 @@ let monotonic_clock_conf = object
     Mirage_key.(if_ is_unix)
       [ package ~min:"1.2.0" ~max:"3.0.0" "mirage-clock-unix" ]
       [ package ~min:"1.2.0" ~max:"3.0.0" "mirage-clock-freestanding" ]
-  method! connect _ modname _args = Fmt.strf "%s.connect ()" modname
+  method! connect _ modname _args = `Eff (Fmt.strf "%s.connect ()" modname)
 end
 
 let default_monotonic_clock = impl monotonic_clock_conf

lib/mirage_impl_network.ml

@@ -26,7 +26,7 @@ let network_conf (intf : string Key.key) =
       | `Virtio | `Hvt | `Muen | `Genode ->
         [ package ~min:"0.4.0" ~max:"0.5.0" "mirage-net-solo5" ]
     method! connect _ modname _ =
-      Fmt.strf "%s.connect %a" modname Key.serialize_call key
+      `Eff (Fmt.strf "%s.connect %a" modname Key.serialize_call key)
     method! configure i =
       all_networks := Key.get (Info.context i) intf :: !all_networks;
       Rresult.R.ok ()

lib/mirage_impl_pclock.ml

@@ -12,7 +12,7 @@ let posix_clock_conf = object
     Mirage_key.(if_ is_unix)
       [ package ~min:"1.2.0" ~max:"3.0.0" "mirage-clock-unix" ]
       [ package ~min:"1.2.0" ~max:"3.0.0" "mirage-clock-freestanding" ]
-  method! connect _ modname _args = Fmt.strf "%s.connect ()" modname
+  method! connect _ modname _args = `Eff (Fmt.strf "%s.connect ()" modname)
 end
 
 let default_posix_clock = impl posix_clock_conf

lib/mirage_impl_qrexec.ml

@@ -17,12 +17,13 @@ let qrexec_qubes = impl @@ object
     | `Qubes -> R.ok ()
     | _ -> R.error_msg "Qubes remote-exec invoked for non-Qubes target."
   method! connect _ modname _args =
-    Fmt.strf
-      "@[<v 2>\
-       %s.connect ~domid:0 () >>= fun qrexec ->@ \
-       Lwt.async (fun () ->@ \
-       OS.Lifecycle.await_shutdown_request () >>= fun _ ->@ \
-       %s.disconnect qrexec);@ \
-       Lwt.return (`Ok qrexec)@]"
-      modname modname
+    `Eff
+      (Fmt.strf
+         "@[<v 2>\
+          %s.connect ~domid:0 () >>= fun qrexec ->@ \
+          Lwt.async (fun () ->@ \
+          OS.Lifecycle.await_shutdown_request () >>= fun _ ->@ \
+          %s.disconnect qrexec);@ \
+          Lwt.return (`Ok qrexec)@]"
+         modname modname)
 end

lib/mirage_impl_qubesdb.ml

@@ -18,7 +18,7 @@ let qubesdb_conf = object
     match get_target i with
     | `Qubes | `Xen -> R.ok ()
     | _ -> R.error_msg "Qubes DB invoked for an unsupported target; qubes and xen are supported"
-  method! connect _ modname _args = Fmt.strf "%s.connect ~domid:0 ()" modname
+  method! connect _ modname _args = `Eff (Fmt.strf "%s.connect ~domid:0 ()" modname)
 end
 
 let default_qubesdb = impl qubesdb_conf