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)