unikernel/duniverse/mirage/lib_runtime/functoria/dune

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

unikernel/duniverse/mirage/lib_runtime/functoria/functoria_runtime.ml

@@ -0,0 +1,88 @@
+(*
+ * Copyright (c) 2015 Gabriel Radanne <drupyog@zoho.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let runtime_args_r = ref []
+let runtime_args () = !runtime_args_r
+
+module Arg = struct
+  type 'a t = { arg : 'a Cmdliner.Term.t; mutable value : 'a option }
+
+  let create arg = { arg; value = None }
+
+  let get t =
+    match t.value with
+    | None ->
+        invalid_arg
+          "Called too early. Please delay this call to after the start \
+           function of the unikernel."
+    | Some v -> v
+
+  let term (type a) (t : a t) =
+    let set w = t.value <- Some w in
+    Cmdliner.Term.(const set $ t.arg)
+end
+
+let initialized = ref false
+
+let register_arg t =
+  if !initialized then
+    invalid_arg
+      "The function register_arg was called to late. Please call register_arg \
+       before the start function is executed (e.g. in a top-level binding).";
+  let u = Arg.create t in
+  runtime_args_r := Arg.term u :: !runtime_args_r;
+  fun () -> Arg.get u
+
+let register = register_arg
+let help_version = 63
+let argument_error = 64
+
+let with_argv ?sections keys s argv =
+  let open Cmdliner in
+  if !initialized then ()
+  else
+    let gather k rest = Term.(const (fun () () -> ()) $ k $ rest) in
+    let t = List.fold_right gather keys (Term.const ()) in
+    let exits =
+      [
+        Cmd.Exit.info ~doc:"on success." Cmd.Exit.ok;
+        Cmd.Exit.info ~doc:"on Solo5 internal error." 1;
+        Cmd.Exit.info ~doc:"on showing this help." help_version;
+        Cmd.Exit.info ~doc:"on any argument parsing error." argument_error;
+        Cmd.Exit.info
+          ~doc:
+            "on unexpected internal errors (bugs) while processing the boot \
+             parameters."
+          Cmd.Exit.internal_error;
+        Cmd.Exit.info ~doc:"on OCaml uncaught exception." 255;
+      ]
+    in
+    let man = Option.map (List.map (fun s -> `S s)) sections in
+    match Cmd.(eval_value ~argv (Cmd.v (info ?man ~exits s) t)) with
+    | Ok (`Ok _) ->
+        initialized := true;
+        ()
+    | Error `Parse -> exit argument_error
+    | Error `Term ->
+        print_endline
+          "Hint: To pass a space, it needs to be escaped twice: \
+           \027[1m--hello='Hello,\\ world!'\027[m";
+        print_endline
+          "      Another possibility is: \027[1m--hello='\"Hello, \
+           world!\"'\027[m";
+        exit argument_error
+    | Error `Exn -> exit Cmd.Exit.internal_error
+    | Ok `Help | Ok `Version -> exit help_version

unikernel/duniverse/mirage/lib_runtime/functoria/functoria_runtime.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.
+ *)
+
+(** Functoria runtime. *)
+
+val register : 'a Cmdliner.Term.t -> unit -> 'a
+[@@ocaml.deprecated "Use register_arg instead."]
+(** [register t] registers the Cmdliner term [k] as a runtime argument and
+    return a callback [f] that evaluates to [t]s' value passed on the
+    command-line.
+
+    [f] will raise [Invalid_argument] if called before cmdliner's evaluation. *)
+
+val register_arg : 'a Cmdliner.Term.t -> unit -> 'a
+(** [register_arg t] registers the Cmdliner term [k] as a runtime argument and
+    return a callback [f] that evaluates to [t]s' value passed on the
+    command-line.
+
+    [f] will raise [Invalid_argument] if called before cmdliner's evaluation. *)
+
+val with_argv :
+  ?sections:string list ->
+  unit Cmdliner.Term.t list ->
+  string ->
+  string array ->
+  unit
+(** [with_argv ?sections arguments name argv] evaluates the [arguments]
+    {{!Key.term} terms} on the command-line [argv]. [name] is the executable
+    name. [sections] is a list of sections to include in the man page - useful
+    for enforcing a specific order of sections. On evaluation error the
+    application calls [exit(3)] with status [64]. If [`Help] or [`Version] were
+    evaluated, [exit(3)] is called with status [63]. *)
+
+val runtime_args : unit -> unit Cmdliner.Term.t list
+
+(** {2 Exit Codes} *)
+
+val argument_error : int
+(** [argument_error] is the exit code used for argument parsing errors: 64. *)
+
+val help_version : int
+(** [help_version] is the exit code used when help/version is used: 63. *)