Merge pull request #1493 from samoht/runtime-keys

Better API for application runtime keys

CHANGES.md

@@ -1,23 +1,27 @@
 ### Unreleased
 
 - This release introduces a significant change in the Mirage tool by
-  splitting the configure-time and runtime keys. Configure-time keys
-  are essential during the setup of module dependencies for the
-  unikernel, allowing for a specialized production of a unikernel for
-  a given target runtime environment. On the other hand, runtime keys
-  are useful for customizing deployments without altering the
-  dependencies of the unikernels. (#1449, #1450, #1451, #1455 @samoht,
-  review by @hannesm)
+  splitting the definition of command-line arguments used at
+  configure-time and runtime. Command-line arguments used in the
+  configure script (also called 'configuration keys' and defined in
+  the `Key` module) are essential during the setup of module
+  dependencies for the unikernel, allowing for a specialized
+  production of a unikernel for a given target runtime environment. On
+  the other hand, command-line arguments that the unikernel can use at
+  runtime (defined in the `Runtime_arg` module) are useful for
+  customizing deployments without altering the dependencies of the
+  unikernels. (#1449, #1450, #1451, #1455 @samoht, review by @hannesm)
 
   * API changes:
     - There is no more `~stage` parameter for `Key.Arg.info`.
-    - `Key` now define configure-time keys only.
-    - There is a new module `Runtime_arg` to define runtime keys.
+    - `Key` now define command-line arguments for the configuration tool.
+    - There is a new module `Runtime_arg` to define command-line arguments
+      for the unikernel.
     - As there are no more keys type `'Both`, users are now expected to create
       two separated keys in that case (one for configure-time, one for runtime)
       or decide if the key is useful at runtime of configure-time.
 
-  * Intended use of configure-time keys (values of type `'a key`):
+  * Intended use of configuration keys (values of type `'a key`):
     - Used to set up module dependencies of the unikernel, such as the
       target (hvt, xen, etc.) and whether to use DHCP or a fixed IP address.
     - Enable the production of specialized unikernels suitable for
@@ -26,16 +30,26 @@
     - Similar keys will produce reproducible binaries to be uploaded to artifact
       repositories like Docker Hub or https://builds.robur.coop/.
 
-  * Intended use of runtime keys (values of type `a runtime_arg`):
+  * Intended use of command-line runtime arguments (values of type
+    `a runtime_arg`):
     - Allow users to customize deployments by changing device
       configuration, like IP addresses, secrets, block device names,
       etc., post downloading of binaries.
     - These keys don’t alter the dependencies of the unikernels.
     - A runtime keys is just a reference to a normal Cmdliner term.
 
-  * Code migration:
+  * `key_gen.ml` is not generated anymore, so users cannot refer to
+    `Key_gen.<key_name>` directy.
+    - Any runtime argument has to be declared (using `runtime_arg` and
+      registered on the device (using `~runtime_args`). The value of that
+      argument will then be passed  as an extra parameter of the `connect`
+      function of that device.
+    - Configuration keys are not available at runtime anymore. For
+      instance, `Key_gen.target` has been removed.
+
+* Code migration:
     ```ocaml
-    (* in `config.ml` *)
+    (* in config.ml *)
     let key =
       let doc = Key.Arg.info ~doc:"A Key." ~stage:`Run [ "key" ] in
       Key.(create "key" Arg.(opt_all ~stage:`Run string doc))
@@ -50,15 +64,29 @@
       Arg.(value & opt_all string [] doc)
     ```
 
-   * Changes in the auto-generated `key_gen.ml` file:
-     - Users are not expected to refer to `Key_gen.<key_name>`
-       directy. Instead, they should use normal Cmdliner
-       terms. `mirage configure` is still generating a `key_gen.ml`
-       file containing (registered) runtime keys that are needed by
-       device-initialisation code.
-     - Configure-time keys are not registerd anymore. This means that
-       they are not available `key_gen.ml` anymore. As a consequence,
-       `Key_gen.target` has been removed.
+    ```ocaml
+    (* in unikernel.ml *)
+    let start _ =
+      let key = Key_gen.hello () in
+      ...
+    ```
+    becomes:
+    ```ocaml
+    (* in config.ml *)
+    let hello = runtime_arg ~pos:__POS__ "Unikernel.hello"
+    let main = main ~runtime_args:[hello] ...
+    ```
+
+    ```
+    (* in unikernel.ml *)
+    let hello =
+      let open Cmdliner in
+      let doc = Arg.info ~doc:"How to say hello." [ "hello" ] in
+      Arg.(value & opt string "Hello World!" doc)
+
+    let start _ hello =
+      ...
+    ```
 
 - BREAKING: `Mirage.keys` is renamed to `Mirage.runtime_args` (#1506, @samoht)
 - BREAKING: remove `Mirage.foreign. Use `Mirage.main` instead (#1505, @samoht)

lib/functoria/DSL.ml

@@ -48,6 +48,11 @@ let impl ?packages ?packages_v ?install ?install_v ?keys ?runtime_args
   @@ Device.v ?packages ?packages_v ?install ?install_v ?keys ?runtime_args
        ?extra_deps ?connect ?dune ?configure ?files module_name module_type
 
-let main ?pos ?packages ?packages_v module_name ty =
+let main ?pos ?packages ?packages_v ?runtime_args module_name ty =
   let connect _ = Device.start ?pos in
-  impl ?packages ?packages_v ~connect module_name ty
+  impl ?packages ?packages_v ?runtime_args ~connect module_name ty
+
+let runtime_arg ~pos ?name ?packages fmt =
+  Fmt.kstr
+    (fun code -> Runtime_arg.v (Runtime_arg.create ~pos ?name ?packages code))
+    fmt

lib/functoria/DSL.mli

@@ -64,10 +64,17 @@ val dep : 'a impl -> abstract_impl
 (** {1:keys Keys} *)
 
 type 'a key = 'a Key.key
-(** The type for command-line parameters. *)
+(** The type for configure-time command-line arguments. *)
 
 type 'a runtime_arg = 'a Runtime_arg.arg
-(** The type for command-line parameters. *)
+(** The type for runtime command-line arguments. *)
+
+val runtime_arg :
+  pos:string * int * int * int ->
+  ?name:string ->
+  ?packages:Package.t list ->
+  ('a, Format.formatter, unit, Runtime_arg.t) format4 ->
+  'a
 
 type abstract_key = Key.t
 (** The type for abstract keys. *)
@@ -131,6 +138,7 @@ val main :
   ?pos:string * int * int * int ->
   ?packages:package list ->
   ?packages_v:package list value ->
+  ?runtime_args:Runtime_arg.t list ->
   string ->
   'a typ ->
   'a impl

lib/functoria/engine.ml

@@ -186,17 +186,23 @@ let reset_pos { dir; path; lines } =
   let file = Fpath.(dir // path) |> Fpath.normalize |> Fpath.to_string in
   Some (file, lines + 1, 0, 0)
 
-let emit_connect fmt (iname, names, connect_code) =
+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 { Device.pos; code } = connect_code rnames in
-  Fmt.pf fmt "let %s = lazy (\n%a%a%a  %s\n);;" iname
+  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);;\n" iname
     Fmt.(list ~sep:nop meta_init)
     (List.combine names rnames)
     Fmt.(list ~sep:nop bind)
-    rnames pp_pos pos code
+    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. *)
@@ -213,9 +219,10 @@ let connect ?(init = []) info t =
     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, Device.connect dev info impl_name)
+        (var_name, arg_names, runtime_args, Device.connect dev info impl_name)
     in
     append_main main "reset" "%a" pp_pos (reset_pos main)
   in

lib/functoria/functoria.ml

@@ -44,21 +44,13 @@ module type KEY =
      and type t = Key.t
      and type Set.t = Key.Set.t
 
-module type RUNTIME_ARG =
-  module type of Runtime_arg
-    with type 'a arg = 'a Runtime_arg.arg
-     and type t = Runtime_arg.t
-     and type Set.t = Runtime_arg.Set.t
-
 (** Devices *)
 
 include DSL
 
 let job = Job.t
 let noop = Job.noop
-
-let runtime_args ?runtime_package ?runtime_modname x =
-  Job.runtime_args ?runtime_package ?runtime_modname x
+let runtime_args = Job.runtime_args
 
 type argv = Argv.t
 

lib/functoria/functoria.mli

@@ -122,23 +122,6 @@
 module type DSL = module type of DSL
 
 include DSL
-
-(** The signature for configure-time command-line keys. *)
-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
-
-(** The signature for run-time command-line keys. *)
-module type RUNTIME_ARG =
-  module type of Runtime_arg
-    with type 'a arg = 'a Runtime_arg.arg
-     and type t = Runtime_arg.t
-     and type Set.t = Runtime_arg.Set.t
-
 module Package = Package
 module Info = Info
 module Install = Install
@@ -164,7 +147,7 @@ val sys_argv : argv impl
 
 val runtime_args :
   ?runtime_package:string -> ?runtime_modname:string -> argv impl -> job impl
-(** [runtinme_args a] is an implementation of {!type-job} that holds the parsed
+(** [runtime_args a] is an implementation of {!type-job} that holds the parsed
     command-line arguments. By default [runtime_package] is
     ["functoria-runtime"] and [runtime_modname] is ["Functoria_runtime"]. *)
 

lib/functoria/impl.ml

@@ -57,15 +57,17 @@ let rec app_has_no_arguments = function
 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 v ?packages ?packages_v ?keys ?extra_deps ?connect ?dune ?configure ?files
-    module_name module_type =
+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 ?keys ?extra_deps ?connect ?dune ?configure
-       ?files module_name module_type
+  @@ Device.v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect
+       ?dune ?configure ?files module_name module_type
 
-let main ?pos ?packages ?packages_v ?keys ?extra_deps module_name ty =
+let main ?pos ?packages ?packages_v ?runtime_args ?keys ?extra_deps module_name
+    ty =
   let connect _ = Device.start ?pos in
-  v ?packages ?packages_v ?keys ?extra_deps ~connect module_name ty
+  v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ~connect module_name
+    ty
 
 (* If *)
 

lib/functoria/impl.mli

@@ -57,6 +57,7 @@ val of_device : 'a device -> 'a 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) ->
@@ -72,6 +73,7 @@ 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 ->

lib/functoria/job.ml

@@ -19,7 +19,6 @@
 let src = Logs.Src.create "functoria" ~doc:"functoria library"
 
 module Log = (val Logs.src_log src : Logs.LOG)
-open Astring
 
 type t = JOB
 
@@ -29,27 +28,23 @@ let t = Type.v JOB
 let noop = Impl.v "Unit" t
 
 module Args = struct
-  let configure ~file i =
-    Log.info (fun m -> m "Generating: %a (keys)" Fpath.pp file);
-    Action.with_output ~path:file ~purpose:"key_gen file" (fun ppf ->
+  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 Runtime_arg.serialize)
-          keys)
+        Fmt.pf ppf "@[<v>%a@]@." Fmt.(iter Runtime_arg.Set.iter serialize) keys)
 end
 
 let runtime_args ?(runtime_package = "functoria-runtime")
     ?(runtime_modname = "Functoria_runtime") (argv : Argv.t Impl.t) =
   let packages = [ Package.v runtime_package ] in
   let extra_deps = [ Impl.abstract argv ] in
-  let key_gen = Runtime_arg.module_name in
-  let file = Fpath.(v (String.Ascii.lowercase key_gen) + "ml") in
-  let configure = Args.configure ~file in
-  let files _ = [ file ] 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 ~files ~configure ~packages ~extra_deps ~connect key_gen t
+  Impl.v ~configure ~packages ~extra_deps ~connect "struct end" t

lib/functoria/key.ml

@@ -21,6 +21,8 @@ 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

lib/functoria/key.mli

@@ -50,6 +50,17 @@ module Arg : sig
         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 ->
+    ?docv:string ->
+    ?doc:string ->
+    ?env:Cmd.Env.info ->
+    string list ->
+    Arg.info
+  (** Same as {!Cmdliner.Arg.info}. *)
 end
 
 (** {1 Configuration Keys} *)

lib/functoria/runtime_arg.ml

@@ -16,7 +16,13 @@
 
 open Misc
 
-type 'a arg = { name : string; code : string; packages : Package.t list }
+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
@@ -43,20 +49,22 @@ module Set = struct
   let pp = pp_gen pp_elt
 end
 
-let create ?name ?(packages = []) code =
+let create ~pos ?name ?(packages = []) code =
   let name = match name with None -> Name.ocamlify code | Some n -> n in
-  { name; packages; code }
+  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 module_name = "Key_gen"
 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 fmt (Any k) =
-  Format.fprintf fmt "@[<2>let %s =@ @[Functoria_runtime.register@ %s@]@]@,"
-    (ocaml_name k.name) k.code
+let serialize ~runtime_modname fmt (Any k) =
+  Format.fprintf fmt "let %s__key = %s.register @@@@\n%a  @[<v2>%s@]\n;;\n"
+    (ocaml_name k.name) runtime_modname pp_pos k.pos k.code
 
-let call fmt k = Fmt.pf fmt "(%s.%s ())" module_name (ocaml_name k.name)
+let call fmt (Any k) = Fmt.pf fmt "%s__key ()" (ocaml_name k.name)
+let var_name (Any k) = ocaml_name k.name