unikernel/duniverse/mirage/lib/functoria/DSL.ml

@@ -0,0 +1,70 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type 'a key = 'a Key.key
+type 'a runtime_arg = 'a Runtime_arg.arg
+type 'a value = 'a Key.value
+type abstract_key = Key.t
+type package = Package.t
+type scope = Package.scope
+type 'a typ = 'a Type.t
+type 'a impl = 'a Impl.t
+type abstract_impl = Impl.abstract
+type 'a device = ('a, Impl.abstract) Device.t
+type context = Context.t
+type job = Job.t
+type info = Info.t
+type 'a code = 'a Device.code
+
+let code = Device.code
+let package = Package.v
+let ( @-> ) = Type.( @-> )
+let typ = Type.v
+let ( $ ) = Impl.( $ )
+let of_device = Impl.of_device
+let key = Key.v
+let dep = Impl.abstract
+let if_impl = Impl.if_
+let match_impl = Impl.match_
+
+let impl ?packages ?packages_v ?local_libs ?install ?install_v ?keys
+    ?runtime_args ?extra_deps ?connect ?dune ?configure ?files module_name
+    module_type =
+  of_device
+  @@ Device.v ?packages ?packages_v ?local_libs ?install ?install_v ?keys
+       ?runtime_args ?extra_deps ?connect ?dune ?configure ?files module_name
+       module_type
+
+let main ?pos ?packages ?packages_v ?local_libs ?runtime_args ?deps module_name
+    ty =
+  let connect _ = Device.start ?pos in
+  let extra_deps =
+    if Type.is_functor ty then deps
+    else
+      match deps with
+      | None | Some [] ->
+          print_endline
+            "adding unit argument to 'start ()' (to delay execution)";
+          Some [ dep Job.noop ]
+      | _ -> deps
+  in
+  impl ?packages ?packages_v ?local_libs ?runtime_args ?extra_deps ~connect
+    module_name ty
+
+let runtime_arg ~pos ?packages str =
+  Runtime_arg.v (Runtime_arg.create ~pos ?packages str)

unikernel/duniverse/mirage/lib/functoria/DSL.mli

@@ -0,0 +1,210 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** The Functoria DSL allows users to describe how to create portable and
+    flexible applications. It allows to pass application parameters easily using
+    command-line arguments either at configure-time or at runtime.
+
+    Users of the Functoria DSL composes their application by defining a list of
+    {{!main} module} implementations, specify the command-line {!type-key} that
+    are required and {{!section-combinators} combine} all of them together using
+    {{:http://dx.doi.org/10.1017/S0956796807006326} applicative} operators.
+
+    The DSL expression is then compiled into an
+    {{!section-app} application builder}, which will, once evaluated, produced
+    the final portable and flexible application. *)
+
+(** {1:combinators Combinators} *)
+
+type 'a typ = 'a Type.t
+(** The type for values representing module types. *)
+
+val typ : 'a -> 'a typ
+(** [type t] is a value representing the module type [t]. *)
+
+val ( @-> ) : 'a typ -> 'b typ -> ('a -> 'b) typ
+(** Construct a functor type from a type and an existing functor type. This
+    corresponds to prepending a parameter to the list of functor parameters. For
+    example:
+
+    {[
+      kv_ro @-> ip @-> kv_ro
+    ]}
+
+    This describes a functor type that accepts two arguments -- a [kv_ro] and an
+    [ip] device -- and returns a [kv_ro]. *)
+
+type 'a impl = 'a Impl.t
+(** The type for values representing module implementations. *)
+
+val ( $ ) : ('a -> 'b) impl -> 'a impl -> 'b impl
+(** [m $ a] applies the functor [m] to the module [a]. *)
+
+type abstract_impl = Impl.abstract
+(** Same as {!type-impl} but with hidden type. *)
+
+val dep : 'a impl -> abstract_impl
+(** [dep t] is the (build-time) dependency towards [t]. *)
+
+(** {1:keys Keys} *)
+
+type 'a key = 'a Key.key
+(** The type for configure-time command-line arguments. *)
+
+type 'a runtime_arg = 'a Runtime_arg.arg
+(** The type for runtime command-line arguments. *)
+
+val runtime_arg :
+  pos:string * int * int * int ->
+  ?packages:Package.t list ->
+  string ->
+  Runtime_arg.t
+(** [runtime_arg ~pos ?packages v] is the runtime argument pointing to the value
+    [v]. [pos] is expected to be [__POS__]. [packages] specifies in which opam
+    package the value [v] is defined. *)
+
+type abstract_key = Key.t
+(** The type for abstract keys. *)
+
+type context = Context.t
+(** The type for keys' parsing context. See {!module-Key.type-context}. *)
+
+type 'a value = 'a Key.value
+(** The type for values parsed from the command-line. See {!Key.type-value}. *)
+
+val key : 'a key -> Key.t
+(** [key k] is an untyped representation of [k]. *)
+
+val if_impl : bool value -> 'a impl -> 'a impl -> 'a impl
+(** [if_impl v impl1 impl2] is [impl1] if [v] is resolved to true and [impl2]
+    otherwise. *)
+
+val match_impl : 'b value -> default:'a impl -> ('b * 'a impl) list -> 'a impl
+(** [match_impl v cases ~default] chooses the implementation amongst [cases] by
+    matching the [v]'s value. [default] is chosen if no value matches. *)
+
+(** {1:pkg Package dependencies}
+
+    For specifying opam package dependencies, the type {!type-package} is used.
+    It consists of the opam package name, the ocamlfind names, and optional
+    lower and upper bounds. The version constraints are merged with other
+    modules. *)
+
+type package = Package.t
+(** The type for opam packages. *)
+
+type scope = Package.scope
+(** Installation scope of a package. *)
+
+val package :
+  ?scope:scope ->
+  ?build:bool ->
+  ?sublibs:string list ->
+  ?libs:string list ->
+  ?min:string ->
+  ?max:string ->
+  ?pin:string ->
+  ?pin_version:string ->
+  string ->
+  package
+(** [package ~scope ~build ~sublibs ~libs ~min ~max ~pin opam] is a [package].
+    [Build] indicates a build-time dependency only, defaults to [false]. The
+    library name is by default the same as [opam], you can specify [~sublibs] to
+    add additional sublibraries (e.g. [~sublibs:["mirage"] "foo"] will result in
+    the library names [["foo"; "foo.mirage"]]. In case the library name is
+    disjoint (or empty), use [~libs]. Specifying both [~libs] and [~sublibs]
+    leads to an invalid argument. Version constraints are given as [min]
+    (inclusive) and [max] (exclusive). If [pin] is provided, a
+    {{:https://opam.ocaml.org/doc/Manual.html#opamfield-pin-depends}
+     pin-depends} is generated, [pin_version] is ["dev"] by default. [~scope]
+    specifies the installation location of the package. *)
+
+(** {1:app Application Builder}
+
+    Values of type {!type-impl} are tied to concrete module implementation with
+    the {!device} and {!main} construct. Module implementations of type
+    {!type-job} can then be {{!Functoria.Lib.Make.register} registered} into an
+    application builder. The builder is in charge if parsing the command-line
+    arguments and of generating code for the final application. See
+    {!Functoria.Lib} for details. *)
+
+type info = Info.t
+(** The type for build information. *)
+
+val main :
+  ?pos:string * int * int * int ->
+  ?packages:package list ->
+  ?packages_v:package list value ->
+  ?local_libs:string list ->
+  ?runtime_args:Runtime_arg.t list ->
+  ?deps:abstract_impl list ->
+  string ->
+  'a typ ->
+  'a impl
+(** [main name typ] is the functor [name], having the module type [typ]. The
+    connect code will call [<name>.start].
+
+    - If [packages] or [packages_v] is set, then the given packages are
+      installed before compiling the current application. *)
+
+(** {1 Devices} *)
+
+type 'a code = 'a Device.code
+
+val code :
+  pos:string * int * int * int ->
+  ('a, Format.formatter, unit, 'b code) format4 ->
+  'a
+
+type 'a device = ('a, abstract_impl) Device.t
+
+val of_device : 'a device -> 'a impl
+(** [of_device t] is the implementation device [t]. *)
+
+val impl :
+  ?packages:package list ->
+  ?packages_v:package list Key.value ->
+  ?local_libs:string list ->
+  ?install:(Info.t -> Install.t) ->
+  ?install_v:(Info.t -> Install.t Key.value) ->
+  ?keys:Key.t list ->
+  ?runtime_args:Runtime_arg.t list ->
+  ?extra_deps:abstract_impl list ->
+  ?connect:(info -> string -> string list -> 'a code) ->
+  ?dune:(info -> Dune.stanza list) ->
+  ?configure:(info -> unit Action.t) ->
+  ?files:(info -> Fpath.t list) ->
+  string ->
+  'a typ ->
+  'a impl
+(** [impl ~packages ~packages_v ~install ~install_v ~keys ~runtime_args
+     ~extra_deps ~connect ~dune ~configure ~files module_name module_type] is an
+    implementation of the device constructed by the arguments. [packages] and
+    [packages_v] are the dependencies (where [packages_v] is inside
+    {!Key.value}). [install] and [install_v] are the install instructions (used
+    in the generated opam file), [keys] are the configuration-time keys,
+    [runtime_args] the arguments at runtime, [extra_deps] are a list of extra
+    dependencies (other implementations), [connect] is the code emitted for
+    initializing the device, [dune] are dune stanzas added to the build rule,
+    [configure] are commands executed at the configuration phase, [files] are
+    files to be added to the list of generated files, [module_name] is the name
+    of the device module, and [module_type] is the type of the module. *)
+
+(** {1 Jobs} *)
+
+type job = Job.t

unikernel/duniverse/mirage/lib/functoria/action.ml

@@ -0,0 +1,652 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
+ * Copyright (c) 2019-2020 Etienne Millon <etienne@tarides.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.
+ *)
+
+let src = Logs.Src.create "functoria.action" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+open Astring
+
+type 'a or_err = ('a, Rresult.R.msg) result
+type tmp_name_pat = Bos.OS.File.tmp_name_pat
+
+type 'a with_output = {
+  mode : int option;
+  path : Fpath.t;
+  purpose : string;
+  contents : Format.formatter -> 'a;
+  append : bool;
+}
+
+type channel = [ `Null | `Fmt of Format.formatter ]
+type cmd = { cmd : Bos.Cmd.t; err : channel; out : channel; trim : bool }
+type ls = { root : Fpath.t; filter : Fpath.t -> bool }
+
+type _ command =
+  | Rmdir : Fpath.t -> unit command
+  | Mkdir : Fpath.t -> bool command
+  | Ls : ls -> Fpath.t list command
+  | Rm : Fpath.t -> unit command
+  | Is_file : Fpath.t -> bool command
+  | Is_dir : Fpath.t -> bool command
+  | Size_of : Fpath.t -> int option command
+  | Run_cmd : cmd -> unit command
+  | Run_cmd_out : cmd -> string command
+  | Run_cmd_cli : Bos.Cmd.t -> unit command
+  | Get_var : string -> string option command
+  | Set_var : string * string option -> unit command
+  | With_dir : Fpath.t * (unit -> 'a t) -> 'a command
+  | Pwd : Fpath.t command
+  | Tmp_file : int option * tmp_name_pat -> Fpath.t command
+  | Write_file : Fpath.t * string -> unit command
+  | Read_file : Fpath.t -> string command
+  | With_output : 'a with_output -> 'a command
+
+and _ t =
+  | Done : 'a -> 'a t
+  | Fail : string -> 'a t
+  | Run : 'r command * ('r -> 'a t) -> 'a t
+
+let ok x = Done x
+let error e = Fail e
+let errorf fmt = Fmt.kstr error fmt
+
+let rec bind ~f = function
+  | Done r -> f r
+  | Fail s -> Fail s
+  | Run (c, k) ->
+      let k2 r = bind ~f (k r) in
+      Run (c, k2)
+
+let map ~f x = bind x ~f:(fun y -> ok (f y))
+let rec seq = function [] -> ok () | h :: t -> bind ~f:(fun () -> seq t) h
+let wrap x = Run (x, ok)
+let ( ! ) = Fpath.normalize
+let rm path = wrap @@ Rm !path
+let rmdir path = wrap @@ Rmdir !path
+let mkdir path = wrap @@ Mkdir !path
+let ls path filter = wrap @@ Ls { root = !path; filter }
+let with_dir path f = wrap @@ With_dir (!path, f)
+let pwd () = wrap @@ Pwd
+let is_file path = wrap @@ Is_file !path
+let is_dir path = wrap @@ Is_dir !path
+let size_of path = wrap @@ Size_of !path
+let set_var c v = wrap @@ Set_var (c, v)
+let get_var c = wrap @@ Get_var c
+
+let run_cmd ?(err = `Fmt Fmt.stderr) ?(out = `Fmt Fmt.stdout) cmd =
+  wrap @@ Run_cmd { cmd; out; err; trim = false }
+
+let run_cmd_out ?(err = `Fmt Fmt.stderr) cmd =
+  wrap @@ Run_cmd_out { cmd; out = `Null; err; trim = true }
+
+let run_cmd_cli cmd = wrap @@ Run_cmd_cli cmd
+let write_file path contents = wrap @@ Write_file (!path, contents)
+let read_file path = wrap @@ Read_file !path
+let tmp_file ?mode pat = wrap @@ Tmp_file (mode, pat)
+
+let with_output ?mode ?(append = false) ~path ~purpose contents =
+  wrap @@ With_output { append; mode; path; purpose; contents }
+
+let pfo ppf s = match ppf with `Null -> () | `Fmt ppf -> Fmt.pf ppf "%s%!" s
+
+let interpret_cmd { cmd; err; out; trim } =
+  Log.debug (fun l -> l "RUN: %a" Bos.Cmd.pp cmd);
+  let open Rresult in
+  let err =
+    match err with
+    | `Null -> Ok (Bos.OS.Cmd.err_null, fun () -> Ok ())
+    | `Fmt ppf ->
+        Bos.OS.File.tmp "cmd-err-%s" >>| fun path ->
+        let flush () = Bos.OS.File.read path >>| fun s -> Fmt.pf ppf "%s%!" s in
+        (Bos.OS.Cmd.err_file path, flush)
+  in
+  err >>= fun (err, flush_err) ->
+  let res = Bos.OS.Cmd.run_out ~err cmd in
+  let res = Bos.OS.Cmd.out_string ~trim res in
+  res >>= fun (str_out, _) ->
+  pfo out str_out;
+  flush_err () >>= fun () -> Bos.OS.Cmd.success res
+
+let interpret_cmd_cli cmd =
+  Log.debug (fun l -> l "RUN-CLI: %a" Bos.Cmd.pp cmd);
+  let res = Bos.OS.Cmd.run_out cmd in
+  match Bos.OS.Cmd.out_stdout res with
+  | Ok ((), (_, `Exited 0)) -> Ok ()
+  | Ok ((), (_, `Exited _)) -> Error (`Msg "")
+  | failure -> Bos.OS.Cmd.success failure
+
+let rec interpret_command : type r. r command -> r or_err = function
+  | Rmdir path ->
+      Log.debug (fun l -> l "rmdir %a" Fpath.pp path);
+      Bos.OS.Dir.delete ~recurse:true path
+  | Mkdir path ->
+      Log.debug (fun l -> l "mkdir %a" Fpath.pp path);
+      Bos.OS.Dir.create ~path:true path
+  | Ls { root; filter } ->
+      let open Rresult in
+      Log.debug (fun l -> l "ls %a" Fpath.pp root);
+      Bos.OS.Path.matches ~dotfiles:true Fpath.(root / "$(file)")
+      >>| fun files -> List.filter filter files
+  | Rm path ->
+      Log.debug (fun l -> l "rm %a" Fpath.pp path);
+      Bos.OS.File.delete ~must_exist:false path
+  | Is_file path ->
+      Log.debug (fun l -> l "is-file %a" Fpath.pp path);
+      Bos.OS.File.exists path
+  | Is_dir path ->
+      Log.debug (fun l -> l "is-dir %a" Fpath.pp path);
+      Bos.OS.Dir.exists path
+  | Size_of path -> (
+      Log.debug (fun l -> l "size-of %a" Fpath.pp path);
+      match Bos.OS.Path.stat path with
+      | Ok s -> Ok (Some s.Unix.st_size)
+      | _ -> Ok None)
+  | Run_cmd cmd -> Rresult.(interpret_cmd cmd >>| fun _ -> ())
+  | Run_cmd_out cmd -> interpret_cmd cmd
+  | Run_cmd_cli cmd -> interpret_cmd_cli cmd
+  | Set_var (c, v) ->
+      Log.debug (fun l ->
+          l "set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v);
+      Bos.OS.Env.set_var c v
+  | Get_var c ->
+      Log.debug (fun l -> l "get_var %s" c);
+      Ok (Bos.OS.Env.var c)
+  | With_dir (dir, f) ->
+      let f () = run (f ()) in
+      let open Rresult in
+      Bos.OS.Dir.current () >>= fun old ->
+      Log.debug (fun l -> l "entering %a" Fpath.pp dir);
+      Rresult.R.join @@ Bos.OS.Dir.with_current dir f () >>| fun r ->
+      Log.debug (fun l -> l "entering %a" Fpath.pp old);
+      r
+  | Pwd ->
+      Log.debug (fun l -> l "pwd");
+      Bos.OS.Dir.current ()
+  | Write_file (path, contents) ->
+      Log.debug (fun l -> l "write %a" Fpath.pp path);
+      Bos.OS.File.write path contents
+  | Read_file path ->
+      Log.debug (fun l -> l "read-file %a" Fpath.pp path);
+      Bos.OS.File.read path
+  | Tmp_file (mode, pat) ->
+      Log.debug (fun l -> l "tmp-file %s" Fmt.(str pat "*"));
+      Bos.OS.File.tmp ?mode pat
+  | With_output { mode; path; purpose; contents; append } -> (
+      try
+        let oc =
+          let path = Fpath.to_string path in
+          let mode = match mode with None -> 0o666 | Some m -> m in
+          if append then
+            open_out_gen [ Open_wronly; Open_append; Open_text ] mode path
+          else open_out path
+        in
+        let ppf = Format.formatter_of_out_channel oc in
+        let r = contents ppf in
+        Fmt.pf ppf "%!";
+        flush oc;
+        close_out oc;
+        Ok r
+      with e ->
+        Rresult.R.error_msgf "couldn't open output channel for %s: %a" purpose
+          Fmt.exn e)
+
+and run : type r. r t -> r or_err = function
+  | Done r -> Ok r
+  | Fail f -> Error (`Msg f)
+  | Run (cmd, k) -> Rresult.R.bind (interpret_command cmd) (fun x -> run @@ k x)
+
+type files = [ `Passtrough of Fpath.t | `Files of (Fpath.t * string) list ]
+
+let default_exec cmd =
+  let cmd =
+    Fmt.str "$(%a)\n" Fmt.(list ~sep:(any " ") string) (Bos.Cmd.to_list cmd)
+  in
+  Some (cmd, "")
+
+(* (simple) virtual environment *)
+module Env : sig
+  type t
+
+  val eq : t -> t -> bool
+  val pp : t Fmt.t
+  val diff_files : old:t -> t -> Fpath.Set.t
+  val pwd : t -> Fpath.t
+  val chdir : t -> Fpath.t -> t
+  val ls : t -> Fpath.t -> Fpath.t list option
+
+  val v :
+    ?exec:(Bos.Cmd.t -> (string * string) option) ->
+    ?env:(string * string) list ->
+    ?pwd:Fpath.t ->
+    ?files:files ->
+    unit ->
+    t
+
+  val exec : t -> Bos.Cmd.t -> (string * string) option
+  val is_file : t -> Fpath.t -> bool
+  val is_dir : t -> Fpath.t -> bool
+  val mkdir : t -> Fpath.t -> (t * bool) option
+  val rm : t -> Fpath.t -> (t * bool) option
+  val rmdir : t -> Fpath.t -> t
+  val size_of : t -> Fpath.t -> int option
+  val write : t -> Fpath.t -> string -> t
+  val read : t -> Fpath.t -> string option
+  val tmp_file : t -> tmp_name_pat -> Fpath.t
+  val set_var : t -> string -> string option -> t
+  val get_var : t -> string -> string option
+end = struct
+  type t = {
+    files : string Fpath.Map.t;
+    pwd : Fpath.t;
+    env : string String.Map.t;
+    exec : Bos.Cmd.t -> (string * string) option;
+  }
+
+  let diff_files ~old t =
+    let to_set t =
+      Fpath.Map.fold
+        (fun f _ acc ->
+          match Fpath.rem_prefix t.pwd f with
+          | None -> acc
+          | Some f -> Fpath.Set.add f acc)
+        t.files Fpath.Set.empty
+    in
+    Fpath.Set.diff (to_set t) (to_set old)
+
+  let scan dir =
+    (let open Rresult in
+     Bos.OS.Path.fold ~dotfiles:true ~elements:`Files ~traverse:`Any
+       (fun file files ->
+         files >>= fun files ->
+         Bos.OS.File.read file >>| fun c -> (file, c) :: files)
+       (Ok []) [ dir ])
+    |> Rresult.R.join
+    |> Rresult.R.error_msg_to_invalid_arg
+
+  let v ?(exec = default_exec) ?env ?pwd ?(files = `Files []) () =
+    let env =
+      match env with Some e -> String.Map.of_list e | None -> String.Map.empty
+    in
+    let pwd = match pwd with None -> Fpath.v "/" | Some p -> p in
+    let files =
+      let files =
+        match files with `Passtrough dir -> scan dir | `Files files -> files
+      in
+      let files =
+        List.map
+          (fun (f, c) ->
+            match Fpath.is_rel f with
+            | false -> (f, c)
+            | true -> (Fpath.(pwd // f), c))
+          files
+      in
+      List.map (fun (f, c) -> (Fpath.normalize f, c)) files
+    in
+    { files = Fpath.Map.of_list files; pwd; env; exec }
+
+  let eq x y =
+    Fpath.Map.equal ( = ) x.files y.files
+    && Fpath.equal x.pwd y.pwd
+    && String.Map.equal ( = ) x.env y.env
+
+  let pp =
+    let open Fmt.Dump in
+    record
+      [
+        field "files" (fun t -> t.files) (Fpath.Map.dump string);
+        field "pwd" (fun t -> t.pwd) Fpath.dump;
+        field "env" (fun t -> t.env) (String.Map.dump string);
+      ]
+
+  let pwd t = t.pwd
+  let exec t cmd = t.exec cmd
+
+  let mk_path t path =
+    match (Fpath.to_string t.pwd, Fpath.is_rel path) with
+    | _, true -> Fpath.(normalize @@ (t.pwd // path))
+    | _, false -> Fpath.normalize path
+
+  let chdir t path =
+    let pwd = mk_path t path in
+    { t with pwd }
+
+  let is_root path = Fpath.to_string path = "/"
+
+  let mkdir t path =
+    let path = mk_path t path in
+    if is_root path then Some (t, false)
+    else
+      match Fpath.Map.find path t.files with
+      | Some f when f <> "<DIR>" -> None
+      | r ->
+          let t = { t with files = Fpath.Map.add path "<DIR>" t.files } in
+          Some (t, r = None)
+
+  let rmdir t path =
+    let path = mk_path t path in
+    let files =
+      Fpath.Map.filter
+        (fun f _ ->
+          let f = mk_path t f in
+          let b = not (Fpath.is_prefix path f) in
+          b)
+        t.files
+    in
+    { t with files }
+
+  let ls t path =
+    let root = mk_path t path in
+    match Fpath.Map.find root t.files with
+    | Some "<DIR>" -> Some []
+    | Some _ -> Some [ path ]
+    | None -> (
+        Fpath.Map.fold
+          (fun file _ acc ->
+            let file = mk_path t file in
+            match Fpath.relativize ~root file with
+            | None -> acc
+            | Some f -> f :: acc)
+          t.files []
+        |> function
+        | [] -> None
+        | x -> Some (List.rev x))
+
+  let write t path f =
+    let path = mk_path t path in
+    { t with files = Fpath.Map.add path f t.files }
+
+  let read t path =
+    let path = mk_path t path in
+    Fpath.Map.find path t.files
+
+  let tmp_file t pat =
+    let rec aux n =
+      let dir = Fpath.v "/tmp" in
+      let file = Fpath.(dir / Fmt.str pat (string_of_int n)) in
+      if Fpath.Map.mem file t.files then aux (n + 1) else file
+    in
+    aux 0
+
+  let is_dir t path =
+    let path = mk_path t path in
+    match Fpath.Map.find path t.files with
+    | Some "<DIR>" -> true
+    | Some _ -> false
+    | None ->
+        Fpath.Map.exists
+          (fun f _ ->
+            let f = mk_path t f in
+            Fpath.is_prefix path f)
+          t.files
+
+  let is_file t path =
+    let path = mk_path t path in
+    match Fpath.Map.find path t.files with
+    | Some "<DIR>" | None -> false
+    | Some _ -> true
+
+  let rm t path =
+    let path = mk_path t path in
+    match Fpath.Map.find path t.files with
+    | Some "<DIR>" -> None
+    | Some _ -> Some ({ t with files = Fpath.Map.remove path t.files }, true)
+    | None -> if is_dir t path then None else Some (t, false)
+
+  let size_of t path =
+    let path = mk_path t path in
+    match Fpath.Map.find path t.files with
+    | None -> None
+    | Some "<DIR>" -> Some 0
+    | Some f -> Some (String.length f)
+
+  let set_var t c = function
+    | None -> { t with env = String.Map.remove c t.env }
+    | Some v -> { t with env = String.Map.add c v t.env }
+
+  let get_var t c = String.Map.find c t.env
+end
+
+let error_msg = Rresult.R.error_msgf
+
+type env = Env.t
+
+let env = Env.v
+
+type 'a domain = { result : 'a or_err; env : Env.t; logs : string list }
+
+let pp_or_err pp_a = Rresult.R.pp ~error:Rresult.R.pp_msg ~ok:pp_a
+let eq_or_err eq_a = Rresult.R.equal ~error:( = ) ~ok:eq_a
+
+let pp_domain pp_a =
+  let open Fmt.Dump in
+  record
+    [
+      field "result" (fun t -> t.result) (pp_or_err pp_a);
+      field "env" (fun t -> t.env) Env.pp;
+      field "logs" (fun t -> t.logs) Fmt.Dump.(list string);
+    ]
+
+let eq_domain eq a b =
+  eq_or_err eq a.result b.result && Env.eq a.env b.env && a.logs = b.logs
+
+let dom result env logs = { result; env; logs }
+
+let interpret_dry_cmd env { cmd; err; out; _ } : string domain =
+  Log.debug (fun l -> l "Run_cmd '%a'" Bos.Cmd.pp cmd);
+  let log x = Fmt.str "Run_cmd '%a' (%s)" Bos.Cmd.pp cmd x in
+  match Env.exec env cmd with
+  | None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
+  | Some (o, e) ->
+      pfo out o;
+      pfo err e;
+      dom (Ok o) env [ log "ok" ]
+
+let interpret_dry_cmd_cli env cmd : unit domain =
+  Log.debug (fun l -> l "Run_cmd_cli '%a'" Bos.Cmd.pp cmd);
+  let log x = Fmt.str "Run_cmd_cli '%a' (%s)" Bos.Cmd.pp cmd x in
+  match Env.exec env cmd with
+  | None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
+  | Some _ -> dom (Ok ()) env [ log "ok" ]
+
+let rec interpret_dry : type r. env:Env.t -> r command -> r domain =
+ fun ~env -> function
+  | Mkdir path -> (
+      Log.debug (fun l -> l "Mkdir %a" Fpath.pp path);
+      let log s = Fmt.str "Mkdir %a (%s)" Fpath.pp path s in
+      match Env.mkdir env path with
+      | Some (env, true) -> dom (Ok true) env [ log "created" ]
+      | Some (env, false) -> dom (Ok false) env [ log "already exists" ]
+      | None ->
+          dom
+            (error_msg "a file named '%a' already exists" Fpath.pp path)
+            env
+            [ log "error" ])
+  | Rmdir path ->
+      Log.debug (fun l -> l "Rmdir %a" Fpath.pp path);
+      let log s = Fmt.str "Rmdir %a (%s)" Fpath.pp path s in
+      if Env.is_dir env path || Env.is_file env path then
+        dom (Ok ()) (Env.rmdir env path) [ log "removed" ]
+      else dom (Ok ()) env [ log "no-op" ]
+  | Ls { root; filter } -> (
+      Log.debug (fun l -> l "Ls %a" Fpath.pp root);
+      let logs fmt = Fmt.kstr (Fmt.str "Ls %a (%s)" Fpath.pp root) fmt in
+      match Env.ls env root with
+      | None ->
+          dom
+            (error_msg "%a: no such file or directory" Fpath.pp root)
+            env
+            [ logs "error" ]
+      | Some es -> (
+          match List.filter filter es with
+          | ([] | [ _ ]) as e ->
+              dom (Ok e) env [ logs "%d entry" (List.length e) ]
+          | es -> dom (Ok es) env [ logs "%d entries" (List.length es) ]))
+  | Rm path -> (
+      Log.debug (fun l -> l "Rm %a" Fpath.pp path);
+      let log s = Fmt.str "Rm %a (%s)" Fpath.pp path s in
+      match Env.rm env path with
+      | Some (env, b) ->
+          dom (Ok ()) env [ log (if b then "removed" else "no-op") ]
+      | None ->
+          dom (error_msg "%a is a directory" Fpath.pp path) env [ log "error" ])
+  | Is_file path ->
+      Log.debug (fun l -> l "Is_file %a" Fpath.pp path);
+      let r = Env.is_file env path in
+      dom (Ok r) env [ Fmt.str "Is_file? %a -> %b" Fpath.pp path r ]
+  | Is_dir path ->
+      Log.debug (fun l -> l "Is_dir %a" Fpath.pp path);
+      let r = Env.is_dir env path in
+      dom (Ok r) env [ Fmt.str "Is_dir? %a -> %b" Fpath.pp path r ]
+  | Size_of path ->
+      Log.debug (fun l -> l "Size_of %a" Fpath.pp path);
+      let r = Env.size_of env path in
+      dom (Ok r) env
+        [
+          Fmt.str "Size_of %a -> %a" Fpath.pp path
+            Fmt.(option ~none:(any "error") int)
+            r;
+        ]
+  | Run_cmd cmd -> (
+      let domain = interpret_dry_cmd env cmd in
+      match domain.result with
+      | Ok _ -> { domain with result = Ok () }
+      | Error _ as r -> { domain with result = r })
+  | Run_cmd_out cmd -> interpret_dry_cmd env cmd
+  | Run_cmd_cli cmd -> interpret_dry_cmd_cli env cmd
+  | Write_file (path, s) ->
+      Log.debug (fun l -> l "Write_file %a" Fpath.pp path);
+      dom (Ok ()) (Env.write env path s)
+        [ Fmt.str "Write to %a (%d bytes)" Fpath.pp path (String.length s) ]
+  | Read_file path -> (
+      Log.debug (fun l -> l "Read_file %a" Fpath.pp path);
+      match Env.read env path with
+      | None ->
+          let log = Fmt.str "Read: %a" Fpath.pp path in
+          dom (error_msg "read_file: file does not exist") env [ log ]
+      | Some r ->
+          let log =
+            Fmt.str "Read %a (%d bytes)" Fpath.pp path (String.length r)
+          in
+          dom (Ok r) env [ log ])
+  | Tmp_file (_, pat) ->
+      Log.debug (fun l -> l "Tmp_file %s" Fmt.(str pat "*"));
+      let r = Env.tmp_file env pat in
+      dom (Ok r) env [ Fmt.str "Tmp_file -> %a" Fpath.pp r ]
+  | Set_var (c, v) ->
+      Log.debug (fun l ->
+          l "Set_var %s %a" c Fmt.(option ~none:(any "<none>") string) v);
+      let env = Env.set_var env c v in
+      let log =
+        Fmt.str "Set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v
+      in
+      dom (Ok ()) env [ log ]
+  | Get_var c ->
+      Log.debug (fun l -> l "Get_var %s" c);
+      let v = Env.get_var env c in
+      let log =
+        Fmt.str "Get_var %s -> %a" c
+          Fmt.(option ~none:(any "<not set>") string)
+          v
+      in
+      dom (Ok v) env [ log ]
+  | With_dir (dir, f) ->
+      Log.debug (fun l -> l "With_dir %a" Fpath.pp dir);
+      let old = Env.pwd env in
+      let env = Env.chdir env dir in
+      let domain = dry_run ~env (f ()) in
+      let env = Env.chdir domain.env old in
+      let log =
+        Fmt.str "With_dir %a [%a]" Fpath.pp dir
+          Fmt.(vbox ~indent:2 (list ~sep:(any "@,") string))
+          domain.logs
+      in
+      { domain with env; logs = [ log ] }
+  | Pwd ->
+      Log.debug (fun l -> l "Pwd");
+      let r = Env.pwd env in
+      dom (Ok r) env [ Fmt.str "Pwd -> %a" Fpath.pp r ]
+  | With_output { mode; path; purpose; contents; append } ->
+      let pp_append ppf () = if append then Fmt.string ppf "[append]" else () in
+      Log.debug (fun l ->
+          l "With_output%a %a (%s)" pp_append () Fpath.pp path purpose);
+      let buf = Buffer.create 0 in
+      let fmt = Format.formatter_of_buffer buf in
+      let pp_mode fmt = function
+        | None -> Format.fprintf fmt "default"
+        | Some n -> Format.fprintf fmt "%#o" n
+      in
+      let r = contents fmt in
+      Fmt.pf fmt "%!";
+      let f = Buffer.contents buf in
+      let log =
+        Fmt.str "Write to %a (mode: %a, purpose: %s)" Fpath.pp path pp_mode mode
+          purpose
+      in
+      dom (Ok r) (Env.write env path f) [ log ]
+
+and dry_run : type r. env:Env.t -> r t -> r domain =
+ fun ~env t ->
+  let rec go t ~env log =
+    match t with
+    | Done r -> dom (Ok r) env log
+    | Fail e -> dom (Error (`Msg e)) env log
+    | Run (cmd, k) -> (
+        let domain = interpret_dry ~env cmd in
+        let new_log = List.rev domain.logs @ log in
+        match domain.result with
+        | Ok x -> go (k x) ~env:domain.env new_log
+        | Error _ as e -> dom e domain.env new_log)
+  in
+  let domain = go t ~env [] in
+  { domain with logs = List.rev domain.logs }
+
+let dry_run ?(env = env ()) t = dry_run ~env t
+
+let dry_run_trace ?env t =
+  let domain = dry_run ?env t in
+  List.iter print_endline domain.logs
+
+let generated_files ?(env = env ~exec:(fun _ -> None) ()) t =
+  let domain = dry_run ~env t in
+  Env.diff_files ~old:env domain.env
+
+module Infix = struct
+  let ( >>= ) x f = bind ~f x
+  let ( >|= ) x f = map ~f x
+end
+
+module Syntax = struct
+  open Infix
+
+  let ( let* ) = ( >>= )
+  let ( let+ ) = ( >|= )
+end
+
+module List = struct
+  open Infix
+
+  let iter ~f l = List.fold_left (fun acc e -> acc >>= fun () -> f e) (ok ()) l
+
+  let map ~f l =
+    List.fold_left
+      (fun acc e ->
+        acc >>= fun acc ->
+        f e >|= fun e -> e :: acc)
+      (ok []) l
+end

unikernel/duniverse/mirage/lib/functoria/action.mli

@@ -0,0 +1,182 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
+ * Copyright (c) 2019-2020 Etienne Millon <etienne@tarides.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.
+ *)
+
+(** Wrapper around [Bos] which provides a "dry run" feature. *)
+
+(** {1 The action type} *)
+
+type 'a t
+(** An action that when executed may return a value of type ['a]. *)
+
+val ok : 'a -> 'a t
+(** An action that returns a value. *)
+
+val error : string -> 'a t
+(** [error e] is the failed action with error message [e]. *)
+
+val errorf : ('a, Format.formatter, unit, 'b t) format4 -> 'a
+(** [errorf fmt] is the failed action with error message [fmt]. *)
+
+val map : f:('a -> 'b) -> 'a t -> 'b t
+(** Functor instance. *)
+
+val bind : f:('a -> 'b t) -> 'a t -> 'b t
+(** Monad instance. *)
+
+val seq : unit t list -> unit t
+(** [seq t] runs the elements of [t] in sequence. *)
+
+module List : sig
+  val iter : f:('a -> unit t) -> 'a list -> unit t
+  val map : f:('a -> 'b t) -> 'a list -> 'b list t
+end
+
+module Infix : sig
+  val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+  val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module Syntax : sig
+  val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
+  val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+end
+
+(** {1 Actions} *)
+
+val rm : Fpath.t -> unit t
+(** Delete a file. (see [Bos.OS.File.delete]) *)
+
+val mkdir : Fpath.t -> bool t
+(** Create a directory. (See [Bos.OS.Dir.create] *)
+
+val rmdir : Fpath.t -> unit t
+(** Remove a directory. (see [Bos.OS.Dir.delete]) *)
+
+val with_dir : Fpath.t -> (unit -> 'a t) -> 'a t
+(** [with_dir d f] runs [f] with [d] as current working directory. (See
+    [Bos.OS.Dir.with_current]). *)
+
+val pwd : unit -> Fpath.t t
+(** [pwd ()] is the current working directory. (See [Bos.OS.Dir.current]) *)
+
+val is_file : Fpath.t -> bool t
+(** Does a file exist? (see [Bos.OS.File.exists]) *)
+
+val is_dir : Fpath.t -> bool t
+(** Does a directory exist? (see [Bos.OS.Dir.exists]) *)
+
+val size_of : Fpath.t -> int option t
+(** [size_of f] is [Some i] if [f] exists and is of size [i], and [None] if [f]
+    doesn't exist. *)
+
+val set_var : string -> string option -> unit t
+(** [set_var v c] sets env variable [c] to [c]. (see [Bos.OS.Env.set_var]) *)
+
+val get_var : string -> string option t
+(** [get_var v] gets the value of the variable [c] in the environment. (see
+    [Bos.OS.Env.get]) *)
+
+type channel = [ `Null | `Fmt of Format.formatter ]
+(** The type for channels. *)
+
+val run_cmd : ?err:channel -> ?out:channel -> Bos.Cmd.t -> unit t
+(** Run a command. By default, [err] is [Fmt.stderr] and [out] is [Fmt.stdout].
+    (see [Bos.OS.Cmd.run]) *)
+
+val run_cmd_out : ?err:channel -> Bos.Cmd.t -> string t
+(** Run a command and return its trimmed stdout. By default [err] is
+    [Fmt.stderr]. (See [Bos.OS.Cmd.run_out]) *)
+
+val run_cmd_cli : Bos.Cmd.t -> unit t
+(** Run a command as a command line interface, meaning stdout and stderr remain
+    untouched. *)
+
+val write_file : Fpath.t -> string -> unit t
+(** Write some data to a file. (see [Bos.OS.File.write]) *)
+
+val read_file : Fpath.t -> string t
+(** [read_file f] is [f]'s contents. (see [Bos.OS.File.read]) *)
+
+val tmp_file : ?mode:int -> Bos.OS.File.tmp_name_pat -> Fpath.t t
+(** [tmp_file pat] is a tempory file built using the pattern [pat]. (See
+    [Bos.OS.File.tmp]) *)
+
+val ls : Fpath.t -> (Fpath.t -> bool) -> Fpath.t list t
+(** [ls dir] is the list of files in [dir]. *)
+
+val with_output :
+  ?mode:int ->
+  ?append:bool ->
+  path:Fpath.t ->
+  purpose:string ->
+  (Format.formatter -> 'a) ->
+  'a t
+(** Open a file with a given mode, and write some data to it through a function.
+    (see [Bos.OS.File.with_oc]). [purpose] is used in error messages. If
+    [append] is set (by default it is not), the data is appended to [path]. *)
+
+(** {1 Interpreters} *)
+
+val run : 'a t -> ('a, Rresult.R.msg) result
+(** Run the command through [Bos]. *)
+
+type env
+(** The type for virtual environments. *)
+
+type files = [ `Passtrough of Fpath.t | `Files of (Fpath.t * string) list ]
+
+val default_exec : Bos.Cmd.t -> (string * string) option
+(** [default_exec cmd] is [Some ("$(<cmd>)", "")]. *)
+
+val env :
+  ?exec:(Bos.Cmd.t -> (string * string) option) ->
+  ?env:(string * string) list ->
+  ?pwd:Fpath.t ->
+  ?files:files ->
+  unit ->
+  env
+
+type 'a domain = {
+  result : ('a, Rresult.R.msg) result;
+  env : env;
+  logs : string list;
+}
+(** The type for interpreted values. *)
+
+val eq_domain : ('a -> 'a -> bool) -> 'a domain -> 'a domain -> bool
+(** [eq_domain] is the equality function between {!domain}s. *)
+
+val pp_domain : 'a Fmt.t -> 'a domain Fmt.t
+(** [pp_domain] is the pretty-printer for {!domain}s. *)
+
+val dry_run : ?env:env -> 'a t -> 'a domain
+(** Emulate the action. This will not do IO on the actual files. Some
+    approximation is done to determine the result of actions. [files] is a list
+    of paths that are supposed to exist at the beginning. Returns:
+
+    - the result of the action (which can be an [Bos] error)
+    - the list of files after execution
+    - a trace (list of log messages) *)
+
+val dry_run_trace : ?env:env -> 'a t -> unit
+(** Only output the trace part of [dry_run]. *)
+
+val generated_files : ?env:env -> 'a t -> Fpath.Set.t
+(** [generated_files t] is the set of files created by [t]. Note: this might be
+    incomplete/incorrect in case of calls to external commands. *)

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

@@ -0,0 +1,25 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t = ARGV
+
+let argv = Type.v ARGV
+
+let sys_argv =
+  let connect _ _ _ = Device.code ~pos:__POS__ "return Sys.argv" in
+  Impl.v ~connect "Sys" argv

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

@@ -0,0 +1,29 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Device representing the command line. *)
+
+type t
+(** The type for command-line arguments, similar to the usual [Sys.argv]. *)
+
+val argv : t Type.t
+(** [argv] is a value representing {!argv} module types. *)
+
+val sys_argv : t Impl.t
+(** [sys_argv] is a device providing command-line arguments by using
+    {!Sys.argv}. *)

unikernel/duniverse/mirage/lib/functoria/cli.ml

@@ -0,0 +1,591 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ())
+
+open Cmdliner
+
+let common_section = "COMMON OPTIONS"
+let configuration_section = "CONFIGURE OPTIONS"
+let query_section = "QUERY OPTIONS"
+let description_section = "DESCRIBE OPTIONS"
+
+type query_kind =
+  [ `Name
+  | `Packages
+  | `Opam
+  | `Files
+  | `Dune of [ `Config | `Build | `Project | `Workspace | `Dist ]
+  | `Makefile ]
+
+let query_kinds : (string * query_kind) list =
+  [
+    ("name", `Name);
+    ("packages", `Packages);
+    ("opam", `Opam);
+    ("files", `Files);
+    ("Makefile", `Makefile);
+    ("dune.config", `Dune `Config);
+    ("dune.build", `Dune `Build);
+    ("dune-project", `Dune `Project);
+    ("dune-workspace", `Dune `Workspace);
+    ("dune.dist", `Dune `Dist);
+  ]
+
+let setup ~with_setup =
+  Term.(
+    const (if with_setup then setup_log else fun _ _ -> ())
+    $ Fmt_cli.style_renderer ~docs:common_section ()
+    $ Logs_cli.level ~docs:common_section ())
+
+let config_file =
+  let doc =
+    Arg.info ~docs:configuration_section ~docv:"FILE"
+      ~doc:"The configuration file to use."
+      [ "f"; "file"; "config-file" ]
+  in
+  Term.(const Fpath.v $ Arg.(value & opt string "config.ml" & doc))
+
+let map_default ~default f x = if x == default then None else Some (f x)
+
+let context_file mname =
+  let doc =
+    Arg.info ~docs:configuration_section ~docv:"FILE"
+      ~doc:"The context file to use." [ "context-file" ]
+  in
+  let default = mname ^ ".context" in
+  Term.(
+    const (map_default ~default Fpath.v)
+    $ Arg.(value & opt string default & doc))
+
+let extra_repos doc_section =
+  let key =
+    let parser str =
+      match Astring.String.cut ~sep:":" str with
+      | Some (name, repository) -> Ok (name, repository)
+      | None ->
+          Rresult.R.error_msgf
+            "Invalid extra repository argument (expected <name>:<repository>)"
+    in
+    let pp ppf (name, repository) = Fmt.pf ppf "%s:%s" name repository in
+    Arg.conv (parser, pp)
+  in
+  let env = Cmd.Env.info "MIRAGE_EXTRA_REPOS" in
+  let doc =
+    Arg.info ~docs:doc_section ~docv:"NAME1:URL1,NAME2:URL2,..." ~env
+      ~doc:
+        "Additional opam-repositories to use when using `opam monorepo lock' \
+         to gather local sources. Default: \
+         https://github.com/dune-universe/opam-overlays.git & \
+         https://github.com/dune-universe/mirage-opam-overlays.git."
+      [ "extra-repos" ]
+  in
+  Arg.(
+    value
+    & opt (list key)
+        [
+          ("opam-overlays", "https://github.com/dune-universe/opam-overlays.git");
+          ( "mirage-overlays",
+            "https://github.com/dune-universe/mirage-opam-overlays.git" );
+        ]
+    & doc)
+
+let no_extra_repo doc_section =
+  let doc =
+    Arg.info ~docs:doc_section ~doc:"Disable the use of any overlay repository."
+      [ "no-extra-repo" ]
+  in
+  Arg.(value & flag & doc)
+
+let extra_repos doc_section =
+  let ex = extra_repos doc_section in
+  let no_ex = no_extra_repo doc_section in
+  Term.(const (fun ex no_ex -> if no_ex then [] else ex) $ ex $ no_ex)
+
+let dry_run =
+  let doc =
+    Arg.info ~docs:configuration_section
+      ~doc:"Display I/O actions instead of executing them." [ "dry-run" ]
+  in
+  Arg.(value & flag doc)
+
+(** * Argument specifications *)
+
+(** Argument specification for --depext *)
+let depext section =
+  let depext_doc =
+    Arg.info ~docs:section [ "depext" ]
+      ~doc:"Enable call to `opam depext' in the project Makefile."
+  in
+  let no_depext_doc =
+    Arg.info ~docs:section [ "no-depext" ]
+      ~doc:"Disable call to `opam depext' in the project Makefile."
+  in
+  let eval_opts = [ (true, depext_doc); (false, no_depext_doc) ] in
+  Arg.(value & vflag true eval_opts)
+
+(** Argument specification for --eval *)
+let full_eval =
+  let eval_doc =
+    Arg.info ~docs:description_section [ "eval" ]
+      ~doc:
+        "Fully evaluate the graph before showing it. The default when the \
+         unikernel has already been configured."
+  in
+  let no_eval_doc =
+    Arg.info ~docs:description_section [ "no-eval" ]
+      ~doc:
+        "Do not evaluate the graph before showing it. See $(b,--eval). The \
+         default when the unikernel has not been configured."
+  in
+  let eval_opts = [ (Some true, eval_doc); (Some false, no_eval_doc) ] in
+  Arg.(value & vflag None eval_opts)
+
+(** Argument specification for --dot *)
+let dot =
+  let doc =
+    Arg.info ~docs:description_section [ "dot" ]
+      ~doc:
+        "Output a dot description. If no output file is given, it will display \
+         the dot file using the  command  given to $(b,--dot-command). Use in \
+         combination with $(b,--output=-) (short version: $(b,-o-)) to display \
+         the dot file on stdout."
+  in
+  Arg.(value & flag doc)
+
+(** Argument specification for --dot-command=COMMAND *)
+let dotcmd =
+  let doc =
+    Arg.info ~docs:description_section ~docv:"COMMAND" [ "dot-command" ]
+      ~doc:
+        "Command used to show a dot file. This command should accept a dot \
+         file on its standard input."
+  in
+  Arg.(value & opt string "xdot" & doc)
+
+(** Argument specification for -o FILE or --output=FILE *)
+let output =
+  let doc =
+    Arg.info ~docs:configuration_section ~docv:"FILE" [ "o"; "output" ]
+      ~doc:"Name of the output file."
+  in
+  Arg.(value & opt (some string) None & doc)
+
+let kind =
+  let enums = Arg.doc_alts_enum ~quoted:true query_kinds in
+  let doc =
+    Arg.info ~docs:configuration_section ~docv:"INFO" []
+      ~doc:(Fmt.str "The information to query. $(docv) must be %s" enums)
+  in
+  Arg.(value & pos 0 (enum query_kinds) `Packages & doc)
+
+type 'a args = {
+  context : 'a;
+  config_file : Fpath.t;
+  context_file : Fpath.t option;
+  output : string option;
+  dry_run : bool;
+}
+
+let default_args =
+  {
+    context = ();
+    config_file = Fpath.v "dummy";
+    context_file = None;
+    output = None;
+    dry_run = false;
+  }
+
+type 'a configure_args = {
+  args : 'a args;
+  depext : bool;
+  extra_repo : (string * string) list;
+}
+
+type 'a build_args = 'a args
+type 'a clean_args = 'a args
+type 'a help_args = 'a args
+
+type 'a describe_args = {
+  args : 'a args;
+  dotcmd : string;
+  dot : bool;
+  eval : bool option;
+}
+
+type 'a query_args = {
+  args : 'a args;
+  kind : query_kind;
+  depext : bool;
+  extra_repo : (string * string) list;
+}
+
+type 'a action =
+  | Configure of 'a configure_args
+  | Query of 'a query_args
+  | Describe of 'a describe_args
+  | Clean of 'a clean_args
+  | Help of 'a help_args
+
+(*
+ * Pretty-printing
+ *)
+
+let pp_args pp_a =
+  let open Fmt.Dump in
+  record
+    [
+      field "context" (fun (t : 'a args) -> t.context) pp_a;
+      field "config_file" (fun t -> t.config_file) Fpath.pp;
+      field "output" (fun t -> t.output) (option string);
+      field "dry_run" (fun t -> t.dry_run) Fmt.bool;
+    ]
+
+let pp_configure pp_a =
+  let open Fmt.Dump in
+  record
+    [
+      field "args" (fun (t : 'a configure_args) -> t.args) (pp_args pp_a);
+      field "depext" (fun (t : 'a configure_args) -> t.depext) Fmt.bool;
+    ]
+
+let pp_clean = pp_args
+let pp_help = pp_args
+
+let pp_query_kind ppf (q : query_kind) =
+  let rec aux = function
+    | [] -> invalid_arg "missing query kind!"
+    | (a, b) :: t -> if b = q then Fmt.string ppf a else aux t
+  in
+  aux query_kinds
+
+let pp_query pp_a =
+  let open Fmt.Dump in
+  record
+    [
+      field "args" (fun (t : 'a query_args) -> t.args) (pp_args pp_a);
+      field "kind" (fun t -> t.kind) pp_query_kind;
+      field "depext" (fun t -> t.depext) Fmt.bool;
+    ]
+
+let pp_describe pp_a =
+  let open Fmt.Dump in
+  record
+    [
+      field "args" (fun (t : 'a describe_args) -> t.args) (pp_args pp_a);
+      field "dotcmd" (fun t -> t.dotcmd) string;
+      field "dot" (fun t -> t.dot) Fmt.bool;
+      field "eval" (fun t -> t.eval) (option Fmt.bool);
+    ]
+
+let pp_action pp_a ppf = function
+  | Configure c -> Fmt.pf ppf "@[configure:@ @[<2>%a@]@]" (pp_configure pp_a) c
+  | Query q -> Fmt.pf ppf "@[query:@ @[<2>%a@]@]" (pp_query pp_a) q
+  | Describe d -> Fmt.pf ppf "@[describe:@ @[<2>%a@]@]" (pp_describe pp_a) d
+  | Clean c -> Fmt.pf ppf "@[clean:@ @[<2>%a@]@]" (pp_clean pp_a) c
+  | Help h -> Fmt.pf ppf "@[help:@ @[<2>%a@]@]" (pp_help pp_a) h
+
+(*
+ * Subcommand specifications
+ *)
+
+module Subcommands = struct
+  type 'a t = { with_setup : bool; mname : string; context : 'a Term.t }
+
+  module T = struct
+    let args { with_setup; context; mname } =
+      Term.(
+        const (fun () config_file context_file dry_run output context ->
+            { config_file; context_file; dry_run; output; context })
+        $ setup ~with_setup
+        $ config_file
+        $ context_file mname
+        $ dry_run
+        $ output
+        $ context)
+  end
+
+  (** The 'configure' subcommand *)
+  let configure t =
+    ( Term.(
+        const (fun args depext extra_repo ->
+            Configure { args; depext; extra_repo })
+        $ T.args t
+        $ depext configuration_section
+        $ extra_repos configuration_section),
+      Cmd.info "configure" ~doc:"Configure a $(mname) application."
+        ~man:
+          [
+            `S "DESCRIPTION";
+            `P
+              "The $(b,configure) command initializes a fresh $(mname) \
+               application.";
+          ] )
+
+  let query t =
+    ( Term.(
+        const (fun kind args depext extra_repo ->
+            Query { kind; args; depext; extra_repo })
+        $ kind
+        $ T.args t
+        $ depext query_section
+        $ extra_repos query_section),
+      Cmd.info "query" ~doc:"Query information about the $(mname) application."
+        ~man:
+          [
+            `S "DESCRIPTION";
+            `P
+              "The $(b,query) command queries information about the $(mname) \
+               application.";
+          ] )
+
+  (** The 'describe' subcommand *)
+  let describe t =
+    ( Term.(
+        const (fun args eval dotcmd dot -> Describe { args; eval; dotcmd; dot })
+        $ T.args t
+        $ full_eval
+        $ dotcmd
+        $ dot),
+      Cmd.info "describe" ~doc:"Describe a $(mname) application."
+        ~man:
+          [
+            `S "DESCRIPTION";
+            `P
+              "The $(b,describe) command describes the configuration of a \
+               $(mname) application.";
+            `P "The dot output contains the following elements:";
+            `Noblank;
+            `I
+              ( "If vertices",
+                "Represented as circles. Branches are dotted, and the default \
+                 branch is in bold." );
+            `Noblank;
+            `I
+              ( "Configurables",
+                "Represented as rectangles. The order of the output arrows is \
+                 the order of the functor arguments." );
+            `Noblank;
+            `I ("Data dependencies", "Represented as dashed arrows.");
+            `Noblank;
+            `I
+              ( "App vertices",
+                "Represented as diamonds. The bold arrow is the functor part."
+              );
+          ] )
+
+  (** The 'clean' subcommand *)
+  let clean t =
+    let doc = "Clean the files produced by $(mname) for a given application." in
+    ( Term.(const (fun args -> Clean args) $ T.args t),
+      Cmd.info "clean" ~doc ~man:[ `S "DESCRIPTION"; `P doc ] )
+
+  (** The 'help' subcommand *)
+  let help t =
+    let topic =
+      let doc = Arg.info [] ~docv:"TOPIC" ~doc:"The topic to get help on." in
+      Arg.(value & pos 0 (some string) None & doc)
+    in
+    let help man_format cmds topic =
+      match topic with
+      | None -> `Help (man_format, None)
+      | Some topic -> (
+          let parser =
+            Arg.conv_parser
+              (Arg.enum (List.rev_map (fun s -> (s, s)) ("topics" :: cmds)))
+          in
+          match parser topic with
+          | Error (`Msg e) -> `Error (false, e)
+          | Ok t when t = "topics" ->
+              List.iter print_endline cmds;
+              `Ok ()
+          | Ok t -> `Help (man_format, Some t))
+    in
+    ( Term.(
+        const (fun args _ _ _ () -> Help args)
+        $ T.args t
+        $ depext configuration_section
+        $ extra_repos configuration_section
+        $ full_eval
+        $ ret (const help $ Arg.man_format $ Term.choice_names $ topic)),
+      Cmd.info "help" ~doc:"Display help about $(mname) commands."
+        ~man:
+          [
+            `S "DESCRIPTION";
+            `P "Prints help.";
+            `P "Use `$(mname) help topics' to get the full list of help topics.";
+          ] )
+
+  let default ~with_setup ~name ~version =
+    let usage = `Help (`Plain, None) in
+    ( Term.(ret (const usage) $ setup ~with_setup),
+      Cmd.info name ~version ~doc:"The $(mname) application builder"
+        ~man:
+          [
+            `S "DESCRIPTION";
+            `P
+              "The $(mname) application builder. It glues together a set of \
+               libraries and configuration (e.g. network and storage) into a \
+               standalone unikernel or UNIX binary.";
+            `P
+              "Use $(mname) $(b,help <command>) for more information on a \
+               specific command.";
+          ] )
+end
+
+(*
+ * Functions for extracting particular flags from the command line.
+ *)
+
+let peek_full_eval argv =
+  match Cmd.eval_peek_opts ~argv full_eval with _, Ok (`Ok b) -> b | _ -> None
+
+let peek_output argv =
+  match Cmd.eval_peek_opts ~argv output with _, Ok (`Ok b) -> b | _ -> None
+
+let peek_args ?(with_setup = false) ~mname argv =
+  let args =
+    Subcommands.T.args { with_setup; mname; context = Term.const () }
+  in
+  match Cmd.eval_peek_opts ~argv args with
+  | _, Ok (`Ok b) | Some b, _ -> Some b
+  | _ -> None
+
+let eval ?(with_setup = true) ?help_ppf ?err_ppf ~name ~version ~configure
+    ~query ~describe ~clean ~help ~mname argv =
+  let default, info = Subcommands.default ~with_setup ~name ~version in
+  let args context = { Subcommands.with_setup; mname; context } in
+  let group =
+    Cmd.group ~default info
+      (List.map
+         (fun (term, info) -> Cmd.v info term)
+         [
+           Subcommands.configure (args configure);
+           Subcommands.describe (args describe);
+           Subcommands.query (args query);
+           Subcommands.clean (args clean);
+           Subcommands.help (args help);
+         ])
+  in
+  match Cmd.eval_value ?help:help_ppf ?err:err_ppf ~argv ~catch:false group with
+  | Ok (#Cmd.eval_ok as v) -> v
+  | Error (#Cmd.eval_error as e) -> `Error e
+
+let args = function
+  | Configure { args; _ } -> args
+  | Clean x | Help x -> x
+  | Query { args; _ } -> args
+  | Describe { args; _ } -> args
+
+let choices =
+  [
+    ("configure", `Configure);
+    ("clean", `Clean);
+    ("query", `Query);
+    ("describe", `Describe);
+    ("help", `Help);
+  ]
+
+let find_choices s =
+  List.find_all (fun (k, _) -> Astring.String.is_prefix ~affix:s k) choices
+
+let find_kind s =
+  List.find_all (fun (k, _) -> Astring.String.is_prefix ~affix:s k) query_kinds
+
+let next_pos_arg argv i =
+  let rec aux i =
+    if i >= Array.length argv then None
+    else if argv.(i) = "" then aux (i + 1)
+    else if argv.(i).[0] = '-' then aux (i + 1)
+    else Some i
+  in
+  aux i
+
+let remove_argv argv i =
+  let a = Array.sub argv 0 i in
+  let b = Array.sub argv (i + 1) (Array.length argv - i - 1) in
+  Array.append a b
+
+let rec find_next_kind argv i =
+  match next_pos_arg argv i with
+  | None -> (None, argv)
+  | Some i -> (
+      match find_kind argv.(i) with
+      | [] -> find_next_kind argv (i + 1)
+      | _ :: _ :: _ as cs ->
+          Fmt.invalid_arg "ambiguous sub-command: %a\n%!"
+            Fmt.Dump.(list string)
+            (List.map fst cs)
+      | [ (_, k) ] -> (Some k, remove_argv argv i))
+
+let rec find_next_choice argv i =
+  match next_pos_arg argv i with
+  | None -> (None, argv)
+  | Some i -> (
+      match find_choices argv.(i) with
+      | [] -> find_next_choice argv (i + 1)
+      | _ :: _ :: _ as cs ->
+          Fmt.invalid_arg "ambiguous sub-command: %a\n%!"
+            Fmt.Dump.(list string)
+            (List.map fst cs)
+      | [ (_, a) ] -> (
+          match a with
+          | (`Configure | `Clean | `Describe | `Help) as c ->
+              (Some c, remove_argv argv i)
+          | `Query ->
+              let k, argv = find_next_kind argv (i + 1) in
+              (Some (`Query k), remove_argv argv i)))
+
+let peek_choice argv =
+  try match find_next_choice argv 1 with Some c, _ -> `Ok c | _ -> `Default
+  with Invalid_argument _ -> `Error `Parse
+
+type 'a result =
+  [ `Ok of 'a action
+  | `Error of 'a args option * [ `Exn | `Parse | `Term ]
+  | `Version ]
+
+let peek ?(with_setup = false) ~mname argv : unit result =
+  let niet = Term.const () in
+  let peek t =
+    match Cmd.eval_peek_opts ~argv ~version_opt:true (fst t) with
+    | _, Ok `Version -> `Version
+    | _, Error e -> `Error (peek_args ~mname argv, e)
+    | _, Ok `Help -> (
+        let args = peek_args ~with_setup:false ~mname argv in
+        match args with
+        | Some args -> `Ok (Help args)
+        | _ -> `Error (None, `Parse))
+    | Some v, _ | _, Ok (`Ok v) -> `Ok v
+  in
+  let peek_cmd f =
+    let args = { Subcommands.with_setup; mname; context = niet } in
+    peek (f args)
+  in
+  match peek_choice argv with
+  | `Ok `Configure -> peek_cmd Subcommands.configure
+  | `Ok `Clean -> peek_cmd Subcommands.clean
+  | `Ok (`Query _) -> peek_cmd Subcommands.query
+  | `Ok `Describe -> peek_cmd Subcommands.describe
+  | `Ok `Help -> peek_cmd Subcommands.help
+  | `Default ->
+      peek (Subcommands.default ~with_setup ~name:"<name>" ~version:"<version>")
+  | `Error e -> `Error (peek_args ~mname argv, e)

unikernel/duniverse/mirage/lib/functoria/cli.mli

@@ -0,0 +1,144 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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 handling. *)
+
+open Cmdliner
+
+type 'a args = {
+  context : 'a;
+  config_file : Fpath.t;
+  context_file : Fpath.t option;
+  output : string option;
+  dry_run : bool;
+}
+(** The type for global arguments. *)
+
+val default_args : unit args
+
+val peek_args :
+  ?with_setup:bool -> mname:string -> string array -> unit args option
+(** [peek_args ?with_setup argv] parses the global command-line arguments. If
+    [with_setup] is set (by default it is), interprets [-v] and [--color] to
+    set-up the terminal configuration as a side-effect. Returns None if global
+    command-line arguments are invalid. *)
+
+val peek_output : string array -> string option
+(** [peek_full_eval argv] reads the [--output] option from [argv]; the return
+    value is [None] if option is absent in [argv]. *)
+
+val pp_args : 'a Fmt.t -> 'a args Fmt.t
+(** [pp_args] is the pretty-printer for args. *)
+
+(** {1 Sub-commands} *)
+
+type 'a configure_args = {
+  args : 'a args;
+  depext : bool;
+  extra_repo : (string * string) list;
+}
+(** The type for arguments of the [configure] sub-command. *)
+
+type 'a build_args = 'a args
+(** The type for arguments of the [build] sub-command. *)
+
+type 'a clean_args = 'a args
+(** The type for arguments of the [clean] sub-command. *)
+
+type 'a help_args = 'a args
+(** The type for arguments of the [help] sub-command. *)
+
+type query_kind =
+  [ `Name
+  | `Packages
+  | `Opam
+  | `Files
+  | `Dune of [ `Config | `Build | `Project | `Workspace | `Dist ]
+  | `Makefile ]
+
+val pp_query_kind : query_kind Fmt.t
+(** [pp_query_kind] is the pretty-printer for query kinds. *)
+
+type 'a query_args = {
+  args : 'a args;
+  kind : query_kind;
+  depext : bool;
+  extra_repo : (string * string) list;
+}
+(** The type for arguments of the [query] sub-command. *)
+
+type 'a describe_args = {
+  args : 'a args;
+  dotcmd : string;
+  dot : bool;
+  eval : bool option;
+}
+(** The type for arguments of the [describe] sub-command. *)
+
+val peek_full_eval : string array -> bool option
+(** [peek_full_eval argv] reads the [--eval] option from [argv]; the return
+    value is [None] if option is absent in [argv]. *)
+
+(** A value of type [action] is the result of parsing command-line arguments
+    using [parse_args]. *)
+type 'a action =
+  | Configure of 'a configure_args
+  | Query of 'a query_args
+  | Describe of 'a describe_args
+  | Clean of 'a clean_args
+  | Help of 'a help_args
+
+val pp_action : 'a Fmt.t -> 'a action Fmt.t
+(** [pp_action] is the pretty-printer for actions. *)
+
+val args : 'a action -> 'a args
+(** [args a] are [a]'s global arguments. *)
+
+(** {1 Evaluation} *)
+
+val eval :
+  ?with_setup:bool ->
+  ?help_ppf:Format.formatter ->
+  ?err_ppf:Format.formatter ->
+  name:string ->
+  version:string ->
+  configure:'a Term.t ->
+  query:'a Term.t ->
+  describe:'a Term.t ->
+  clean:'a Term.t ->
+  help:'a Term.t ->
+  mname:string ->
+  string array ->
+  [ `Ok of 'a action | `Error of [ `Parse | `Term | `Exn ] | `Version | `Help ]
+(** Parse the functoria command line. The arguments to [~configure],
+    [~describe], etc., describe extra command-line arguments that should be
+    accepted by the corresponding subcommands.
+
+    There are no side effects, save for the printing of usage messages and other
+    help when either the 'help' subcommand or no subcommand is specified. *)
+
+type 'a result =
+  [ `Ok of 'a action
+  | `Error of 'a args option * [ `Exn | `Parse | `Term ]
+  | `Version ]
+(** Similar to [Cmdliner.Term.result] but help is folded into [`Ok] and errors
+    also carry global command-line parameters. *)
+
+val peek : ?with_setup:bool -> mname:string -> string array -> unit result
+(** [peek] is the same as {!val:eval} but without failing on unknown arguments.
+*)

unikernel/duniverse/mirage/lib/functoria/context.ml

@@ -0,0 +1,50 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type 'a key = { name : string; put : 'a -> exn; get : exn -> 'a }
+
+let new_key (type a) name =
+  let module M = struct
+    exception E of a
+  end in
+  let put a = M.E a in
+  let get = function
+    | M.E a -> a
+    | _ -> raise @@ Invalid_argument ("duplicate key: " ^ name)
+  in
+  { name; put; get }
+
+module Map = Map.Make (String)
+
+type t = exn Map.t
+
+let empty = Map.empty
+let add k v (t : t) : t = Map.add k.name (k.put v) t
+let mem k (t : t) = Map.mem k.name t
+
+let find k (t : t) =
+  if Map.mem k.name t then Some (k.get @@ Map.find k.name t) else None
+
+let dump : t Fmt.t =
+  let pp_elt ppf (k, v) = Fmt.pf ppf "[%s: %a]" k Fmt.exn v in
+  let map_iter f = Map.iter (fun k v -> f (k, v)) in
+  Fmt.box ~indent:2 @@ Fmt.(iter ~sep:(any "@ ")) map_iter pp_elt
+
+let merge ~default m =
+  let aux _ _ v = Some v in
+  Map.union aux default m

unikernel/duniverse/mirage/lib/functoria/context.mli

@@ -0,0 +1,49 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Universal map of keys *)
+
+type 'a key
+(** The type for keys. *)
+
+val new_key : string -> 'a key
+(** [new_key n] is a new key with name [k]. *)
+
+type t
+(** The type for context maps. *)
+
+val empty : t
+(** [empty] is the empty context. *)
+
+val add : 'a key -> 'a -> t -> t
+(** [add k v t] is [t] augmented with the binding [(k, v)]. Any previous binding
+    of [k] is removed. *)
+
+val mem : 'a key -> t -> bool
+(** [mem k t] is true iff [k] has been added to [t]. *)
+
+val find : 'a key -> t -> 'a option
+(** [find k t] is [v] is the binding [(k, v)] has been added to [t], otherwise
+    it is [None]. *)
+
+val merge : default:t -> t -> t
+(** [merge ~default t] merges [t] on top of [default]. If a key appears in both
+    [default] and [t], the value present in [t] is kept. *)
+
+val dump : t Fmt.t
+(** [dump] dumps the state of [t]. *)

unikernel/duniverse/mirage/lib/functoria/context_cache.ml

@@ -0,0 +1,82 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+open Action.Syntax
+
+let src = Logs.Src.create "functoria.cache" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type t = string array
+
+let empty = [| "" |]
+let is_empty t = t = empty
+
+let write file argv =
+  Log.info (fun m ->
+      m "Preserving arguments in %a:@ %a" Fpath.pp file
+        Fmt.Dump.(array string)
+        argv);
+  (* Only keep args *)
+  let args = List.tl (Array.to_list argv) in
+  let args = List.map String.Ascii.escape args in
+  let args = String.concat ~sep:"\n" args ^ "\n" in
+  Action.write_file file args
+
+let read file =
+  Log.info (fun l -> l "reading cache %a" Fpath.pp file);
+  let* is_file = Action.is_file file in
+  if not is_file then Action.ok empty
+  else
+    let* args = Action.read_file file in
+    let args = String.cuts ~sep:"\n" args in
+    (* remove trailing '\n' *)
+    let args = List.rev (List.tl (List.rev args)) in
+    (* Add an empty command *)
+    let args = "" :: args in
+    let args = Array.of_list args in
+    try
+      let args =
+        Array.map
+          (fun x ->
+            match String.Ascii.unescape x with
+            | Some s -> s
+            | None -> Fmt.failwith "%S: cannot parse" x)
+          args
+      in
+      Action.ok args
+    with Failure e -> Action.error e
+
+let peek t term =
+  match Cmdliner.Cmd.eval_peek_opts ~argv:t term with
+  | Some c, _ | _, Ok (`Ok c) -> Some c
+  | _ -> None
+
+let merge t term =
+  let cache = match peek t term with None -> Context.empty | Some c -> c in
+  let f term = Context.merge ~default:cache term in
+  Cmdliner.Term.(const f $ term)
+
+let peek_output t = Cli.peek_output t
+
+let file ~name args =
+  let build_dir = Fpath.parent args.Cli.config_file in
+  match args.Cli.context_file with
+  | Some f -> f
+  | None -> Fpath.(build_dir / name / "context")

unikernel/duniverse/mirage/lib/functoria/context_cache.mli

@@ -0,0 +1,53 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Manage context caches, via the [--context-file <file>] command-line
+    argument. *)
+
+type t
+(** The type for cache. *)
+
+val file : name:string -> 'a Cli.args -> Fpath.t
+(** [file ~name args] is the filename of the context cache for the tool [name].
+*)
+
+val empty : t
+(** The empty cache. *)
+
+val is_empty : t -> bool
+(** [is_empty t] is empty iff [t] is {!empty}. *)
+
+val write : Fpath.t -> string array -> unit Action.t
+(** [write f argv] writes the context cache in the file [f]. *)
+
+val read : Fpath.t -> t Action.t
+(** [read f] reads the context cache stored in [f]. The result is
+    [Action.ok empty] if [f] does not exists and [Action.error _] if the cache
+    contains garbage. *)
+
+val peek : t -> Context.t Cmdliner.Term.t -> Context.t option
+(** [peek t term] is the context obtained by evaluating [term] over the cached
+    context [t]. *)
+
+val merge : t -> Context.t Cmdliner.Term.t -> Context.t Cmdliner.Term.t
+(** [eval_context t term] is the context obtained by evaluating [term] over the
+    cached context [t]. *)
+
+val peek_output : t -> string option
+(** [peek_output t] is the evaluation of {!Cli.output} over the cached context
+    [t]. *)

unikernel/duniverse/mirage/lib/functoria/device.ml

@@ -0,0 +1,202 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Action.Syntax
+open Astring
+
+type package = Package.t
+type info = Info.t
+type 'a value = 'a Key.value
+type 'a code = { pos : (string * int * int * int) option; code : string }
+
+let code_opt ?pos fmt = Fmt.kstr (fun code -> { pos; code }) fmt
+let code ~pos fmt = Fmt.kstr (fun code -> { pos = Some pos; code }) fmt
+
+type ('a, 'impl) t = {
+  id : 'a Typeid.t;
+  module_name : string;
+  module_type : 'a Type.t;
+  keys : Key.t list;
+  runtime_args : Runtime_arg.t list;
+  packages : package list value;
+  local_libs : string list;
+  install : info -> Install.t value;
+  connect : info -> string -> string list -> 'a code;
+  dune : info -> Dune.stanza list;
+  configure : info -> unit Action.t;
+  files : (info -> Fpath.t list) option;
+  extra_deps : 'impl list;
+}
+
+let pp : type a b. b Fmt.t -> (a, b) t Fmt.t =
+ fun pp_impl ppf t ->
+  let open Fmt.Dump in
+  let fields =
+    [
+      field "id" (fun t -> t.id) Typeid.pp;
+      field "module_name" (fun t -> t.module_name) string;
+      field "module_type" (fun t -> t.module_type) Type.pp;
+      field "keys" (fun t -> t.keys) (list Key.pp);
+      field "install" (fun _ -> "<dyn>") Fmt.string;
+      field "packages" (fun _ -> "<dyn>") Fmt.string;
+      field "extra_deps" (fun t -> t.extra_deps) (list pp_impl);
+    ]
+  in
+  record fields ppf t
+
+let equal x y = Typeid.equal x.id y.id
+let witness x y = Typeid.witness x.id y.id
+let hash x = Typeid.id x.id
+let default_connect _ _ l = code_opt "return (%s)" (String.concat ~sep:", " l)
+let niet _ = Action.ok ()
+let nil _ = []
+
+let merge empty union a b =
+  match (a, b) with
+  | None, None -> Key.pure empty
+  | Some a, None -> Key.pure a
+  | None, Some b -> b
+  | Some a, Some b -> Key.(pure union $ pure a $ b)
+
+let merge_packages = merge [] List.append
+let merge_install = merge Install.empty Install.union
+
+let v ?packages ?packages_v ?(local_libs = []) ?install ?install_v ?(keys = [])
+    ?(runtime_args = []) ?(extra_deps = []) ?(connect = default_connect)
+    ?(dune = nil) ?(configure = niet) ?files module_name module_type =
+  let id = Typeid.gen () in
+  let packages = merge_packages packages packages_v in
+  let install i =
+    let aux = function None -> None | Some f -> Some (f i) in
+    merge_install (aux install) (aux install_v)
+  in
+  {
+    module_type;
+    id;
+    module_name;
+    keys;
+    runtime_args;
+    connect;
+    packages;
+    local_libs;
+    install;
+    dune;
+    configure;
+    files;
+    extra_deps;
+  }
+
+let id t = Typeid.id t.id
+let module_name t = t.module_name
+let module_type t = t.module_type
+let packages t = t.packages
+let local_libs t = t.local_libs
+let install t = t.install
+let connect t = t.connect
+let configure t = t.configure
+
+let files t i =
+  let gen = Action.generated_files (t.configure i) in
+  match t.files with
+  | None -> gen
+  | Some files -> Fpath.Set.(union gen (of_list (files i)))
+
+let dune t = t.dune
+let keys t = t.keys
+let runtime_args t = t.runtime_args
+let extra_deps t = t.extra_deps
+
+let start ?pos impl_name args =
+  code_opt ?pos "@[(%s.start@ %a@ : unit io)@]" impl_name
+    Fmt.(list ~sep:sp string)
+    args
+
+let uniq t = Fpath.Set.(elements (of_list t))
+let exec_hook i = function None -> Action.ok () | Some h -> h i
+
+let extend ?packages ?packages_v ?dune ?pre_configure ?post_configure ?files t =
+  let files =
+    match (files, t.files) with
+    | None, None -> None
+    | Some f, None | None, Some f -> Some f
+    | Some x, Some y -> Some (fun i -> uniq (x i @ y i))
+  in
+  let packages =
+    Key.(pure List.append $ merge_packages packages packages_v $ t.packages)
+  in
+  let exec pre f post i =
+    let* () = exec_hook i pre in
+    let* () = f i in
+    exec_hook i post
+  in
+  let configure = exec pre_configure t.configure post_configure in
+  let dune =
+    Option.map (fun dune i -> t.dune i @ dune i) dune
+    |> Option.value ~default:t.dune
+  in
+  { t with packages; files; configure; dune }
+
+let nice_name d =
+  module_name d
+  |> String.cuts ~sep:"."
+  |> String.concat ~sep:"_"
+  |> String.Ascii.lowercase
+  |> Misc.Name.ocamlify
+
+type ('a, 'i) device = ('a, 'i) t
+
+module Graph = struct
+  type t =
+    | D : { dev : ('a, _) device; args : t list; deps : t list; id : int } -> t
+
+  type dtree = t
+
+  module IdTbl = Hashtbl.Make (struct
+    type t = dtree
+
+    let hash (D t) = t.id
+    let equal (D t1) (D t2) = Int.equal t1.id t2.id
+  end)
+
+  (* We iter in *reversed* topological order. *)
+  let fold f t z =
+    let tbl = IdTbl.create 50 in
+    let state = ref z in
+    let rec aux v =
+      if IdTbl.mem tbl v then ()
+      else
+        let (D { args; deps; _ }) = v in
+        IdTbl.add tbl v ();
+        List.iter aux deps;
+        List.iter aux args;
+        state := f v !state
+    in
+    aux t;
+    !state
+
+  let impl_name (D { dev; args = _; deps = _; id }) =
+    match Type.is_functor (module_type dev) with
+    | false -> module_name dev
+    | true ->
+        let prefix = Astring.String.Ascii.capitalize (nice_name dev) in
+        Fmt.str "%s__%d" prefix id
+
+  let var_name (D { dev; args = _; deps = _; id }) =
+    let prefix = nice_name dev in
+    Fmt.str "%s__%i" prefix id
+end

unikernel/duniverse/mirage/lib/functoria/device.mli

@@ -0,0 +1,169 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Signature for functoria devices. A [device] is a module implementation which
+    contains a runtime state which can be set either at configuration time (by
+    the application builder) or at runtime, using command-line arguments. *)
+
+type ('a, 'b) t
+(** The type for devices whose runtime state is of type ['a] and having extra
+    data-dependencies of type ['b]. *)
+
+val module_type : ('a, 'b) t -> 'a Type.t
+(** [module_type t] is [t]'s module type. *)
+
+val module_name : ('a, 'b) t -> string
+(** [module_name t] is [t]'s module name. *)
+
+val packages : ('a, 'b) t -> Package.t list Key.value
+(** [packages t] is the list of OPAM packages that are needed by [t].*)
+
+val local_libs : ('a, 'b) t -> string list
+(** [local_libs t] is the list of local libraries that are needed by [t]. *)
+
+val install : ('a, 'b) t -> Info.t -> Install.t Key.value
+(** [install t i] is the list of files installed by [t], using the build
+    information [i]. *)
+
+val extra_deps : ('a, 'b) t -> 'b list
+(** [extra_deps t] is the list of dependencies that be initialized before
+    running the code generated by [connect t]. *)
+
+val id : ('a, 'b) t -> int
+(** [id t] is [t]'s unique identifier. Freshly generated for each call to {!v}.
+*)
+
+val pp : 'b Fmt.t -> ('a, 'b) t Fmt.t
+(** [pp pp_dep] is the pretty-printer for devices, using [pp_dep] to
+    pretty-print the extra data-dependencies. *)
+
+val equal : ('a, 'b) t -> ('c, 'd) t -> bool
+(** [equal] is the equality function for devices. *)
+
+val witness : ('a, _) t -> ('b, _) t -> ('a, 'b) Typeid.witness
+(** [witness a b] provides an equality witness. *)
+
+val hash : ('a, 'b) t -> int
+(** [hash t] is [t]'s hash. *)
+
+(** {1 Resources} *)
+
+val files : ('a, 'b) t -> Info.t -> Fpath.Set.t
+(** [files t info s] is the list of files generated configure-time. *)
+
+val keys : ('a, 'b) t -> Key.t list
+(** [keys t] is the list of keys which can be used to configure [t]. *)
+
+val runtime_args : ('a, 'b) t -> Runtime_arg.t list
+(** [runtime_args t] is the list of command-line arguments which can be used to
+    configure [t] at runtime. *)
+
+(** {1 Code Generation} *)
+
+type 'a code = private {
+  pos : (string * int * int * int) option;
+  code : string;
+}
+(** The type for fragments of code of type ['a]. *)
+
+val code :
+  pos:string * int * int * int ->
+  ('a, Format.formatter, unit, 'b code) format4 ->
+  'a
+(** Generate localised code. *)
+
+val connect : ('a, 'b) t -> Info.t -> string -> string list -> 'a code
+(** [connect t info impl_name args] is the code to execute in order to create a
+    new state (usually calling [<module_name t>.connect]) with the arguments
+    [args], in the context of the project information [info]. The freshly
+    created state will be made available in [var_name t] *)
+
+val start : ?pos:string * int * int * int -> string -> string list -> 'a code
+(** [start ?pos impl_name args] is the code [<impl_name>.start <args>]. *)
+
+val nice_name : _ t -> string
+(** [nice_name d] provides a identifier unique to [d] which is a valid OCaml
+    identifier. *)
+
+(** {1 Actions} *)
+val dune : ('a, 'b) t -> Info.t -> Dune.stanza list
+(** [dune t info] are the dune stanza which needs to be generated to build the
+    application. *)
+
+(** {1 Configuration} *)
+
+val configure : ('a, 'b) t -> Info.t -> unit Action.t
+(** [configure t info] is configure hook for [t] the device and the files it
+    generates. During the configure phase, you cannot rely on [packages t] being
+    installed.
+
+    To run code during the [build] phase, generate a [dune] fragment instead. *)
+
+(** {1 Constructors} *)
+
+val v :
+  ?packages:Package.t list ->
+  ?packages_v:Package.t list Key.value ->
+  ?local_libs:string list ->
+  ?install:(Info.t -> Install.t) ->
+  ?install_v:(Info.t -> Install.t Key.value) ->
+  ?keys:Key.t list ->
+  ?runtime_args:Runtime_arg.t list ->
+  ?extra_deps:'b list ->
+  ?connect:(Info.t -> string -> string list -> 'a code) ->
+  ?dune:(Info.t -> Dune.stanza list) ->
+  ?configure:(Info.t -> unit Action.t) ->
+  ?files:(Info.t -> Fpath.t list) ->
+  string ->
+  'a Type.t ->
+  ('a, 'b) t
+
+val extend :
+  ?packages:Package.t list ->
+  ?packages_v:Package.t list Key.value ->
+  ?dune:(Info.t -> Dune.stanza list) ->
+  ?pre_configure:(Info.t -> unit Action.t) ->
+  ?post_configure:(Info.t -> unit Action.t) ->
+  ?files:(Info.t -> Fpath.t list) ->
+  ('a, 'b) t ->
+  ('a, 'b) t
+
+(** {1 Device graphs} *)
+
+module Graph : sig
+  type ('a, 'i) device
+
+  (** A graph of devices, annotated with their arguments, dependencies, and a
+      unique identifier.
+
+      Warning: this is truly a DAG: sharing {b must} be preserved. Manual walks
+      are discouraged, please use {!fold} instead. *)
+  type t =
+    | D : { dev : (_, _) device; args : t list; deps : t list; id : int } -> t
+
+  val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a
+  (** [fold f g z] applies [f] on each device in topological order. *)
+
+  val var_name : t -> string
+  (** [var_name t] returns the name identifying [t] which is a valid OCaml
+      variable identifier. *)
+
+  val impl_name : t -> string
+  (** [impl_name t] returns the name identifying [t]'s module implementation. *)
+end
+with type ('a, 'i) device := ('a, 'i) t

unikernel/duniverse/mirage/lib/functoria/dune

@@ -0,0 +1,19 @@
+(include_subdirs no)
+
+(library
+ (name functoria)
+ (public_name mirage.functoria)
+ (libraries
+  uri
+  emile
+  unix
+  cmdliner
+  rresult
+  fmt
+  astring
+  fpath
+  bos
+  fmt.cli
+  logs.fmt
+  fmt.tty
+  logs.cli))

unikernel/duniverse/mirage/lib/functoria/dune.ml

@@ -0,0 +1,107 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+
+type stanza = string option
+type t = string list
+
+let stanza v = Some (String.trim v)
+let stanzaf fmt = Fmt.kstr stanza fmt
+
+let v x : t =
+  List.fold_left
+    (fun acc -> function None -> acc | Some f -> f :: acc)
+    [] (List.rev x)
+
+let pp_list pp = Fmt.(list ~sep:(any "\n\n") pp)
+let pp ppf (t : t) = Fmt.pf ppf "%a" (pp_list Fmt.string) t
+let to_string t = Fmt.to_to_string pp t ^ "\n"
+
+(* emulate the dune compact form for lists *)
+let compact_list ?(indent = 2) field ppf l =
+  let all = Buffer.create 1024 in
+  let line = Buffer.create 70 in
+  let sep = "\n" ^ String.v ~len:indent (fun _ -> ' ') in
+  let first_char = ref true in
+  let first_line = ref true in
+  let flush () =
+    Buffer.add_buffer all line;
+    Buffer.clear line;
+    Buffer.add_string line sep;
+    first_line := false
+  in
+  List.iter
+    (fun w ->
+      let max = if !first_line then 75 - indent - String.length field else 75 in
+      let wn = String.length w in
+      if wn >= 40 || Buffer.length line + wn >= max then flush ();
+      if not !first_char then Buffer.add_char line ' ';
+      first_char := false;
+      Buffer.add_string line w)
+    l;
+  flush ();
+  Fmt.pf ppf "%s" (Buffer.contents all)
+
+let config_rule ~config_ml_file ~packages =
+  let pkgs =
+    match packages with
+    | [] -> ""
+    | pkgs ->
+        let pkgs =
+          List.fold_left
+            (fun acc pkg ->
+              let pkgs = String.Set.of_list (Package.libraries pkg) in
+              String.Set.union pkgs acc)
+            String.Set.empty pkgs
+          |> String.Set.elements
+        in
+        String.concat ~sep:" " pkgs
+  in
+  let rename_config_file =
+    let config_ml_file = Fpath.base config_ml_file in
+    let ext = Fpath.get_ext config_ml_file in
+    let name = Fpath.rem_ext config_ml_file |> Fpath.to_string in
+    if name = "config" then []
+    else
+      [
+        stanzaf "(rule (copy# %s config%s))"
+          (Fpath.to_string config_ml_file)
+          ext;
+      ]
+  in
+  let contents =
+    stanzaf
+      {|
+(executable
+ (name config)
+ (modules config)
+ (flags :standard -warn-error -A)
+ (libraries %s))
+|}
+      pkgs
+  in
+  v (rename_config_file @ [ contents ])
+
+let base ~packages ~config_ml_file =
+  let dune_base = config_rule ~config_ml_file ~packages in
+  let disable_conflicting_directories = "(data_only_dirs duniverse dist)" in
+  disable_conflicting_directories :: dune_base
+
+let base_project = [ stanza "(lang dune 2.9)" ]
+let base_workspace = v [ stanza "(lang dune 2.9)\n(context default)" ]

unikernel/duniverse/mirage/lib/functoria/dune.mli

@@ -0,0 +1,40 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Dune files. *)
+
+type stanza
+
+val stanza : string -> stanza
+val stanzaf : ('a, Format.formatter, unit, stanza) format4 -> 'a
+
+type t
+
+val v : stanza list -> t
+val pp : t Fmt.t
+val to_string : t -> string
+val compact_list : ?indent:int -> string -> string list Fmt.t
+
+val base : packages:Package.t list -> config_ml_file:Fpath.t -> t
+(** [base] is a minimal [dune] file able to build [config.ml] *)
+
+val base_project : stanza list
+(** the minimal [dune-project] to compile [config.ml]. *)
+
+val base_workspace : t
+(** the minimal [dune-workspace] to compile [config.ml]. *)

unikernel/duniverse/mirage/lib/functoria/engine.ml

@@ -0,0 +1,245 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+open Action.Syntax
+
+type t = Device.Graph.t
+
+let if_keys x =
+  Impl.collect
+    (module Key.Set)
+    (function If cond -> Key.deps cond | App | Dev _ -> Key.Set.empty)
+    x
+
+module Keys = struct
+  type t = Key.Set.t
+
+  let union a b = Key.Set.union a b
+  let empty = Key.Set.empty
+end
+
+let keys x =
+  Impl.collect
+    (module Keys)
+    (function
+      | Dev c -> Key.Set.of_list (Device.keys c)
+      | If cond -> Key.deps cond
+      | App -> Keys.empty)
+    x
+
+module Runtime_args = struct
+  type t = Runtime_arg.Set.t
+
+  let union a b = Runtime_arg.Set.union a b
+  let empty = Runtime_arg.Set.empty
+end
+
+let runtime_args x =
+  Impl.collect
+    (module Runtime_args)
+    (function
+      | Dev c -> Runtime_arg.Set.of_list (Device.runtime_args c)
+      | If _ -> Runtime_args.empty
+      | App -> Runtime_args.empty)
+    x
+
+module Packages = struct
+  type t = Package.Set.t Key.value
+
+  let union x y = Key.(pure Package.Set.union $ x $ y)
+  let empty = Key.pure Package.Set.empty
+end
+
+let packages t =
+  let open Impl in
+  let aux = function
+    | Dev c ->
+        let pkgs = Device.packages c in
+        let runtime_args = Device.runtime_args c in
+        let extra_pkgs =
+          List.fold_left
+            (fun acc k ->
+              let pkgs = Runtime_arg.packages k in
+              Package.Set.(union acc (of_list pkgs)))
+            Package.Set.empty runtime_args
+        in
+        let aux x = Package.Set.(union (of_list x) extra_pkgs) in
+        Key.(pure aux $ pkgs)
+    | If _ | App -> Packages.empty
+  in
+  let return x = Package.Set.to_list x in
+  Key.(pure return $ Impl.collect (module Packages) aux t)
+
+module Installs = struct
+  type t = Install.t Key.value
+
+  let union x y = Key.(pure Install.union $ x $ y)
+  let empty = Key.pure Install.empty
+end
+
+let install i x =
+  Impl.collect
+    (module Installs)
+    (function Dev c -> Device.install c i | If _ | App -> Installs.empty)
+    x
+
+let files info t =
+  Impl.collect
+    (module Fpath.Set)
+    (function Dev c -> Device.files c info | If _ | App -> Fpath.Set.empty)
+    t
+
+module Dune = struct
+  type t = Dune.stanza list
+
+  let union = ( @ )
+  let empty = []
+end
+
+let dune info =
+  Impl.collect (module Dune) @@ function
+  | Dev c -> Device.dune c info
+  | If _ | App -> Dune.empty
+
+(* [module_expresion tbl c args] returns the module expression of
+   the functor [c] applies to [args]. *)
+let module_expression fmt (c, args) =
+  Fmt.pf fmt "%s%a" (Device.module_name c)
+    Fmt.(
+      list ~sep:(any "")
+        (any "(" ++ of_to_string Device.Graph.impl_name ++ any ")"))
+    args
+
+let find_all_devices info g i =
+  let ctx = Info.context info in
+  let id = Impl.with_left_most_device ctx i { f = Device.id } in
+  let f x l =
+    let (Device.Graph.D { dev; _ }) = x in
+    if Device.id dev = id then x :: l else l
+  in
+  Device.Graph.fold f g []
+
+let iter_actions f t =
+  let f v res =
+    let* () = res in
+    f v
+  in
+  Device.Graph.fold f t (Action.ok ())
+
+let lines_of_str str =
+  String.fold_left (fun n -> function '\n' -> n + 1 | _ -> n) 0 str
+
+type main = { dir : Fpath.t; path : Fpath.t; mutable lines : int }
+
+let main info =
+  let path = Info.main info in
+  let dir = Fpath.(Info.(parent (config_file info) / project_name info)) in
+  let+ str = Action.read_file path in
+  let lines = lines_of_str str in
+  { dir; path; lines }
+
+let append_main main msg fmt =
+  let purpose = Fmt.str "Append to main.ml (%s)" msg in
+  Fmt.kstr
+    (fun str ->
+      main.lines <- main.lines + lines_of_str str + 1;
+      Action.with_output ~path:main.path ~append:true ~purpose (fun ppf ->
+          Fmt.pf ppf "%s@." str))
+    fmt
+
+let pp_pos ppf = function
+  | None -> ()
+  | Some (file, line, _, _) -> Fmt.pf ppf "# %d %S@." line file
+
+let reset_pos { dir; path; lines } =
+  (* lines are 1-based and the line directive is refering to
+     "next line will be Y", so if we put a directive in the first line of a
+     file, it needs to say "# 2 myfile.ml" since the next line will be the
+     second one. This is the reason for the 2 below. *)
+  let file = Fpath.(dir // path) |> Fpath.normalize |> Fpath.to_string in
+  Some (file, lines + 2, 0, 0)
+
+let configure info t =
+  let f (v : t) =
+    let* main = main info in
+    let (D { dev; args; _ }) = v in
+    let* () = Device.configure dev info in
+    if args = [] then Action.ok ()
+    else
+      let* () = append_main main "reset" "%a" pp_pos (reset_pos main) in
+      append_main main "configure" "module %s = %a\n" (Device.Graph.impl_name v)
+        module_expression (dev, args)
+  in
+  iter_actions f t
+
+let meta_init fmt (connect_name, result_name) =
+  Fmt.pf fmt "  let _%s = Lazy.force %s in@ " result_name connect_name
+
+let emit_connect fmt (iname, names, runtime_args, connect_code) =
+  (* We avoid potential collision between double application
+     by prefixing with "_". This also avoid warnings. *)
+  let rnames = List.map (fun x -> "_" ^ x) names in
+  let knames = List.map (fun k -> "_" ^ Runtime_arg.var_name k) runtime_args in
+  let bind ppf name = Fmt.pf ppf "  _%s >>= fun %s ->\n" name name in
+  let bind_key ppf k =
+    Fmt.pf ppf "  let _%s = %a in\n" (Runtime_arg.var_name k) Runtime_arg.call k
+  in
+  let { Device.pos; code } = connect_code (rnames @ knames) in
+  Fmt.pf fmt "let %s = lazy (\n%a%a%a%a  %s@\n);;" iname
+    Fmt.(list ~sep:nop meta_init)
+    (List.combine names rnames)
+    Fmt.(list ~sep:nop bind)
+    rnames
+    Fmt.(list ~sep:nop bind_key)
+    runtime_args pp_pos pos code
+
+let emit_run main init main_name =
+  (* "exit 1" is ok in this code, since cmdliner will print help. *)
+  let force ppf name = Fmt.pf ppf "Lazy.force %s >>= fun _ ->\n  " name in
+  append_main main "emit_run"
+    "let () =\n  let t = %aLazy.force %s in\n  run t\n;;"
+    Fmt.(list ~sep:nop force)
+    init main_name
+
+let connect ?(init = []) info t =
+  let* main = main info in
+  let f (v : t) =
+    let (D { dev; args; deps; _ }) = v in
+    let var_name = Device.Graph.var_name v in
+    let impl_name = Device.Graph.impl_name v in
+    let arg_names = List.map Device.Graph.var_name (args @ deps) in
+    let runtime_args = Device.runtime_args dev in
+    let* () =
+      append_main main "connect" "%a" emit_connect
+        (var_name, arg_names, runtime_args, Device.connect dev info impl_name)
+    in
+    append_main main "reset" "%a" pp_pos (reset_pos main)
+  in
+  let* () = iter_actions f t in
+  let main_name = Device.Graph.var_name t in
+  let init_names =
+    List.fold_left
+      (fun acc i ->
+        match find_all_devices info t i with
+        | [] -> assert false
+        | ds -> List.map Device.Graph.var_name ds @ acc)
+      [] init
+    |> List.rev
+  in
+  emit_run main init_names main_name

unikernel/duniverse/mirage/lib/functoria/engine.mli

@@ -0,0 +1,56 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Functoria engine. *)
+
+val if_keys : Impl.abstract -> Key.Set.t
+(** [if_keys t] is the set of [if] keys in the graph [t]. *)
+
+val keys : Impl.abstract -> Key.Set.t
+(** [keys t] is the set of keys in the graph [t]. *)
+
+val runtime_args : Impl.abstract -> Runtime_arg.Set.t
+(** [runtime_args t] is the set of runtime arguments in the graph [t]. *)
+
+val packages : Impl.abstract -> Package.t list Key.value
+(** [packages t] is the set of packages in the graph [t]. *)
+
+val install : Info.t -> Impl.abstract -> Install.t Key.value
+(** [install i t] is the set of files installed by the graph [t]. *)
+
+val files : Info.t -> Impl.abstract -> Fpath.Set.t
+(** [files i t] is the list of files generated configure-time. *)
+
+val dune : Info.t -> Impl.abstract -> Dune.stanza list
+(** [dune i t] is the list of dune stanzas needed to build the project [t] with
+    the build information [i]. *)
+
+(** {2 Triggering Hooks} *)
+
+type t = Device.Graph.t
+(** The type for key graphs. *)
+
+val configure : Info.t -> t -> unit Action.t
+(** [configure i t] calls all the configuration hooks for each of the
+    implementations appearing in [t], in topological order. Use the build
+    information [i]. *)
+
+val connect : ?init:'a Impl.t list -> Info.t -> t -> unit Action.t
+(** [connect ?init i t] generates the [connect] functions in [main.ml], for each
+    of the implementations appearing [t], in topological order. Use build
+    information [i]. *)

unikernel/duniverse/mirage/lib/functoria/filegen.ml

@@ -0,0 +1,91 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+open Action.Syntax
+
+module type PROJECT = sig
+  val name : string
+  val version : string
+end
+
+module Make (P : PROJECT) = struct
+  let lang path =
+    let base, ext = Fpath.split_ext path in
+    let base = Fpath.basename base in
+    match (base, ext) with
+    | _, (".ml" | ".mli") -> Some `OCaml
+    | _, (".opam" | ".install") -> Some `Opam
+    | "Makefile", _ -> Some `Make
+    | ("dune" | "dune-project" | "dune-workspace"), _ -> Some `Sexp
+    | _ -> None
+
+  let headers lang =
+    let line = Fmt.str "Generated by %s.%s" P.name P.version in
+    match lang with
+    | `Sexp -> Fmt.str ";; %s" line
+    | `Opam | `Make -> Fmt.str "# %s" line
+    | `OCaml -> Fmt.str "(* %s *)" line
+
+  let short_headers lang =
+    match lang with
+    | `Sexp -> Fmt.str ";; Generated by"
+    | `Opam | `Make -> "# Generated by"
+    | `OCaml -> "(* Generated by"
+
+  let has_headers file contents =
+    match Fpath.basename file with
+    | "dune-project" | "dune-workspace" -> (
+        let lines = String.cuts ~sep:"\n" ~empty:true (String.trim contents) in
+        match List.rev lines with
+        | x :: _ -> String.is_infix ~affix:(short_headers `Sexp) x
+        | _ -> false)
+    | _ -> (
+        match lang file with
+        | None -> false
+        | Some lang ->
+            let affix = short_headers lang in
+            String.is_infix ~affix contents)
+
+  let can_overwrite file =
+    let* is_file = Action.is_file file in
+    if is_file then
+      let+ content = Action.read_file file in
+      has_headers file content
+    else Action.ok true
+
+  let rm file =
+    let* can_overwrite = can_overwrite file in
+    if not can_overwrite then Action.ok () else Action.rm file
+
+  let with_headers file contents =
+    if has_headers file contents then contents
+    else
+      match Fpath.basename file with
+      | "dune-project" | "dune-workspace" | "dune-workspace.config" ->
+          Fmt.str "%s\n%s\n" contents (headers `Sexp)
+      | _ -> (
+          match lang file with
+          | None -> Fmt.invalid_arg "%a: invalide lang" Fpath.pp file
+          | Some lang -> Fmt.str "%s\n\n%s" (headers lang) contents)
+
+  let write file contents =
+    let* can_overwrite = can_overwrite file in
+    if not can_overwrite then Action.ok ()
+    else Action.write_file file (with_headers file contents)
+end

unikernel/duniverse/mirage/lib/functoria/filegen.mli

@@ -0,0 +1,30 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Basic helpers to generate files. *)
+
+module type PROJECT = sig
+  val name : string
+  val version : string
+end
+
+module Make (_ : PROJECT) : sig
+  val write : Fpath.t -> string -> unit Action.t
+  val headers : [ `OCaml | `Sexp | `Make | `Opam ] -> string
+  val rm : Fpath.t -> unit Action.t
+end

unikernel/duniverse/mirage/lib/functoria/functoria.ml

@@ -0,0 +1,58 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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 Context = Context
+module Key = Key
+module Runtime_arg = Runtime_arg
+module Package = Package
+module Info = Info
+module Type = Type
+module Impl = Impl
+module Device = Device
+module Install = Install
+module Opam = Opam
+module Lib = Lib
+module Tool = Tool
+module Engine = Engine
+module DSL = DSL
+module Cli = Cli
+module Action = Action
+module Dune = Dune
+
+module type DSL = module type of DSL
+
+module type KEY =
+  module type of Key
+    with type 'a Arg.t = 'a Key.Arg.t
+     and type 'a value = 'a Key.value
+     and type 'a key = 'a Key.key
+     and type t = Key.t
+     and type Set.t = Key.Set.t
+
+(** Devices *)
+
+include DSL
+
+let job = Job.t
+let noop = Job.noop
+let runtime_args = Job.runtime_args
+
+type argv = Argv.t
+
+let sys_argv = Argv.sys_argv
+let argv = Argv.argv

unikernel/duniverse/mirage/lib/functoria/functoria.mli

@@ -0,0 +1,168 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** {1 The Functoria DSL} *)
+
+(** Functoria is a DSL to describe a set of modules and functors, their types
+    and how to apply them in order to produce a complete application.
+
+    The main use case is mirage. See the [Mirage] documentation for details.
+
+    Functoria is a DSL to write configuration files for functor-heavy
+    applications. Such configuration files (imaginatively called [config.ml])
+    usually contains three parts: one for defining toplevel modules, one for
+    defining configuration kyes and one for defining applications using these
+    modules and keys.
+
+    {2 Defining toplevel modules}
+
+    To define toplevel modules, use the {!main} function. Among its various
+    arguments, it takes the module name and its signature. The type is assembled
+    with the {!Type} combinators, like the [@->] operator, which represents a
+    functor arrow.
+
+    {[
+      let main = main "Unikernel.Main" (m @-> job)
+    ]}
+
+    This declares that the functor [Unikernel.Main] takes a module of type [m]
+    and returns a module of type {!module-DSL.job}. [job] has a specific meaning
+    for functoria: it is a module which defines at least a function [start],
+    which should have one argument per functor argument and should return
+    [unit].
+
+    It is up to the user to ensure that the declaration matches the
+    implementation, or be rewarded by a compiler error later on. If the
+    declaration is correct, everything that follows will be.
+
+    {2 Defining configuration keys}
+
+    A configuration key is composed of:
+
+    - {i name} : The name of the value in the program.
+    - {i description} : How it should be displayed/serialized.
+    - {i stage} : Is the key available only at runtime, at configure time or
+      both?
+    - {i documentation} : It is not optional so you should really write it.
+
+    Consider a multilingual application: we want to pass the default language as
+    a parameter. We will use a simple string, so we can use the predefined
+    description {!Key.Arg.string}. We want to be able to define it both at
+    configure and run time, so we use the stage [Both]. This gives us the
+    following code:
+
+    {[
+      let lang_key =
+        let doc =
+          Key.Arg.info ~doc:"The default language for the application."
+            [ "l"; "lang" ]
+        in
+        Key.create "language" @@ Key.Arg.(opt ~stage:`Both string "en" doc)
+    ]}
+
+    Here, we defined both a long option ["--lang"] and a short one ["-l"] (the
+    format is similar to the one used by
+    {{:http://erratique.ch/software/cmdliner} Cmdliner}. In the application
+    code, the value is retrieved with [Key_gen.language ()].
+
+    The option is also documented in the ["--help"] option for both the
+    [configure] subcommand (at configure time) and [./app.exe] (at startup
+    time).
+
+    {v
+      -l VAL, --lang=VAL (absent=en) The default language for the application.
+    v}
+
+    {2 Defining applications}
+
+    To register a new application, use [register]:
+
+    {[
+      let () = register "app" [ main $ impl ]
+    ]}
+
+    This function (which should only be called once) takes as argument the name
+    of the application and a list of jobs. The jobs are defined using the
+    {!Impl} DSL; for instance the operator [$] is used to apply the functor
+    [main] (aka [Unikernel.Main]) to the default console.
+
+    Once an application is registered, it can be configured and built using
+    command-line arguments.
+
+    Configuration keys we can use be used to switch implementation at configure
+    time. This is done by using the {!Key} DSL, for instance to check whether
+    [lang_key] is instanciated with a given string:
+
+    {[
+      let lang_is "s" = Key.(pure (( = ) s) $ value lang_key)
+    ]}
+
+    Then by using the {!if_impl} combinator to choose between two
+    implementations depending on the value of the key:
+
+    {[
+      let impl = if_impl (is "fi") finnish_impl not_finnish_implementation
+    ]} *)
+
+module type DSL = module type of DSL
+
+include DSL
+module Package = Package
+module Info = Info
+module Install = Install
+module Device = Device
+
+(** {1 Useful module implementations} *)
+
+val job : job typ
+(** [job] is the signature for user's application main module. *)
+
+val noop : job impl
+(** [noop] is an implementation of {!type-job} that holds no state, does nothing
+    and has no dependency. *)
+
+type argv = Argv.t
+(** The type for command-line arguments, similar to the usual [Sys.argv]. *)
+
+val argv : argv typ
+(** [argv] is a value representing {!type-argv} module types. *)
+
+val sys_argv : argv impl
+(** [sys_argv] is a device providing command-line arguments by using [Sys.argv].
+*)
+
+val runtime_args :
+  ?runtime_package:package -> ?runtime_modname:string -> argv impl -> job impl
+(** [runtime_args a] is an implementation of {!type-job} that holds the parsed
+    command-line arguments. By default [runtime_package] is
+    ["mirage-runtime.functoria"] and [runtime_modname] is ["Functoria_runtime"].
+*)
+
+module Type = Type
+module Impl = Impl
+module Context = Context
+module Key = Key
+module Runtime_arg = Runtime_arg
+module Opam = Opam
+module Lib = Lib
+module Tool = Tool
+module Engine = Engine
+module DSL = DSL
+module Cli = Cli
+module Action = Action
+module Dune = Dune

unikernel/duniverse/mirage/lib/functoria/impl.ml

@@ -0,0 +1,464 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+let src = Logs.Src.create "functoria" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type 'a t =
+  | If : {
+      cond : 't Key.value;
+      branches : ('t * 'a t) list;
+      default : 'a t;
+    }
+      -> 'a t
+  | Dev : { dev : 'a device; args : ('a, 'v) tl; deps : abstract list } -> 'v t
+  | App : { f : 'a t; args : ('a, 'v) tl } -> 'v t
+
+and abstract = Abstract : _ t -> abstract
+
+and ('a, 'b) tl =
+  | Nil : ('a, 'a) tl
+  | Cons : 'a t * ('b, 'c) tl -> ('a -> 'b, 'c) tl
+
+and 'a device = ('a, abstract) Device.t
+
+(** Constructors *)
+
+let abstract t = Abstract t
+
+let rec app_has_no_arguments : type a. a t -> bool = function
+  | App { f = _; args = Cons _ } -> false
+  | App { f; args = Nil } -> app_has_no_arguments f
+  | Dev { args = Nil; deps = []; dev } ->
+      (* special hack for Job.noop *)
+      if not (String.equal (Device.module_name dev) "Unit") then
+        match Device.runtime_args dev with [] -> true | _ -> false
+      else false
+  | Dev _ -> false
+  | If { cond = _; branches; default } ->
+      app_has_no_arguments default
+      || List.exists (fun (_, branch) -> app_has_no_arguments branch) branches
+
+(* Devices *)
+
+let mk_dev ~args ~deps dev = Dev { dev; args; deps }
+let of_device dev = mk_dev ~args:Nil ~deps:(Device.extra_deps dev) dev
+let local_libs = function Dev { dev; _ } -> Device.local_libs dev | _ -> []
+
+let v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect ?dune
+    ?configure ?files module_name module_type =
+  of_device
+  @@ Device.v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect
+       ?dune ?configure ?files module_name module_type
+
+let main ?pos ?packages ?packages_v ?runtime_args ?keys ?extra_deps module_name
+    ty =
+  let connect _ = Device.start ?pos in
+  v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ~connect module_name
+    ty
+
+(* If *)
+
+let mk_switch ~cond ~branches ~default = If { cond; branches; default }
+
+let if_ cond then_ else_ =
+  mk_switch ~cond ~branches:[ (true, then_); (false, else_) ] ~default:then_
+
+let match_ cond ~default branches = mk_switch ~cond ~branches ~default
+
+(* App *)
+
+let rec concat_tl : type a b c. (a, b) tl -> (b, c) tl -> (a, c) tl =
+ fun t1 t2 -> match t1 with Nil -> t2 | Cons (h, t) -> Cons (h, concat_tl t t2)
+
+let rec mk_app : type a v. f:a t -> args:(a, v) tl -> v t =
+ fun ~f ~args:args1 ->
+  match f with
+  | Dev { dev; args = args2; deps } ->
+      mk_dev ~args:(concat_tl args2 args1) ~deps dev
+  | App { f; args = args2 } -> mk_app ~f ~args:(concat_tl args2 args1)
+  | _ -> App { f; args = args1 }
+
+let ( $ ) f x = mk_app ~f ~args:(Cons (x, Nil))
+
+(** Utilities *)
+
+let rec pp : type a. a t Fmt.t =
+ fun ppf -> function
+  | Dev { dev; args; deps = _ } ->
+      Fmt.pf ppf "@[<v>@[Dev %a@]@,@[<v2>args=[%a]@]@]" (Device.pp pp_abstract)
+        dev pp_tl args
+  | App { f; args } -> Fmt.pf ppf "App %a(%a)" pp f pp_tl args
+  | If { cond = _; branches; default } ->
+      Fmt.pf ppf "Switch (_,%a,%a)" (Fmt.list pp) (List.map snd branches) pp
+        default
+
+and pp_tl : type a b. (a, b) tl Fmt.t =
+ fun ppf -> function
+  | Nil -> ()
+  | Cons (h, t) -> Fmt.pf ppf "%a,@ %a" pp h pp_tl t
+
+and pp_abstract ppf (Abstract i) = pp ppf i
+
+(** Tables and traversals *)
+
+(* **** WARNING ******
+
+   The [impl] type forms a DAG, implemented as terms with sharing.
+
+   It is *essential* to preserve sharing while walking the terms.
+   Otherwise
+   - We risk double initialization of devices
+   - The DOT graph is a mess
+   - We might collect information twice
+
+   As such, the equality, hashing, and tables must be tuned to share
+   [impl]s appropriately and the various traversals must use appropriate tables.
+*)
+
+let rec hash : type a. a t -> int = function
+  | Dev { dev; args; deps } ->
+      Hashtbl.hash
+        (`Dev, Device.hash dev, hash_tl args, List.map hash_abstract deps)
+  | App { f; args } -> Hashtbl.hash (`App, hash f, hash_tl args)
+  | If { cond; branches; default } ->
+      Hashtbl.hash
+        ( `If,
+          cond,
+          List.map (fun (p, t) -> Hashtbl.hash (p, hash t)) branches,
+          hash default )
+
+and hash_abstract (Abstract x) = hash x
+
+and hash_tl : type a v. (a, v) tl -> int =
+ fun x ->
+  match x with
+  | Nil -> Hashtbl.hash `Nil
+  | Cons (h, t) -> Hashtbl.hash (`Cons, hash h, hash_tl t)
+
+type ex = Ex : 'a -> ex
+
+let equal_list p l1 l2 =
+  List.length l1 = List.length l2 && List.for_all2 p l1 l2
+
+let rec equal : type t1 t2. t1 t -> t2 t -> (t1, t2) Typeid.witness =
+ fun x y ->
+  match (x, y) with
+  | Dev c, Dev c' -> (
+      match
+        ( equal_list equal_abstract c.deps c'.deps,
+          equal_tl c.args c'.args (Device.witness c.dev c'.dev) )
+      with
+      | true, Eq -> Eq
+      | _ -> NotEq)
+  | App a, App b -> (
+      match equal_tl a.args b.args (equal a.f b.f) with
+      | Eq -> Eq
+      | NotEq -> NotEq)
+  | If x1, If x2 -> (
+      match
+        ( equal x1.default x2.default,
+          Obj.repr x1.cond == Obj.repr x2.cond,
+          equal_list
+            (fun (p1, t1) (p2, t2) ->
+              Ex p1 = Ex p2 && equal_abstract (abstract t1) (abstract t2))
+            x1.branches x2.branches )
+      with
+      | Eq, true, true -> Eq
+      | _ -> NotEq)
+  | _ -> NotEq
+
+and equal_abstract (Abstract x) (Abstract y) = Typeid.to_bool @@ equal x y
+
+and equal_tl : type t1 t2 v1 v2.
+    (t1, v1) tl ->
+    (t2, v2) tl ->
+    (t1, t2) Typeid.witness ->
+    (v1, v2) Typeid.witness =
+ fun x y eq ->
+  match (x, y, eq) with
+  | Nil, Nil, Eq -> Eq
+  | Cons (h1, t1), Cons (h2, t2), Eq -> (
+      match (equal h1 h2, equal_tl t1 t2 Eq) with Eq, Eq -> Eq | _ -> NotEq)
+  | _ -> NotEq
+
+module Tbl = Hashtbl.Make (struct
+  type t = abstract
+
+  let hash = hash_abstract
+  let equal = equal_abstract
+end)
+
+module Hashcons : sig
+  type tbl
+
+  val create : unit -> tbl
+  val add : tbl -> 'a t -> 'a t -> unit
+  val get : tbl -> 'a t -> 'a t option
+end = struct
+  type tbl = abstract Tbl.t
+
+  let create () = Tbl.create 50
+  let add tbl a b = Tbl.add tbl (abstract a) (abstract b)
+
+  let get (type a) tbl (oldv : a t) : a t option =
+    if Tbl.mem tbl @@ abstract oldv then
+      let (Abstract newv) = Tbl.find tbl (abstract oldv) in
+      match equal oldv newv with Eq -> Some newv | NotEq -> None
+    else None
+end
+
+let simplify ~full ~context (Abstract t) =
+  let tbl = Hashcons.create () in
+  let rec aux : type a. a t -> a t =
+   fun impl ->
+    match Hashcons.get tbl impl with
+    | Some impl' -> impl'
+    | None ->
+        let acc =
+          match impl with
+          | If { cond; branches; default } ->
+              (* Either
+                 - A key is present in the context
+                 - We are in full mode, and we use its default value
+              *)
+              if full || Key.mem context cond then
+                let path = Key.eval context cond in
+                let t =
+                  try List.assoc path branches with Not_found -> default
+                in
+                aux t
+              else
+                let branches = List.map (fun (p, t) -> (p, aux t)) branches in
+                mk_switch ~cond ~branches ~default
+          | Dev { dev; args; deps } ->
+              let args = aux_tl args in
+              let deps = List.map aux_abstract deps in
+              mk_dev ~args ~deps dev
+          | App { f; args } ->
+              let f = aux f in
+              let args = aux_tl args in
+              mk_app ~f ~args
+        in
+        Hashcons.add tbl impl acc;
+        acc
+  and aux_abstract (Abstract a) = Abstract (aux a)
+  and aux_tl : type a v. (a, v) tl -> (a, v) tl = function
+    | Nil -> Nil
+    | Cons (h, t) -> Cons (aux h, aux_tl t)
+  in
+  Abstract (aux t)
+
+let eval ~context (Abstract t) =
+  let new_id =
+    let r = ref 0 in
+    fun () ->
+      incr r;
+      !r
+  in
+  let tbl = Tbl.create 50 in
+  let rec aux : type a. a t -> Device.Graph.t =
+   fun impl ->
+    if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
+    else
+      let acc =
+        match impl with
+        | Dev { dev; args; deps } ->
+            let args = aux_tl args in
+            let deps = List.map aux_abstract deps in
+            Device.Graph.D { dev; args; deps; id = new_id () }
+        | App { f; args = extra_args } ->
+            let (D { dev; args; deps; id = _ }) = aux f in
+            let extra_args = aux_tl extra_args in
+            D { dev; args = args @ extra_args; deps; id = new_id () }
+        | If { cond; branches; default } ->
+            let path = Key.eval context cond in
+            let t = try List.assoc path branches with Not_found -> default in
+            aux t
+      in
+      Tbl.add tbl (abstract impl) acc;
+      acc
+  and aux_abstract (Abstract a) = aux a
+  and aux_tl : type a v. (a, v) tl -> _ = function
+    | Nil -> []
+    | Cons (h, t) ->
+        let a = aux h in
+        a :: aux_tl t
+  in
+  aux t
+
+type 'b f_dev = { f : 'a. ('a, abstract) Device.t -> 'b }
+
+let with_left_most_device ctx t (f : _ f_dev) =
+  let rec aux : type a. a t -> _ = function
+    | Dev d -> f.f d.dev
+    | App a -> aux a.f
+    | If { cond; branches; default } ->
+        let path = Key.eval ctx cond in
+        let t = try List.assoc path branches with Not_found -> default in
+        aux t
+  in
+  aux t
+
+type 'b f_dev_full = {
+  f : 'a 'v. args:'b list -> deps:'b list -> 'a device -> 'b;
+}
+
+type 'a f_switch = {
+  if_ : 'r. cond:'r Key.value -> branches:('r * 'a) list -> default:'a -> 'a;
+}
+
+type 'a f_app = f:'a -> args:'a list -> 'a
+
+let map (type r) ~(mk_switch : _ f_switch) ~(mk_app : _ f_app)
+    ~(mk_dev : _ f_dev_full) t =
+  let tbl = Tbl.create 50 in
+  let rec aux : type a. a t -> r =
+   fun impl ->
+    if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
+    else
+      let acc =
+        match impl with
+        | Dev { dev; args; deps } ->
+            let deps =
+              List.fold_right (fun (Abstract x) l -> aux x :: l) deps []
+            in
+            let args = aux_tl args in
+            mk_dev.f ~args ~deps dev
+        | App { f; args } ->
+            let f = aux f in
+            let args = aux_tl args in
+            mk_app ~f ~args
+        | If { cond; branches; default } ->
+            let branches = List.map (fun (p, t) -> (p, aux t)) branches in
+            let default = aux default in
+            mk_switch.if_ ~cond ~branches ~default
+      in
+      Tbl.add tbl (abstract impl) acc;
+      acc
+  and aux_tl : type a v. (a, v) tl -> r list = function
+    | Nil -> []
+    | Cons (h, t) -> aux h :: aux_tl t
+  in
+  aux t
+
+type label = If : _ Key.value -> label | Dev : _ Device.t -> label | App
+
+let collect : type ty.
+    (module Misc.Monoid with type t = ty) -> (label -> ty) -> abstract -> ty =
+ fun (module M) op (Abstract t) ->
+  let r = ref M.empty in
+  let add x = r := M.union (op x) !r in
+  let mk_switch = { if_ = (fun ~cond ~branches:_ ~default:_ -> add @@ If cond) }
+  and mk_app ~f:_ ~args:_ = add App
+  and mk_dev = { f = (fun ~args:_ ~deps:_ dev -> add @@ Dev dev) } in
+  let () = map ~mk_switch ~mk_app ~mk_dev t in
+  !r
+
+(* {2 Dot output} *)
+module Dot = struct
+  type edge_label =
+    | Functor
+    | Argument
+    | Dependency
+    | Branch of { default : bool }
+
+  let as_dot_graph (Abstract t) =
+    let r = ref 0 in
+    let new_id () =
+      incr r;
+      !r
+    in
+    let vertices = ref [] in
+    let edges = ref [] in
+    let add r x = r := x :: !r in
+    let mk_switch =
+      {
+        if_ =
+          (fun ~cond ~branches ~default ->
+            let id = new_id () in
+            add vertices (id, If cond);
+            List.iter
+              (fun (_, id') -> add edges (id, id', Branch { default = false }))
+              branches;
+            add edges (id, default, Branch { default = true });
+            id);
+      }
+    and mk_app ~f ~args =
+      let id = new_id () in
+      add vertices (id, App);
+      add edges (id, f, Functor);
+      List.iter (fun id' -> add edges (id, id', Argument)) args;
+      id
+    and mk_dev =
+      {
+        f =
+          (fun ~args ~deps dev ->
+            let id = new_id () in
+            add vertices (id, Dev dev);
+            List.iter (fun id' -> add edges (id, id', Argument)) args;
+            List.iter (fun id' -> add edges (id, id', Dependency)) deps;
+            id);
+      }
+    in
+    let _ = map ~mk_switch ~mk_app ~mk_dev t in
+    (List.rev !vertices, List.rev !edges)
+
+  let pp_vertice ppf (id, label) =
+    let attrs =
+      match label with
+      | App -> [ ("label", "$"); ("shape", "diamond") ]
+      | If cond -> [ ("label", Fmt.str "If\n%a" Key.pp_deps cond) ]
+      | Dev dev ->
+          let name = Fmt.str "%s__%i" (Device.nice_name dev) id in
+          let label =
+            Fmt.str "%s\n%s\n%a" name (Device.module_name dev)
+              Fmt.(list ~sep:(any ", ") Key.pp)
+              (Device.keys dev)
+          in
+          [ ("label", label); ("shape", "box") ]
+    in
+    let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
+    Fmt.pf ppf "%d [%a];" id (Fmt.list ~sep:(Fmt.any ", ") pp_attr) attrs
+
+  let pp_edges ppf (id, id', label) =
+    let attrs =
+      match label with
+      | Functor -> [ ("style", "bold"); ("tailport", "sw") ]
+      | Argument -> []
+      | Dependency -> [ ("style", "dashed") ]
+      | Branch { default } ->
+          let l = [ ("style", "dotted"); ("headport", "n") ] in
+          if default then ("style", "bold") :: l else l
+    in
+    let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
+    Fmt.pf ppf "%d -> %d [%a];" id id'
+      (Fmt.list ~sep:(Fmt.any ", ") pp_attr)
+      attrs
+
+  let pp ppf t =
+    let vertices, edges = as_dot_graph t in
+    Fmt.pf ppf {|@[<v2>digraph G {@,ordering=out;@,%a@,@,%a@,}@]|}
+      (Fmt.list ~sep:Fmt.cut pp_vertice)
+      vertices
+      (Fmt.list ~sep:Fmt.cut pp_edges)
+      edges
+end
+
+let pp_dot = Dot.pp

unikernel/duniverse/mirage/lib/functoria/impl.mli

@@ -0,0 +1,120 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type 'a t
+(** The type for values representing module implementations of type ['a]. *)
+
+type abstract
+(** The type for untyped {!t}. *)
+
+type 'a device = ('a, abstract) Device.t
+(** The type for device whose dependencies have type {!type:abstract}. *)
+
+val abstract : 'a t -> abstract
+(** [abstract i] is [i] with its type erased. *)
+
+val app_has_no_arguments : 'a t -> bool
+(** [app_has_no_arguments i] is [true] if the argument list is empty and it is
+    an application, [false] otherwise. *)
+
+val pp : 'a t Fmt.t
+(** [pp] is the pretty-printer for module implementations. *)
+
+val pp_abstract : abstract Fmt.t
+(** [pp_abstract] is the pretty-printer for abstract module implementations. *)
+
+val pp_dot : abstract Fmt.t
+(** [pp_dot] outputs the dot representation of module implementations. *)
+
+val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t
+(** [m $ a] applies the functor [m] to the module [a]. *)
+
+val if_ : bool Key.value -> 'a t -> 'a t -> 'a t
+(** [if_t v t1 t2] is [t1] if [v] is resolved to true and [t2] otherwise. *)
+
+val match_ : 'b Key.value -> default:'a t -> ('b * 'a t) list -> 'a t
+(** [match_t v cases ~default] chooses the tementation amongst [cases] by
+    matching the [v]'s value. [default] is chosen if no value matches. *)
+
+val of_device : 'a device -> 'a t
+(** [of_device t] is the tementation device [t]. *)
+
+val local_libs : 'a t -> string list
+(** [local_libs t] is the list of of local libraries that are needed by [t]. *)
+
+val v :
+  ?packages:Package.t list ->
+  ?packages_v:Package.t list Key.value ->
+  ?runtime_args:Runtime_arg.t list ->
+  ?keys:Key.t list ->
+  ?extra_deps:abstract list ->
+  ?connect:(Info.t -> string -> string list -> 'a Device.code) ->
+  ?dune:(Info.t -> Dune.stanza list) ->
+  ?configure:(Info.t -> unit Action.t) ->
+  ?files:(Info.t -> Fpath.t list) ->
+  string ->
+  'a Type.t ->
+  'a t
+(** [v ...] is [of_device @@ Device.v ...] *)
+
+val main :
+  ?pos:string * int * int * int ->
+  ?packages:Package.t list ->
+  ?packages_v:Package.t list Key.value ->
+  ?runtime_args:Runtime_arg.t list ->
+  ?keys:Key.t list ->
+  ?extra_deps:abstract list ->
+  string ->
+  'a Type.t ->
+  'a t
+(** [main ... name ty] is [v ... ~connect name ty] where [connect] is
+    [<name>.start <args>] *)
+
+module Tbl : Hashtbl.S with type key = abstract
+(** Hashtbl of implementations. *)
+
+(** {1 Applications} *)
+
+type 'b f_dev = { f : 'a. 'a device -> 'b }
+(** The type for iterators on devices. *)
+
+val with_left_most_device : Context.t -> _ t -> 'a f_dev -> 'a
+(** [with_left_most_device ctx t f] applies [f] on the left-most device in [f].
+    [If] node are resolved using [ctx]. *)
+
+val simplify : full:bool -> context:Context.t -> abstract -> abstract
+(** [simplify ~full ~context impl] simplifies the implementation [impl]
+    according to keys present in the [context].
+
+    If [full] is [true], then the default values of keys are used in their
+    absence. Otherwise, absent keys are left un-simplified. *)
+
+val eval : context:Context.t -> abstract -> Device.Graph.t
+(** [eval ~context impl] fully evaluates the implementation [impl] according to
+    keys present in the [context]. It returns a graph composed only of devices.
+*)
+
+(** Collections *)
+
+(** The description of a vertex *)
+type label = If : _ Key.value -> label | Dev : _ Device.t -> label | App
+
+val collect :
+  (module Misc.Monoid with type t = 'ty) -> (label -> 'ty) -> abstract -> 'ty
+(** [collect (module M) f g] collects the content of [f v] for each vertex [v]
+    in [g]. *)

unikernel/duniverse/mirage/lib/functoria/info.ml

@@ -0,0 +1,135 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+
+type t = {
+  config_file : Fpath.t;
+  name : string;
+  project_name : string;
+  output : string option;
+  keys : Key.Set.t;
+  runtime_args : Runtime_arg.Set.t;
+  context : Context.t;
+  packages : Package.t String.Map.t;
+  local_libs : string list;
+  opam :
+    extra_repo:(string * string) list ->
+    install:Install.t ->
+    opam_name:string ->
+    Opam.t;
+}
+
+let name t = t.name
+let project_name t = t.project_name
+let config_file t = t.config_file
+
+let main t =
+  let main = match t.output with None -> "main" | Some f -> f in
+  Fpath.v (main ^ ".ml")
+
+let get t k = Key.get t.context k
+let opam t = t.opam
+let output t = t.output
+let with_output t output = { t with output = Some output }
+
+let libraries ps =
+  let libs p =
+    if Package.build_dependency p then String.Set.empty
+    else String.Set.of_list (Package.libraries p)
+  in
+  String.Set.elements
+    (List.fold_left String.Set.union String.Set.empty (List.map libs ps))
+
+let packages t = List.map snd (String.Map.bindings t.packages)
+let libraries t = libraries (packages t) @ t.local_libs
+
+let pins packages =
+  List.fold_left
+    (fun acc p -> match Package.pin p with None -> acc | Some u -> u :: acc)
+    [] packages
+
+let keys t = Key.Set.elements t.keys
+let runtime_args t = Runtime_arg.Set.elements t.runtime_args
+let context t = t.context
+
+let v ?(config_file = Fpath.v "config.ml") ~packages ~local_libs ~keys
+    ~runtime_args ~context ?configure_cmd ?pre_build_cmd ?lock_location
+    ~build_cmd ~src ~project_name name =
+  let keys = Key.Set.of_list keys in
+  let runtime_args = Runtime_arg.Set.of_list runtime_args in
+  let opam ~extra_repo ~install ~opam_name =
+    Opam.v ~depends:packages ~install ~pins:(pins packages) ~extra_repo
+      ?configure:configure_cmd ?pre_build:pre_build_cmd ?lock_location
+      ~build:build_cmd ~src ~opam_name name
+  in
+  let packages =
+    List.fold_left
+      (fun m p ->
+        let n = Package.name p in
+        match String.Map.find n m with
+        | None -> String.Map.add n p m
+        | Some p' -> (
+            match Package.merge p p' with
+            | Some p -> String.Map.add n p m
+            | None -> m))
+      String.Map.empty packages
+  in
+  {
+    config_file;
+    name;
+    project_name;
+    keys;
+    runtime_args;
+    packages;
+    local_libs;
+    context;
+    output = None;
+    opam;
+  }
+
+let pp_packages ?(surround = "") ?sep ppf t =
+  let pkgs = packages t in
+  Fmt.pf ppf "%a" (Fmt.iter ?sep List.iter (Package.pp ~surround)) pkgs
+
+let pp verbose ppf ({ name; keys; context; output; _ } as t) =
+  let show ?(newline = true) name =
+    Fmt.pf ppf ("@[<2>%-10s@ %a@]" ^^ if newline then "@," else "") name
+  in
+  let list = Fmt.iter ~sep:(Fmt.any ",@ ") List.iter Fmt.string in
+  show "Name" Fmt.string name;
+  show "Keys" ~newline:(verbose || output <> None) (Key.pps context) keys;
+  let () =
+    match output with
+    | None -> ()
+    | Some o -> show "Output" ~newline:verbose Fmt.(string) o
+  in
+  if verbose then show "Libraries " list (libraries t);
+  if verbose then
+    show "Packages" ~newline:false
+      (pp_packages ?surround:None ~sep:(Fmt.any ",@ "))
+      t
+
+let t =
+  let i =
+    v ~config_file:(Fpath.v "config.ml") ~packages:[] ~local_libs:[] ~keys:[]
+      ~runtime_args:[]
+      ~build_cmd:(fun _ -> "dummy")
+      ~context:Context.empty ~src:`None "dummy" ~project_name:"dummy"
+  in
+  Type.v i

unikernel/duniverse/mirage/lib/functoria/info.mli

@@ -0,0 +1,92 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Information about the final application. *)
+
+type t
+(** The type for information about the final application. *)
+
+val config_file : t -> Fpath.t
+(** [config_file t] is the configuration file of the application. *)
+
+val name : t -> string
+(** [name t] is the name of the application. *)
+
+val project_name : t -> string
+(** [project_name t] is the project name. *)
+
+val main : t -> Fpath.t
+(** [main t] is the name of the main application file. *)
+
+val output : t -> string option
+(** [output t] is the name of [t]'s output. Derived from {!name} if not set. *)
+
+val with_output : t -> string -> t
+(** [with_output t o] is similar to [t] but with the output set to [Some o]. *)
+
+val libraries : t -> string list
+(** [libraries t] are the direct OCamlfind dependencies. *)
+
+val packages : t -> Package.t list
+(** [packages t] are the opam package dependencies by the project. *)
+
+val opam :
+  t ->
+  extra_repo:(string * string) list ->
+  install:Install.t ->
+  opam_name:string ->
+  Opam.t
+(** [opam scope t] is [t]'opam file to install in the [scope] context.*)
+
+val keys : t -> Key.t list
+(** [keys t] is the list of keys which can be used to configure [t]. *)
+
+val runtime_args : t -> Runtime_arg.t list
+(** [runtime_args t] is the list of command-line arguments which can be used to
+    configure [t] at runtime. *)
+
+val context : t -> Context.t
+(** [parsed t] is a value representing the command-line argument being parsed.
+*)
+
+val get : t -> 'a Key.key -> 'a
+(** [get i k] is the value associated with [k] in [context i]. *)
+
+val v :
+  ?config_file:Fpath.t ->
+  packages:Package.t list ->
+  local_libs:string list ->
+  keys:Key.t list ->
+  runtime_args:Runtime_arg.t list ->
+  context:Context.t ->
+  ?configure_cmd:string ->
+  ?pre_build_cmd:(Fpath.t option -> string) ->
+  ?lock_location:(Fpath.t option -> string -> string) ->
+  build_cmd:(Fpath.t option -> string) ->
+  src:[ `Auto | `None | `Some of string ] ->
+  project_name:string ->
+  string ->
+  t
+(** [create context n r] contains information about the application being built.
+*)
+
+val pp : bool -> t Fmt.t
+
+(** {1 Devices} *)
+
+val t : t Type.t

unikernel/duniverse/mirage/lib/functoria/install.ml

@@ -0,0 +1,95 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t = { bin : (Fpath.t * Fpath.t) list; etc : Fpath.t list }
+
+let v ?(bin = []) ?(etc = []) () = { bin; etc }
+let empty = v ()
+
+let dump ppf t =
+  let bin ppf t = Fmt.Dump.(list (pair Fpath.pp Fpath.pp)) ppf t.bin in
+  let etc ppf t = Fmt.Dump.(list Fpath.pp) ppf t.etc in
+  Fmt.Dump.record [ bin; etc ] ppf t
+
+let pp ppf t =
+  let pp_bin ppf (src, dst) =
+    Fmt.pf ppf "\n  \"%a\" {\"%a\"}" Fpath.pp src Fpath.pp dst
+  in
+  let pp_etc ppf file =
+    Fmt.pf ppf "\n  \"%a\" {\"%s\"}" Fpath.pp file Fpath.(basename file)
+  in
+  let bins = List.map (Fmt.to_to_string pp_bin) t.bin in
+  let etcs = List.map (Fmt.to_to_string pp_etc) t.etc in
+  Fmt.pf ppf "bin: [%s%s]\n" (String.concat "" bins)
+    (match bins with [] -> "" | _ -> "\n");
+  Fmt.pf ppf "etc: [%s%s]" (String.concat "" etcs)
+    (match etcs with [] -> "" | _ -> "\n")
+
+let pp_opam ?subdir () ppf t =
+  let pp_bin ppf (src, dst) =
+    Fmt.pf ppf {|"cp" "%adist/%a" "%%{bin}%%/%a"|}
+      Fmt.(option ~none:(any "") Fpath.pp)
+      subdir Fpath.pp src Fpath.pp dst
+  in
+  let pp_etc ppf etc =
+    Fmt.pf ppf {|"cp" "%adist/%a" "%%{etc}%%"|}
+      Fmt.(option ~none:(any "") Fpath.pp)
+      subdir Fpath.pp etc
+  in
+  Fmt.pf ppf "\n%a\n"
+    (Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf "  [ %a ]" pp_bin))
+    t.bin;
+  match t.etc with
+  | [] -> ()
+  | _ ->
+      Fmt.pf ppf "%a\n"
+        (Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf "  [ %a ]" pp_etc))
+        t.etc
+
+let promote_artifact ~context_name ~src ~dst =
+  Dune.stanzaf
+    {|
+(rule
+ (mode (promote (until-clean)))
+ (target %a)
+ (enabled_if (= %%{context_name} "%s"))
+ (action
+  (copy %a %%{target}))
+)
+|}
+    Fpath.pp dst context_name Fpath.pp
+    Fpath.(v ".." // src)
+
+let dune ~context_name_for_bin ~context_name_for_etc t =
+  let bin_rules =
+    List.map
+      (fun (src, dst) ->
+        promote_artifact ~context_name:context_name_for_bin ~src ~dst)
+      t.bin
+  in
+  let etc_rules =
+    List.map
+      (fun etc ->
+        promote_artifact ~context_name:context_name_for_etc ~src:etc ~dst:etc)
+      t.etc
+  in
+  Dune.v (bin_rules @ etc_rules)
+
+let union_etc x y = Fpath.Set.(elements (union (of_list x) (of_list y)))
+let union_bin x y = x @ y
+let union x y = { bin = union_bin x.bin y.bin; etc = union_etc x.etc y.etc }

unikernel/duniverse/mirage/lib/functoria/install.mli

@@ -0,0 +1,48 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t
+
+val v : ?bin:(Fpath.t * Fpath.t) list -> ?etc:Fpath.t list -> unit -> t
+(** [v ~bin:[(src,dst),...] ~etc ()] is the installation of [src] as [dst] as
+    binary files, and [etc] as configuration/artifact. *)
+
+val union : t -> t -> t
+(** [union a b] merge to sets of installation rules. *)
+
+val empty : t
+(** [empty] is the installation of nothing. *)
+
+val pp : t Fmt.t
+(** Print the .install rules to install [t] *)
+
+val pp_opam : ?subdir:Fpath.t -> unit -> t Fmt.t
+(** Print the opam rules to install [t]. If [~subdir] is provided, this will be
+    used as prefix (i.e. if your unikernel is in the "tutorial/hello/"
+    subdirectory (which is passed as [~subdir], the install instructions will
+    use [cp tutorial/hello/dist/hello.hvt %{bin}%/hello.hvt]). *)
+
+val dune :
+  context_name_for_bin:string -> context_name_for_etc:string -> t -> Dune.t
+(** [dune ~context_name_for_bin ~context_name_for_etc ()] is the dune rules to
+    promote installed files back in the source tree. A context-name is required
+    for [bin] and [etc] artifacts. The first one should be the cross-compiler
+    context and the second one should be the host's compiler context. *)
+
+val dump : t Fmt.t
+(** Dump installation rules. *)

unikernel/duniverse/mirage/lib/functoria/job.ml

@@ -0,0 +1,51 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+let src = Logs.Src.create "functoria" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type t = JOB
+
+let t = Type.v JOB
+
+(* Noop, the job that does nothing. *)
+let noop = Impl.v "Unit" t
+
+module Args = struct
+  let configure ~runtime_modname i =
+    let serialize = Runtime_arg.serialize ~runtime_modname in
+    let file = Info.main i in
+    Action.with_output ~append:true ~path:file ~purpose:"keys" (fun ppf ->
+        let keys = Runtime_arg.Set.of_list @@ Info.runtime_args i in
+        Fmt.pf ppf "@[<v>%a@]@." Fmt.(iter Runtime_arg.Set.iter serialize) keys)
+end
+
+let runtime_args
+    ?(runtime_package = Package.v "mirage-runtime" ~sublibs:[ "functoria" ])
+    ?(runtime_modname = "Functoria_runtime") (argv : Argv.t Impl.t) =
+  let packages = [ runtime_package ] in
+  let extra_deps = [ Impl.abstract argv ] in
+  let configure = Args.configure ~runtime_modname in
+  let connect info _ = function
+    | [ argv ] ->
+        Device.code ~pos:__POS__ "return %s.(with_argv (runtime_args ()) %S %s)"
+          runtime_modname (Info.name info) argv
+    | _ -> failwith "The keys connect should receive exactly one argument."
+  in
+  Impl.v ~configure ~packages ~extra_deps ~connect "struct end" t

unikernel/duniverse/mirage/lib/functoria/job.mli

@@ -0,0 +1,37 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** The representation of main tasks. *)
+
+type t
+(** Type for job values. *)
+
+val t : t Type.t
+(** [job] is the signature for user's application main module. *)
+
+val noop : t Impl.t
+(** [noop] is an implementation of {!Functoria.job} that holds no state, does
+    nothing and has no dependency. *)
+
+val runtime_args :
+  ?runtime_package:Package.t ->
+  ?runtime_modname:string ->
+  Argv.t Impl.t ->
+  t Impl.t
+(** [runtime_args a] is an implementation of {!Functoria.job} that holds the
+    parsed command-line arguments. *)

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

@@ -0,0 +1,218 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Cmdliner
+
+module Arg = struct
+  (** {1 Arguments} *)
+
+  let info = Arg.info
+
+  type 'a kind =
+    | Opt : 'a * 'a Arg.conv -> 'a kind
+    | Opt_all : 'a Arg.conv -> 'a list kind
+    | Required : 'a Arg.conv -> 'a option kind
+    | Flag : bool kind
+
+  let pp_conv c = Arg.conv_printer c
+
+  let pp_kind : type a. a kind -> a Fmt.t = function
+    | Opt (_, c) -> pp_conv c
+    | Opt_all c -> pp_conv (Arg.list c)
+    | Required c -> pp_conv (Arg.some c)
+    | Flag -> Fmt.bool
+
+  let compare_kind : type a b. a kind -> b kind -> int =
+   fun a b ->
+    let default cx x = Fmt.to_to_string (Arg.conv_printer cx) x in
+    match (a, b) with
+    | Opt (x, cx), Opt (y, cy) -> String.compare (default cx x) (default cy y)
+    | Required _, Required _ -> 0
+    | Opt_all _, Opt_all _ -> 0
+    | Flag, Flag -> 0
+    | Opt _, _ -> 1
+    | _, Opt _ -> -1
+    | Required _, _ -> 1
+    | _, Required _ -> -1
+    | Opt_all _, _ -> 1
+    | _, Opt_all _ -> -1
+
+  type 'a t = { info : Arg.info; kind : 'a kind }
+
+  let pp t = pp_kind t.kind
+  let equal x y = compare_kind x.kind y.kind = 0
+  let opt conv default info = { info; kind = Opt (default, conv) }
+  let flag info = { info; kind = Flag }
+  let required conv info = { info; kind = Required conv }
+  let opt_all conv info = { info; kind = Opt_all conv }
+
+  let default (type a) (t : a t) =
+    match t.kind with
+    | Opt (d, _) -> d
+    | Flag -> (false : bool)
+    | Required _ -> (None : _ option)
+    | Opt_all _ -> ([] : _ list)
+
+  let make_opt_cmdliner wrap i default desc =
+    Arg.(wrap @@ opt (some' ?none:default desc) None i)
+
+  let make_opt_all_cmdliner wrap i desc = Arg.(wrap @@ opt_all desc [] i)
+
+  (* Wrap terms into an ['a option] to distinguish between default
+     and absent values. *)
+  let to_cmdliner (type a) (t : a t) : a option Cmdliner.Term.t =
+    let i = t.info in
+    match t.kind with
+    | Flag -> Arg.(value & vflag None [ (Some true, i) ])
+    | Opt (default, desc) -> make_opt_cmdliner Arg.value i (Some default) desc
+    | Required desc ->
+        make_opt_cmdliner Arg.required i None (Arg.some (Arg.some desc))
+    | Opt_all desc ->
+        let list_to_option = function
+          | [] -> None
+          | _ :: _ as lst -> Some lst
+        in
+        let wrap arg = Term.(const list_to_option $ Arg.value arg) in
+        make_opt_all_cmdliner wrap i desc
+end
+
+type 'a key = { name : string; arg : 'a Arg.t; key : 'a Context.key }
+type t = Any : 'a key -> t
+
+let equal (Any x) (Any y) = String.equal x.name y.name && Arg.equal x.arg y.arg
+
+(* Set of keys, without runtime name conflicts. This is useful to create a
+   valid cmdliner term. *)
+module Names = Stdlib.Set.Make (struct
+  type nonrec t = t
+
+  let compare (Any x) (Any y) = String.compare x.name y.name
+end)
+
+(* Set of keys, where keys with the same name but with different
+   defaults are distinguished. This is useful to build the graph of
+   devices. *)
+module Set = struct
+  module M = struct
+    type nonrec t = t
+
+    let compare = compare
+  end
+
+  include Set.Make (M)
+
+  let add k set =
+    if mem k set then
+      if k != find k set then
+        match k with Any k -> Fmt.invalid_arg "Duplicate key name: %s" k.name
+      else set
+    else add k set
+
+  let pp_gen = Fmt.iter ~sep:(Fmt.any ",@ ") iter
+  let pp_elt fmt (Any k) = Fmt.string fmt k.name
+  let pp = pp_gen pp_elt
+end
+
+let v x = Any x
+let name (Any k) = k.name
+
+(* Key Map *)
+
+type context = Context.t
+
+let add_to_context t = Context.add t.key
+let find (type a) ctx (t : a key) : a option = Context.find t.key ctx
+let get ctx t = match find ctx t with Some x -> x | None -> Arg.default t.arg
+let mem_u ctx t = Context.mem t.key ctx
+
+(* {2 Values} *)
+
+type +'a value = { deps : Set.t; v : context -> 'a }
+
+let eval p v = v.v p
+let pure x = { deps = Set.empty; v = (fun _ -> x) }
+
+let app f x =
+  { deps = Set.union f.deps x.deps; v = (fun p -> (eval p f) (eval p x)) }
+
+let map f x = app (pure f) x
+let pipe x f = map f x
+let if_ c t e = pipe c @@ fun b -> if b then t else e
+let match_ v f = map f v
+let ( $ ) = app
+
+let value k =
+  let v c = get c k in
+  { deps = Set.singleton (Any k); v }
+
+let of_deps deps = { (pure ()) with deps }
+let deps k = k.deps
+let mem p v = Set.for_all (function Any x -> mem_u p x) v.deps
+let peek p v = if mem p v then Some (eval p v) else None
+let default v = eval Context.empty v
+
+(* {2 Pretty printing} *)
+
+let pp = Set.pp_elt
+let pp_deps fmt v = Set.pp fmt v.deps
+
+let pps p ppf l =
+  let pp' fmt k v =
+    let default = if mem_u p k then Fmt.nop else Fmt.any " (default)" in
+    Fmt.pf fmt "%a=%a%a"
+      Fmt.(styled `Bold string)
+      k.name (Arg.pp k.arg) v default ()
+  in
+  let f fmt (Any k) =
+    match (k.arg.Arg.kind, get p k) with
+    | Arg.Required _, None -> Fmt.(styled `Bold string) fmt k.name
+    | Arg.Opt _, v -> pp' fmt k v
+    | Arg.Required _, v -> pp' fmt k v
+    | Arg.Flag, v -> pp' fmt k v
+    | Arg.Opt_all _, v -> pp' fmt k v
+    (* Warning 4 and GADT don't interact well. *)
+  in
+  let pp = Fmt.vbox @@ fun ppf s -> Set.(pp_gen f ppf @@ s) in
+  pp ppf l
+
+(* {2 Key creation} *)
+
+(* Unexposed smart constructor. *)
+let make ~arg ~name =
+  let key = Context.new_key name in
+  { arg; name; key }
+
+let create name arg =
+  if name = "" then
+    invalid_arg "Key.create: key name cannot be the empty string";
+  make ~arg ~name
+
+(* {2 Cmdliner interface} *)
+
+let context l =
+  let names = Names.of_list (Set.elements l) in
+  let gather (Any k) rest =
+    let f v p = match v with None -> p | Some v -> Context.add k.key v p in
+    let key = Arg.to_cmdliner k.arg in
+    match k.arg.Arg.kind with
+    | Arg.Opt _ -> Cmdliner.Term.(const f $ key $ rest)
+    | Arg.Required _ -> Cmdliner.Term.(const f $ key $ rest)
+    | Arg.Flag -> Cmdliner.Term.(const f $ key $ rest)
+    | Arg.Opt_all _ -> Cmdliner.Term.(const f $ key $ rest)
+  in
+  Names.fold gather names (Cmdliner.Term.const Context.empty)

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

@@ -0,0 +1,175 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Configuration command-line arguments. *)
+
+open Cmdliner
+
+module Arg : sig
+  (** Terms for cross-stage arguments.
+
+      This module extends
+      {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html}
+       Cmdliner.Arg} to allow MetaOCaml-style typed cross-stage persistency of
+      command-line arguments. *)
+
+  type 'a t
+  (** The type for arguments holding data of type ['a]. *)
+
+  (** {1 Optional Arguments} *)
+
+  val opt : 'a Arg.conv -> 'a -> Arg.info -> 'a t
+  (** [opt conv v i] is similar to
+      {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html#val-opt}
+       Cmdliner.Arg.opt} but for cross-stage optional command-line arguments. *)
+
+  val required : 'a Arg.conv -> Arg.info -> 'a option t
+  (** [required conv i] is similar to
+      {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html#val-required}
+       Cmdliner.Arg.required} but for cross-stage required command-line
+      arguments. *)
+
+  val flag : Arg.info -> bool t
+  (** [flag i] is similar to
+      {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html#val-flag}
+       Cmdliner.Arg.flag} but for cross-stage command-line flags. *)
+
+  val opt_all : 'a Arg.conv -> Arg.info -> 'a list t
+
+  val info :
+    ?deprecated:string ->
+    ?absent:string ->
+    ?docs:string ->
+    ?doc_envs:Cmd.Env.info list ->
+    ?docv:string ->
+    ?doc:string ->
+    ?env:Cmd.Env.info ->
+    string list ->
+    Arg.info
+  (** Same as {!Cmdliner.Arg.info}. *)
+end
+
+(** {1 Configuration Keys} *)
+
+type 'a key
+(** The type for configuration keys. Keys are used to parameterize the choice of
+    {{!Functoria.if_impl} module implementation}. *)
+
+val create : string -> 'a Arg.t -> 'a key
+(** [create n a] is the key named [n] whose contents is determined by parsing
+    the command-line argument [a]. *)
+
+(** {1 Configuration Values} *)
+
+type +'a value
+(** The type for configure-time and run-time values. Values are either {!pure}
+    or obtained by composing other values. Values might have
+    {{!deps} data dependencies}, which form an (implicit) directed and acyclic
+    graph that need to be evaluated. *)
+
+val pure : 'a -> 'a value
+(** [pure x] is a value without any dependency. *)
+
+val ( $ ) : ('a -> 'b) value -> 'a value -> 'b value
+(** [f $ v] is is the value resulting from the application of [f]'value to [v]'s
+    value. [$] is the usual {i app} operator for
+    {{:http://dx.doi.org/10.1017/S0956796807006326} applicative functor}. *)
+
+val map : ('a -> 'b) -> 'a value -> 'b value
+(** [map f v] is [pure f $ v]. *)
+
+val if_ : bool value -> 'a -> 'a -> 'a value
+(** [if_ v x y] is [map (fun b -> if b then x else y) v]. *)
+
+val match_ : 'a value -> ('a -> 'b) -> 'b value
+(** [match_ v pattern] is [map pattern v]. *)
+
+val default : 'a value -> 'a
+(** [default v] returns the default value for [v]. *)
+
+val value : 'a key -> 'a value
+(** [value k] is the value parsed by [k]. *)
+
+(** {1 Abstract Keys} *)
+
+type t
+(** The type for abstract {{!type:key} keys}. *)
+
+val name : t -> string
+(** [name t] is the string given as [t]'s name when [t] was created. *)
+
+val v : 'a key -> t
+(** [v k] is the [k] with its type hidden. *)
+
+val equal : t -> t -> bool
+(** [equal] is the equality function of untyped keys. *)
+
+val pp : t Fmt.t
+(** [pp fmt k] prints the name of [k]. *)
+
+(** [Set] implements sets over [t] elements. *)
+module Set : sig
+  include Set.S with type elt = t
+
+  val pp : t Fmt.t
+  (** [pp] pretty-prints sets of keys. *)
+end
+
+val of_deps : Set.t -> unit value
+(** [of_deps keys] is a value with [keys] as data-dependencies. *)
+
+val deps : 'a value -> Set.t
+(** [deps v] are [v]'s data-dependencies. *)
+
+val pp_deps : 'a value Fmt.t
+(** [pp_deps fmt v] prints the name of the dependencies of [v]. *)
+
+(** {1 Parsing context} *)
+
+type context := Context.t
+(** The type for values holding parsing context. *)
+
+val add_to_context : 'a key -> 'a -> context -> context
+(** Add a binding to a context. *)
+
+val context : Set.t -> context Cmdliner.Term.t
+(** [context ks] is a [Cmdliner]
+    {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Term/index.html#type-t}
+     term} that evaluates into a parsing context for command-line arguments. *)
+
+val mem : context -> 'a value -> bool
+(** [mem c v] is [true] iff all the dependencies of [v] have been evaluated. *)
+
+val peek : context -> 'a value -> 'a option
+(** [peek c v] is [Some x] if [mem v] and [None] otherwise. *)
+
+val eval : context -> 'a value -> 'a
+(** [eval c v] evaluates [v] in [c]'s context, using default values if
+    necessary. *)
+
+val get : context -> 'a key -> 'a
+(** [get c k] is [k]'s value in [c]'s context. If [k] is not present in [c], it
+    is [k]'s default value.*)
+
+val find : context -> 'a key -> 'a option
+(** [find c k] is [k]'s value in [c]'s context or [None] if [k] is not present
+    in [c]. *)
+
+val pps : context -> Set.t Fmt.t
+(** [pps c fmt ks] prints the keys [ks] using the context [c] to get their
+    value. *)

unikernel/duniverse/mirage/lib/functoria/lib.ml

@@ -0,0 +1,523 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Action.Syntax
+open Astring
+open DSL
+module Name = Misc.Name
+
+let src = Logs.Src.create "functoria" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Config = struct
+  type t = {
+    config_file : Fpath.t;
+    name : string;
+    project_name : string;
+    configure_cmd : string;
+    pre_build_cmd : Fpath.t option -> string;
+    lock_location : Fpath.t option -> string -> string;
+    build_cmd : Fpath.t option -> string;
+    packages : package list Key.value;
+    local_libs : string list;
+    if_keys : Key.Set.t;
+    runtime_args : Runtime_arg.Set.t;
+    init : job impl list;
+    jobs : Impl.abstract;
+    src : [ `Auto | `None | `Some of string ];
+  }
+
+  type out = {
+    init : job impl list;
+    jobs : Impl.abstract;
+    info : Info.t;
+    device_graph : Device.Graph.t;
+  }
+
+  (* In practice, we get all the keys associated to [if] cases, and
+     all the keys that have a setter to them. *)
+  let get_if_context jobs =
+    let all_keys = Engine.keys jobs in
+    let skeys = Engine.if_keys jobs in
+    let f k s = if true then s else Key.Set.add k s in
+    Key.Set.fold f all_keys skeys
+
+  let v ?(config_file = Fpath.v "config.ml") ?(init = []) ~configure_cmd
+      ~pre_build_cmd ~lock_location ~build_cmd ~src ~project_name name jobs =
+    let local_libs = Impl.local_libs jobs in
+    let jobs = Impl.abstract jobs in
+    let if_keys = get_if_context jobs in
+    let runtime_args = Runtime_arg.Set.empty in
+    {
+      config_file;
+      if_keys;
+      runtime_args;
+      name;
+      project_name;
+      init;
+      configure_cmd;
+      pre_build_cmd;
+      lock_location;
+      build_cmd;
+      packages = Key.pure [];
+      local_libs;
+      jobs;
+      src;
+    }
+
+  let eval ~full context
+      {
+        config_file;
+        name = n;
+        project_name;
+        configure_cmd;
+        pre_build_cmd;
+        lock_location;
+        build_cmd;
+        packages;
+        local_libs;
+        if_keys;
+        runtime_args;
+        jobs;
+        init;
+        src;
+      } =
+    let jobs = Impl.simplify ~full ~context jobs in
+    let device_graph = Impl.eval ~context jobs in
+    let packages = Key.(pure List.append $ packages $ Engine.packages jobs) in
+    let all_keys = Engine.keys jobs in
+    let all_runtime_args = Engine.runtime_args jobs in
+    let runtime_args =
+      Runtime_arg.Set.(elements (union runtime_args all_runtime_args))
+    in
+    let keys = Key.Set.(elements (union if_keys all_keys)) in
+    let mk packages _ context =
+      let info =
+        Info.v ~config_file ~packages ~local_libs ~keys ~runtime_args ~context
+          ~configure_cmd ~pre_build_cmd ~lock_location ~build_cmd ~src
+          ~project_name n
+      in
+      { init; jobs; info; device_graph }
+    in
+    Key.(pure mk $ packages $ of_deps (Set.of_list keys))
+
+  let if_keys t = t.if_keys
+  let pp_dot = Impl.pp_dot
+end
+
+module type S = sig
+  val prelude : Info.t -> string
+  val packages : Package.t list
+  val name : string
+  val version : string
+  val create : job impl list -> job impl
+  val name_of_target : Info.t -> string
+  val target_filename : Info.t -> string
+  val dune_project : Dune.stanza list
+  val dune_workspace : (?build_dir:Fpath.t -> info -> Dune.t) option
+  val context_name : Info.t -> string
+end
+
+module Make (P : S) = struct
+  module Filegen = Filegen.Make (P)
+
+  let default_init = [ Job.runtime_args Argv.sys_argv ]
+  let build_dir args = Fpath.parent args.Cli.config_file
+  let config_file args = args.Cli.config_file
+  let mirage_dir args = Fpath.(build_dir args / P.name)
+  let artifacts_dir args = Fpath.(build_dir args / "dist")
+
+  let exit_err args = function
+    | Ok v -> v
+    | Error (`Msg m) ->
+        flush_all ();
+        if m <> "" then Fmt.epr "%a\n%!" Fmt.(styled (`Fg `Red) string) m;
+        if not args.Cli.dry_run then exit 1 else Fmt.epr "(exit 1)"
+
+  let get_cmds _ =
+    let command_line_arguments =
+      Sys.argv
+      |> Array.to_list
+      |> List.tl
+      |> List.filter (fun arg ->
+             arg <> "configure" && arg <> "query" && arg <> "opam")
+      |> String.concat ~sep:" "
+    in
+    let opts =
+      if command_line_arguments = "" then None else Some command_line_arguments
+    in
+    ( Fmt.str {|%s configure%a --no-extra-repo|} P.name
+        Fmt.(option ~none:(any "") (any " " ++ string))
+        opts,
+      (fun sub ->
+        Fmt.str {|make %a"lock" "depext-lockfile" "pull"|}
+          Fmt.(option ~none:(any "") (any "\"-C" ++ Fpath.pp ++ any "\" "))
+          sub),
+      (fun sub unikernel ->
+        Fmt.str {|%amirage/%s.opam.locked|}
+          Fmt.(option ~none:(any "") Fpath.pp)
+          sub unikernel),
+      fun sub ->
+        Fmt.str {|make %a"build"|}
+          Fmt.(option ~none:(any "") (any "\"-C" ++ Fpath.pp ++ any "\" "))
+          sub )
+
+  (* STAGE 2 *)
+
+  let src = Logs.Src.create (P.name ^ "-configure") ~doc:"functoria generated"
+
+  module Log = (val Logs.src_log src : Logs.LOG)
+
+  let eval_cached ~full ~output ~cache context t =
+    let info = Config.eval ~full context t in
+    let keys = Key.deps info in
+    let output =
+      match (output, Context_cache.peek_output cache) with
+      | Some _, _ -> output
+      | _, cache -> cache
+    in
+    let context = Key.context keys in
+    let context = Context_cache.merge cache context in
+    let f context =
+      let config = Key.eval context info context in
+      match output with
+      | None -> config
+      | Some o -> { config with info = Info.with_output config.info o }
+    in
+    Cmdliner.Term.(const f $ context)
+
+  (* FIXME: describe init *)
+  let describe (t : _ Cli.describe_args) =
+    let { Config.jobs; _ } = t.args.Cli.context in
+    let f fmt =
+      Fmt.pf fmt "%a\n%!" (if t.dot then Config.pp_dot else Fmt.nop) jobs
+    in
+    let with_fmt f =
+      match t.args.output with
+      | None when t.dot ->
+          f Format.str_formatter;
+          let data = Format.flush_str_formatter () in
+          let* tmp = Action.tmp_file ~mode:0o644 "graph%s.dot" in
+          let* () = Action.write_file tmp data in
+          Action.run_cmd Bos.Cmd.(v t.dotcmd % p tmp)
+      | None -> Action.ok (f Fmt.stdout)
+      | Some "-" -> Action.ok (f Fmt.stdout)
+      | Some s -> Action.with_output ~path:(Fpath.v s) ~purpose:"dot file" f
+    in
+    with_fmt f
+
+  let configure_main i init jobs =
+    let main = Info.main i in
+    let purpose = Fmt.str "configure: create %a" Fpath.pp main in
+    Log.info (fun m -> m "Generating: %a (main file)" Fpath.pp main);
+    let* () =
+      Action.with_output ~path:main ~append:false ~purpose (fun ppf ->
+          Fmt.pf ppf "%a@.@." Fmt.text (P.prelude i))
+    in
+    let* () = Engine.configure i jobs in
+    Engine.connect i ~init jobs
+
+  let files i jobs =
+    let main = Info.main i in
+    let files = Engine.files i jobs in
+    let files = Fpath.Set.add main files in
+    Fpath.Set.(elements files)
+
+  let opam_contents ~opam_name ~extra_repo args =
+    let { Config.info; jobs; _ } = args.Cli.context in
+    let install = Key.eval (Info.context info) (Engine.install info jobs) in
+    let name = Misc.Name.Opam.to_string opam_name in
+    let opam = Info.opam ~install ~extra_repo ~opam_name:name info in
+    Fmt.str "%a" Opam.pp opam
+
+  let generate_opam ~opam_name ~extra_repo args =
+    let contents = opam_contents ~opam_name ~extra_repo args in
+    let name = Misc.Name.Opam.to_string opam_name in
+    let file = Fpath.(v (name ^ ".opam")) in
+    Log.info (fun m ->
+        m "Generating: %a (%a)" Fpath.pp file Cli.pp_query_kind `Opam);
+    Filegen.write file contents
+
+  let copy_files files =
+    List.map
+      (fun f ->
+        match Fpath.split_ext f with
+        | _, (".ml" | ".mli") -> Dune.stanzaf "(copy_files# %a)" Fpath.pp f
+        | _ -> Dune.stanzaf "(copy_files %a)" Fpath.pp f)
+      files
+
+  let dune_contents alias args =
+    let { Config.info; jobs; _ } = args.Cli.context in
+    let name = P.name_of_target info in
+    let build_dir = build_dir args in
+    match alias with
+    | `Build ->
+        let files = files info jobs in
+        let files = List.map (fun p -> Fpath.(v "." / P.name // p)) files in
+        let dune = Dune.v (copy_files files @ Engine.dune info jobs) in
+        Fmt.str "%a\n" Dune.pp dune
+    | `Project ->
+        let dune =
+          Dune.v
+            (Dune.base_project
+            @ (Dune.stanzaf "(name %s)" name :: P.dune_project))
+        in
+        Fmt.str "%a\n" Dune.pp dune
+    | `Workspace ->
+        let dune =
+          match P.dune_workspace with
+          | None -> Dune.base_workspace
+          | Some f -> f ~build_dir info
+        in
+        Fmt.str "%a\n" Dune.pp dune
+    | `Dist ->
+        let install = Key.eval (Info.context info) (Engine.install info jobs) in
+        Fmt.str "%a\n" Dune.pp
+          (Install.dune ~context_name_for_bin:(P.context_name info)
+             ~context_name_for_etc:"default" install)
+    | `Config ->
+        let cwd = Bos.OS.Dir.current () |> Result.get_ok in
+        let config_ml_file = Fpath.(cwd // args.Cli.config_file) in
+        let dune = Dune.base ~config_ml_file ~packages:P.packages in
+        Fmt.str "%a\n" Dune.pp dune
+
+  let generate_dune alias args =
+    let contents = dune_contents alias args in
+    let file =
+      match alias with
+      | `Dist -> Fpath.(v "dune")
+      | `Build -> Fpath.(v "dune.build")
+      | `Config -> Fpath.(v "dune.config")
+      | `Workspace -> Fpath.(v "dune-workspace")
+      | `Project -> Fpath.(v "dune-project")
+    in
+    Log.info (fun m ->
+        m "Generating: %a (%a)" Fpath.pp file Cli.pp_query_kind
+          (`Dune alias :> Cli.query_kind));
+    Filegen.write file contents
+
+  let makefile_contents ~build_dir ~depext ~extra_repo ~public_name opam_name =
+    Fmt.to_to_string Makefile.pp
+      (Makefile.v ~build_dir ~depext ~builder_name:P.name ~public_name
+         ~extra_repo opam_name)
+
+  let generate_makefile ~build_dir ~depext ~extra_repo ~public_name opam_name =
+    let contents =
+      makefile_contents ~build_dir ~depext ~extra_repo ~public_name opam_name
+    in
+    let file = Fpath.(v "Makefile") in
+    Filegen.write file contents
+
+  let public_name info =
+    let default = P.target_filename info in
+    Option.value ~default (Info.output info)
+
+  let query ({ args; kind; depext; extra_repo } : _ Cli.query_args) =
+    let { Config.jobs; info; _ } = args.Cli.context in
+    let name = P.name_of_target info in
+    let build_dir = Fpath.parent args.config_file in
+    let public_name = public_name info in
+    match kind with
+    | `Name -> Fmt.pr "%s\n%!" (Info.name info)
+    | `Packages ->
+        let pkgs = Info.packages info in
+        List.iter (Fmt.pr "%a\n%!" (Package.pp ~surround:"\"")) pkgs
+    | `Opam ->
+        let opam_name = Misc.Name.opamify name in
+        let contents = opam_contents ~opam_name ~extra_repo args in
+        Fmt.pr "%s\n%!" contents
+    | `Files ->
+        let files = files info jobs in
+        Fmt.pr "%a\n%!" Fmt.(list ~sep:(any " ") Fpath.pp) files
+    | `Makefile ->
+        let opam_name = Misc.Name.opamify name in
+        let contents =
+          makefile_contents ~build_dir ~depext ~extra_repo ~public_name
+            opam_name
+        in
+        Fmt.pr "%s\n%!" contents
+    | `Dune alias -> Fmt.pr "%s%!" (dune_contents alias args)
+
+  (* Configuration step. *)
+
+  let clean (args : _ Cli.clean_args) =
+    let* () = Action.rmdir (mirage_dir args) in
+    Action.rmdir (artifacts_dir args)
+
+  let configure ({ args; depext; extra_repo; _ } : _ Cli.configure_args) =
+    let { Config.init; info; device_graph; _ } = args.Cli.context in
+    (* Get application name *)
+    let build_dir = build_dir args in
+    let name = P.name_of_target info in
+    let opam_name = Misc.Name.opamify name in
+    let public_name = public_name info in
+    let* () =
+      generate_makefile ~build_dir ~depext ~extra_repo ~public_name opam_name
+    in
+    let* _ = Action.mkdir (mirage_dir args) in
+    let* () =
+      Action.with_dir (mirage_dir args) (fun () ->
+          (* OPAM file *)
+          let* () = generate_opam ~opam_name ~extra_repo args in
+          (* Generate application specific-files *)
+          Log.info (fun m -> m "in dir %a" (Cli.pp_args (fun _ _ -> ())) args);
+          configure_main info init device_graph)
+    in
+    let* () =
+      Action.with_dir build_dir (fun () ->
+          let* () = generate_dune `Build args in
+          Filegen.write Fpath.(v "dune") "(include dune.build)\n")
+    in
+    (* dune-workspace: defines compilation contexts *)
+    let* () = generate_dune `Workspace args in
+    (* dune-project *)
+    let* () = generate_dune `Project args in
+    (* Get install spec *)
+    let* _ = Action.mkdir (artifacts_dir args) in
+    Action.with_dir (artifacts_dir args) (fun () -> generate_dune `Dist args)
+
+  let ok () = Action.ok ()
+  let exit () = Action.error ""
+
+  let with_output args =
+    match args.Cli.output with
+    | None -> args
+    | Some o ->
+        let r = args.Cli.context in
+        let info = Info.with_output r.Config.info o in
+        { args with context = { r with info } }
+
+  let pp_info (f : ('a, Format.formatter, unit) format -> 'a) level args =
+    let verbose = Logs.level () >= level in
+    f "@[<v>%a@]" (Info.pp verbose) args.Cli.context.Config.info
+
+  let handle_parse_args_result = function
+    | `Error _ -> exit ()
+    | `Version | `Help -> ok ()
+    | `Ok action -> (
+        match action with
+        | Cli.Help _ -> ok ()
+        | Cli.Configure t ->
+            let t = { t with args = with_output t.args } in
+            Log.info (fun m -> pp_info m (Some Logs.Debug) t.args);
+            configure t
+        | Cli.Query t ->
+            let t = { t with args = with_output t.args } in
+            Log.info (fun m -> pp_info m (Some Logs.Debug) t.args);
+            query t;
+            ok ()
+        | Cli.Describe t ->
+            let t = { t with args = with_output t.args } in
+            pp_info Fmt.(pf stdout) (Some Logs.Info) t.args;
+            describe t
+        | Cli.Clean t ->
+            let t = with_output t in
+            Log.info (fun m -> pp_info m (Some Logs.Debug) t);
+            clean t)
+
+  let action_run args a =
+    if not args.Cli.dry_run then Action.run a
+    else
+      let exec cmd =
+        match Bos.Cmd.to_list cmd with
+        | [ "opam"; "config"; "var"; "prefix" ] -> Some ("$prefix", "")
+        | _ -> Action.default_exec cmd
+      in
+      let env = Action.env ~files:(`Passtrough (Fpath.v ".")) ~exec () in
+      let dom = Action.dry_run ~env a in
+      List.iter
+        (fun line ->
+          Fmt.epr "%a %s\n%!" Fmt.(styled (`Fg `Cyan) string) "*" line)
+        dom.logs;
+      dom.result
+
+  let read_context args =
+    match args.Cli.context_file with
+    | None -> Action.ok Context_cache.empty
+    | Some file ->
+        let* is_file = Action.is_file file in
+        if is_file then Context_cache.read file
+        else Action.errorf "cannot find file `%a'" Fpath.pp file
+
+  let run_with_argv argv args config =
+    (*   whether to fully evaluate the graph *)
+    let full_eval = Cli.peek_full_eval argv in
+
+    let* cache = read_context args in
+    let base_context =
+      (* Consider only the non-required keys. *)
+      let non_required_term =
+        let if_keys = Config.if_keys config in
+        Key.context if_keys
+      in
+      let context =
+        match Cmdliner.Cmd.eval_peek_opts ~argv non_required_term with
+        | _, Ok (`Ok context) -> context
+        | _ -> Context.empty
+      in
+      match Context_cache.peek cache non_required_term with
+      | None -> context
+      | Some default -> Context.merge ~default context
+    in
+    let output = Cli.peek_output argv in
+
+    (* 3. Parse the command-line and handle the result. *)
+    let configure = eval_cached ~full:true ~output ~cache base_context config in
+
+    let describe =
+      let full =
+        match full_eval with
+        | None -> not (Context_cache.is_empty cache)
+        | Some b -> b
+      in
+      eval_cached ~full ~output ~cache base_context config
+    in
+
+    let clean = eval_cached ~full:true ~output ~cache base_context config in
+    let query = clean in
+    let help = clean in
+
+    handle_parse_args_result
+      (Cli.eval ~name:P.name ~version:P.version ~configure ~query ~describe
+         ~clean ~help ~mname:P.name argv)
+
+  let register ?(init = default_init) ?(src = `Auto) name jobs =
+    (* 1. Pre-parse the arguments set the log level, config file
+       and root directory. *)
+    let argv = Sys.argv in
+    (* TODO: do not are parse the command-line twice *)
+    let args =
+      (* tool.ml made sure that global arguments are correctly parsed before
+         running config.exe*)
+      Cli.peek_args ~with_setup:true ~mname:P.name argv |> Option.get
+    in
+    let config_file = config_file args in
+    let run () =
+      let configure_cmd, pre_build_cmd, lock_location, build_cmd =
+        get_cmds args
+      in
+      let main_dev = P.create (init @ jobs) in
+      let c =
+        Config.v ~config_file ~init ~configure_cmd ~pre_build_cmd ~lock_location
+          ~build_cmd ~src ~project_name:P.name name main_dev
+      in
+      run_with_argv argv args c
+    in
+    run () |> action_run args |> exit_err args
+end

unikernel/duniverse/mirage/lib/functoria/lib.mli

@@ -0,0 +1,82 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Application builder. API for building libraries to link with [config.ml] *)
+
+(** {1 Builders} *)
+
+(** [S] is the signature that application builders have to provide. *)
+module type S = sig
+  open DSL
+
+  val prelude : Info.t -> string
+  (** Prelude printed at the beginning of [main.ml].
+
+      It should put in scope:
+
+      - a [io] type as an alias to type ['a t]
+      - a [run] function of type ['a t -> 'a]
+      - a [return] function of type ['a -> 'a t]
+      - a [>>=] operator of type ['a t -> ('a -> 'b t) -> 'b t] *)
+
+  val packages : Package.t list
+  (** The packages to load when compiling the configuration file. *)
+
+  val name : string
+  (** Name of the custom DSL. *)
+
+  val version : string
+  (** Version of the custom DSL. *)
+
+  val create : job impl list -> job impl
+  (** [create jobs] is the top-level job in the custom DSL which will execute
+      the given list of [job]. *)
+
+  val name_of_target : Info.t -> string
+  (** [name_of_target i] is the name used to build the project with the build
+      info [i]. For simple projects it can be [Info.name]. For more complex
+      projects (like [mirage]), the name is suffixed by the value of the target
+      key defined in [i]. *)
+
+  val target_filename : Info.t -> string
+  (** [target_filename i] is the filename of this project's output, as it will
+      be installed by dune. *)
+
+  val dune_project : Dune.stanza list
+  val dune_workspace : (?build_dir:Fpath.t -> info -> Dune.t) option
+  val context_name : Info.t -> string
+end
+
+module Make (_ : S) : sig
+  open DSL
+
+  (** Configuration builder: stage 1 *)
+
+  val register :
+    ?init:job impl list ->
+    ?src:[ `Auto | `None | `Some of string ] ->
+    string ->
+    job impl list ->
+    unit
+  (** [register name jobs] registers the application named by [name] which will
+      execute the given [jobs]. Same optional arguments as {!module-DSL.main}.
+
+      [init] is the list of job to execute before anything else (such as
+      command-line argument parsing, log reporter setup, etc.). The jobs are
+      always executed in the sequence specified by the caller. *)
+end

unikernel/duniverse/mirage/lib/functoria/makefile.ml

@@ -0,0 +1,161 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t = {
+  depext : bool;
+  build_dir : Fpath.t;
+  builder_name : string;
+  unikernel_opam_name : Misc.Name.Opam.t;
+  extra_repo : (string * string) list;
+  public_name : string;
+}
+
+let v ?(extra_repo = []) ~build_dir ~builder_name ~depext ~public_name
+    unikernel_opam_name =
+  {
+    depext;
+    build_dir;
+    builder_name;
+    unikernel_opam_name;
+    extra_repo;
+    public_name;
+  }
+
+let depext_rules =
+  {|
+depext-lockfile: $(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam.locked
+	echo " ↳ install external dependencies for monorepo"
+	env OPAMVAR_monorepo="opam-monorepo" $(OPAM) monorepo depext -y -l $<
+|}
+
+let opam_repo_add_rule extra =
+  let buf = Buffer.create 0x100 in
+  let ppf = Format.formatter_of_buffer buf in
+  Fmt.pf ppf
+    {|repo-add:
+	@@printf "\033[2musing overlay repository mirage: %a \033[0m\n"
+|}
+    Fmt.(brackets (list ~sep:(any ", ") (using fst string)))
+    extra;
+  List.iter
+    (fun (name, repo) ->
+      Fmt.pf ppf "\t$(OPAM) repo add %s %s || $(OPAM) repo set-url %s %s\n" name
+        repo name repo)
+    extra;
+  Buffer.contents buf
+
+let opam_repo_remove_rule extra =
+  let buf = Buffer.create 0x100 in
+  let ppf = Format.formatter_of_buffer buf in
+  Fmt.pf ppf
+    {|repo-rm:
+	@@printf "\033[2mremoving overlay repository %a\033[0m\n"
+|}
+    Fmt.(brackets (list ~sep:(any ", ") (using fst string)))
+    extra;
+  List.iter
+    (fun (name, repo) -> Fmt.pf ppf "\t$(OPAM) repo remove %s %s\n" name repo)
+    extra;
+  Buffer.contents buf
+
+let pp_extra_rules ppf t =
+  let rules, targets =
+    match t.depext with
+    | true -> ([ depext_rules ], [ "depext-lockfile" ])
+    | false -> ([], [])
+  in
+  let rules, targets =
+    match t.extra_repo with
+    | _ :: _ as extra ->
+        ( opam_repo_add_rule extra :: opam_repo_remove_rule extra :: rules,
+          "repo-add" :: "repo-rm" :: targets )
+    | [] -> (rules, targets)
+  in
+  match rules with
+  | [] -> ()
+  | _ ->
+      Fmt.pf ppf " %a\n\n"
+        (Fmt.list ~sep:(fun ppf () -> Fmt.pf ppf " ") Fmt.string)
+        targets;
+      Fmt.pf ppf "%a"
+        (Fmt.list ~sep:(fun ppf () -> Fmt.pf ppf "\n\n") Fmt.string)
+        rules
+
+let pp ppf t =
+  let mirage_dir = Fpath.(t.build_dir / t.builder_name) in
+  let pp_depext_lockfile ppf = function
+    | true -> Fmt.string ppf "\n\t@$(MAKE) -s depext-lockfile"
+    | false -> ()
+  and pp_no_depext ppf = function
+    | true -> ()
+    | false -> Fmt.string ppf " --no-depexts"
+  and pp_add_repo ppf = function
+    | _ :: _ -> Fmt.string ppf "\n\t@$(MAKE) -s repo-add"
+    | [] -> ()
+  and pp_or_remove_repo ppf = function
+    | _ :: _ -> Fmt.string ppf "; (ret=$$?; $(MAKE) -s repo-rm && exit $$ret)"
+    | [] -> ()
+  in
+  Fmt.pf ppf
+    {|-include Makefile.user
+BUILD_DIR = %a
+MIRAGE_DIR = %a
+UNIKERNEL_NAME = %s
+OPAM = opam
+
+all::
+	@@$(MAKE) --no-print-directory depends
+	@@$(MAKE) --no-print-directory build
+
+.PHONY: all lock install-switch pull clean depend depends build%a
+
+$(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam.locked: $(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam%a
+	@@echo " ↳ generate lockfile for monorepo dependencies"
+	@@env OPAMVAR_monorepo="opam-monorepo" $(OPAM) monorepo lock --require-cross-compile --build-only $(UNIKERNEL_NAME) -l $@@ --ocaml-version $(shell ocamlc --version)%a
+
+lock::
+	@@$(MAKE) -B $(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam.locked
+	@@echo "The lock file has been generated. Run 'make pull' to retrieve the sources, or 'make install-switch' to install the host dependencies."
+
+pull:: $(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam.locked
+	@@echo " ↳ fetch monorepo dependencies in the duniverse folder"
+	@@env OPAMVAR_monorepo="opam-monorepo" $(OPAM) monorepo pull -l $< -r $(abspath $(BUILD_DIR))
+	@@echo "The sources have been pulled to the duniverse folder. Run 'make build' to build the unikernel."
+
+install-switch:: $(MIRAGE_DIR)/$(UNIKERNEL_NAME).opam
+	@@echo " ↳ opam install switch dependencies"
+	@@$(OPAM) install $< --deps-only --yes%a%a
+	@@echo "The dependencies have been installed. Run 'make build' to build the unikernel."
+
+depends depend::
+	@@$(MAKE) --no-print-directory lock
+	@@$(MAKE) --no-print-directory install-switch
+	@@$(MAKE) --no-print-directory pull
+
+build::
+	dune build --profile release --root . $(BUILD_DIR)dist
+	@@echo "Your unikernel binary is now ready in $(BUILD_DIR)dist/%s"
+	@@echo "Execute the binary using solo5-hvt, solo5-spt, xl, ..."
+
+clean::
+	mirage clean
+|}
+    Fpath.pp t.build_dir Fpath.pp mirage_dir
+    (Misc.Name.Opam.to_string t.unikernel_opam_name)
+    pp_extra_rules t pp_add_repo t.extra_repo pp_or_remove_repo t.extra_repo
+    pp_no_depext t.depext pp_depext_lockfile t.depext t.public_name

unikernel/duniverse/mirage/lib/functoria/makefile.mli

@@ -0,0 +1,30 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t
+
+val v :
+  ?extra_repo:(string * string) list ->
+  build_dir:Fpath.t ->
+  builder_name:string ->
+  depext:bool ->
+  public_name:string ->
+  Misc.Name.Opam.t ->
+  t
+
+val pp : t Fmt.t

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

@@ -0,0 +1,68 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Rresult
+open Astring
+
+let err_cmdliner ?(usage = false) = function
+  | Ok x -> `Ok x
+  | Error s -> `Error (usage, s)
+
+module type Monoid = sig
+  type t
+
+  val empty : t
+  val union : t -> t -> t
+end
+
+(* {Misc informations} *)
+
+module Name = struct
+  module Opam = struct
+    type t = string
+
+    let to_string = Fun.id
+  end
+
+  let opamify s =
+    let b = Buffer.create (String.length s) in
+    String.iter
+      (function
+        | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c ->
+            Buffer.add_char b c
+        | '.' -> Buffer.add_char b '_'
+        | _ -> ())
+      s;
+    let s' = Buffer.contents b in
+    if String.length s' = 0 then raise (Invalid_argument s);
+    s'
+
+  let ocamlify s =
+    let b = Buffer.create (String.length s) in
+    String.iter
+      (function
+        | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_') as c ->
+            Buffer.add_char b c
+        | '-' | '.' | ' ' -> Buffer.add_char b '_'
+        | _ -> ())
+      s;
+    let s' = Buffer.contents b in
+    if String.length s' = 0 || ('0' <= s'.[0] && s'.[0] <= '9') then
+      raise (Invalid_argument s);
+    s'
+end

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

@@ -0,0 +1,43 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Utility module. *)
+
+(** {2 Misc} *)
+
+open Rresult
+
+val err_cmdliner : ?usage:bool -> ('a, string) result -> 'a Cmdliner.Term.ret
+
+module type Monoid = sig
+  type t
+
+  val empty : t
+  val union : t -> t -> t
+end
+
+module Name : sig
+  module Opam : sig
+    type t
+
+    val to_string : t -> string
+  end
+
+  val opamify : string -> Opam.t
+  val ocamlify : string -> string
+end

unikernel/duniverse/mirage/lib/functoria/opam.ml

@@ -0,0 +1,257 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Action.Syntax
+
+let find_git () =
+  let is_git p = Action.is_dir Fpath.(p / ".git") in
+  let app_opt p d = match p with None -> d | Some p -> Fpath.(d // p) in
+  let rec find p path =
+    if Fpath.is_root p then Action.ok None
+    else
+      let* has_git = is_git p in
+      if has_git then Action.ok (Some path)
+      else find (Fpath.parent p) (Some (app_opt path (Fpath.base p)))
+  in
+  let* cwd = Action.pwd () in
+  (* this is invoked from within the mirage subdirectory *)
+  let* cwd = find (Fpath.parent cwd) None in
+  match cwd with
+  | None -> Action.ok None
+  | Some subdir ->
+      let git_branch =
+        Bos.Cmd.(v "git" % "rev-parse" % "--abbrev-ref" % "HEAD")
+      in
+      let* branch = Action.(run_cmd_out ~err:`Null git_branch) in
+      let git_remote = Bos.Cmd.(v "git" % "remote" % "get-url" % "origin") in
+      let+ git_url = Action.(run_cmd_out ~err:`Null git_remote) in
+      Some (subdir, branch, git_url)
+
+module Endpoint = struct
+  type t = {
+    scheme : [ `SSH of string | `Git | `HTTP | `HTTPS | `Scheme of string ];
+    port : int option;
+    path : string;
+    hostname : string;
+  }
+
+  let of_string str =
+    let open Rresult in
+    let parse_ssh str =
+      let len = String.length str in
+      Emile.of_string_raw ~off:0 ~len str
+      |> R.reword_error (R.msgf "%a" Emile.pp_error)
+      >>= fun (consumed, m) ->
+      match
+        Astring.String.cut ~sep:":" (String.sub str consumed (len - consumed))
+      with
+      | Some ("", path) ->
+          let path = "/" ^ path in
+          let local =
+            List.map
+              (function `Atom x -> x | `String x -> Fmt.str "%S" x)
+              m.Emile.local
+          in
+          let user = String.concat "." local in
+          let hostname =
+            match fst m.Emile.domain with
+            | `Domain vs -> String.concat "." vs
+            | `Literal v -> v
+            | `Addr (Emile.IPv4 v) -> Ipaddr.V4.to_string v
+            | `Addr (Emile.IPv6 v) -> Ipaddr.V6.to_string v
+            | `Addr (Emile.Ext (k, v)) -> Fmt.str "%s:%s" k v
+          in
+          R.ok { scheme = `SSH user; path; port = None; hostname }
+      | _ -> R.error_msg "Invalid SSH pattern"
+    in
+    let parse_uri str =
+      let uri = Uri.of_string str in
+      let path = Uri.path uri in
+      match (Uri.scheme uri, Uri.host uri, Uri.port uri) with
+      | Some "git", Some hostname, port ->
+          R.ok { scheme = `Git; path; port; hostname }
+      | Some "http", Some hostname, port ->
+          R.ok { scheme = `HTTP; path; port; hostname }
+      | Some "https", Some hostname, port ->
+          R.ok { scheme = `HTTPS; path; port; hostname }
+      | Some scheme, Some hostname, port ->
+          R.ok { scheme = `Scheme scheme; path; port; hostname }
+      | _ -> R.error_msgf "Invalid uri: %a" Uri.pp uri
+    in
+    match (parse_ssh str, parse_uri str) with
+    | Ok v, _ -> Ok v
+    | _, Ok v -> Ok v
+    | Error _, Error _ -> R.error_msgf "Invalid endpoint: %s" str
+end
+
+let guess_src () =
+  let git_info =
+    match Action.run @@ find_git () with
+    | Error _ | Ok None -> None
+    | Ok (Some (subdir, branch, git_url)) -> Some (subdir, branch, git_url)
+  in
+  match git_info with
+  | None -> (None, None)
+  | Some (subdir, branch, origin) ->
+      (* TODO is there a library for git urls anywhere? *)
+      let public =
+        match Endpoint.of_string origin with
+        | Ok
+            { Endpoint.scheme = `Scheme scheme; port = None; path; hostname; _ }
+          ->
+            Fmt.str "%s://%s%s" scheme hostname path
+        | Ok
+            {
+              Endpoint.scheme = `Scheme scheme;
+              port = Some port;
+              path;
+              hostname;
+              _;
+            } ->
+            Fmt.str "%s://%s:%d%s" scheme hostname port path
+        | Ok { Endpoint.port = None; path; hostname; _ } ->
+            Fmt.str "git+https://%s%s" hostname path
+        | Ok { Endpoint.port = Some port; path; hostname; _ } ->
+            Fmt.str "git+https://%s:%d%s" hostname port path
+        | _ -> "git+https://invalid/endpoint"
+      in
+      (subdir, Some (Fmt.str "%s#%s" public branch))
+
+type t = {
+  name : string;
+  depends : Package.t list;
+  configure : string option;
+  pre_build : (Fpath.t option -> string) option;
+  lock_location : (Fpath.t option -> string -> string) option;
+  build : (Fpath.t option -> string) option;
+  install : Install.t;
+  extra_repo : (string * string) list;
+  pins : (string * string) list;
+  src : string option;
+  subdir : Fpath.t option;
+  opam_name : string;
+}
+
+let v ?configure ?pre_build ?lock_location ?build ?(install = Install.empty)
+    ?(extra_repo = []) ?(depends = []) ?(pins = []) ?subdir ~src ~opam_name name
+    =
+  let subdir, src =
+    match src with
+    | `Auto ->
+        let subdir', src = guess_src () in
+        ((match subdir with None -> subdir' | Some _ as s -> s), src)
+    | `None -> (subdir, None)
+    | `Some d -> (subdir, Some d)
+  in
+  {
+    name;
+    depends;
+    configure;
+    pre_build;
+    lock_location;
+    build;
+    install;
+    extra_repo;
+    pins;
+    src;
+    subdir;
+    opam_name;
+  }
+
+let pp_packages ppf packages =
+  Fmt.pf ppf "\n  %a\n"
+    Fmt.(list ~sep:(any "\n  ") (Package.pp ~surround:"\""))
+    packages
+
+let pp_pins ppf = function
+  | [] -> ()
+  | pins ->
+      let pp_pin ppf (package, url) = Fmt.pf ppf "[\"%s\" %S]" package url in
+      Fmt.pf ppf "@.pin-depends: [ @[<hv>%a@]@ ]@."
+        Fmt.(list ~sep:(any "@ ") pp_pin)
+        pins
+
+let pp_src ppf = function
+  | None -> ()
+  | Some src -> Fmt.pf ppf {|@.url { src: %S }|} src
+
+let pp_switch_package ppf s = Fmt.pf ppf "%S" s
+
+let pp ppf t =
+  let pp_cmd = function
+    | None -> ""
+    | Some cmd ->
+        Fmt.str {|"sh" "-exc" "%a%s"|}
+          Fmt.(option ~none:(any "") (any "cd " ++ Fpath.pp ++ any " && "))
+          t.subdir cmd
+  in
+  let pp_with_sub ppf = function
+    | None -> ()
+    | Some f -> Fmt.string ppf (f t.subdir)
+  in
+  let pp_repo =
+    Fmt.(
+      list ~sep:(any "\n")
+        (brackets (pair ~sep:(any " ") (quote string) (quote string))))
+  in
+  let switch_packages =
+    List.filter_map
+      (fun p ->
+        match Package.scope p with
+        | `Switch -> Some (Package.name p)
+        | `Monorepo -> None)
+      t.depends
+  in
+  Fmt.pf ppf
+    {|opam-version: "2.0"
+maintainer: "dummy"
+authors: "dummy"
+homepage: "dummy"
+bug-reports: "dummy"
+dev-repo: "git://dummy"
+synopsis: "Unikernel %s - switch dependencies"
+description: """
+It assumes that local dependencies are already
+fetched.
+"""
+
+build: [%a]
+
+install: [%a]
+
+depends: [%a]
+
+x-mirage-opam-lock-location: %S
+
+x-mirage-configure: [%s]
+
+x-mirage-pre-build: [%a]
+
+x-mirage-extra-repo: [%a]
+
+x-opam-monorepo-opam-provided: [%a]
+%a%a|}
+    t.name pp_with_sub t.build
+    (Install.pp_opam ?subdir:t.subdir ())
+    t.install pp_packages t.depends
+    (Option.fold ~none:""
+       ~some:(fun l -> l t.subdir t.opam_name)
+       t.lock_location)
+    (pp_cmd t.configure) pp_with_sub t.pre_build pp_repo t.extra_repo
+    (Fmt.list ~sep:(Fmt.any " ") pp_switch_package)
+    switch_packages pp_src t.src pp_pins t.pins

unikernel/duniverse/mirage/lib/functoria/opam.mli

@@ -0,0 +1,36 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type t
+
+val v :
+  ?configure:string ->
+  ?pre_build:(Fpath.t option -> string) ->
+  ?lock_location:(Fpath.t option -> string -> string) ->
+  ?build:(Fpath.t option -> string) ->
+  ?install:Install.t ->
+  ?extra_repo:(string * string) list ->
+  ?depends:Package.t list ->
+  ?pins:(string * string) list ->
+  ?subdir:Fpath.t ->
+  src:[ `Auto | `None | `Some of string ] ->
+  opam_name:string ->
+  string ->
+  t
+
+val pp : t Fmt.t

unikernel/duniverse/mirage/lib/functoria/package.ml

@@ -0,0 +1,136 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Astring
+
+type scope = [ `Switch | `Monorepo ]
+
+type t = {
+  name : string;
+  pin : (string * string) option;  (** [name_version * url] *)
+  scope : scope;
+  build : bool;
+  libs : String.Set.t;
+  min : String.Set.t;
+  max : String.Set.t;
+}
+
+let name t = t.name
+
+let key t =
+  match t.scope with
+  | `Switch -> "switch-" ^ t.name
+  | `Monorepo -> "monorepo-" ^ t.name
+
+let pin t = t.pin
+let build_dependency t = t.build
+let scope t = t.scope
+let libraries t = String.Set.elements t.libs
+let min_versions t = String.Set.elements t.min
+let max_versions t = String.Set.elements t.max
+
+let merge a b =
+  if a.name <> b.name then None
+  else if a.scope <> b.scope then None
+  else
+    let name = a.name in
+    let libs = String.Set.union a.libs b.libs
+    and min = String.Set.union a.min b.min
+    and max = String.Set.union a.max b.max
+    and pin =
+      match (a.pin, b.pin) with
+      | None, None -> None
+      | None, Some a | Some a, None -> Some a
+      | Some (an, au), Some (bn, bu)
+        when String.equal an au && String.equal bn bu ->
+          a.pin
+      | _ -> invalid_arg ("conflicting pin depends for " ^ name)
+    and build = a.build || b.build
+    and scope = a.scope in
+    match pin with
+    | None -> Some { name; build; scope; libs; min; max; pin }
+    | Some _ ->
+        (* pin wins over min and max *)
+        let empty = String.Set.empty in
+        Some { name; build; scope; libs; min = empty; max = empty; pin }
+
+let package_name_is_valid name =
+  let has_letter = String.exists Char.Ascii.is_letter name in
+  let only_allowed_chars =
+    String.for_all
+      (function
+        | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true | _ -> false)
+      name
+  in
+  only_allowed_chars && has_letter
+
+let v ?(scope = `Monorepo) ?(build = false) ?sublibs ?libs ?min ?max ?pin
+    ?(pin_version = "dev") name =
+  if not (package_name_is_valid name) then
+    Fmt.invalid_arg "package name %S is invalid" name;
+  let libs =
+    match (sublibs, libs) with
+    | None, None -> [ name ]
+    | Some xs, None ->
+        List.map (fun x -> if x = "" then name else name ^ "." ^ x) xs
+    | None, Some a -> a
+    | Some _, Some _ ->
+        Fmt.invalid_arg
+          "dependent package %s may either specify ~sublibs or ~ocamlfind" name
+  in
+  let libs = String.Set.of_list libs in
+  let to_set = function
+    | None -> String.Set.empty
+    | Some m -> String.Set.singleton m
+  in
+  let min = to_set min
+  and max = to_set max
+  and pin =
+    match pin with Some p -> Some (name ^ "." ^ pin_version, p) | None -> None
+  in
+  { name; build; scope; libs; min; max; pin }
+
+let with_scope ~scope t = { t with scope }
+
+let exts_to_string ppf (min, max, build, scope) =
+  let build_strs = if build then [ "build" ] else [] in
+  let esc_prefix prefix e = Fmt.str "%s %S" prefix e in
+  let min_strs = List.map (esc_prefix ">=") (String.Set.elements min)
+  and max_strs = List.map (esc_prefix "<") (String.Set.elements max) in
+  let constr_list = build_strs @ min_strs @ max_strs in
+  let constr_list =
+    match scope with
+    | `Monorepo -> "?monorepo" :: constr_list
+    | `Switch -> constr_list
+  in
+  if List.length constr_list > 0 then
+    Fmt.pf ppf " { %s }" (String.concat ~sep:" & " constr_list)
+
+let pp ?(surround = "") ppf p =
+  Fmt.pf ppf "%s%s%s%a" surround p.name surround exts_to_string
+    (p.min, p.max, p.build, p.scope)
+
+module Set = struct
+  type elt = t
+  type t = elt String.Map.t
+
+  let of_list x = String.Map.of_list (List.map (fun p -> (name p, p)) x)
+  let to_list x = String.Map.fold (fun _ v acc -> v :: acc) x [] |> List.rev
+  let union x y = String.Map.union (fun _ -> merge) x y
+  let empty = String.Map.empty
+end

unikernel/duniverse/mirage/lib/functoria/package.mli

@@ -0,0 +1,99 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Representation of opam packages. *)
+
+type scope = [ `Switch | `Monorepo ]
+(** The scope of package installation:
+
+    - Switch: installed with opam.
+    - Monorepo: locally fetched along unikernel sources. *)
+
+type t
+(** The type for opam packages. *)
+
+val v :
+  ?scope:scope ->
+  ?build:bool ->
+  ?sublibs:string list ->
+  ?libs:string list ->
+  ?min:string ->
+  ?max:string ->
+  ?pin:string ->
+  ?pin_version:string ->
+  string ->
+  t
+(** [v ~scope ~build ~sublibs ~libs ~min ~max ~pin opam] is a [package]. [Build]
+    indicates a build-time dependency only, defaults to [false]. The library
+    name is by default the same as [opam], you can specify [~sublibs] to add
+    sublibraries (e.g. [~sublibs:["mirage"] "foo"] will result in the library
+    name [["foo.mirage"]], and [~sublibs:[""; "mirage"] "foo"] will result in
+    the library names [["foo";"foo.mirage"]] ). In case the library name is
+    disjoint (or empty), use [~libs]. Specifying both [~libs] and [~sublibs]
+    leads to an invalid argument. Version constraints are given as [min]
+    (inclusive) and [max] (exclusive). If [pin] is provided, a
+    {{:https://opam.ocaml.org/doc/Manual.html#opamfield-pin-depends}
+     pin-depends} is generated, [pin_version] is ["dev"] by default. [~scope]
+    specifies the installation location of the package. *)
+
+val with_scope : scope:scope -> t -> t
+(** [with_scope t] returns t with chosen installation location.*)
+
+val name : t -> string
+(** [name t] is [t]'s opam name. *)
+
+val key : t -> string
+(** [key t] is [t]'s key (concatenation of name and installation scope). *)
+
+val scope : t -> scope
+(** [scope t] is [t]'s installation scope. *)
+
+val pin : t -> (string * string) option
+(** [pin t] is [Some (name_version, r)] iff [t] is pinned to the repository [r].
+*)
+
+val build_dependency : t -> bool
+(** [build_dependency t] is [true] iff [t] is a build-time dependency. *)
+
+val libraries : t -> string list
+(** [libraries t] is the set of libraries (and sub-libraries) used in the
+    package [t]. For most packages, it will only contain one library whose name
+    is [name t]. *)
+
+val max_versions : t -> string list
+(** [max_versions] is the set of maximum versions of [t] which are required. *)
+
+val min_versions : t -> string list
+(** [min_versions] is the set minimum versions of [t] which are required. *)
+
+val merge : t -> t -> t option
+(** [merge x y] is merges the information of [x] and [y]. The result is [None]
+    if [name x != name y]. *)
+
+val pp : ?surround:string -> t Fmt.t
+(** [pp] is the pretty-printer for packages. *)
+
+module Set : sig
+  type elt = t
+  type t
+
+  val of_list : elt list -> t
+  val to_list : t -> elt list
+  val union : t -> t -> t
+  val empty : t
+end

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

@@ -0,0 +1,70 @@
+(*
+ * 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 Misc
+
+type 'a arg = {
+  pos : string * int;
+  name : string;
+  code : string;
+  packages : Package.t list;
+}
+
+type t = Any : 'a arg -> t
+
+(* Set of keys, where keys with the same name but with different
+   defaults are distinguished. This is useful to build the graph of
+   devices. *)
+module Set = struct
+  module M = struct
+    type nonrec t = t
+
+    let compare = compare
+  end
+
+  include Set.Make (M)
+
+  let add k set =
+    if mem k set then
+      if k != find k set then
+        match k with Any k -> Fmt.invalid_arg "Duplicate key name: %s" k.name
+      else set
+    else add k set
+
+  let pp_gen = Fmt.iter ~sep:(Fmt.any ",@ ") iter
+  let pp_elt fmt (Any k) = Fmt.string fmt k.name
+  let pp = pp_gen pp_elt
+end
+
+let create ~pos ?(packages = []) code =
+  let name = Name.ocamlify code in
+  let pos = match pos with file, lnum, _, _ -> (file, lnum) in
+  { pos; name; packages; code }
+
+let v k = Any k
+let packages (Any k) = k.packages
+
+(* {2 Code emission} *)
+
+let ocaml_name k = String.lowercase_ascii (Name.ocamlify k)
+let pp_pos ppf (file, line) = Fmt.pf ppf "# %d %S@." line file
+
+let serialize ~runtime_modname fmt (Any k) =
+  Format.fprintf fmt "let %s__key = %s.register_arg @@@@\n%a  @[<v2>%s@]\n;;\n"
+    (ocaml_name k.name) runtime_modname pp_pos k.pos k.code
+
+let call fmt (Any k) = Fmt.pf fmt "(%s__key ())" (ocaml_name k.name)
+let var_name (Any k) = ocaml_name k.name

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

@@ -0,0 +1,55 @@
+(*
+ * 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.
+ *)
+
+(** Define runtime command-line arguments. *)
+
+type 'a arg
+(** The type for command-line arguments that reads a value of type ['a]. *)
+
+val create :
+  pos:string * int * int * int -> ?packages:Package.t list -> string -> 'a arg
+(** [create ~pos ?packages v] is the runtime argument pointing to the value [v].
+    [pos] is expected to be [__POS__]. [packages] specifies in which opam
+    package the value [v] is defined. This should be constrained to the correct
+    type of the variable it is pointing to. *)
+
+type t
+(** The type command-line arguments where the type of the value is abstract. *)
+
+val packages : t -> Package.t list
+
+val v : 'a arg -> t
+(** [v k] is the [k] with its type hidden. *)
+
+(** [Set] implements sets over [t] elements. *)
+module Set : sig
+  include Set.S with type elt = t
+
+  val pp : t Fmt.t
+  (** [pp] pretty-prints sets of keys. *)
+end
+
+(** {1 Code Serialization} *)
+
+val call : t Fmt.t
+(** [call fmt k] outputs [name ()] to [fmt], where [n] is [k]'s
+    {{!ocaml_name} OCaml name}. *)
+
+val serialize : runtime_modname:string -> t Fmt.t
+(** [serialize ctx ppf k] outputs the [Cmdliner] runes to parse command-line
+    arguments represented by [k] at runtime. *)
+
+val var_name : t -> string

unikernel/duniverse/mirage/lib/functoria/tool.ml

@@ -0,0 +1,371 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+open Action.Syntax
+open DSL
+
+let src = Logs.Src.create "functoria.tool" ~doc:"functoria library"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module type S = sig
+  val name : string
+  val version : string
+  val packages : package list
+  val create : job impl list -> job impl
+end
+
+let check_version ~name ~version data =
+  let ( let* ) = Result.bind in
+  let extract_version v =
+    if String.for_all (function '0' .. '9' | '.' -> true | _ -> false) v then
+      try Ok (Scanf.sscanf v "%u.%u.%u" (fun ma mi pa -> (ma, mi, pa))) with
+      | Scanf.Scan_failure _ | End_of_file -> (
+          try Ok (Scanf.sscanf v "%u.%u" (fun ma mi -> (ma, mi, 0))) with
+          | Scanf.Scan_failure _ | End_of_file -> (
+              try Ok (Scanf.sscanf v "%u" (fun ma -> (ma, 0, 0)))
+              with Scanf.Scan_failure _ | Failure _ | End_of_file ->
+                Error ("couldn't extract version (%u) from " ^ v))
+          | Failure f ->
+              Error ("couldn't extract version (%u.%u) from " ^ v ^ ": " ^ f))
+      | Failure f ->
+          Error ("couldn't extract version (%u.%u.%u) from " ^ v ^ ": " ^ f)
+    else Error "only digits and . allowed in version"
+  in
+  if String.equal version ("%%" ^ "VERSION%%") then (
+    Log.warn (fun m ->
+        m "Skipping version check, since our_version is not watermarked");
+    Ok ())
+  else
+    match extract_version version with
+    | Error msg ->
+        Log.warn (fun m ->
+            m
+              "Skipping version check, since our_version (%S) fails to parse: \
+               %s"
+              version msg);
+        Ok ()
+    | Ok version' ->
+        let first_str = "(* " ^ name ^ " " in
+        let fl = String.length first_str in
+        if
+          fl < String.length data
+          && String.equal (String.sub data 0 fl) first_str
+        then
+          let* lower_version, upper_version =
+            let vs =
+              String.split_on_char ' '
+                (String.sub data fl (String.length data - fl))
+            in
+            let rec go lower upper = function
+              | "&" :: tl -> go lower upper tl
+              | ">=" :: v :: tl ->
+                  if lower = None then go (Some v) upper tl
+                  else Error "Bad comment, multiple >= constraints"
+              | "<" :: v :: tl ->
+                  if upper = None then go lower (Some v) tl
+                  else Error "Bad comment, multiple < constraints"
+              | "*)" :: _ -> Ok (lower, upper)
+              | "" :: tl -> go lower upper tl
+              | _ ->
+                  Error
+                    (Fmt.str
+                       "Unknown first line, must be (* %s [>= a.b.c] [&] [< \
+                        d.e.f] *)"
+                       name)
+            in
+            go None None vs
+          in
+          let cmp ~eq (ma, mi, pa) (ma', mi', pa') =
+            ma > ma'
+            || (ma = ma' && mi > mi')
+            || (ma = ma' && mi = mi' && pa > pa')
+            || (ma = ma' && mi = mi' && pa = pa' && eq)
+          in
+          let* () =
+            match lower_version with
+            | None -> Ok ()
+            | Some v ->
+                let* v' = extract_version v in
+                if cmp ~eq:true version' v' then Ok ()
+                else
+                  Error
+                    (Fmt.str
+                       "Version mismatch: required is %s >= %s, but %s is \
+                        installed. Please upgrade your installation (opam \
+                        update; opam install '%s>=%s')"
+                       name v version name v)
+          in
+          match upper_version with
+          | None -> Ok ()
+          | Some v ->
+              let* v' = extract_version v in
+              if cmp ~eq:false v' version' then Ok ()
+              else
+                Error
+                  (Fmt.str
+                     "Version mismatch: required is %s < %s, but %s is \
+                      installed. Please downgrade your installation (opam \
+                      update; opam install '%s<%s')"
+                     name v version name v)
+        else Ok ()
+
+module Make (P : S) = struct
+  module Filegen = Filegen.Make (P)
+
+  let build_dir t = Fpath.parent t.Cli.config_file
+  let context_file t = Context_cache.file ~name:P.name t
+
+  let add_context_file t argv =
+    match t.Cli.context_file with
+    | Some _ -> Action.ok argv
+    | None ->
+        let file = context_file t in
+        let+ is_file = Action.is_file file in
+        if is_file then
+          Array.append argv [| "--context-file"; Fpath.to_string file |]
+        else (* should only happen when doing configure --help *) argv
+
+  let run_cmd ?ppf ?err_ppf command =
+    let err = match err_ppf with None -> None | Some f -> Some (`Fmt f) in
+    let out = match ppf with None -> None | Some f -> Some (`Fmt f) in
+    Action.run_cmd ?err ?out command
+
+  let re_exec_cli t argv =
+    let* argv = add_context_file t argv in
+    let args = Bos.Cmd.of_list (List.tl (Array.to_list argv)) in
+    let config_exe =
+      Fpath.(v "_build" / "default" // build_dir t / "config.exe")
+    in
+    let command = Bos.Cmd.(v (p config_exe) %% args) in
+    Action.run_cmd_cli command
+
+  (* Generate the base dune and dune-project files *)
+  let generate_base_dune t =
+    let dune_config_path = Fpath.(build_dir t / "dune.config") in
+    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_config_path);
+    let dune_config =
+      Dune.base ~config_ml_file:t.Cli.config_file ~packages:P.packages
+    in
+    let dune_config = Fmt.str "%a\n%!" Dune.pp dune_config in
+    let* () = Filegen.write dune_config_path dune_config in
+    let dune_path = Fpath.(build_dir t / "dune") in
+    let dune = Fmt.str "(include dune.config)" in
+    Filegen.write dune_path dune
+
+  let dune_workspace_path t =
+    Fpath.(build_dir t / P.name / "dune-workspace.config")
+
+  let generate_base_dune_workspace t =
+    let dune_workspace_path = dune_workspace_path t in
+    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_workspace_path);
+    let dune = Dune.base_workspace in
+    let dune = Fmt.str "%a\n%!" Dune.pp dune in
+    Filegen.write dune_workspace_path dune
+
+  let generate_base_dune_project () =
+    let dune_project_path = Fpath.(v "dune-project") in
+    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_project_path);
+    let dune = Dune.v Dune.base_project in
+    let dune = Fmt.str "%a\n%!" Dune.pp dune in
+    Filegen.write dune_project_path dune
+
+  let build_config_exe t ?ppf ?err_ppf () =
+    let dune_workspace_path = dune_workspace_path t in
+    let command =
+      Bos.Cmd.(
+        v "dune"
+        % "build"
+        % p Fpath.(build_dir t / "config.exe")
+        % "--root"
+        % "."
+        % "--workspace"
+        % p dune_workspace_path)
+    in
+    run_cmd ?ppf ?err_ppf command
+
+  let write_context t argv = Context_cache.write (context_file t) argv
+  let remove_context t = Action.rm (context_file t)
+
+  (* Generated a project skeleton and try to compile config.exe. *)
+  let generate_project_skeleton ~save_args t ?ppf ?err_ppf argv =
+    let* _ = Action.mkdir Fpath.(build_dir t / P.name) in
+    let* () = generate_base_dune_workspace t in
+    let* () = generate_base_dune_project () in
+    let* () = generate_base_dune t in
+    let* () = if save_args then write_context t argv else Action.ok () in
+    (* try to compile config.exe to detect early compilation errors. *)
+    build_config_exe t ?ppf ?err_ppf ()
+
+  let exit_err t = function
+    | Ok v -> v
+    | Error (`Msg m) ->
+        flush_all ();
+        if m <> "" then Fmt.epr "%a\n%!" Fmt.(styled (`Fg `Red) string) m;
+        if not t.Cli.dry_run then exit 1 else Fmt.epr "(exit 1)\n%!"
+
+  let handle_parse_args_no_config ?help_ppf ?err_ppf (`Msg error) argv =
+    let context =
+      (* Extract all the keys directly. Useful to pre-resolve the keys
+         provided by the specialized DSL. *)
+      let base_keys = Engine.keys @@ Impl.abstract @@ P.create [] in
+      Cmdliner.Term.(const (fun _ -> Action.ok ()) $ Key.context base_keys)
+    in
+    let result =
+      Cli.eval ?help_ppf ?err_ppf ~name:P.name ~version:P.version
+        ~configure:context ~query:context ~describe:context ~clean:context
+        ~help:context ~mname:P.name argv
+    in
+    let ok = Action.ok () in
+    let error = Action.error error in
+    match result with `Version | `Help | `Ok (Cli.Help _) -> ok | _ -> error
+
+  let with_project_skeleton ~save_args t ?ppf ?err_ppf argv f =
+    let file = t.Cli.config_file in
+    let* is_file = Action.is_file file in
+    if not is_file then
+      let msg = Fmt.str "configuration file %a missing" Fpath.pp file in
+      handle_parse_args_no_config ?help_ppf:ppf ?err_ppf (`Msg msg) argv
+    else
+      let* () = generate_project_skeleton ~save_args t ?ppf ?err_ppf argv in
+      f ()
+
+  let action_run t a =
+    if not t.Cli.dry_run then Action.run a
+    else
+      let env = Action.env ~files:(`Passtrough (Fpath.v ".")) () in
+      let dom = Action.dry_run ~env a in
+      List.iter
+        (fun line ->
+          Fmt.epr "%a %s\n%!" Fmt.(styled (`Fg `Cyan) string) "*" line)
+        dom.logs;
+      dom.result
+
+  let clean_files ?ppf ?err_ppf args =
+    let dune_clean () =
+      let* var = Action.get_var "INSIDE_FUNCTORIA_TESTS" in
+      match var with
+      | Some "1" | Some "" -> Action.rm Fpath.(build_dir args / ".merlin")
+      | _ -> run_cmd ?ppf ?err_ppf Bos.Cmd.(v "dune" % "clean")
+    in
+    let rm_gen_files () =
+      let* files = Action.ls (Fpath.v ".") (fun _ -> true) in
+      let files = List.sort Fpath.compare files in
+      let files =
+        List.filter_map
+          (fun file ->
+            if Fpath.parent file <> Fpath.v "./" then None
+            else
+              let base, ext = Fpath.split_ext file in
+              let base = Fpath.basename base in
+              match (base, ext) with
+              | ("Makefile" | "dune-project" | "dune-workspace"), "" ->
+                  Some file
+              | _ ->
+                  Log.info (fun f -> f "Skipped %a" Fpath.pp file);
+                  None)
+          files
+      in
+      let* () = Action.List.iter ~f:Filegen.rm files in
+      let* () = remove_context args in
+      let* () = Filegen.rm Fpath.(build_dir args / "dune") in
+      let* () = Filegen.rm Fpath.(build_dir args / "dune.build") in
+      Filegen.rm Fpath.(build_dir args / "dune.config")
+    in
+    let* () = dune_clean () in
+    rm_gen_files ()
+
+  (* App builder configuration *)
+  let configure ({ args; _ } : _ Cli.configure_args) ?ppf ?err_ppf argv =
+    let file = args.Cli.config_file in
+    let* () =
+      let* is_file = Action.is_file file in
+      if not is_file then
+        Action.errorf "configuration file %a missing" Fpath.pp file
+      else Action.ok ()
+    in
+    let* () =
+      let* data =
+        let cmd = Bos.Cmd.(v "head" % "-1" % p file) in
+        Action.run_cmd_out ~err:`Null cmd
+      in
+      let version =
+        let v = P.version in
+        if String.length v > 0 && String.get v 0 = 'v' then
+          String.sub v 1 (String.length v - 1)
+        else v
+      in
+      Result.fold
+        ~ok:(fun () -> Action.ok ())
+        ~error:(fun msg -> Action.error msg)
+        (check_version ~name:P.name ~version data)
+    in
+    (* Files to build config.ml *)
+    with_project_skeleton ~save_args:true args ?ppf ?err_ppf argv @@ fun () ->
+    Log.info (fun f -> f "Set-up config skeleton.");
+    (* Launch config.exe: additional generated files for the application. *)
+    re_exec_cli args argv
+
+  let try_to_re_exec args ?ppf ?err_ppf argv =
+    with_project_skeleton ~save_args:false args ?ppf ?err_ppf argv @@ fun () ->
+    re_exec_cli args argv
+
+  let error t = try_to_re_exec t
+  let query (t : 'a Cli.query_args) = try_to_re_exec t.args
+  let describe (t : 'a Cli.describe_args) = try_to_re_exec t.args
+  let help (t : 'a Cli.help_args) = try_to_re_exec t
+
+  let clean args ?ppf ?err_ppf argv =
+    let config = args.Cli.config_file in
+    let* () =
+      let* is_file = Action.is_file config in
+      if is_file then try_to_re_exec args ?ppf ?err_ppf argv else Action.ok ()
+    in
+    clean_files args
+
+  let run args action = action |> action_run args |> exit_err args
+  let pp_unit _ _ = ()
+
+  let run_with_argv ?help_ppf ?err_ppf argv =
+    let t = Cli.peek ~with_setup:true ~mname:P.name argv in
+    match t with
+    | `Version ->
+        Log.info (fun l -> l "version");
+        Fmt.pr "%s\n%!" P.version
+    | `Error (Some t, _) ->
+        Log.info (fun l -> l "error: %a" (Cli.pp_args pp_unit) t);
+        run t @@ error t ?ppf:help_ppf ?err_ppf argv
+    | `Error (None, _) ->
+        let action =
+          handle_parse_args_no_config ?help_ppf ?err_ppf (`Msg "") argv
+        in
+        let args = Cli.default_args in
+        action_run args action |> exit_err args
+    | `Ok t -> (
+        Log.info (fun l -> l "run: %a" (Cli.pp_action pp_unit) t);
+        let run = run (Cli.args t) in
+        let ppf = help_ppf in
+        match t with
+        | Configure t -> run @@ configure t ?ppf ?err_ppf argv
+        | Clean t -> run @@ clean t ?ppf ?err_ppf argv
+        | Query t -> run @@ query t ?ppf ?err_ppf argv
+        | Describe t -> run @@ describe t ?ppf ?err_ppf argv
+        | Help t -> run @@ help t ?ppf ?err_ppf argv)
+
+  let run () = run_with_argv Sys.argv
+end

unikernel/duniverse/mirage/lib/functoria/tool.mli

@@ -0,0 +1,57 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Creation of CLI tools to assemble functors. *)
+
+open DSL
+
+val check_version :
+  name:string -> version:string -> string -> (unit, string) result
+(** [check_version ~name ~version data] checks [data] for version constraints,
+    and if present checks that the [version] matches the bounds. The [data] is
+    expected to be a single line (an OCaml comment):
+    [(* <name> [>= a.b.c] [&] [< d.e.f] *)]. *)
+
+module type S = sig
+  val name : string
+  (** Name of the tool. *)
+
+  val version : string
+  (** Version of the tool. *)
+
+  val packages : package list
+  (** The packages to load when compiling the configuration file. *)
+
+  val create : job impl list -> job impl
+end
+
+module Make (_ : S) : sig
+  val run : unit -> unit
+  (** Run the configuration builder. This should be called exactly once to run
+      the configuration builder: command-line arguments will be parsed, and some
+      code will be generated and compiled. *)
+
+  val run_with_argv :
+    ?help_ppf:Format.formatter ->
+    ?err_ppf:Format.formatter ->
+    string array ->
+    unit
+  (** [run_with_argv a] is the same as {!run} but parses [a] instead of the
+      process command line arguments. It also allows to set the error and help
+      channels using [help_ppf] and [err_ppf]. *)
+end

unikernel/duniverse/mirage/lib/functoria/type.ml

@@ -0,0 +1,49 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type _ t =
+  | Type : 'a -> 'a t (* module type *)
+  | Function : 'a t * 'b t -> ('a -> 'b) t
+
+let v x = Type x
+let ( @-> ) f x = Function (f, x)
+
+let rec pp : type a. a t Fmt.t =
+ fun ppf -> function
+  | Type _ -> Fmt.string ppf "_"
+  | Function (a, b) -> Fmt.pf ppf "(%a -> %a)" pp a pp b
+
+type job = JOB
+
+let job = Type JOB
+
+(* Default argv *)
+
+type argv = ARGV
+
+let argv = Type ARGV
+
+(* Keys *)
+
+type info = INFO
+
+let info = Type INFO
+
+let is_functor : type a. a t -> bool = function
+  | Type _ -> false
+  | Function _ -> true

unikernel/duniverse/mirage/lib/functoria/type.mli

@@ -0,0 +1,63 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Representation of module signatures. *)
+
+(** The type for values representing module types. *)
+type 'a t = Type : 'a -> 'a t | Function : 'a t * 'b t -> ('a -> 'b) t
+
+val v : 'a -> 'a t
+(** [type t] is a value representing the module type [t]. *)
+
+val ( @-> ) : 'a t -> 'b t -> ('a -> 'b) t
+(** [x @-> y] is the functor type from the module signature [x] to the module
+    signature [y]. This corresponds to prepending a parameter to the list of
+    functor parameters. For example:
+
+    {[
+      kv_ro @-> ip @-> kv_ro
+    ]}
+
+    This describes a functor type that accepts two arguments -- a [kv_ro] and an
+    [ip] device -- and returns a [kv_ro]. *)
+
+val is_functor : _ t -> bool
+(** [is_functor t] is true if [t] has type [(a -> b) t]. *)
+
+val pp : 'a t Fmt.t
+(** [pp] is the pretty printer for module types. *)
+
+(** {1 Useful module types} *)
+
+type job
+(** Type for job values. *)
+
+val job : job t
+(** [job] is the signature for user's application main module. *)
+
+type argv
+(** The type for command-line arguments, similar to the usual [Sys.argv]. *)
+
+val argv : argv t
+(** [argv] is a value representing {!type-argv} module types. *)
+
+type info
+(** The type for application about the application being built. *)
+
+val info : info t
+(** [info] is a value representing {!type-info} module types. *)

unikernel/duniverse/mirage/lib/functoria/typeid.ml

@@ -0,0 +1,61 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+type (_, _) witness = Eq : ('a, 'a) witness | NotEq : ('a, 'b) witness
+
+let to_bool : type a b. (a, b) witness -> bool = function
+  | Eq -> true
+  | NotEq -> false
+
+module Id = struct
+  type _ t = ..
+end
+
+module type ID = sig
+  type t
+  type _ Id.t += Tid : t Id.t
+
+  val id : int
+end
+
+type 'a t = (module ID with type t = 'a)
+
+let gen_id =
+  let r = ref 0 in
+  fun () ->
+    incr r;
+    !r
+
+let gen () (type s) =
+  let module M = struct
+    type t = s
+    type _ Id.t += Tid : t Id.t
+
+    let id = gen_id ()
+  end in
+  (module M : ID with type t = s)
+
+let witness : type r s. r t -> s t -> (r, s) witness =
+ fun r s ->
+  let module R = (val r : ID with type t = r) in
+  let module S = (val s : ID with type t = s) in
+  match R.Tid with S.Tid -> Eq | _ -> NotEq
+
+let equal a b = to_bool @@ witness a b
+let pp (type a) ppf ((module M) : a t) = Fmt.int ppf M.id
+let id (type a) ((module M) : a t) = M.id

unikernel/duniverse/mirage/lib/functoria/typeid.mli

@@ -0,0 +1,44 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 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.
+ *)
+
+(** Typed identifiers and equality witnesses *)
+
+type 'a t
+(** A typed unique identifiers *)
+
+val gen : unit -> 'a t
+(** [gen ()] creates a new unique identifier. *)
+
+val equal : 'r t -> 's t -> bool
+(** [equal tid1 tid2] tests if [tid1] and [tid2] are equal. *)
+
+val id : 'a t -> int
+(** [id tid] returns a integer that uniquely identify [tid]. *)
+
+val pp : Format.formatter -> 'a t -> unit
+(** [pp ppf tid] prints [id tif]. *)
+
+(** A annotated boolean that also witness the equality between two types. *)
+type (_, _) witness = Eq : ('a, 'a) witness | NotEq : ('a, 'b) witness
+
+val witness : 'r t -> 's t -> ('r, 's) witness
+(** [witness tid1 tid2] is equivalent to [equal tid1 tid2], but exposes the
+    equality between their types. *)
+
+val to_bool : ('a, 'b) witness -> bool
+(** [to_bool w] converts the witness into a boolean. *)