unikernel/duniverse/mirage/lib/devices/argv.ml

@@ -0,0 +1,34 @@
+open Functoria.DSL
+
+let ty = Functoria.argv
+
+let no_argv =
+  let connect _ _ _ = code ~pos:__POS__ "return [|\"\"|]" in
+  impl ~connect "Mirage_runtime" ty
+
+let impl sublib =
+  let packages =
+    [
+      package ~min:"1.0.0" ~max:"2.0.0" ~sublibs:[ ""; sublib ] "mirage-bootvar";
+    ]
+  in
+  let connect _ _ _ = code ~pos:__POS__ "return (Mirage_bootvar.argv ())" in
+  impl ~packages ~connect "Mirage_bootvar" ty
+
+let argv_unix = impl "unix"
+let argv_solo5 = impl "solo5"
+let argv_xen = impl "xen"
+
+let default_argv =
+  match_impl
+    Key.(value target)
+    [
+      (`Xen, argv_xen);
+      (`Qubes, argv_xen);
+      (`Virtio, argv_solo5);
+      (`Hvt, argv_solo5);
+      (`Muen, argv_solo5);
+      (`Genode, argv_solo5);
+      (`Spt, argv_solo5);
+    ]
+    ~default:argv_unix

unikernel/duniverse/mirage/lib/devices/argv.mli

@@ -0,0 +1,4 @@
+open Functoria.DSL
+
+val default_argv : Functoria.argv impl
+val no_argv : Functoria.argv impl

unikernel/duniverse/mirage/lib/devices/arp.ml

@@ -0,0 +1,17 @@
+open Functoria.DSL
+
+type arpv4 = Arpv4
+
+let arpv4 = typ Arpv4
+
+let arp_conf =
+  let packages =
+    [ package ~min:"4.0.0" ~max:"5.0.0" ~sublibs:[ "mirage" ] "arp" ]
+  in
+  let connect _ modname = function
+    | [ eth ] -> code ~pos:__POS__ "%s.connect %s" modname eth
+    | _ -> Misc.connect_err "arp" 1
+  in
+  impl ~packages ~connect "Arp.Make" (Ethernet.ethernet @-> arpv4)
+
+let arp (eth : Ethernet.ethernet impl) = arp_conf $ eth

unikernel/duniverse/mirage/lib/devices/arp.mli

@@ -0,0 +1,6 @@
+open Functoria.DSL
+
+type arpv4
+
+val arpv4 : arpv4 typ
+val arp : Ethernet.ethernet impl -> arpv4 impl

unikernel/duniverse/mirage/lib/devices/block.ml

@@ -0,0 +1,345 @@
+module Dune = Functoria.Dune
+module Info = Functoria.Info
+module Install = Functoria.Install
+open Functoria.DSL
+open Functoria.Action
+
+type block = BLOCK
+
+let block = typ BLOCK
+
+type block_t = { filename : string; number : int }
+
+let all_blocks = Hashtbl.create 7
+
+let make_block_t =
+  (* NB: reserve number 0 for the boot disk *)
+  let next_number = ref 1 in
+  fun filename ->
+    let b =
+      if Hashtbl.mem all_blocks filename then Hashtbl.find all_blocks filename
+      else
+        let number = !next_number in
+        incr next_number;
+        let b = { filename; number } in
+        Hashtbl.add all_blocks filename b;
+        b
+    in
+    b
+
+let xen_block_packages =
+  [ package ~min:"2.1.0" ~max:"3.0.0" ~sublibs:[ "front" ] "mirage-block-xen" ]
+
+(* this function takes a string rather than an int as `id` to allow
+   the user to pass stuff like "/dev/xvdi1", which mirage-block-xen
+   also understands *)
+let xenstore_conf id =
+  let configure i =
+    match Misc.get_target i with
+    | `Qubes | `Xen -> ok ()
+    | _ ->
+        error
+          "XenStore IDs are only valid ways of specifying block devices when \
+           the target is Xen or Qubes."
+  in
+  let connect _ impl_name _ = code ~pos:__POS__ "%s.connect %S" impl_name id in
+  impl ~configure ~connect ~packages:xen_block_packages "Block" block
+
+let block_of_xenstore_id id = xenstore_conf id
+
+(* calculate the XenStore ID for the nth available block device.
+   Taken from https://github.com/mirage/mirage-block-xen/blob/
+   a64d152586c7ebc1d23c5adaa4ddd440b45a3a83/lib/device_number.ml#L64 . *)
+let xenstore_id_of_index number =
+  if number < 16 then (202 lsl 8) lor (number lsl 4)
+  else (1 lsl 28) lor (number lsl 8)
+
+let block_conf file =
+  let connect_name target =
+    match target with
+    | #Key.mode_unix -> file (* open the file directly *)
+    | #Key.mode_xen ->
+        let b = make_block_t file in
+        xenstore_id_of_index b.number |> string_of_int
+    | #Key.mode_solo5 ->
+        (* XXX For now, on Solo5, just pass the "file" name through directly as
+         * the Solo5 block device name *)
+        file
+    | #Key.mode_unikraft -> file
+  in
+  let packages_v =
+    Key.match_ Key.(value target) @@ function
+    | #Key.mode_xen -> xen_block_packages
+    | #Key.mode_solo5 ->
+        [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-block-solo5" ]
+    | #Key.mode_unix ->
+        [ package ~min:"2.12.0" ~max:"3.0.0" "mirage-block-unix" ]
+    | #Key.mode_unikraft ->
+        [ package ~min:"1.0.0" ~max:"2.0.0" "mirage-block-unikraft" ]
+  in
+  let configure _ =
+    let (_ : block_t) = make_block_t file in
+    ok ()
+  in
+  let connect i s _ =
+    match Misc.get_target i with
+    | `Muen -> failwith "Block devices not supported on Muen target."
+    | _ ->
+        code ~pos:__POS__ "%s.connect %S" s (connect_name (Misc.get_target i))
+  in
+  Functoria.Device.v ~configure ~packages_v ~connect "Block" block
+
+let block_of_file file = of_device (block_conf file)
+
+let ramdisk rname =
+  let packages = [ package "mirage-block-ramdisk" ] in
+  let connect _ m _ = code ~pos:__POS__ "%s.connect ~name:%S" m rname in
+  impl ~connect ~packages "Ramdisk" block
+
+let generic_block ?group ?(key = Key.(value @@ block ?group ())) name =
+  match_impl key
+    [
+      (`XenstoreId, block_of_xenstore_id name);
+      (`BlockFile, block_of_file name);
+      (`Ramdisk, ramdisk name);
+    ]
+    ~default:(ramdisk name)
+
+let tar_kv_ro_conf =
+  let packages = [ package ~min:"1.0.0" ~max:"4.0.0" "tar-mirage" ] in
+  let connect _ modname = function
+    | [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
+    | _ -> Misc.connect_err "tar_kv_ro" 1
+  in
+  impl ~packages ~connect "Tar_mirage.Make_KV_RO" (block @-> Kv.ro)
+
+let tar_kv_rw_conf =
+  let packages = [ package ~min:"2.2.0" ~max:"4.0.0" "tar-mirage" ] in
+  let connect _ modname = function
+    | [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
+    | _ -> Misc.connect_err "tar_kv_rw" 1
+  in
+  impl ~packages ~connect "Tar_mirage.Make_KV_RW" (block @-> Kv.rw)
+
+let tar_kv_ro block = tar_kv_ro_conf $ block
+let tar_kv_rw block = tar_kv_rw_conf $ block
+
+let fat_conf =
+  let packages = [ package ~min:"0.15.0" ~max:"0.16.0" "fat-filesystem" ] in
+  let connect _ modname = function
+    | [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
+    | _ -> Misc.connect_err "fat" 1
+  in
+  impl ~packages ~connect "Fat.KV_RO" (block @-> Kv.ro)
+
+let fat_ro block = fat_conf $ block
+
+type mode = [ `Fast | `Light ]
+
+let pp_mode ppf = function
+  | `Fast -> Fmt.string ppf "Fast"
+  | `Light -> Fmt.string ppf "Light"
+
+let pp_branch ppf = function
+  | None -> ()
+  | Some branch -> Fmt.pf ppf " -b %s" branch
+
+let docteur_unix (mode : mode) extra_deps ~name:_ ~output branch analyze remote
+    =
+  let dune info =
+    let ctx = Info.context info in
+    let output = Key.get ctx output in
+    let source_tree =
+      let uri = Uri.of_string remote in
+      match Uri.scheme uri with
+      | Some "file" ->
+          let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
+          Fmt.str " (source_tree /%s)" path
+      | Some "relativize" ->
+          let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
+          Fmt.str " (source_tree %s)" path
+      | _ -> ""
+    in
+    let dune =
+      Dune.stanzaf
+        {dune|
+(rule
+ (targets %s)
+ (enabled_if (= %%{context_name} "default"))
+ (deps (:make %%{bin:docteur.make})%a%s)
+ (action (run %%{make} %s%a %s)))
+|dune}
+        output
+        Fmt.(list ~sep:nop (const string " " ++ string))
+        extra_deps source_tree remote pp_branch branch output
+    in
+    [ dune ]
+  in
+  let install info =
+    let ctx = Info.context info in
+    let output = Fpath.v (Key.get ctx output) in
+    Install.v ~etc:[ output ] ()
+  in
+  let configure info =
+    let ctx = Info.context info in
+    let name = Key.get ctx output in
+    let (_ : block_t) = make_block_t name in
+    ok ()
+  in
+  let connect info modname = function
+    | [ analyze ] ->
+        let ctx = Info.context info in
+        let name = Key.get ctx output in
+        code ~pos:__POS__
+          {ocaml|let ( <.> ) f g = fun x -> f (g x) in
+             let f = Rresult.R.(failwith_error_msg <.> reword_error (msgf "%%a" %s.pp_error)) in
+             Lwt.map f (%s.connect ~analyze:%s %S)|ocaml}
+          modname modname analyze name
+    | _ -> Misc.connect_err "docteur_unix" 1
+  in
+  let keys = [ Key.v output ] in
+  let runtime_args = Runtime_arg.[ v analyze ] in
+  let packages = [ package "docteur-unix" ~min:"0.0.6" ] in
+  impl ~runtime_args ~keys ~packages ~dune ~install ~configure ~connect
+    (Fmt.str "Docteur_unix.%a" pp_mode mode)
+    Kv.ro
+
+let docteur_solo5 (mode : mode) extra_deps ~name ~output branch analyze remote =
+  let dune info =
+    let ctx = Info.context info in
+    let output = Key.get ctx output in
+    let source_tree =
+      let uri = Uri.of_string remote in
+      match Uri.scheme uri with
+      | Some "file" ->
+          let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
+          Fmt.str " (source_tree /%s)" path
+      | Some "relativize" ->
+          let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
+          Fmt.str " (source_tree %s)" path
+      | _ -> ""
+    in
+    let dune =
+      Dune.stanzaf
+        {dune|
+(rule
+ (targets %s)
+ (enabled_if (= %%{context_name} "default"))
+ (deps (:make %%{bin:docteur.make})%a%s)
+ (action (run %%{make} %s%a %s)))
+|dune}
+        output
+        Fmt.(list ~sep:nop (const string " " ++ string))
+        extra_deps source_tree remote pp_branch branch output
+    in
+    [ dune ]
+  in
+  let install info =
+    let ctx = Info.context info in
+    let output = Fpath.v (Key.get ctx output) in
+    Install.v ~etc:[ output ] ()
+  in
+  let configure info =
+    let ctx = Info.context info in
+    let name = Key.get ctx name in
+    let (_ : block_t) = make_block_t name in
+    ok ()
+  in
+  let connect info modname = function
+    | [ analyze ] ->
+        let ctx = Info.context info in
+        let name = Key.get ctx name in
+        code ~pos:__POS__
+          {ocaml|let ( <.> ) f g = fun x -> f (g x) in
+             let f = Rresult.R.(failwith_error_msg <.> reword_error (msgf "%%a" %s.pp_error)) in
+             Lwt.map f (%s.connect ~analyze:%s %S)|ocaml}
+          modname modname analyze name
+    | _ -> Misc.connect_err "docteur_solo5" 1
+  in
+  let keys = [ Key.v output; Key.v name ] in
+  let runtime_args = Runtime_arg.[ v analyze ] in
+  let packages = [ package "docteur-solo5" ~min:"0.0.6" ] in
+  impl ~keys ~runtime_args ~packages ~dune ~install ~configure ~connect
+    (Fmt.str "Docteur_solo5.%a" pp_mode mode)
+    Kv.ro
+
+let disk_name =
+  let doc =
+    Cmdliner.Arg.info
+      ~doc:
+        "Name of the docteur disk (for Solo5 targets, the name must contains \
+         only alpanumeric characters)."
+      [ "disk-name" ]
+  in
+  let key = Key.Arg.opt Cmdliner.Arg.string "docteur" doc in
+  Key.create "disk-name" key
+
+let disk_output =
+  let doc =
+    Cmdliner.Arg.info ~doc:"The output of the generated docteur image."
+      [ "disk-output" ]
+  in
+  let key = Key.Arg.opt Cmdliner.Arg.string "disk.img" doc in
+  Key.create "disk-output" key
+
+let docteur_solo5 (mode : mode) extra_deps ?(name = disk_name)
+    ?(output = disk_output) branch analyze remote =
+  docteur_solo5 mode extra_deps ~name ~output branch analyze remote
+
+let docteur_unix (mode : mode) extra_deps ?(name = disk_name)
+    ?(output = disk_output) branch analyze remote =
+  docteur_unix mode extra_deps ~name ~output branch analyze remote
+
+let analyze = Runtime_arg.create ~pos:__POS__ "Mirage_runtime.analyze"
+
+let docteur ?(mode = `Fast) ?name ?output ?(analyze = analyze) ?branch
+    ?(extra_deps = []) remote =
+  match_impl
+    Key.(value target)
+    [
+      (`Xen, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
+      (`Qubes, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
+      ( `Virtio,
+        docteur_solo5 mode extra_deps ?name ?output branch analyze remote );
+      (`Hvt, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
+      (`Spt, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
+      (`Muen, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
+      ( `Genode,
+        docteur_solo5 mode extra_deps ?name ?output branch analyze remote );
+    ]
+    ~default:(docteur_unix mode extra_deps ?name ?output branch analyze remote)
+
+let chamelon ~program_block_size =
+  let runtime_args = Runtime_arg.[ v program_block_size ] in
+  let packages = [ package "chamelon" ~sublibs:[ "kv" ] ~min:"0.0.8" ] in
+  let connect _ modname = function
+    | [ block; program_block_size ] ->
+        code ~pos:__POS__
+          {ocaml|%s.connect ~program_block_size:%s %s
+                 >|= Result.map_error (Fmt.str "%%a" %s.pp_error)
+                 >|= Result.fold ~ok:Fun.id ~error:failwith|ocaml}
+          modname program_block_size block modname
+    | _ -> Misc.connect_err "chameleon" 2
+  in
+  impl ~packages ~runtime_args ~connect "Kv.Make" (block @-> Kv.rw)
+
+let ccm_block ?nonce_len key =
+  let runtime_args = Runtime_arg.[ v key ] in
+  let packages = [ package "mirage-block-ccm" ~min:"2.0.0" ~max:"3.0.0" ] in
+  let connect _ modname = function
+    | [ block; key ] ->
+        code ~pos:__POS__
+          {ocaml|let key = %s in
+                 let key =
+                   if String.length key >= 2 && String.(equal "0x" (sub key 0 2)) then
+                     String.sub key 2 (String.length key - 2)
+                   else
+                     key
+                 in
+                 %s.connect ?nonce_len:%a ~key:(Cstruct.of_hex key) %s|ocaml}
+          key modname
+          Fmt.(parens (Dump.option int))
+          nonce_len block
+    | _ -> Misc.connect_err "ccm_block" 2
+  in
+  impl ~packages ~runtime_args ~connect "Block_ccm.Make" (block @-> block)

unikernel/duniverse/mirage/lib/devices/block.mli

@@ -0,0 +1,37 @@
+open Functoria.DSL
+
+type block
+
+val block : block typ
+
+val generic_block :
+  ?group:string ->
+  ?key:[ `BlockFile | `Ramdisk | `XenstoreId ] value ->
+  string ->
+  block impl
+
+val tar_kv_ro : block impl -> Kv.ro impl
+val fat_ro : block impl -> Kv.ro impl
+val ramdisk : string -> block impl
+val block_of_xenstore_id : string -> block impl
+val block_of_file : string -> block impl
+val block_conf : string -> block device
+
+val docteur :
+  ?mode:[ `Fast | `Light ] ->
+  ?name:string key ->
+  ?output:string key ->
+  ?analyze:bool runtime_arg ->
+  ?branch:string ->
+  ?extra_deps:string list ->
+  string ->
+  Kv.ro impl
+
+type block_t = { filename : string; number : int }
+
+val all_blocks : (string, block_t) Hashtbl.t
+val chamelon : program_block_size:int runtime_arg -> (block -> Kv.rw) impl
+val tar_kv_rw : block impl -> Kv.rw impl
+
+val ccm_block :
+  ?nonce_len:int -> string option runtime_arg -> (block -> block) impl

unikernel/duniverse/mirage/lib/devices/conduit.ml

@@ -0,0 +1,25 @@
+open Functoria.DSL
+
+type conduit = Conduit
+
+let conduit = typ Conduit
+let pkg = package ~min:"8.0.0" ~max:"9.0.0" "conduit-mirage"
+
+let tcp =
+  let packages = [ pkg ] in
+  let connect _ _ = function
+    | [ stack ] -> code ~pos:__POS__ "Lwt.return %s@;" stack
+    | _ -> Misc.connect_err "tcp_conduit" 1
+  in
+  impl ~packages ~connect "Conduit_mirage.TCP" (Stack.stackv4v6 @-> conduit)
+
+let tls =
+  let packages = [ pkg; package ~min:"2.0.0" ~max:"3.0.0" "tls-mirage" ] in
+  let connect _ _ = function
+    | [ stack ] -> code ~pos:__POS__ "Lwt.return %s@;" stack
+    | _ -> Misc.connect_err "tls_conduit" 1
+  in
+  impl ~packages ~connect "Conduit_mirage.TLS" (conduit @-> conduit)
+
+let conduit_direct ?tls:(use_tls = false) s =
+  if use_tls then tls $ (tcp $ s) else tcp $ s

unikernel/duniverse/mirage/lib/devices/conduit.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type conduit
+
+val pkg : package
+val conduit : conduit typ
+val conduit_direct : ?tls:bool -> Stack.stackv4v6 impl -> conduit impl

unikernel/duniverse/mirage/lib/devices/dns.ml

@@ -0,0 +1,21 @@
+open Functoria.DSL
+
+type dns_client = Dns_client
+
+let dns_client = typ Dns_client
+
+let generic_dns_client ?group ?timeout ?nameservers ?cache_size () =
+  let packages = [ package "dns-client-mirage" ~min:"10.0.0" ~max:"11.0.0" ] in
+  let nameservers = Runtime_arg.dns_servers ?group nameservers
+  and timeout = Runtime_arg.dns_timeout ?group timeout
+  and cache_size = Runtime_arg.dns_cache_size ?group cache_size in
+  let runtime_args = Runtime_arg.[ v nameservers; v timeout; v cache_size ] in
+  let connect _info modname = function
+    | [ stackv4v6; happy_eyeballs; nameservers; timeout; cache_size ] ->
+        code ~pos:__POS__
+          {ocaml|%s.connect @[?nameservers:%s ?timeout:%s ?cache_size:%s@ (%s, %s)@]|ocaml}
+          modname nameservers timeout cache_size stackv4v6 happy_eyeballs
+    | _ -> Misc.connect_err "generic_dns_client" 5
+  in
+  impl ~runtime_args ~packages ~connect "Dns_client_mirage.Make"
+    (Stack.stackv4v6 @-> Happy_eyeballs.happy_eyeballs @-> dns_client)

unikernel/duniverse/mirage/lib/devices/dns.mli

@@ -0,0 +1,13 @@
+open Functoria.DSL
+
+type dns_client
+
+val dns_client : dns_client typ
+
+val generic_dns_client :
+  ?group:string ->
+  ?timeout:int64 ->
+  ?nameservers:string list ->
+  ?cache_size:int ->
+  unit ->
+  (Stack.stackv4v6 -> Happy_eyeballs.happy_eyeballs -> dns_client) impl

unikernel/duniverse/mirage/lib/devices/dune

@@ -0,0 +1,4 @@
+(library
+ (name devices)
+ (public_name mirage.devices)
+ (libraries mirage.functoria))

unikernel/duniverse/mirage/lib/devices/ethernet.ml

@@ -0,0 +1,15 @@
+open Functoria.DSL
+
+type ethernet = ETHERNET
+
+let ethernet = typ ETHERNET
+
+let ethif_conf =
+  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
+    | _ -> Misc.connect_err "etif" 1
+  in
+  impl ~packages ~connect "Ethernet.Make" (Network.network @-> ethernet)
+
+let ethif network = ethif_conf $ network

unikernel/duniverse/mirage/lib/devices/ethernet.mli

@@ -0,0 +1,6 @@
+open Functoria.DSL
+
+type ethernet
+
+val ethernet : ethernet typ
+val ethif : Network.network impl -> ethernet impl

unikernel/duniverse/mirage/lib/devices/git.ml

@@ -0,0 +1,55 @@
+open Functoria.DSL
+
+type git_client = Git_client
+
+let git_client = typ Git_client
+
+let git_merge_clients =
+  let packages = [ package "mimic" ] in
+  let connect _ _modname = function
+    | [ a; b ] -> code ~pos:__POS__ "Lwt.return (Mimic.merge %s %s)" a b
+    | _ -> Misc.connect_err "git_merge_client" 2
+  in
+  impl ~packages ~connect "Mimic.Merge"
+    (git_client @-> git_client @-> git_client)
+
+let git_tcp =
+  let packages = [ package ~max:"1.0.0" "git-net" ] in
+  let connect _ modname = function
+    | [ _tcpv4v6; ctx ] ->
+        code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx
+    | _ -> Misc.connect_err "git_tcp" 2
+  in
+  impl ~packages ~connect "Git_net.TCP.Make"
+    (Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)
+
+let git_ssh ?group ?authenticator ?key ?password () =
+  let packages = [ package ~max:"1.0.0" "git-net" ] in
+  let key = Runtime_arg.ssh_key ?group key
+  and password = Runtime_arg.ssh_password ?group password
+  and authenticator = Runtime_arg.ssh_authenticator ?group authenticator in
+  let runtime_args = Runtime_arg.[ v key; v password; v authenticator ] in
+  let connect _ modname = function
+    | [ _tcpv4v6; ctx; key; password; authenticator ] ->
+        code ~pos:__POS__
+          {ocaml|%s.connect %s >>= %s.with_optionnal_key ?authenticator:%s ~key:%s ~password:%s|ocaml}
+          modname ctx modname authenticator key password
+    | _ -> Misc.connect_err "git_ssh" 5
+  in
+  impl ~packages ~connect ~runtime_args "Git_net.SSH.Make"
+    (Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)
+
+let git_http ?group ?authenticator ?headers () =
+  let packages = [ package ~max:"1.0.0" "git-net" ] in
+  let authenticator = Runtime_arg.tls_authenticator ?group authenticator
+  and headers = Runtime_arg.http_headers ?group headers in
+  let runtime_args = Runtime_arg.[ v authenticator; v headers ] in
+  let connect _ modname = function
+    | [ _tcpv4v6; ctx; authenticator; headers ] ->
+        code ~pos:__POS__
+          {ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers ?headers:%s ?authenticator:%s|ocaml}
+          modname ctx modname headers authenticator
+    | _ -> Misc.connect_err "git_http" 4
+  in
+  impl ~packages ~connect ~runtime_args "Git_net.HTTP.Make"
+    (Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)

unikernel/duniverse/mirage/lib/devices/git.mli

@@ -0,0 +1,22 @@
+open Functoria.DSL
+
+type git_client
+
+val git_client : git_client typ
+val git_merge_clients : (git_client -> git_client -> git_client) impl
+val git_tcp : (Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl
+
+val git_ssh :
+  ?group:string ->
+  ?authenticator:string ->
+  ?key:string ->
+  ?password:string ->
+  unit ->
+  (Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl
+
+val git_http :
+  ?group:string ->
+  ?authenticator:string ->
+  ?headers:(string * string) list ->
+  unit ->
+  (Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl

unikernel/duniverse/mirage/lib/devices/happy_eyeballs.ml

@@ -0,0 +1,47 @@
+open Functoria.DSL
+
+type happy_eyeballs = Happy_eyeballs
+
+let happy_eyeballs = typ Happy_eyeballs
+
+let generic_happy_eyeballs ?group ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries ?timer_interval () =
+  let packages =
+    [ package "happy-eyeballs-mirage" ~min:"2.0.0" ~max:"3.0.0" ]
+  in
+  let aaaa_timeout = Runtime_arg.he_aaaa_timeout ?group aaaa_timeout
+  and connect_delay = Runtime_arg.he_connect_delay ?group connect_delay
+  and connect_timeout = Runtime_arg.he_connect_timeout ?group connect_timeout
+  and resolve_timeout = Runtime_arg.he_resolve_timeout ?group resolve_timeout
+  and resolve_retries = Runtime_arg.he_resolve_retries ?group resolve_retries
+  and timer_interval = Runtime_arg.he_timer_interval ?group timer_interval in
+  let runtime_args =
+    Runtime_arg.
+      [
+        v aaaa_timeout;
+        v connect_delay;
+        v connect_timeout;
+        v resolve_timeout;
+        v resolve_retries;
+        v timer_interval;
+      ]
+  in
+  let connect _info modname = function
+    | [
+        stack;
+        aaaa_timeout;
+        connect_delay;
+        connect_timeout;
+        resolve_timeout;
+        resolve_retries;
+        timer_interval;
+      ] ->
+        code ~pos:__POS__
+          {ocaml|%s.connect_device ?aaaa_timeout:%s ?connect_delay:%s
+?connect_timeout:%s ?resolve_timeout:%s ?resolve_retries:%s ?timer_interval:%s %s|ocaml}
+          modname aaaa_timeout connect_delay connect_timeout resolve_timeout
+          resolve_retries timer_interval stack
+    | _ -> Misc.connect_err "generic_happy_eyeballs" 7
+  in
+  impl ~runtime_args ~packages ~connect "Happy_eyeballs_mirage.Make"
+    (Stack.stackv4v6 @-> happy_eyeballs)

unikernel/duniverse/mirage/lib/devices/happy_eyeballs.mli

@@ -0,0 +1,16 @@
+open Functoria.DSL
+
+type happy_eyeballs
+
+val happy_eyeballs : happy_eyeballs typ
+
+val generic_happy_eyeballs :
+  ?group:string ->
+  ?aaaa_timeout:int64 ->
+  ?connect_delay:int64 ->
+  ?connect_timeout:int64 ->
+  ?resolve_timeout:int64 ->
+  ?resolve_retries:int ->
+  ?timer_interval:int64 ->
+  unit ->
+  (Stack.stackv4v6 -> happy_eyeballs) impl

unikernel/duniverse/mirage/lib/devices/http.ml

@@ -0,0 +1,69 @@
+open Functoria.DSL
+
+type http = HTTP
+
+let http = typ HTTP
+
+type http_client = HTTP_client
+
+let http_client = typ HTTP_client
+
+let connect err _i modname = function
+  | [ conduit ] -> code ~pos:__POS__ "Lwt.return (%s.listen %s)" modname conduit
+  | _ -> Misc.connect_err err 1
+
+let cohttp_server =
+  let packages = [ package ~min:"6.1.0" ~max:"7.0.0" "cohttp-mirage" ] in
+  impl ~packages ~connect:(connect "http") "Cohttp_mirage.Server.Make"
+    (Conduit.conduit @-> http)
+
+let cohttp_server conduit = cohttp_server $ conduit
+
+let cohttp_client =
+  let packages = [ package ~min:"6.1.0" ~max:"7.0.0" "cohttp-mirage" ] in
+  let connect _i modname = function
+    | [ resolver; conduit ] ->
+        code ~pos:__POS__ "Lwt.return (%s.ctx %s %s)" modname resolver conduit
+    | _ -> Misc.connect_err "http" 2
+  in
+  impl ~packages ~connect "Cohttp_mirage.Client.Make"
+    (Resolver.resolver @-> Conduit.conduit @-> http_client)
+
+let cohttp_client resolver conduit = cohttp_client $ resolver $ conduit
+
+let httpaf_server conduit =
+  let packages = [ package "httpaf-mirage" ] in
+  let extra_deps = [ dep conduit ] in
+  impl ~packages ~connect:(connect "httpaf") ~extra_deps
+    "Httpaf_mirage.Server_with_conduit" http
+
+type http_server = HTTP_server
+
+let http_server = typ HTTP_server
+
+let paf_server port =
+  let connect _ modname = function
+    | [ tcpv4v6; port ] ->
+        code ~pos:__POS__ {ocaml|%s.init ~port:%s %s|ocaml} modname port tcpv4v6
+    | _ -> Misc.connect_err "paf_server" 2
+  in
+  let packages =
+    [ package "paf" ~sublibs:[ "mirage" ] ~min:"0.8.0" ~max:"0.9.0" ]
+  in
+  let runtime_args = Runtime_arg.[ v port ] in
+  impl ~connect ~packages ~runtime_args "Paf_mirage.Make"
+    (Tcp.tcpv4v6 @-> http_server)
+
+type alpn_client = ALPN_client
+
+let alpn_client = typ ALPN_client
+
+let paf_client =
+  let packages = [ package "http-mirage-client" ~min:"0.0.9" ~max:"0.1.0" ] in
+  let connect _ modname = function
+    | [ _tcpv4v6; ctx ] ->
+        code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx
+    | _ -> Misc.connect_err "paf_client" 2
+  in
+  impl ~connect ~packages "Http_mirage_client.Make"
+    (Tcp.tcpv4v6 @-> Mimic.mimic @-> alpn_client)

unikernel/duniverse/mirage/lib/devices/http.mli

@@ -0,0 +1,24 @@
+open Functoria.DSL
+
+type http
+
+val http : http typ
+val cohttp_server : Conduit.conduit impl -> http impl
+val httpaf_server : Conduit.conduit impl -> http impl
+
+type http_client
+
+val http_client : http_client typ
+
+val cohttp_client :
+  Resolver.resolver impl -> Conduit.conduit impl -> http_client impl
+
+type http_server
+
+val http_server : http_server typ
+val paf_server : int runtime_arg -> (Tcp.tcpv4v6 -> http_server) impl
+
+type alpn_client
+
+val alpn_client : alpn_client typ
+val paf_client : (Tcp.tcpv4v6 -> Mimic.mimic -> alpn_client) impl

unikernel/duniverse/mirage/lib/devices/icmp.ml

@@ -0,0 +1,17 @@
+open Functoria.DSL
+
+type 'a icmp = ICMP
+type icmpv4 = Ip.v4 icmp
+
+let icmp = typ ICMP
+let icmpv4 : icmpv4 typ = icmp
+
+let icmpv4_direct () =
+  let packages_v = Ip.right_tcpip_library ~sublibs:[ "icmpv4" ] "tcpip" in
+  let connect _ modname = function
+    | [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
+    | _ -> Misc.connect_err "icmpv4" 1
+  in
+  impl ~packages_v ~connect "Icmpv4.Make" (Ip.ip @-> icmp)
+
+let direct_icmpv4 ip = icmpv4_direct () $ ip

unikernel/duniverse/mirage/lib/devices/icmp.mli

@@ -0,0 +1,6 @@
+open Functoria.DSL
+
+type icmpv4
+
+val icmpv4 : icmpv4 typ
+val direct_icmpv4 : Ip.ipv4 impl -> icmpv4 impl

unikernel/duniverse/mirage/lib/devices/ip.ml

@@ -0,0 +1,122 @@
+open Functoria.DSL
+
+type v4
+type v6
+type v4v6
+type 'a ip = IP
+type ipv4 = v4 ip
+type ipv6 = v6 ip
+type ipv4v6 = v4v6 ip
+
+let ip = Functoria.Type.Type IP
+let ipv4 : ipv4 typ = ip
+let ipv6 : ipv6 typ = ip
+let ipv4v6 : ipv4v6 typ = ip
+
+(* convenience function for linking tcpip.unix for checksums *)
+let right_tcpip_library ?libs ~sublibs pkg =
+  let min = "9.0.0" and max = "10.0.0" in
+  Key.pure [ 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 runtime_args = Runtime_arg.[ v ip; v gateway; v no_init ] in
+  let connect _ modname = function
+    | [ etif; arp; ip; gateway; no_init ] ->
+        code ~pos:__POS__
+          "%s.connect@[~no_init:%s@ ~cidr:%s@ ?gateway:%s@ %s@ %s@]" modname
+          no_init ip gateway etif arp
+    | _ -> Misc.connect_err "ipv4 keyed" 5
+  in
+  impl ~packages_v ~runtime_args ~connect "Static_ipv4.Make"
+    (Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
+
+let ipv4_dhcp_conf =
+  let packages =
+    [ package ~min:"2.0.0" ~max:"3.0.0" ~sublibs:[ "mirage" ] "charrua-client" ]
+  in
+  let connect _ modname = function
+    | [ network; ethernet; arp ] ->
+        code ~pos:__POS__ "%s.connect@[@ %s@ %s@ %s@]" modname network ethernet
+          arp
+    | _ -> Misc.connect_err "ipv4 dhcp" 3
+  in
+  impl ~packages ~connect "Dhcp_ipv4.Make"
+    (Network.network @-> Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
+
+let ipv4_of_dhcp net ethif arp = ipv4_dhcp_conf $ net $ ethif $ arp
+
+let keyed_create_ipv4 ?group
+    ?(network = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24") ?gateway ~no_init
+    etif arp =
+  let ip = Runtime_arg.V4.network ?group network
+  and gateway = Runtime_arg.V4.gateway ?group gateway in
+  ipv4_keyed_conf ~ip ~gateway ~no_init () $ etif $ arp
+
+let create_ipv4 ?group etif arp =
+  let network, gateway = (Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24", None) in
+  let ip = Runtime_arg.V4.network ?group network
+  and gateway = Runtime_arg.V4.gateway ?group gateway
+  and no_init = Runtime_arg.ipv6_only ?group () in
+  ipv4_keyed_conf ~ip ~gateway ~no_init () $ etif $ arp
+
+let ipv4_qubes_conf =
+  let packages = [ package ~min:"2.0.0" ~max:"3.0.0" "mirage-qubes-ipv4" ] in
+  let connect _ modname = function
+    | [ db; etif; arp ] ->
+        code ~pos:__POS__ "%s.connect@[@ %s@ %s@ %s@]" modname db etif arp
+    | _ -> Misc.connect_err "qubes_ipv4" 3
+  in
+  impl ~packages ~connect "Qubesdb_ipv4.Make"
+    (Qubesdb.qubesdb @-> Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
+
+let ipv4_qubes db ethernet arp = ipv4_qubes_conf $ db $ ethernet $ arp
+
+let ipv6_conf ~ip ~gateway ~handle_ra ~no_init () =
+  let packages_v = right_tcpip_library ~sublibs:[ "ipv6" ] "tcpip" in
+  let runtime_args = Runtime_arg.[ v ip; v gateway; v handle_ra; v no_init ] in
+  let connect _ modname = function
+    | [ netif; etif; ip; gateway; handle_ra; no_init ] ->
+        code ~pos:__POS__
+          "%s.connect@[~no_init:%s@ ~handle_ra:%s@ ?cidr:%s@ ?gateway:%s@ %s@ \
+           %s@]"
+          modname no_init handle_ra ip gateway netif etif
+    | _ -> Misc.connect_err "ipv6" 6
+  in
+
+  impl ~packages_v ~runtime_args ~connect "Ipv6.Make"
+    (Network.network @-> Ethernet.ethernet @-> ipv6)
+
+let keyed_create_ipv6 ?group ?network ?gateway ~no_init netif etif =
+  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
+
+let create_ipv6 ?group netif etif =
+  let network, gateway = (None, None) in
+  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 ()
+  and no_init = Runtime_arg.ipv4_only ?group () in
+  ipv6_conf ~ip ~gateway ~handle_ra ~no_init () $ netif $ etif
+
+let ipv4v6_conf ~ipv4_only ~ipv6_only () =
+  let packages_v = right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
+  let runtime_args = [ Runtime_arg.v ipv4_only; Runtime_arg.v ipv6_only ] in
+  let connect _ modname = function
+    | [ ipv4; ipv6; ipv4_only; ipv6_only ] ->
+        code ~pos:__POS__ "%s.connect@[@ ~ipv4_only:%s@ ~ipv6_only:%s@ %s@ %s@]"
+          modname ipv4_only ipv6_only ipv4 ipv6
+    | _ -> Misc.connect_err "ipv4v6" 4
+  in
+  impl ~packages_v ~runtime_args ~connect "Tcpip_stack_direct.IPV4V6"
+    (ipv4 @-> ipv6 @-> ipv4v6)
+
+let keyed_ipv4v6 ~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 ()
+  and ipv6_only = Runtime_arg.ipv6_only ?group () in
+  keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6

unikernel/duniverse/mirage/lib/devices/ip.mli

@@ -0,0 +1,56 @@
+open Functoria.DSL
+
+type v4
+type v6
+type v4v6
+type 'a ip
+type ipv4 = v4 ip
+type ipv6 = v6 ip
+type ipv4v6 = v4v6 ip
+
+val ip : 'a ip typ
+val ipv4 : ipv4 typ
+val ipv6 : ipv6 typ
+val ipv4v6 : ipv4v6 typ
+
+val create_ipv4 :
+  ?group:string -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
+
+val keyed_create_ipv4 :
+  ?group:string ->
+  ?network:Ipaddr.V4.Prefix.t ->
+  ?gateway:Ipaddr.V4.t ->
+  no_init:bool runtime_arg ->
+  Ethernet.ethernet impl ->
+  Arp.arpv4 impl ->
+  ipv4 impl
+
+val create_ipv6 :
+  ?group:string -> Network.network impl -> Ethernet.ethernet impl -> ipv6 impl
+
+val keyed_create_ipv6 :
+  ?group:string ->
+  ?network:Ipaddr.V6.Prefix.t ->
+  ?gateway:Ipaddr.V6.t ->
+  no_init:bool runtime_arg ->
+  Network.network impl ->
+  Ethernet.ethernet impl ->
+  ipv6 impl
+
+val ipv4_of_dhcp :
+  Network.network impl -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
+
+val ipv4_qubes :
+  Qubesdb.qubesdb impl -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
+
+val create_ipv4v6 : ?group:string -> ipv4 impl -> ipv6 impl -> ipv4v6 impl
+
+val keyed_ipv4v6 :
+  ipv4_only:bool runtime_arg ->
+  ipv6_only:bool runtime_arg ->
+  ipv4 impl ->
+  ipv6 impl ->
+  ipv4v6 impl
+
+val right_tcpip_library :
+  ?libs:string list -> sublibs:string list -> string -> package list value

unikernel/duniverse/mirage/lib/devices/key.ml

@@ -0,0 +1,156 @@
+(*
+ * Copyright (c) 2015 Gabriel Radanne <drupyog@zoho.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+module Action = Functoria.Action
+module Key = Functoria.Key
+
+(** {2 Documentation helper} *)
+
+let mirage_section = "MIRAGE PARAMETERS"
+let unikernel_section = "UNIKERNEL PARAMETERS"
+let pp_group = Fmt.(option ~none:(any "the unikernel") @@ fmt "the %s group")
+
+(** {2 Special keys} *)
+
+(** {3 Mode} *)
+
+type mode_unix = [ `Unix | `MacOSX ]
+type mode_xen = [ `Xen | `Qubes ]
+type mode_solo5 = [ `Hvt | `Spt | `Virtio | `Muen | `Genode ]
+type mode_unikraft = [ `Firecracker | `QEMU ]
+type mode = [ mode_unix | mode_xen | mode_solo5 | mode_unikraft ]
+
+let (target_conv : mode Cmdliner.Arg.conv), target_doc_alts =
+  let enum =
+    [
+      ("unix", `Unix);
+      ("macosx", `MacOSX);
+      ("xen", `Xen);
+      ("virtio", `Virtio);
+      ("hvt", `Hvt);
+      ("muen", `Muen);
+      ("qubes", `Qubes);
+      ("genode", `Genode);
+      ("spt", `Spt);
+      ("unikraft-firecracker", `Firecracker);
+      ("unikraft-qemu", `QEMU);
+    ]
+  in
+  let conv = Cmdliner.Arg.enum enum in
+  (conv, Cmdliner.Arg.doc_alts_enum enum)
+
+let pp_target fmt m = Cmdliner.Arg.conv_printer target_conv fmt m
+
+let default_target =
+  match Sys.getenv "MIRAGE_DEFAULT_TARGET" with
+  | "unix" -> `Unix
+  | s -> Fmt.failwith "invalid default target: %S" s
+  | exception Not_found -> (
+      match Action.run @@ Action.run_cmd_out Bos.Cmd.(v "uname" % "-s") with
+      | Ok "Darwin" -> `MacOSX
+      | _ -> `Unix)
+
+let target =
+  let doc =
+    Fmt.str "Target platform to compile the unikernel for. Valid values are: %s"
+      target_doc_alts
+  in
+  let doc =
+    Cmdliner.Arg.info ~docs:mirage_section ~docv:"TARGET" ~doc [ "t"; "target" ]
+      ~env:(Cmdliner.Cmd.Env.info "MODE")
+  in
+  let key = Key.Arg.opt target_conv default_target doc in
+  Key.create "target" key
+
+let is_unix =
+  Key.match_ Key.(value target) @@ function
+  | #mode_unix -> true
+  | #mode_xen | #mode_solo5 | #mode_unikraft -> false
+
+let is_solo5 =
+  Key.match_ Key.(value target) @@ function
+  | #mode_solo5 -> true
+  | #mode_xen | #mode_unix | #mode_unikraft -> false
+
+let is_xen =
+  Key.match_ Key.(value target) @@ function
+  | #mode_xen -> true
+  | #mode_solo5 | #mode_unix | #mode_unikraft -> false
+
+let is_unikraft =
+  Key.match_ Key.(value target) @@ function
+  | #mode_unikraft -> true
+  | #mode_solo5 | #mode_unix | #mode_xen -> false
+
+(** {2 General mirage keys} *)
+
+let configure_key ?(group = "") ~doc ~default conv name =
+  let prefix = if group = "" then group else group ^ "-" in
+  let doc =
+    Cmdliner.Arg.info ~docs:unikernel_section
+      ~docv:(String.uppercase_ascii name)
+      ~doc
+      [ prefix ^ name ]
+  in
+  let key = Key.Arg.opt conv default doc in
+  Key.create (prefix ^ name) key
+
+(** {3 File system keys} *)
+
+let kv_ro ?group () =
+  let enum = [ ("crunch", `Crunch); ("direct", `Direct) ] in
+  let conv = Cmdliner.Arg.enum enum in
+  let doc =
+    Fmt.str "Use %s pass-through implementation for %a."
+      (Cmdliner.Arg.doc_alts_enum enum)
+      pp_group group
+  in
+  configure_key ~doc ?group ~default:`Crunch conv "kv_ro"
+
+(** {3 Block device keys} *)
+let block ?group () =
+  let enum =
+    [ ("xenstore", `XenstoreId); ("file", `BlockFile); ("ramdisk", `Ramdisk) ]
+  in
+  let conv = Cmdliner.Arg.enum enum in
+  let doc =
+    Fmt.str "Use %s pass-through implementation for %a."
+      (Cmdliner.Arg.doc_alts_enum enum)
+      pp_group group
+  in
+  configure_key ~doc ?group ~default:`Ramdisk conv "block"
+
+(** {3 Stack keys} *)
+
+let dhcp ?group () =
+  let doc = Fmt.str "Enable dhcp for %a." pp_group group in
+  configure_key ~doc ?group ~default:false Cmdliner.Arg.bool "dhcp"
+
+let net ?group () : [ `Host | `OCaml ] option Key.key =
+  let enum =
+    [
+      ("host", `Host); ("socket", `Host); ("direct", `OCaml); ("ocaml", `OCaml);
+    ]
+  in
+  let conv = Cmdliner.Arg.enum enum in
+  let doc =
+    Fmt.str "Use %s group for %a."
+      (Cmdliner.Arg.doc_alts_enum enum)
+      pp_group group
+  in
+  configure_key ~doc ?group ~default:None (Cmdliner.Arg.some conv) "net"
+
+include Key

unikernel/duniverse/mirage/lib/devices/key.mli

@@ -0,0 +1,76 @@
+(*
+ * Copyright (c) 2015 Gabriel Radanne <drupyog@zoho.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(** Command-line arguments for the Mirage configuration tool. *)
+
+include module type of Functoria.Key
+
+type mode_unix = [ `Unix | `MacOSX ]
+type mode_xen = [ `Xen | `Qubes ]
+type mode_solo5 = [ `Hvt | `Spt | `Virtio | `Muen | `Genode ]
+type mode_unikraft = [ `Firecracker | `QEMU ]
+type mode = [ mode_unix | mode_xen | mode_solo5 | mode_unikraft ]
+
+(** {2 Mirage keys} *)
+
+val target : mode key
+(** [-t TARGET]: Key setting the configuration mode for the current project. Is
+    one of ["unix"], ["macosx"], ["xen"], ["qubes"], ["virtio"], ["hvt"],
+    ["muen"], ["genode"] or ["spt"]. *)
+
+val pp_target : mode Fmt.t
+(** Pretty printer for the mode. *)
+
+val is_unix : bool value
+(** Is true iff the {!target} key is a UNIXish system (["unix" or "macosx"]). *)
+
+val is_solo5 : bool value
+(** Is true iff the {!target} key is a Solo5-based target. *)
+
+val is_xen : bool value
+(** Is true iff the {!target} key is a Xen-based system (["xen" or "qubes"]). *)
+
+val is_unikraft : bool value
+(** Is true iff the {!target} key is a Unikraft-based target. *)
+
+(** {2 Generic keys}
+
+    Some keys have a [group] optional argument. This group argument allows to
+    give several keys a prefix.
+
+    For example, if we have two [ip] stacks, one external and one internal, We
+    can use the [group] option to name them [in] and [out]. This way, the
+    available keys will be [--in-ip] and [--out-ip].
+
+    If a key has another, non-optional argument. It is the default value.
+
+    Keys are always named the same as their command line option. *)
+
+(** {3 File system keys} *)
+
+val kv_ro : ?group:string -> unit -> [ `Crunch | `Direct ] key
+(** The type of key value store. Is one of ["crunch"], or ["direct"]. *)
+
+val block : ?group:string -> unit -> [ `XenstoreId | `BlockFile | `Ramdisk ] key
+(** {3 Block device keys} *)
+
+(** {3 Stack keys} *)
+
+val dhcp : ?group:string -> unit -> bool key
+(** Enable dhcp. Is either [true] or [false]. *)
+
+val net : ?group:string -> unit -> [ `OCaml | `Host ] option key
+(** The type of stack. Is either ["ocaml"] or ["host"]. *)

unikernel/duniverse/mirage/lib/devices/kv.ml

@@ -0,0 +1,86 @@
+module Dune = Functoria.Dune
+open Functoria.DSL
+
+type ro = RO
+
+let ro = typ RO
+
+let crunch dirname =
+  let is_valid = function
+    | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true
+    | _ -> false
+  in
+  let name =
+    let modname = String.map (fun c -> if is_valid c then c else '_') dirname in
+    "Static_" ^ String.lowercase_ascii modname
+  in
+  let packages =
+    [
+      package ~min:"4.0.0" ~max:"5.0.0" "mirage-kv-mem";
+      package ~min:"4.0.0" ~max:"5.0.0" ~build:true "crunch";
+    ]
+  in
+  let connect _ modname _ = code ~pos:__POS__ "%s.connect ()" modname in
+  let dune _i =
+    let dir = Fpath.(v dirname) in
+    let file ext = Fpath.(v name + ext) in
+    let ml = file "ml" in
+    let mli = file "mli" in
+    let dune =
+      Dune.stanzaf
+        {|
+(rule
+  (targets %a %a)
+  (deps (source_tree %a))
+  (action
+    (run ocaml-crunch -o %a %a)))
+|}
+        Fpath.pp ml Fpath.pp mli Fpath.pp dir Fpath.pp ml Fpath.pp dir
+    in
+    [ dune ]
+  in
+  impl ~packages ~connect ~dune name ro
+
+let direct_kv_ro dirname =
+  let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in
+  let connect _ modname _names =
+    code ~pos:__POS__ "%s.connect \"%s\"" modname dirname
+  in
+  impl ~packages ~connect "Mirage_kv_unix" ro
+
+let direct_kv_ro dirname =
+  match_impl
+    Key.(value target)
+    [
+      (`Xen, crunch dirname);
+      (`Qubes, crunch dirname);
+      (`Virtio, crunch dirname);
+      (`Hvt, crunch dirname);
+      (`Spt, crunch dirname);
+      (`Muen, crunch dirname);
+      (`Genode, crunch dirname);
+    ]
+    ~default:(direct_kv_ro dirname)
+
+type rw = RW
+
+let rw = typ RW
+
+let direct_kv_rw dirname =
+  let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in
+  let connect _ modname _names =
+    code ~pos:__POS__ "%s.connect \"%s\"" modname dirname
+  in
+  impl ~packages ~connect "Mirage_kv_unix" rw
+
+let mem_kv_rw () =
+  let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-kv-mem" ] in
+  let connect _ modname _names = code ~pos:__POS__ "%s.connect ()" modname in
+  impl ~packages ~connect "Mirage_kv_mem" rw
+
+(** generic kv_ro. *)
+
+let generic_kv_ro ?group ?(key = Key.value @@ Key.kv_ro ?group ()) dir =
+  match_impl key
+    [ (`Crunch, crunch dir); (`Direct, direct_kv_ro dir) ]
+    ~default:(direct_kv_ro dir)

unikernel/duniverse/mirage/lib/devices/kv.mli

@@ -0,0 +1,16 @@
+open Functoria.DSL
+
+type ro
+
+val ro : ro typ
+val direct_kv_ro : string -> ro impl
+val crunch : string -> ro impl
+
+val generic_kv_ro :
+  ?group:string -> ?key:[ `Crunch | `Direct ] value -> string -> ro impl
+
+type rw
+
+val rw : rw typ
+val direct_kv_rw : string -> rw impl
+val mem_kv_rw : unit -> rw impl

unikernel/duniverse/mirage/lib/devices/libvirt.ml

@@ -0,0 +1,104 @@
+module Action = Functoria.Action
+
+let filename ~name = Fpath.(v (name ^ "_libvirt") + "xml")
+let append fmt s = Fmt.pf fmt (s ^^ "@.")
+
+let configure_main ~name =
+  Action.with_output ~path:(filename ~name) ~purpose:"libvirt.xml" (fun fmt ->
+      append fmt "<domain type='xen'>";
+      append fmt "    <name>%s</name>" name;
+      append fmt "    <memory unit='KiB'>262144</memory>";
+      append fmt "    <currentMemory unit='KiB'>262144</currentMemory>";
+      append fmt "    <vcpu placement='static'>1</vcpu>";
+      append fmt "    <os>";
+      append fmt "        <type arch='armv7l' machine='xenpv'>linux</type>";
+      append fmt "        <kernel>%s.xen</kernel>" name;
+      append fmt "        <cmdline> </cmdline>";
+      (* the libxl driver currently needs an empty cmdline to be able to
+           start the domain on arm - due to this?
+           http://lists.xen.org/archives/html/xen-devel/2014-02/msg02375.html *)
+      append fmt "    </os>";
+      append fmt "    <clock offset='utc' adjustment='reset'/>";
+      append fmt "    <on_crash>preserve</on_crash>";
+      append fmt "    <!-- ";
+      append fmt "    You must define network and block interfaces manually.";
+      append fmt
+        "    See http://libvirt.org/drvxen.html for information about \
+         converting .xl-files to libvirt xml automatically.";
+      append fmt "    -->";
+      append fmt "    <devices>";
+      append fmt "        <!--";
+      append fmt "        The disk configuration is defined here:";
+      append fmt "        http://libvirt.org/formatstorage.html.";
+      append fmt "        An example would look like:";
+      append fmt "         <disk type='block' device='disk'>";
+      append fmt "            <driver name='phy'/>";
+      append fmt "            <source dev='/dev/loop0'/>";
+      append fmt "            <target dev='' bus='xen'/>";
+      append fmt "        </disk>";
+      append fmt "        -->";
+      append fmt "        <!-- ";
+      append fmt "        The network configuration is defined here:";
+      append fmt "        http://libvirt.org/formatnetwork.html";
+      append fmt "        An example would look like:";
+      append fmt "        <interface type='bridge'>";
+      append fmt "            <mac address='c0:ff:ee:c0:ff:ee'/>";
+      append fmt "            <source bridge='br0'/>";
+      append fmt "        </interface>";
+      append fmt "        -->";
+      append fmt "        <console type='pty'>";
+      append fmt "            <target type='xen' port='0'/>";
+      append fmt "        </console>";
+      append fmt "    </devices>";
+      append fmt "</domain>")
+
+let configure_virtio ~name =
+  Action.with_output ~path:(filename ~name) ~purpose:"libvirt.xml" (fun fmt ->
+      append fmt "<domain type='kvm'>";
+      append fmt "    <name>%s</name>" name;
+      append fmt "    <memory unit='KiB'>262144</memory>";
+      append fmt "    <currentMemory unit='KiB'>262144</currentMemory>";
+      append fmt "    <vcpu placement='static'>1</vcpu>";
+      append fmt "    <os>";
+      append fmt "        <type arch='x86_64' machine='pc'>hvm</type>";
+      append fmt "        <kernel>%s.virtio</kernel>" name;
+      append fmt "        <!-- Command line arguments can be given if required:";
+      append fmt "        <cmdline>-l *:debug</cmdline>";
+      append fmt "        -->";
+      append fmt "    </os>";
+      append fmt "    <clock offset='utc' adjustment='reset'/>";
+      append fmt "    <devices>";
+      append fmt "        <emulator>/usr/bin/qemu-system-x86_64</emulator>";
+      append fmt "        <!--";
+      append fmt "        Disk/block configuration reference is here:";
+      append fmt "        https://libvirt.org/formatdomain.html#elementsDisks";
+      append fmt
+        "        This example uses a raw file on the host as a block in the \
+         guest:";
+      append fmt "        <disk type='file' device='disk'>";
+      append fmt "            <driver name='qemu' type='raw'/>";
+      append fmt "            <source file='/var/lib/libvirt/images/%s.img'/>"
+        name;
+      append fmt "            <target dev='vda' bus='virtio'/>";
+      append fmt "        </disk>";
+      append fmt "        -->";
+      append fmt "        <!-- ";
+      append fmt "        Network configuration reference is here:";
+      append fmt "        https://libvirt.org/formatdomain.html#elementsNICS";
+      append fmt
+        "        This example adds a device in the 'default' libvirt bridge:";
+      append fmt "        <interface type='bridge'>";
+      append fmt "            <source bridge='virbr0'/>";
+      append fmt "            <model type='virtio'/>";
+      append fmt "            <alias name='0'/>";
+      append fmt "        </interface>";
+      append fmt "        -->";
+      append fmt "        <serial type='pty'>";
+      append fmt "            <target port='0'/>";
+      append fmt "        </serial>";
+      append fmt "        <console type='pty'>";
+      append fmt "            <target type='serial' port='0'/>";
+      append fmt "        </console>";
+      append fmt "        <memballoon model='none'/>";
+      append fmt "    </devices>";
+      append fmt "</domain>")

unikernel/duniverse/mirage/lib/devices/libvirt.mli

@@ -0,0 +1,3 @@
+val filename : name:string -> Fpath.t
+val configure_main : name:string -> unit Functoria.Action.t
+val configure_virtio : name:string -> unit Functoria.Action.t

unikernel/duniverse/mirage/lib/devices/mimic.ml

@@ -0,0 +1,18 @@
+open Functoria.DSL
+
+type mimic = Mimic
+
+let mimic = typ Mimic
+
+let mimic_happy_eyeballs =
+  let packages = [ package "mimic-happy-eyeballs" ~min:"0.0.9" ] in
+  let connect _ modname = function
+    | [ _stackv4v6; happy_eyeballs; _dns_client ] ->
+        code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname happy_eyeballs
+    | _ -> Misc.connect_err "mimic" 3
+  in
+  impl ~packages ~connect "Mimic_happy_eyeballs.Make"
+    (Stack.stackv4v6
+    @-> Happy_eyeballs.happy_eyeballs
+    @-> Dns.dns_client
+    @-> mimic)

unikernel/duniverse/mirage/lib/devices/misc.ml

@@ -0,0 +1,16 @@
+let get_target i = Key.(get (Functoria.Info.context i) target)
+
+let connect_err name number =
+  let str =
+    Fmt.str "The %s connect expects exactly %d argument%s" name number
+      (if number = 1 then "" else "s")
+  in
+  failwith str
+
+let terminal () =
+  let dumb = try Sys.getenv "TERM" = "dumb" with Not_found -> true in
+  let isatty =
+    try Unix.(isatty (descr_of_out_channel Stdlib.stdout))
+    with Unix.Unix_error _ -> false
+  in
+  (not dumb) && isatty

unikernel/duniverse/mirage/lib/devices/misc.mli

@@ -0,0 +1,3 @@
+val get_target : Functoria.Info.t -> Key.mode
+val connect_err : string -> int -> 'a
+val terminal : unit -> bool

unikernel/duniverse/mirage/lib/devices/mtime.ml

@@ -0,0 +1,18 @@
+open Functoria.DSL
+
+type mtime = job
+
+let mtime = Functoria.job
+let no_mtime = impl "Mirage_runtime" mtime
+
+let impl sublib =
+  let packages =
+    [ package ~min:"5.2.0" ~max:"6.0.0" ~sublibs:[ ""; sublib ] "mirage-mtime" ]
+  in
+  impl ~packages "Mirage_mtime" mtime
+
+let default_mtime =
+  if_impl Key.is_unix (impl "unix")
+    (if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))
+
+let mock_mtime = impl "mock"

unikernel/duniverse/mirage/lib/devices/mtime.mli

@@ -0,0 +1,8 @@
+open Functoria.DSL
+
+type mtime = job
+
+val mtime : mtime typ
+val default_mtime : mtime impl
+val no_mtime : mtime impl
+val mock_mtime : mtime impl

unikernel/duniverse/mirage/lib/devices/network.ml

@@ -0,0 +1,53 @@
+open Functoria.DSL
+open Functoria.Action
+
+type network = NETWORK
+
+let network = typ NETWORK
+let all_networks = ref []
+let add_new_network name = all_networks := name :: !all_networks
+
+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" ]
+    | #Key.mode_unikraft ->
+        [ package ~min:"1.0.0" ~max:"2.0.0" "mirage-net-unikraft" ]
+  in
+  let connect _ modname = function
+    | [] -> code ~pos:__POS__ "%s.connect %S" modname name
+    | [ intf ] -> code ~pos:__POS__ "%s.connect %s" modname intf
+    | _ -> Misc.connect_err "network_conf (sometimes 0 arguments)" 1
+  in
+  let configure _ =
+    add_new_network name;
+    ok ()
+  in
+  impl ~runtime_args ~packages_v ~connect ~configure "Netif" network
+
+let netif ?group dev =
+  if_impl Key.is_solo5 (network_conf dev)
+    (network_conf ~intf:(Runtime_arg.interface ?group dev) dev)
+
+let default_network =
+  match_impl
+    Key.(value target)
+    [
+      (`Unix, netif "tap0");
+      (`MacOSX, netif "tap0");
+      (* On Solo5 targets, a single default network is customarily
+       * named just 'service' *)
+      (`Hvt, netif "service");
+      (`Spt, netif "service");
+      (`Virtio, netif "service");
+      (`Muen, netif "service");
+      (`Genode, netif "service");
+    ]
+    ~default:(netif "0")

unikernel/duniverse/mirage/lib/devices/network.mli

@@ -0,0 +1,8 @@
+open Functoria.DSL
+
+type network
+
+val network : network typ
+val netif : ?group:string -> string -> network impl
+val default_network : network impl
+val all_networks : string list ref

unikernel/duniverse/mirage/lib/devices/ptime.ml

@@ -0,0 +1,18 @@
+open Functoria.DSL
+
+type ptime = job
+
+let ptime = Functoria.job
+let no_ptime = impl "Mirage_runtime" ptime
+
+let impl sublib =
+  let packages =
+    [ package ~min:"5.1.0" ~max:"6.0.0" ~sublibs:[ ""; sublib ] "mirage-ptime" ]
+  in
+  impl ~packages "Mirage_ptime" ptime
+
+let default_ptime =
+  if_impl Key.is_unix (impl "unix")
+    (if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))
+
+let mock_ptime = impl "mock"

unikernel/duniverse/mirage/lib/devices/ptime.mli

@@ -0,0 +1,8 @@
+open Functoria.DSL
+
+type ptime = job
+
+val ptime : ptime typ
+val default_ptime : ptime impl
+val no_ptime : ptime impl
+val mock_ptime : ptime impl

unikernel/duniverse/mirage/lib/devices/qubesdb.ml

@@ -0,0 +1,22 @@
+open Functoria.DSL
+open Functoria.Action
+
+type qubesdb = QUBES_DB
+
+let qubesdb = typ QUBES_DB
+let pkg = package ~min:"2.0.0" ~max:"3.0.0" "mirage-qubes"
+
+let default_qubesdb =
+  let packages = [ pkg ] in
+  let configure i =
+    match Misc.get_target i with
+    | `Qubes | `Xen -> ok ()
+    | _ ->
+        error
+          "Qubes DB invoked for an unsupported target; qubes and xen are \
+           supported"
+  in
+  let connect _ modname _args =
+    code ~pos:__POS__ "%s.connect ~domid:0 ()" modname
+  in
+  impl ~packages ~configure ~connect "Qubes.DB" qubesdb

unikernel/duniverse/mirage/lib/devices/qubesdb.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type qubesdb
+
+val qubesdb : qubesdb typ
+val default_qubesdb : qubesdb impl
+val pkg : package

unikernel/duniverse/mirage/lib/devices/random.ml

@@ -0,0 +1,17 @@
+open Functoria.DSL
+
+type random = job
+
+let random = Functoria.job
+
+let default_random =
+  let packages =
+    [ package ~min:"2.0.0" ~max:"3.0.0" "mirage-crypto-rng-mirage" ]
+  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" random
+
+let no_random = impl "Mirage_runtime" random

unikernel/duniverse/mirage/lib/devices/random.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type random = job
+
+val random : random typ
+val no_random : random impl
+val default_random : random impl

unikernel/duniverse/mirage/lib/devices/reporter.ml

@@ -0,0 +1,30 @@
+open Functoria.DSL
+
+type reporter = job
+
+let reporter = Functoria.job
+
+let pp_level ppf = function
+  | Some Logs.Error -> Fmt.string ppf "(Some Logs.Error)"
+  | Some Logs.Warning -> Fmt.string ppf "(Some Logs.Warning)"
+  | Some Logs.Info -> Fmt.string ppf "(Some Logs.Info)"
+  | Some Logs.Debug -> Fmt.string ppf "(Some Logs.Debug)"
+  | Some Logs.App -> Fmt.string ppf "(Some Logs.App)"
+  | None -> Fmt.string ppf "None"
+
+let default_reporter ?(level = Some Logs.Info) () =
+  let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-logs" ] in
+  let runtime_args = [ Runtime_arg.v Runtime_arg.logs ] in
+  let connect _ modname = function
+    | [ logs ] ->
+        code ~pos:__POS__
+          "@[<v 2>let reporter = %s.create () in@ Mirage_runtime.set_level \
+           ~default:%a %s;@ Logs.set_reporter reporter;@ Lwt.return reporter@]"
+          modname pp_level level logs
+    | _ -> Misc.connect_err "log" 1
+  in
+  impl ~packages ~runtime_args ~connect "Mirage_logs" reporter
+
+let no_reporter =
+  let connect _ _ _ = code ~pos:__POS__ "assert false" in
+  impl ~connect "Mirage_runtime" reporter

unikernel/duniverse/mirage/lib/devices/reporter.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type reporter = job
+
+val reporter : reporter typ
+val default_reporter : ?level:Logs.level option -> unit -> reporter impl
+val no_reporter : reporter impl

unikernel/duniverse/mirage/lib/devices/resolver.ml

@@ -0,0 +1,42 @@
+open Functoria.DSL
+open Functoria.Action
+
+type resolver = Resolver
+
+let resolver = typ Resolver
+
+let resolver_unix_system =
+  let packages_v =
+    Key.(if_ is_unix)
+      [ Conduit.pkg; package ~min:"8.0.0" ~max:"9.0.0" "conduit-lwt-unix" ]
+      []
+  in
+  let configure i =
+    match Misc.get_target i with
+    | `Unix | `MacOSX -> ok ()
+    | _ -> error "Unix resolver not supported on non-UNIX targets."
+  in
+  let connect _ _modname _ =
+    code ~pos:__POS__ "Lwt.return Resolver_lwt_unix.system"
+  in
+  impl ~packages_v ~configure ~connect "Resolver_lwt" resolver
+
+let resolver_dns_conf ~ns =
+  let packages = [ Conduit.pkg ] in
+  let runtime_args = Runtime_arg.[ v ns ] in
+  let connect _ modname = function
+    | [ stack; ns ] ->
+        code ~pos:__POS__
+          "let nameservers = %s in@;\
+           %s.v ?nameservers %s >|= function@;\
+           | Ok r -> r@;\
+           | Error (`Msg e) -> invalid_arg e@;"
+          ns modname stack
+    | _ -> Misc.connect_err "resolver" 2
+  in
+  impl ~packages ~runtime_args ~connect "Resolver_mirage.Make"
+    (Stack.stackv4v6 @-> resolver)
+
+let resolver_dns ?ns stack =
+  let ns = Runtime_arg.resolver ?default:ns () in
+  resolver_dns_conf ~ns $ stack

unikernel/duniverse/mirage/lib/devices/resolver.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type resolver
+
+val resolver : resolver typ
+val resolver_dns : ?ns:string list -> Stack.stackv4v6 impl -> resolver impl
+val resolver_unix_system : resolver impl

unikernel/duniverse/mirage/lib/devices/runtime_arg.ml

@@ -0,0 +1,199 @@
+(*
+ * Copyright (c) 2023 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Functoria.DSL
+include Functoria.Runtime_arg
+
+(** {2 OCaml runtime} *)
+
+let runtime_arg ~pos name =
+  create ~pos
+    ~packages:[ package "mirage-runtime" ]
+    (Fmt.str "Mirage_runtime.%s" name)
+
+let runtime_network_key ~pos fmt =
+  Fmt.kstr
+    (create ~pos ~packages:[ package "mirage-runtime" ~sublibs:[ "network" ] ])
+    ("Mirage_runtime_network." ^^ fmt)
+
+let delay = runtime_arg ~pos:__POS__ "delay"
+
+let pp_group ppf = function
+  | None | Some "" -> ()
+  | Some g -> Fmt.pf ppf "~group:%S " g
+
+let pp_docs ppf = function
+  | None | Some "" -> ()
+  | Some g -> Fmt.pf ppf "~docs:%S " g
+
+let pp_option pp ppf = function
+  | None -> Fmt.pf ppf "None"
+  | Some d -> Fmt.pf ppf "(Some %a)" pp d
+
+let escape pp ppf = Fmt.kstr (fun str -> Fmt.Dump.string ppf str) "%a" pp
+
+(** {3 Network keys} *)
+
+let interface ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "interface %a%a%S" pp_group group pp_docs
+    docs default
+
+module V4 = struct
+  open Ipaddr.V4
+
+  let pp_prefix ppf p =
+    Fmt.pf ppf "(Ipaddr.V4.Prefix.of_string_exn %a)" (escape Prefix.pp) p
+
+  let pp ppf p = Fmt.pf ppf "(Ipaddr.V4.of_string_exn %a)" (escape pp) p
+
+  let network ?group ?docs default =
+    runtime_network_key ~pos:__POS__ "V4.network %a%a%a" pp_group group pp_docs
+      docs pp_prefix default
+
+  let gateway ?group ?docs default =
+    runtime_network_key ~pos:__POS__ "V4.gateway %a%a%a" pp_group group pp_docs
+      docs (pp_option pp) default
+end
+
+module V6 = struct
+  open Ipaddr.V6
+
+  let pp_prefix ppf p =
+    Fmt.pf ppf "(Ipaddr.V6.Prefix.of_string_exn %a)" (escape Prefix.pp) p
+
+  let pp ppf p = Fmt.pf ppf "(Ipaddr.V6.of_string_exn %a)" (escape pp) p
+
+  let network ?group ?docs default =
+    runtime_network_key ~pos:__POS__ "V6.network %a%a%a" pp_group group pp_docs
+      docs (pp_option pp_prefix) default
+
+  let gateway ?group ?docs default =
+    runtime_network_key ~pos:__POS__ "V6.gateway %a%a%a" pp_group group pp_docs
+      docs (pp_option pp) default
+
+  let accept_router_advertisements ?group ?docs () =
+    runtime_network_key ~pos:__POS__ "V6.accept_router_advertisements %a%a()"
+      pp_group group pp_docs docs
+end
+
+let ipv4_only ?group ?docs () =
+  runtime_network_key ~pos:__POS__ "ipv4_only %a%a()" pp_group group pp_docs
+    docs
+
+let ipv6_only ?group ?docs () =
+  runtime_network_key ~pos:__POS__ "ipv6_only %a%a()" pp_group group pp_docs
+    docs
+
+let resolver ?group ?docs ?(default = []) () =
+  let pp_default ppf = function
+    | [] -> ()
+    | l -> Fmt.pf ppf "~default:%a " Fmt.Dump.(list string) l
+  in
+  runtime_network_key ~pos:__POS__ "resolver %a%a%a()" pp_group group pp_docs
+    docs pp_default default
+
+let dns_servers ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "dns_servers %a%a%a" pp_group group pp_docs
+    docs
+    (pp_option Fmt.Dump.(list string))
+    default
+
+let dns_timeout ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "dns_timeout %a%a%a" pp_group group pp_docs
+    docs (pp_option Fmt.int64) default
+
+let dns_cache_size ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "dns_cache_size %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int) default
+
+let he_aaaa_timeout ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_aaaa_timeout %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int64) default
+
+let he_connect_delay ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_connect_delay %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int64) default
+
+let he_connect_timeout ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_connect_timeout %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int64) default
+
+let he_resolve_timeout ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_resolve_timeout %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int64) default
+
+let he_resolve_retries ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_resolve_retries %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int) default
+
+let he_timer_interval ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "he_timer_interval %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int64) default
+
+let ssh_key ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "ssh_key %a%a%a" pp_group group pp_docs docs
+    (pp_option Fmt.Dump.string)
+    default
+
+let ssh_password ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "ssh_password %a%a%a" pp_group group pp_docs
+    docs
+    (pp_option Fmt.Dump.string)
+    default
+
+let ssh_authenticator ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "ssh_authenticator %a%a%a" pp_group group
+    pp_docs docs
+    (pp_option Fmt.Dump.string)
+    default
+
+let tls_authenticator ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "tls_authenticator %a%a%a" pp_group group
+    pp_docs docs
+    (pp_option Fmt.Dump.string)
+    default
+
+let http_headers ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "http_headers %a%a%a" pp_group group pp_docs
+    docs
+    (pp_option Fmt.Dump.(list (pair string string)))
+    default
+
+let pp_ipaddr ppf p = Fmt.pf ppf "Ipaddr.of_string %a" (escape Ipaddr.pp) p
+
+let syslog ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "syslog %a%a%a" pp_group group pp_docs docs
+    (pp_option pp_ipaddr) default
+
+let syslog_port ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "syslog_port %a%a%a" pp_group group pp_docs
+    docs (pp_option Fmt.int) default
+
+let syslog_truncate ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "syslog_truncate %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.int) default
+
+let syslog_keyname ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "syslog_keyname %a%a%a" pp_group group
+    pp_docs docs (pp_option Fmt.string) default
+
+let monitor ?group ?docs default =
+  runtime_network_key ~pos:__POS__ "monitor %a%a%a" pp_group group pp_docs docs
+    (pp_option pp_ipaddr) default
+
+type log_threshold = [ `All | `Src of string ] * Logs.level option
+
+let logs = runtime_arg ~pos:__POS__ "logs"

unikernel/duniverse/mirage/lib/devices/runtime_arg.mli

@@ -0,0 +1,183 @@
+(*
+ * Copyright (c) 2023 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(** Command-line arguments for Mirage applications. *)
+
+open Functoria.DSL
+include module type of Functoria.Runtime_arg
+
+type 'a arg = 'a runtime_arg
+(** The type for command-line arguments that reads a value of type ['a]. *)
+
+val create :
+  pos:string * int * int * int -> ?packages:package list -> string -> 'a arg
+
+val v : 'a arg -> Functoria.Runtime_arg.t
+(** [v k] is the [k] with its type hidden. *)
+
+(** {3 Network Arguments} *)
+
+val interface : ?group:string -> ?docs:string -> string -> string runtime_arg
+(** A network interface. *)
+
+(** Ipv4 Arguments. *)
+module V4 : sig
+  open Ipaddr.V4
+
+  val network :
+    ?group:string -> ?docs:string -> Prefix.t -> Prefix.t runtime_arg
+  (** A network defined by an address and netmask. *)
+
+  val gateway :
+    ?group:string -> ?docs:string -> t option -> t option runtime_arg
+  (** A default gateway option. *)
+end
+
+(** Ipv6 Arguments. *)
+module V6 : sig
+  open Ipaddr.V6
+
+  val network :
+    ?group:string ->
+    ?docs:string ->
+    Prefix.t option ->
+    Prefix.t option runtime_arg
+  (** A network defined by an address and netmask. *)
+
+  val gateway :
+    ?group:string -> ?docs:string -> t option -> t option runtime_arg
+  (** A default gateway option. *)
+
+  val accept_router_advertisements :
+    ?group:string -> ?docs:string -> unit -> bool runtime_arg
+  (** An option whether to accept router advertisements. *)
+end
+
+val ipv4_only : ?group:string -> ?docs:string -> unit -> bool runtime_arg
+(** An option for dual stack to only use IPv4. *)
+
+val ipv6_only : ?group:string -> ?docs:string -> unit -> bool runtime_arg
+(** An option for dual stack to only use IPv6. *)
+
+val resolver :
+  ?group:string ->
+  ?docs:string ->
+  ?default:string list ->
+  unit ->
+  string list option runtime_arg
+(** The address of the DNS resolver to use. See $REFERENCE for format. *)
+
+val dns_servers :
+  ?group:string ->
+  ?docs:string ->
+  string list option ->
+  string list option runtime_arg
+(** The addresses of the DNS servers to use. *)
+
+val dns_timeout :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The timeout (in nanoseconds) for DNS resolution. *)
+
+val dns_cache_size :
+  ?group:string -> ?docs:string -> int option -> int option runtime_arg
+(** The cache size of the LRU cache used for DNS resolution. *)
+
+val he_aaaa_timeout :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The timeout (in nanoseconds) for IPv6 resolution. *)
+
+val he_connect_delay :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The delay (in nanoseconds) for establishing connections. *)
+
+val he_connect_timeout :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The timeout (in nanoseconds) for establishing connections. *)
+
+val he_resolve_timeout :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The timeout (in nanoseconds) for resolving hostnames. *)
+
+val he_resolve_retries :
+  ?group:string -> ?docs:string -> int option -> int option runtime_arg
+(** The number of resolution attempts before an error is returned. *)
+
+val he_timer_interval :
+  ?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
+(** The interval (in nanoseconds) when the timer is executed. *)
+
+val ssh_key :
+  ?group:string -> ?docs:string -> string option -> string option runtime_arg
+(** A SSH private key. *)
+
+val ssh_password :
+  ?group:string -> ?docs:string -> string option -> string option runtime_arg
+(** A SSH password. *)
+
+val ssh_authenticator :
+  ?group:string -> ?docs:string -> string option -> string option runtime_arg
+(** A SSH authenticator. *)
+
+val tls_authenticator :
+  ?group:string -> ?docs:string -> string option -> string option runtime_arg
+(** A TLS authenticator. *)
+
+val http_headers :
+  ?group:string ->
+  ?docs:string ->
+  (string * string) list option ->
+  (string * string) list option runtime_arg
+(** HTTP headers. *)
+
+val syslog :
+  ?group:string ->
+  ?docs:string ->
+  Ipaddr.t option ->
+  Ipaddr.t option runtime_arg
+(** The address to send syslog frames to. *)
+
+val syslog_port : ?group:string -> ?docs:string -> int option -> int runtime_arg
+(** The port to send syslog frames to. *)
+
+val syslog_truncate :
+  ?group:string -> ?docs:string -> int option -> int option runtime_arg
+(** Truncate syslog frames to a specific byte count, [docs] defaults to
+    {!Mirage_runtime.s_log}. *)
+
+val syslog_keyname :
+  ?group:string -> ?docs:string -> string option -> string option runtime_arg
+(** TLS key used for syslog, [docs] defaults to {!Mirage_runtime.s_log}. *)
+
+val monitor :
+  ?group:string ->
+  ?docs:string ->
+  Ipaddr.t option ->
+  Ipaddr.t option runtime_arg
+(** The address to send monitor statistics to. *)
+
+(** {3 Logs} *)
+
+type log_threshold = [ `All | `Src of string ] * Logs.level option
+(** The type for log threshold. A log level of [None] disables logging. *)
+
+val logs : log_threshold list runtime_arg
+
+(** {3 Startup delay} *)
+
+val delay : int runtime_arg
+(** The initial delay, specified in seconds, before a unikernel starting up.
+    Defaults to 0. Useful for tenders and environments that take some time to
+    bring devices up. *)

unikernel/duniverse/mirage/lib/devices/sleep.ml

@@ -0,0 +1,16 @@
+open Functoria.DSL
+
+type sleep = job
+
+let sleep = Functoria.job
+let no_sleep = impl "Mirage_runtime" sleep
+
+let impl sublib =
+  let packages =
+    [ package ~min:"4.1.0" ~max:"5.0.0" ~sublibs:[ ""; sublib ] "mirage-sleep" ]
+  in
+  impl ~packages "Mirage_sleep" sleep
+
+let default_sleep =
+  if_impl Key.is_unix (impl "unix")
+    (if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))

unikernel/duniverse/mirage/lib/devices/sleep.mli

@@ -0,0 +1,7 @@
+open Functoria.DSL
+
+type sleep = job
+
+val sleep : sleep typ
+val default_sleep : sleep impl
+val no_sleep : sleep impl

unikernel/duniverse/mirage/lib/devices/stack.ml

@@ -0,0 +1,112 @@
+open Functoria.DSL
+
+let dhcp_ipv4 tap e a = Ip.ipv4_of_dhcp tap e a
+
+let qubes_ipv4 ?(qubesdb = Qubesdb.default_qubesdb) e a =
+  Ip.ipv4_qubes qubesdb e a
+
+(** dual stack *)
+
+type stackv4v6 = STACKV4V6
+
+let stackv4v6 = typ STACKV4V6
+
+let stackv4v6_direct_conf () =
+  let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
+  let connect _i modname = function
+    | [ interface; ethif; arp; ipv4v6; icmpv4; udp; tcp ] ->
+        code ~pos:__POS__ "%s.connect %s %s %s %s %s %s %s" modname interface
+          ethif arp ipv4v6 icmpv4 udp tcp
+    | _ -> Misc.connect_err "direct stack" 7
+  in
+  impl ~packages_v ~connect "Tcpip_stack_direct.MakeV4V6"
+    (Network.network
+    @-> Ethernet.ethernet
+    @-> Arp.arpv4
+    @-> Ip.ipv4v6
+    @-> Icmp.icmpv4
+    @-> Udp.udp
+    @-> Tcp.tcp
+    @-> stackv4v6)
+
+let direct_stackv4v6 ?group ?tcp network eth arp ipv4 ipv6 =
+  let ipv4_only = Runtime_arg.ipv4_only ?group ()
+  and ipv6_only = Runtime_arg.ipv6_only ?group () in
+  let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
+  stackv4v6_direct_conf ()
+  $ network
+  $ eth
+  $ arp
+  $ ip
+  $ Icmp.direct_icmpv4 ipv4
+  $ Udp.direct_udp ip
+  $ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
+
+let keyed_direct_stackv4v6 ?tcp ~ipv4_only ~ipv6_only network eth arp ipv4 ipv6
+    =
+  let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
+  stackv4v6_direct_conf ()
+  $ network
+  $ eth
+  $ arp
+  $ ip
+  $ Icmp.direct_icmpv4 ipv4
+  $ Udp.direct_udp ip
+  $ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
+
+let generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
+    ?ipv6_gateway ?(arp = Arp.arp) ?tcp tap =
+  let ipv4_only = Runtime_arg.ipv4_only ?group ()
+  and ipv6_only = Runtime_arg.ipv6_only ?group () in
+  let e = Ethernet.ethif tap in
+  let a = arp e in
+  let i4 =
+    match_impl p
+      [ (`Qubes, qubes_ipv4 e a); (`Dhcp, dhcp_ipv4 tap e a) ]
+      ~default:
+        (Ip.keyed_create_ipv4 ?group ?network:ipv4_network ?gateway:ipv4_gateway
+           ~no_init:ipv6_only e a)
+  in
+  let i6 =
+    Ip.keyed_create_ipv6 ?group ?network:ipv6_network ?gateway:ipv6_gateway
+      ~no_init:ipv4_only tap e
+  in
+  keyed_direct_stackv4v6 ~ipv4_only ~ipv6_only ?tcp tap e a i4 i6
+
+let socket_stackv4v6 ?(group = "") () =
+  let v4key = Runtime_arg.V4.network ~group Ipaddr.V4.Prefix.global in
+  let v6key = Runtime_arg.V6.network ~group None in
+  let ipv4_only = Runtime_arg.ipv4_only ~group () in
+  let ipv6_only = Runtime_arg.ipv6_only ~group () in
+  let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-socket" ] "tcpip" in
+  let extra_deps =
+    [
+      dep (Udp.udpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
+      dep (Tcp.tcpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
+    ]
+  in
+  let connect _i modname = function
+    | [ udp; tcp ] -> code ~pos:__POS__ "%s.connect %s %s" modname udp tcp
+    | _ -> Misc.connect_err "socket_stackv4v6" 2
+  in
+  impl ~packages_v ~extra_deps ~connect "Tcpip_stack_socket.V4V6" stackv4v6
+
+(** Generic stack *)
+let generic_stackv4v6 ?group ?(dhcp_key = Key.value @@ Key.dhcp ?group ())
+    ?(net_key = Key.value @@ Key.net ?group ()) ?ipv4_network ?ipv4_gateway
+    ?ipv6_network ?ipv6_gateway ?tcp (tap : Network.network impl) :
+    stackv4v6 impl =
+  let choose target net dhcp =
+    match (target, net, dhcp) with
+    | `Qubes, _, _ -> `Qubes
+    | _, Some `Host, _ -> `Socket
+    | _, _, true -> `Dhcp
+    | (`Unix | `MacOSX), None, false -> `Socket
+    | _, _, _ -> `Static
+  in
+  let p = Key.(pure choose $ Key.(value target) $ net_key $ dhcp_key) in
+  match_impl p
+    [ (`Socket, socket_stackv4v6 ?group ()) ]
+    ~default:
+      (generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
+         ?ipv6_gateway ?tcp tap)

unikernel/duniverse/mirage/lib/devices/stack.mli

@@ -0,0 +1,27 @@
+open Functoria.DSL
+
+type stackv4v6
+
+val stackv4v6 : stackv4v6 typ
+
+val direct_stackv4v6 :
+  ?group:string ->
+  ?tcp:Tcp.tcpv4v6 impl ->
+  Network.network impl ->
+  Ethernet.ethernet impl ->
+  Arp.arpv4 impl ->
+  Ip.ipv4 impl ->
+  Ip.ipv6 impl ->
+  stackv4v6 impl
+
+val generic_stackv4v6 :
+  ?group:string ->
+  ?dhcp_key:bool value ->
+  ?net_key:[ `OCaml | `Host ] option value ->
+  ?ipv4_network:Ipaddr.V4.Prefix.t ->
+  ?ipv4_gateway:Ipaddr.V4.t ->
+  ?ipv6_network:Ipaddr.V6.Prefix.t ->
+  ?ipv6_gateway:Ipaddr.V6.t ->
+  ?tcp:Tcp.tcpv4v6 impl ->
+  Network.network impl ->
+  stackv4v6 impl

unikernel/duniverse/mirage/lib/devices/syslog.ml

@@ -0,0 +1,95 @@
+open Functoria.DSL
+
+type syslog = SYSLOG
+
+let syslog = typ SYSLOG
+let pkg sublibs = [ package ~min:"0.5.0" ~max:"0.6.0" ~sublibs "logs-syslog" ]
+
+let syslog_udp_conf ?group () =
+  let endpoint = Runtime_arg.syslog ?group None
+  and port = Runtime_arg.syslog_port ?group None
+  and truncate = Runtime_arg.syslog_truncate ?group None in
+  let packages = pkg [ "mirage" ] in
+  let runtime_args = Runtime_arg.[ v endpoint; v port; v truncate ] in
+  let connect _i modname = function
+    | [ stack; endpoint; port; truncate ] ->
+        code ~pos:__POS__
+          "@[<v 2>match %s with@ | None ->Logs.warn (fun m -> m \"no syslog \
+           server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
+           Some server ->@ let reporter =@ %s.create %s \
+           ~hostname:(Mirage_runtime.name ()) ~port:%s server ?truncate:%s ()@ \
+           in@ Logs.set_reporter reporter;@ Lwt.return_unit@]"
+          endpoint modname stack port truncate
+    | _ -> Misc.connect_err "syslog_udp" 5
+  in
+  impl ~packages ~runtime_args ~connect "Logs_syslog_mirage.Udp"
+    (Stack.stackv4v6 @-> syslog)
+
+let syslog_udp ?group stack = syslog_udp_conf ?group () $ stack
+
+let syslog_tcp_conf ?group () =
+  let endpoint = Runtime_arg.syslog ?group None
+  and port = Runtime_arg.syslog_port ?group None
+  and truncate = Runtime_arg.syslog_truncate ?group None in
+  let packages = pkg [ "mirage" ] in
+  let runtime_args = Runtime_arg.[ v endpoint; v port; v truncate ] in
+  let connect _i modname = function
+    | [ stack; endpoint; port; truncate ] ->
+        code ~pos:__POS__
+          "@[<v 2>match %s with@ | None -> Logs.warn (fun m -> m \"no syslog \
+           server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
+           Some server ->@ %s.create %s ~hostname:(Mirage_runtime.name ()) \
+           ~port:%s server ?truncate:%s () >>= function@ | Ok reporter -> \
+           Logs.set_reporter reporter; Lwt.return_unit@ | Error e -> \
+           invalid_arg e@]"
+          endpoint modname stack port truncate
+    | _ -> Misc.connect_err "syslog_tcp" 5
+  in
+  impl ~packages ~runtime_args ~connect "Logs_syslog_mirage.Tcp"
+    (Stack.stackv4v6 @-> syslog)
+
+let syslog_tcp ?group stack = syslog_tcp_conf ?group () $ stack
+
+let syslog_tls_conf ?group () =
+  let endpoint = Runtime_arg.syslog ?group None
+  and port = Runtime_arg.syslog_port ?group None
+  and truncate = Runtime_arg.syslog_truncate ?group None
+  and keyname = Runtime_arg.syslog_keyname ?group None in
+  let packages = pkg [ "mirage"; "mirage.tls" ] in
+  let runtime_args =
+    Runtime_arg.[ v endpoint; v port; v truncate; v keyname ]
+  in
+  let connect _i modname = function
+    | [ stack; kv; endpoint; port; truncate; keyname ] ->
+        code ~pos:__POS__
+          "@[<v 2>match %s with@ | None -> Logs.warn (fun m -> m \"no syslog \
+           server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
+           Some server ->@ %s.create %s %s ~hostname:(Mirage_runtime.name ()) \
+           ~port:%s server ?truncate:%s ?keyname:%s () >>= function@ | Ok \
+           reporter -> Logs.set_reporter reporter; Lwt.return_unit@ | Error e \
+           -> invalid_arg e@]"
+          endpoint modname stack kv port truncate keyname
+    | _ -> Misc.connect_err "syslog_tls" 8
+  in
+  impl ~packages ~runtime_args ~connect "Logs_syslog_mirage_tls.Tls"
+    (Stack.stackv4v6 @-> Kv.ro @-> syslog)
+
+let syslog_tls ?group stack kv = syslog_tls_conf ?group () $ stack $ kv
+
+let monitoring_conf ?group () =
+  let monitor_host = Runtime_arg.monitor ?group None in
+  let packages = [ package ~min:"0.0.6" ~max:"0.1.0" "mirage-monitoring" ] in
+  let runtime_args = Runtime_arg.[ v monitor_host ] in
+  let connect _i modname = function
+    | [ stack; monitor ] ->
+        code ~pos:__POS__
+          "Lwt.return (match %s with| None -> Logs.warn (fun m -> m \"no \
+           monitor specified, not outputting statistics\")| Some ip -> \
+           %s.create ip ~hostname:(Mirage_runtime.name ()) %s)"
+          monitor modname stack
+    | _ -> assert false
+  in
+  impl ~packages ~runtime_args ~connect "Mirage_monitoring.Make"
+    (Stack.stackv4v6 @-> Functoria.job)
+
+let monitoring ?group stack = monitoring_conf ?group () $ stack

unikernel/duniverse/mirage/lib/devices/syslog.mli

@@ -0,0 +1,12 @@
+open Functoria.DSL
+
+type syslog
+
+val syslog : syslog typ
+val syslog_udp : ?group:string -> Stack.stackv4v6 impl -> syslog impl
+val syslog_tcp : ?group:string -> Stack.stackv4v6 impl -> syslog impl
+
+val syslog_tls :
+  ?group:string -> Stack.stackv4v6 impl -> Kv.ro impl -> syslog impl
+
+val monitoring : ?group:string -> Stack.stackv4v6 impl -> Functoria.job impl

unikernel/duniverse/mirage/lib/devices/target.ml

@@ -0,0 +1,565 @@
+module Dune = Functoria.Dune
+module Info = Functoria.Info
+module Install = Functoria.Install
+module Action = Functoria.Action
+open Functoria.DSL
+
+(** A Mirage target: target consists in multiple backends grouped together. *)
+module type TARGET = sig
+  type t
+  (** The type representing a specific backend in a target. *)
+
+  val cast : Key.mode -> t
+  (** Ensures the mode is a backend supported by this target. *)
+
+  val dune : Info.t -> Dune.stanza list
+  (** Dune rules to build the unikernel *)
+
+  val out : Info.t -> string
+  (** Name of the output file (with extension) for this target *)
+
+  val configure : Info.t -> unit Action.t
+  (** Configure-time actions. *)
+
+  val build_context : ?build_dir:Fpath.t -> Info.t -> Dune.stanza list
+  (** Generate build context configuration *)
+
+  val context_name : Info.t -> string
+  (** Dune context *)
+
+  val packages : t -> package list
+  (** The required packages to support this backend. *)
+
+  val install : Info.t -> Install.t
+  (** [install i] returns which files are installed in context [i]. *)
+end
+
+module Unix = struct
+  type t = [ `Unix | `MacOSX ]
+
+  let cast = function #t as t -> t | _ -> invalid_arg "not a unix target."
+  let packages _ = [ Functoria.package ~min:"5.0.0" ~max:"6.0.0" "mirage-unix" ]
+
+  (*Mirage unix is built on the host build context.*)
+  let build_context ?build_dir:_ _ = []
+  let context_name _ = "default"
+  let configure _ = Action.ok ()
+  let main i = Fpath.(base (rem_ext (Info.main i)))
+
+  let public_name i =
+    match Info.output i with None -> Info.name i | Some o -> o
+
+  let flags =
+    (* Disable "70 [missing-mli] Missing interface file." as we are only
+       generating .ml files currently. *)
+    [ ":standard"; "-w"; "-70" ]
+    @ if Misc.terminal () then [ "-color"; "always" ] else []
+
+  let out = public_name
+
+  let dune i =
+    let libraries = Info.libraries i in
+    let public_name = public_name i in
+    let main = Fpath.to_string (main i) in
+    let pp_list f = Dune.compact_list f in
+    let dune =
+      Dune.stanzaf
+        {|
+(rule
+ (target %s)
+ (enabled_if (= %%{context_name} "default"))
+ (deps %s.exe)
+ (action
+  (copy %s.exe %%{target})))
+
+(executable
+ (name %s)
+ (libraries %a)
+ (link_flags (-thread))
+ (modules (:standard \ %a))
+ (flags %a)
+ (enabled_if (= %%{context_name} "default"))
+)
+|}
+        public_name main main main (pp_list "libraries") libraries Fpath.pp
+        (Fpath.rem_ext (Fpath.base (Info.config_file i)))
+        (pp_list "flags") flags
+    in
+    [ dune ]
+
+  let install i =
+    let public_name = public_name i in
+    Install.v ~bin:[ Fpath.(v public_name, v public_name) ] ()
+end
+
+module Xen = struct
+  (* We generate an example .xl with common defaults, and a generic
+     .xl.in which has @VARIABLES@ which must be substituted by sed
+     according to the preferences of the system administrator.
+     The common defaults chosen for the .xl file will be based on values
+     detected from the build host. We assume that the .xl file will
+     mainly be used by developers where build and deployment are on the
+     same host. Production users should use the .xl.in and perform the
+     appropriate variable substition.
+  *)
+
+  let detected_bridge_name =
+    (* Best-effort guess of a bridge name stem to use. Note this
+       inspects the build host and will probably be wrong if the
+       deployment host is different. *)
+    match
+      List.fold_left
+        (fun sofar x ->
+          match sofar with
+          (* This is Linux-specific *)
+          | None when Sys.file_exists (Fmt.str "/sys/class/net/%s0" x) -> Some x
+          | None -> None
+          | Some x -> Some x)
+        None [ "xenbr"; "br"; "virbr" ]
+    with
+    | Some x -> x
+    | None -> "br"
+
+  module Substitutions = struct
+    type v =
+      | Name
+      | Kernel
+      | Memory
+      | Block of Block.block_t
+      | Network of string
+
+    type t = (v * string) list
+
+    let string_of_v = function
+      | Name -> "@NAME@"
+      | Kernel -> "@KERNEL@"
+      | Memory -> "@MEMORY@"
+      | Block b -> Fmt.str "@BLOCK:%s@" b.filename
+      | Network n -> Fmt.str "@NETWORK:%s@" n
+
+    let lookup ts v =
+      if List.mem_assoc v ts then List.assoc v ts else string_of_v v
+
+    let defaults i =
+      let blocks =
+        List.map
+          (fun b -> (Block b, b.filename))
+          (Hashtbl.fold (fun _ v acc -> v :: acc) Block.all_blocks [])
+      and networks =
+        List.mapi
+          (fun i n -> (Network n, Fmt.str "%s%d" detected_bridge_name i))
+          !Network.all_networks
+      in
+      [ (Name, Info.name i); (Kernel, Info.name i ^ ".xen"); (Memory, "256") ]
+      @ blocks
+      @ networks
+  end
+
+  let append fmt s = Fmt.pf fmt (s ^^ "@.")
+
+  let configure_main_xl ?substitutions ~ext i =
+    let open Substitutions in
+    let substitutions =
+      match substitutions with Some x -> x | None -> defaults i
+    in
+    let path = Fpath.(v (Info.name i) + ext) in
+    Action.with_output ~path ~purpose:"xl file" (fun fmt ->
+        let open Block in
+        append fmt "name = '%s'" (lookup substitutions Name);
+        append fmt "kernel = '%s'" (lookup substitutions Kernel);
+        append fmt "type = 'pvh'";
+        append fmt "memory = %s" (lookup substitutions Memory);
+        append fmt "on_crash = 'preserve'";
+        append fmt "";
+        let blocks =
+          List.map
+            (fun b ->
+              (* We need the Linux version of the block number (this is a
+                  strange historical artifact) Taken from
+                  https://github.com/mirage/mirage-block-xen/blob/
+                  a64d152586c7ebc1d23c5adaa4ddd440b45a3a83/lib/device_number.ml#L128 *)
+              let rec string_of_int26 x =
+                let high, low = ((x / 26) - 1, (x mod 26) + 1) in
+                let high' = if high = -1 then "" else string_of_int26 high in
+                let low' =
+                  String.make 1 (char_of_int (low + int_of_char 'a' - 1))
+                in
+                high' ^ low'
+              in
+              let vdev = Fmt.str "xvd%s" (string_of_int26 b.number) in
+              let path = lookup substitutions (Block b) in
+              Fmt.str "'format=raw, vdev=%s, access=rw, target=%s'" vdev path)
+            (Hashtbl.fold (fun _ v acc -> v :: acc) all_blocks [])
+        in
+        append fmt "disk = [ %s ]" (String.concat ", " blocks);
+        append fmt "";
+        let networks =
+          List.map
+            (fun n -> Fmt.str "'bridge=%s'" (lookup substitutions (Network n)))
+            !Network.all_networks
+        in
+        append fmt
+          "# if your system uses openvswitch then either edit /etc/xen/xl.conf \
+           and set";
+        append fmt "#     vif.default.script=\"vif-openvswitch\"";
+        append fmt
+          "# or add \"script=vif-openvswitch,\" before the \"bridge=\" below:";
+        append fmt "vif = [ %s ]" (String.concat ", " networks))
+end
+
+module Solo5 = struct
+  open Action.Syntax
+
+  let solo5_manifest_path = Fpath.v "manifest.json"
+
+  type solo5_target = [ `Virtio | `Muen | `Hvt | `Genode | `Spt ]
+  type xen_target = [ `Xen | `Qubes ]
+  type t = [ solo5_target | xen_target ]
+
+  let cast = function #t as t -> t | _ -> invalid_arg "not a solo5 target."
+
+  let build_packages =
+    [
+      Functoria.package ~min:"0.8.2" ~max:"2.0.0" ~scope:`Switch ~build:true
+        "ocaml-solo5";
+      Functoria.package ~min:"0.7.5" ~max:"0.11.0" ~scope:`Switch ~build:true
+        "solo5";
+    ]
+
+  let runtime_packages target =
+    match target with
+    | #solo5_target ->
+        [ Functoria.package ~min:"0.10.0" ~max:"0.11.0" "mirage-solo5" ]
+    | #xen_target ->
+        [ Functoria.package ~min:"9.0.0" ~max:"10.0.0" "mirage-xen" ]
+
+  let packages target = build_packages @ runtime_packages target
+  let context_name _i = "solo5"
+
+  (* OCaml solo5 build context. *)
+  let build_context ?build_dir:_ i =
+    let build_context =
+      Dune.stanzaf
+        {|
+  (context (default
+  (name %s)
+  (host default)
+  (toolchain solo5)
+  (merlin)
+  (disable_dynamically_linked_foreign_archives true)
+  ))
+  |}
+        (context_name i)
+    in
+    [ build_context ]
+
+  (* Configure step *)
+  let generate_manifest_json with_devices () =
+    let networks = List.map (fun n -> (n, `Network)) !Network.all_networks in
+    let blocks =
+      Hashtbl.fold (fun k _v acc -> (k, `Block) :: acc) Block.all_blocks []
+    in
+    let to_string (name, typ) =
+      Fmt.str {json|{ "name": %S, "type": %S }|json} name
+        (match typ with `Network -> "NET_BASIC" | `Block -> "BLOCK_BASIC")
+    in
+    let devices =
+      if with_devices then List.map to_string (networks @ blocks) else []
+    in
+    let s = String.concat ", " devices in
+    let* () =
+      Action.with_output ~path:solo5_manifest_path
+        ~purpose:"Solo5 application manifest file" (fun fmt ->
+          Fmt.pf fmt
+            {|{
+  "type": "solo5.manifest",
+  "version": 1,
+  "devices": [ %s ]
+}
+|}
+            s)
+    in
+    Action.write_file (Fpath.v "manifest.ml") ""
+
+  let configure i =
+    let name = Info.name i in
+    let target = Info.get i Key.target in
+    let* () =
+      match target with
+      | #solo5_target -> generate_manifest_json true ()
+      | #xen_target -> generate_manifest_json false ()
+      | _ -> assert false
+    in
+    match target with
+    | `Xen ->
+        let* () = Xen.configure_main_xl ~ext:"xl" i in
+        let* () = Xen.configure_main_xl ~substitutions:[] ~ext:"xl.in" i in
+        Libvirt.configure_main ~name
+    | `Virtio -> Libvirt.configure_virtio ~name
+    | _ -> Action.ok ()
+
+  (* Build *)
+
+  let ext = function
+    | `Virtio -> ".virtio"
+    | `Muen -> ".muen"
+    | `Hvt -> ".hvt"
+    | `Genode -> ".genode"
+    | `Spt -> ".spt"
+    | `Xen | `Qubes -> ".xen"
+    | _ -> invalid_arg "solo5 bindings only defined for solo5 targets"
+
+  let main i = Fpath.(base (rem_ext (Info.main i)))
+
+  let out i =
+    let target = Info.get i Key.target in
+    let public_name =
+      match Info.output i with None -> Info.name i | Some o -> o
+    in
+    public_name ^ ext target
+
+  let rename i =
+    let out = out i in
+    let main = Fpath.to_string (main i) in
+    Dune.stanzaf
+      {|
+(rule
+ (target %s)
+ (enabled_if (= %%{context_name} "%s"))
+ (deps %s.exe)
+ (action
+  (copy %s.exe %%{target})))
+|}
+      out (context_name i) main main
+
+  let manifest _i =
+    Dune.stanzaf
+      {|
+(rule
+ (targets manifest.c)
+ (deps manifest.json)
+ (action
+  (run solo5-elftool gen-manifest manifest.json manifest.c)))
+|}
+
+  let solo5_abi = function
+    | #Key.mode_unix | #Key.mode_unikraft -> assert false
+    | #Key.mode_xen -> "xen"
+    | `Virtio -> "virtio"
+    | `Hvt -> "hvt"
+    | `Muen -> "muen"
+    | `Genode -> "genode"
+    | `Spt -> "spt"
+
+  let flags =
+    (* Disable "70 [missing-mli] Missing interface file." as we are only
+       generating .ml files currently. *)
+    [ ":standard"; "-w"; "-70" ]
+    @ if Misc.terminal () then [ "-color"; "always" ] else []
+
+  let main i =
+    let libraries = Info.libraries i in
+    let main = Fpath.to_string (main i) in
+    let target = Info.get i Key.target in
+    let pp_list f = Dune.compact_list f in
+    Dune.stanzaf
+      {|
+(executable
+ (enabled_if (= %%{context_name} "%s"))
+ (name %s)
+ (modes (native exe))
+ (libraries %a)
+ (link_flags %a -cclib "-z solo5-abi=%s")
+ (modules (:standard \ %a manifest))
+ (foreign_stubs (language c) (names manifest))
+)
+|}
+      (context_name i) main (pp_list "libraries") libraries
+      (pp_list "link_flags") flags (solo5_abi target) Fpath.pp
+      (Fpath.rem_ext (Fpath.base (Info.config_file i)))
+
+  let subdir name s = Dune.stanzaf "(subdir %s\n %a)\n" name Dune.pp (Dune.v s)
+  let dune i = [ main i; manifest i; rename i ]
+
+  let install i =
+    let target = Info.get i Key.target in
+    let name = Info.name i in
+    let out = out i in
+    let open Fpath in
+    let additional_artifacts =
+      match target with
+      | `Xen -> [ v (name ^ ".xl"); v (name ^ ".xl.in") ]
+      | _ -> []
+    in
+    Install.v ~bin:[ (v out, v out) ] ~etc:additional_artifacts ()
+end
+
+module Unikraft = struct
+  type t = [ `Firecracker | `QEMU ]
+
+  let configure _ = Action.ok ()
+  let cast = function #t as t -> t | _ -> invalid_arg "not a Unikraft target."
+
+  let build_packages =
+    [
+      Functoria.package ~min:"1.0.0" ~max:"2.0.0" ~scope:`Switch ~build:true
+        "ocaml-unikraft";
+      Functoria.package ~min:"1.0.0" ~max:"2.0.0" "mirage-unikraft";
+    ]
+
+  let backend_packages target =
+    match target with
+    | `Firecracker ->
+        [
+          Functoria.package ~scope:`Switch ~build:true
+            "ocaml-unikraft-backend-firecracker";
+        ]
+    | `QEMU ->
+        [
+          Functoria.package ~scope:`Switch ~build:true
+            "ocaml-unikraft-backend-qemu";
+        ]
+
+  let packages target = build_packages @ backend_packages target
+  let context_name _ = "unikraft"
+
+  let unikraft_abi = function
+    | #Key.mode_unix | #Key.mode_solo5 | #Key.mode_xen -> assert false
+    | `Firecracker -> "firecracker"
+    | `QEMU -> "qemu"
+
+  let build_context ?build_dir:_ i =
+    let target = Info.get i Key.target in
+    let build_context =
+      Dune.stanzaf
+        {|
+(context
+ (default
+  (name %s)
+  (host default)
+  (toolchain unikraft)
+  (env
+   (_
+    (flags :standard -cclib "-z unikraft-backend=%s")
+    (c_flags :standard -z unikraft-backend=%s)))
+  (merlin)
+  (disable_dynamically_linked_foreign_archives true)))
+|}
+        (context_name i) (unikraft_abi target) (unikraft_abi target)
+    in
+    [ build_context ]
+
+  let ext = function
+    | `Firecracker -> ".fc"
+    | `QEMU -> ".qemu"
+    | _ -> invalid_arg "Unikraft bindings only defined for Unikraft targets"
+
+  let main i = Fpath.(base (rem_ext (Info.main i)))
+
+  let out i =
+    let target = Info.get i Key.target in
+    let public_name =
+      match Info.output i with None -> Info.name i | Some o -> o
+    in
+    public_name ^ ext target
+
+  let rename i =
+    let out = out i in
+    let main = Fpath.to_string (main i) in
+    Dune.stanzaf
+      {|
+(rule
+ (target %s)
+ (enabled_if (= %%{context_name} "%s"))
+ (deps %s.exe)
+ (action
+  (copy %s.exe %%{target})))
+|}
+      out (context_name i) main main
+
+  let flags =
+    (* Disable "70 [missing-mli] Missing interface file." as we are only
+       generating .ml files currently. *)
+    [ ":standard"; "-w"; "-70" ]
+    @ if Misc.terminal () then [ "-color"; "always" ] else []
+
+  let main i =
+    let libraries = Info.libraries i in
+    let main = Fpath.to_string (main i) in
+    let pp_list f = Dune.compact_list f in
+    Dune.stanzaf
+      {|
+(executable
+ (enabled_if
+  (= %%{context_name} "%s"))
+ (name %s)
+ (modes
+  (native exe))
+ (libraries %a)
+ (link_flags %a))
+|}
+      (context_name i) main (pp_list "libraries") libraries
+      (pp_list "link_flags") flags
+
+  let dune i = [ main i; rename i ]
+
+  let out i =
+    let target = Info.get i Key.target in
+    let public_name =
+      match Info.output i with None -> Info.name i | Some o -> o
+    in
+    public_name ^ ext target
+
+  let install i =
+    let out = out i in
+    let open Fpath in
+    Install.v ~bin:[ (v out, v out) ] ()
+end
+
+let choose : Key.mode -> (module TARGET) = function
+  | #Solo5.t -> (module Solo5)
+  | #Unix.t -> (module Unix)
+  | #Unikraft.t -> (module Unikraft)
+
+let dune i =
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.dune i
+
+let output_message = ref true
+
+let configure i =
+  let open Action.Infix in
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.configure i >|= fun () ->
+  if !output_message then (
+    output_message := false;
+    Logs.app (fun m ->
+        m
+          "Successfully configured the unikernel. Now run 'make' (or more \
+           fine-grained steps: 'make all', 'make depends', or 'make lock')."))
+
+let build_context ?build_dir i =
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.build_context ?build_dir i
+
+let context_name i =
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.context_name i
+
+let out i =
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.out i
+
+let packages target =
+  let (module Target) = choose target in
+  Target.(packages (cast target))
+
+let install i =
+  let target = Info.get i Key.target in
+  let (module Target) = choose target in
+  Target.install i

unikernel/duniverse/mirage/lib/devices/tcp.ml

@@ -0,0 +1,38 @@
+open Functoria.DSL
+open Functoria.Action
+
+type 'a tcp = TCP
+type tcpv4v6 = Ip.v4v6 tcp
+
+let tcp = Functoria.Type.Type TCP
+let tcpv4v6 : tcpv4v6 typ = tcp
+
+(* this needs to be a function due to the value restriction. *)
+let tcp_direct_func () =
+  let packages_v = Ip.right_tcpip_library ~sublibs:[ "tcp" ] "tcpip" in
+  let connect _ modname = function
+    | [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
+    | _ -> Misc.connect_err "tcp" 1
+  in
+  impl ~packages_v ~connect "Tcp.Flow.Make" (Ip.ip @-> tcp)
+
+let direct_tcp ip = tcp_direct_func () $ ip
+
+let tcpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key =
+  let v = Runtime_arg.v in
+  let runtime_args = [ v ipv4_only; v ipv6_only; v ipv4_key; v ipv6_key ] in
+  let packages_v =
+    Ip.right_tcpip_library ~sublibs:[ "tcpv4v6-socket" ] "tcpip"
+  in
+  let configure i =
+    match Misc.get_target i with
+    | `Unix | `MacOSX -> ok ()
+    | _ -> error "TCPv4v6 socket not supported on non-UNIX targets."
+  in
+  let connect _ modname = function
+    | [ ipv4_only; ipv6_only; ipv4_key; ipv6_key ] ->
+        code ~pos:__POS__ "%s.connect ~ipv4_only:%s ~ipv6_only:%s %s %s" modname
+          ipv4_only ipv6_only ipv4_key ipv6_key
+    | _ -> Misc.connect_err "tcpv4v6_socket_conf" 4
+  in
+  impl ~packages_v ~configure ~runtime_args ~connect "Tcpv4v6_socket" tcpv4v6

unikernel/duniverse/mirage/lib/devices/tcp.mli

@@ -0,0 +1,17 @@
+open Functoria.DSL
+
+type 'a tcp
+
+val tcp : 'a tcp typ
+
+type tcpv4v6 = Ip.v4v6 tcp
+
+val tcpv4v6 : tcpv4v6 typ
+val direct_tcp : 'a Ip.ip impl -> 'a tcp impl
+
+val tcpv4v6_socket_conf :
+  ipv4_only:bool runtime_arg ->
+  ipv6_only:bool runtime_arg ->
+  Ipaddr.V4.Prefix.t runtime_arg ->
+  Ipaddr.V6.Prefix.t option runtime_arg ->
+  tcpv4v6 impl

unikernel/duniverse/mirage/lib/devices/udp.ml

@@ -0,0 +1,38 @@
+module Action = Functoria.Action
+open Functoria.DSL
+
+type 'a udp = UDP
+type udpv4v6 = Ip.v4v6 udp
+
+let udp = Functoria.Type.Type UDP
+let udpv4v6 : udpv4v6 typ = udp
+
+(* Value restriction ... *)
+let udp_direct_func () =
+  let packages_v = Ip.right_tcpip_library ~sublibs:[ "udp" ] "tcpip" in
+  let connect _ modname = function
+    | [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
+    | _ -> Misc.connect_err "udp" 1
+  in
+  impl ~packages_v ~connect "Udp.Make" (Ip.ip @-> udp)
+
+let direct_udp ip = udp_direct_func () $ ip
+
+let udpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key =
+  let v = Runtime_arg.v in
+  let runtime_args = [ v ipv4_only; v ipv6_only; v ipv4_key; v ipv6_key ] in
+  let packages_v =
+    Ip.right_tcpip_library ~sublibs:[ "udpv4v6-socket" ] "tcpip"
+  in
+  let configure i =
+    match Misc.get_target i with
+    | `Unix | `MacOSX -> Action.ok ()
+    | _ -> Action.error "UDPv4v6 socket not supported on non-UNIX targets."
+  in
+  let connect _ modname = function
+    | [ ipv4_only; ipv6_only; ipv4_key; ipv6_key ] ->
+        code ~pos:__POS__ "%s.connect ~ipv4_only:%s ~ipv6_only:%s %s %s" modname
+          ipv4_only ipv6_only ipv4_key ipv6_key
+    | _ -> Misc.connect_err "udpv4v6_socket_conf" 4
+  in
+  impl ~runtime_args ~packages_v ~configure ~connect "Udpv4v6_socket" udpv4v6

unikernel/duniverse/mirage/lib/devices/udp.mli

@@ -0,0 +1,17 @@
+open Functoria.DSL
+
+type 'a udp
+
+val udp : 'a udp typ
+
+type udpv4v6 = Ip.v4v6 udp
+
+val udpv4v6 : udpv4v6 typ
+val direct_udp : 'a Ip.ip impl -> 'a udp impl
+
+val udpv4v6_socket_conf :
+  ipv4_only:bool runtime_arg ->
+  ipv6_only:bool runtime_arg ->
+  Ipaddr.V4.Prefix.t runtime_arg ->
+  Ipaddr.V6.Prefix.t option runtime_arg ->
+  udpv4v6 impl