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