Merge pull request #1335 from hannesm/reproducible

Reproducible

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.21.0
+version = 0.22.4
 profile = conventional
 break-infix = fit-or-vertical
 parse-docstrings = true

lib/functoria/info.ml

@@ -25,7 +25,11 @@ type t = {
   keys : Key.Set.t;
   context : Key.context;
   packages : Package.t String.Map.t;
-  opam : install:Install.t -> Opam.t;
+  opam :
+    extra_repo:(string * string) list ->
+    install:Install.t ->
+    opam_name:string ->
+    Opam.t;
 }
 
 let name t = t.name
@@ -59,12 +63,13 @@ let pins packages =
 let keys t = Key.Set.elements t.keys
 let context t = t.context
 
-let v ?(config_file = Fpath.v "config.ml") ~packages ~keys ~context ~build_cmd
-    ~src name =
+let v ?(config_file = Fpath.v "config.ml") ~packages ~keys ~context
+    ?configure_cmd ?pre_build_cmd ?lock_location ~build_cmd ~src name =
   let keys = Key.Set.of_list keys in
-  let opam ~install =
-    Opam.v ~depends:packages ~install ~pins:(pins packages) ~build:build_cmd
-      ~src name
+  let opam ~extra_repo ~install ~opam_name =
+    Opam.v ~depends:packages ~install ~pins:(pins packages) ~extra_repo
+      ?configure:configure_cmd ?pre_build:pre_build_cmd ?lock_location
+      ~build:build_cmd ~src ~opam_name name
   in
   let packages =
     List.fold_left
@@ -105,6 +110,6 @@ let pp verbose ppf ({ name; keys; context; output; _ } as t) =
 let t =
   let i =
     v ~config_file:(Fpath.v "config.ml") ~packages:[] ~keys:[]
-      ~build_cmd:[ "dummy" ] ~context:Key.empty_context ~src:`None "dummy"
+      ~build_cmd:"dummy" ~context:Key.empty_context ~src:`None "dummy"
   in
   Type.v i

lib/functoria/info.mli

@@ -42,7 +42,12 @@ val libraries : t -> string list
 val packages : t -> Package.t list
 (** [packages t] are the opam package dependencies by the project. *)
 
-val opam : t -> install:Install.t -> Opam.t
+val opam :
+  t ->
+  extra_repo:(string * string) list ->
+  install:Install.t ->
+  opam_name:string ->
+  Opam.t
 (** [opam scope t] is [t]'opam file to install in the [scope] context.*)
 
 val keys : t -> Key.t list
@@ -59,7 +64,10 @@ val v :
   packages:Package.t list ->
   keys:Key.t list ->
   context:Key.context ->
-  build_cmd:string list ->
+  ?configure_cmd:string ->
+  ?pre_build_cmd:(Fpath.t option -> string) ->
+  ?lock_location:(Fpath.t option -> string -> string) ->
+  build_cmd:string ->
   src:[ `Auto | `None | `Some of string ] ->
   string ->
   t

lib/functoria/install.ml

@@ -40,11 +40,17 @@ let pp ppf t =
   Fmt.pf ppf "etc: [%s%s]" (String.concat "" etcs)
     (match etcs with [] -> "" | _ -> "\n")
 
-let pp_opam ppf t =
+let pp_opam ?subdir () ppf t =
   let pp_bin ppf (src, dst) =
-    Fmt.pf ppf {|"cp" "dist/%a" "%%{bin}%%/%a"|} Fpath.pp src Fpath.pp dst
+    Fmt.pf ppf {|"cp" "%adist/%a" "%%{bin}%%/%a"|}
+      Fmt.(option ~none:(any "") Fpath.pp)
+      subdir Fpath.pp src Fpath.pp dst
+  in
+  let pp_etc ppf etc =
+    Fmt.pf ppf {|"cp" "%adist/%a" "%%{etc}%%"|}
+      Fmt.(option ~none:(any "") Fpath.pp)
+      subdir Fpath.pp etc
   in
-  let pp_etc ppf etc = Fmt.pf ppf {|"cp" "dist/%a" "%%{etc}%%"|} Fpath.pp etc in
   Fmt.pf ppf "\n%a\n"
     (Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf "  [ %a ]" pp_bin))
     t.bin;

lib/functoria/install.mli

@@ -31,8 +31,11 @@ val empty : t
 val pp : t Fmt.t
 (** Print the .install rules to install [t] *)
 
-val pp_opam : t Fmt.t
-(** Print the opam rules to install [t] *)
+val pp_opam : ?subdir:Fpath.t -> unit -> t Fmt.t
+(** Print the opam rules to install [t]. If [~subdir] is provided, this will be
+    used as prefix (i.e. if your unikernel is in the "tutorial/hello/"
+    subdirectory (which is passed as [~subdir], the install instructions will
+    use "cp tutorial/hello/dist/hello.hvt %{bin}%/hello.hvt"). *)
 
 val dune :
   context_name_for_bin:string -> context_name_for_etc:string -> t -> Dune.t

lib/functoria/lib.ml

@@ -29,7 +29,10 @@ module Config = struct
   type t = {
     config_file : Fpath.t;
     name : string;
-    build_cmd : string list;
+    configure_cmd : string;
+    pre_build_cmd : Fpath.t option -> string;
+    lock_location : Fpath.t option -> string -> string;
+    build_cmd : string;
     packages : package list Key.value;
     keys : Key.Set.t;
     init : job impl list;
@@ -56,21 +59,47 @@ module Config = struct
     Key.Set.fold f all_keys skeys
 
   let v ?(config_file = Fpath.v "config.ml") ?(keys = []) ?(packages = [])
-      ?(init = []) ~build_cmd ~src name jobs =
+      ?(init = []) ~configure_cmd ~pre_build_cmd ~lock_location ~build_cmd ~src
+      name jobs =
     let packages = Key.pure @@ packages in
     let jobs = Impl.abstract jobs in
     let keys = Key.Set.(union (of_list keys) (get_if_context jobs)) in
-    { config_file; packages; keys; name; init; build_cmd; jobs; src }
+    {
+      config_file;
+      packages;
+      keys;
+      name;
+      init;
+      configure_cmd;
+      pre_build_cmd;
+      lock_location;
+      build_cmd;
+      jobs;
+      src;
+    }
 
   let eval ~full context
-      { config_file; name = n; build_cmd; packages; keys; jobs; init; src } =
+      {
+        config_file;
+        name = n;
+        configure_cmd;
+        pre_build_cmd;
+        lock_location;
+        build_cmd;
+        packages;
+        keys;
+        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 keys = Key.Set.elements (Key.Set.union keys @@ Engine.all_keys jobs) in
     let mk packages _ context =
       let info =
-        Info.v ~config_file ~packages ~keys ~context ~build_cmd ~src n
+        Info.v ~config_file ~packages ~keys ~context ~configure_cmd
+          ~pre_build_cmd ~lock_location ~build_cmd ~src n
       in
       { init; jobs; info; device_graph }
     in
@@ -115,13 +144,23 @@ module Make (P : S) = struct
       |> List.tl
       |> List.filter (fun arg ->
              arg <> "configure" && arg <> "query" && arg <> "opam")
-      |> List.map (fun x -> "\"" ^ x ^ "\"")
       |> String.concat ~sep:" "
     in
-    [
-      Fmt.str {|"%s" "configure" %s|} P.name command_line_arguments;
-      Fmt.str {|"%s" "build"|} P.name;
-    ]
+    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" "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),
+      Fmt.str {|%s build|} P.name )
 
   (* STAGE 2 *)
 
@@ -202,7 +241,8 @@ module Make (P : S) = struct
         let pkgs = Info.packages info in
         List.iter (Fmt.pr "%a\n%!" (Package.pp ~surround:"\"")) pkgs
     | `Opam ->
-        let opam = Info.opam ~install info in
+        let opam_name = Misc.Name.(Opam.to_string (opamify name)) in
+        let opam = Info.opam ~extra_repo ~install ~opam_name info in
         Fmt.pr "%a\n%!" Opam.pp opam
     | `Files ->
         let files = files info jobs in
@@ -247,11 +287,11 @@ module Make (P : S) = struct
 
   (* Configuration step. *)
 
-  let generate_opam ~opam_name (args : _ Cli.args) () =
+  let generate_opam ~opam_name ~extra_repo (args : _ Cli.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 info in
+    let opam = Info.opam ~install ~extra_repo ~opam_name:name info in
     let contents = Fmt.str "%a" Opam.pp opam in
     let file = Fpath.(v (name ^ ".opam")) in
     Log.info (fun m ->
@@ -326,7 +366,7 @@ module Make (P : S) = struct
     let* () =
       Action.with_dir (mirage_dir args) (fun () ->
           (* OPAM file *)
-          let* () = generate_opam ~opam_name args () in
+          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)
@@ -468,11 +508,13 @@ module Make (P : S) = struct
     let args = Cli.peek_args ~with_setup:true ~mname:P.name argv in
     let config_file = config_file args in
     let run () =
-      let build_cmd = get_build_cmd args in
+      let configure_cmd, pre_build_cmd, lock_location, build_cmd =
+        get_build_cmd args
+      in
       let main_dev = P.create (init @ jobs) in
       let c =
-        Config.v ~config_file ?keys ?packages ~init ~build_cmd ~src name
-          main_dev
+        Config.v ~config_file ?keys ?packages ~init ~configure_cmd
+          ~pre_build_cmd ~lock_location ~build_cmd ~src name main_dev
       in
       run_configure_with_argv argv args c
     in

lib/functoria/opam.ml

@@ -29,7 +29,8 @@ let find_git () =
       else find (Fpath.parent p) (Some (app_opt path (Fpath.base p)))
   in
   let* cwd = Action.pwd () in
-  let* cwd = find cwd None in
+  (* this is invoked from within the mirage subdirectory *)
+  let* cwd = find (Fpath.parent cwd) None in
   match cwd with
   | None -> Action.ok None
   | Some subdir ->
@@ -101,11 +102,11 @@ let guess_src () =
   let git_info =
     match Action.run @@ find_git () with
     | Error _ | Ok None -> None
-    | Ok (Some (_, branch, git_url)) -> Some (branch, git_url)
+    | Ok (Some (subdir, branch, git_url)) -> Some (subdir, branch, git_url)
   in
   match git_info with
-  | None -> None
-  | Some (branch, origin) ->
+  | None -> (None, None)
+  | Some (subdir, branch, origin) ->
       (* TODO is there a library for git urls anywhere? *)
       let public =
         match Endpoint.of_string origin with
@@ -128,23 +129,48 @@ let guess_src () =
             Fmt.str "git+https://%s:%d/%s" hostname port path
         | _ -> "git+https://invalid/endpoint"
       in
-      Some (Fmt.str "%s#%s" public branch)
+      (subdir, Some (Fmt.str "%s#%s" public branch))
 
 type t = {
   name : string;
   depends : Package.t list;
-  build : string list;
+  configure : string option;
+  pre_build : (Fpath.t option -> string) option;
+  lock_location : (Fpath.t option -> string -> string) option;
+  build : string option;
   install : Install.t;
+  extra_repo : (string * string) list;
   pins : (string * string) list;
   src : string option;
+  subdir : Fpath.t option;
+  opam_name : string;
 }
 
-let v ?(build = []) ?(install = Install.empty) ?(depends = []) ?(pins = []) ~src
-    name =
-  let src =
-    match src with `Auto -> guess_src () | `None -> None | `Some d -> Some d
+let v ?configure ?pre_build ?lock_location ?build ?(install = Install.empty)
+    ?(extra_repo = []) ?(depends = []) ?(pins = []) ?subdir ~src ~opam_name name
+    =
+  let subdir, src =
+    match src with
+    | `Auto ->
+        let subdir', src = guess_src () in
+        ((match subdir with None -> subdir' | Some _ as s -> s), src)
+    | `None -> (subdir, None)
+    | `Some d -> (subdir, Some d)
   in
-  { name; depends; build; install; pins; src }
+  {
+    name;
+    depends;
+    configure;
+    pre_build;
+    lock_location;
+    build;
+    install;
+    extra_repo;
+    pins;
+    src;
+    subdir;
+    opam_name;
+  }
 
 let pp_packages ppf packages =
   Fmt.pf ppf "\n  %a\n"
@@ -166,8 +192,20 @@ let pp_src ppf = function
 let pp_switch_package ppf s = Fmt.pf ppf "%S" s
 
 let pp ppf t =
-  let pp_build ppf =
-    Fmt.pf ppf "\n%a\n" (Fmt.list ~sep:(Fmt.any "\n") (Fmt.fmt "  [ %s ]"))
+  let pp_build = function
+    | None -> ""
+    | Some cmd ->
+        Fmt.str {|"sh" "-exc" "%a%s"|}
+          Fmt.(option ~none:(any "") (any "cd " ++ Fpath.pp ++ any " && "))
+          t.subdir cmd
+  in
+  let pp_pre_build ppf pre_build =
+    match pre_build with None -> () | Some f -> Fmt.string ppf (f t.subdir)
+  in
+  let pp_repo =
+    Fmt.(
+      list ~sep:(any "\n")
+        (brackets (pair ~sep:(any " ") (quote string) (quote string))))
   in
   let switch_packages =
     List.filter_map
@@ -190,14 +228,28 @@ It assumes that local dependencies are already
 fetched.
 """
 
-build: [%a]
+build: [%s]
 
 install: [%a]
 
 depends: [%a]
 
+x-mirage-opam-lock-location: %S
+
+x-mirage-configure: [%s]
+
+x-mirage-pre-build: [%a]
+
+x-mirage-extra-repo: [%a]
+
 x-opam-monorepo-opam-provided: [%a]
 %a%a|}
-    t.name pp_build t.build Install.pp_opam t.install pp_packages t.depends
+    t.name (pp_build t.build)
+    (Install.pp_opam ?subdir:t.subdir ())
+    t.install pp_packages t.depends
+    (Option.fold ~none:""
+       ~some:(fun l -> l t.subdir t.opam_name)
+       t.lock_location)
+    (pp_build t.configure) pp_pre_build t.pre_build pp_repo t.extra_repo
     (Fmt.list pp_switch_package)
     switch_packages pp_src t.src pp_pins t.pins