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