feature(pkg): extra sources (ocaml#8015)

Opam allows for additional file sources to be specified. We add support for these. Signed-off-by: Rudi Grinberg <[email protected]>
Lucccyo · Jun 20, 2023 · cd15331 · cd15331
1 parent b71213c
commit cd15331
Show file tree

Hide file tree

Showing 6 changed files with 182 additions and 42 deletions.
diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml
@@ -2,12 +2,14 @@ open Import
 open Dune_lang
 
 module Source = struct
+  type fetch =
+    { url : Loc.t * string
+    ; checksum : (Loc.t * Checksum.t) option
+    }
+
   type t =
     | External_copy of Loc.t * Path.External.t
-    | Fetch of
-        { url : Loc.t * string
-        ; checksum : (Loc.t * Checksum.t) option
-        }
+    | Fetch of fetch
 
   let remove_locs = function
     | External_copy (_loc, path) -> External_copy (Loc.none, path)
@@ -51,6 +53,20 @@ module Source = struct
     let checksum = "checksum"
   end
 
+  let decode_fetch =
+    let open Dune_sexp.Decoder in
+    let+ url = field Fields.url (located string)
+    and+ checksum = field_o Fields.checksum (located string) in
+    let checksum =
+      match checksum with
+      | None -> None
+      | Some ((loc, _) as checksum) -> (
+        match Checksum.of_string_user_error checksum with
+        | Ok checksum -> Some (loc, checksum)
+        | Error e -> raise (User_error.E e))
+    in
+    { url; checksum }
+
   let decode =
     let open Dune_lang.Decoder in
     sum
@@ -62,30 +78,22 @@ module Source = struct
                 Path.External.relative path source
               else Path.External.of_string source ) )
       ; ( Fields.fetch
-        , fields
-          @@ let+ url = field Fields.url (located string)
-             and+ checksum = field_o Fields.checksum (located string) in
-             let checksum =
-               match checksum with
-               | None -> None
-               | Some ((loc, _) as checksum) -> (
-                 match Checksum.of_string_user_error checksum with
-                 | Ok checksum -> Some (loc, checksum)
-                 | Error e -> raise (User_error.E e))
-             in
-             fun _ -> Fetch { url; checksum } )
+        , let+ fetch = fields decode_fetch in
+          fun _ -> Fetch fetch )
       ]
 
+  let encode_fetch_field { url = _loc, url; checksum } =
+    let open Dune_sexp.Encoder in
+    [ field Fields.url string url
+    ; field_o Fields.checksum Checksum.encode (Option.map checksum ~f:snd)
+    ]
+
   let encode t =
     let open Dune_lang.Encoder in
     match t with
     | External_copy (_loc, path) ->
       constr Fields.copy string (Path.External.to_string path)
-    | Fetch { url = _loc, url; checksum } ->
-      named_record_fields Fields.fetch
-        [ field Fields.url string url
-        ; field_o Fields.checksum Checksum.encode (Option.map checksum ~f:snd)
-        ]
+    | Fetch fetch -> named_record_fields Fields.fetch (encode_fetch_field fetch)
 end
 
 module Pkg_info = struct
@@ -94,28 +102,40 @@ module Pkg_info = struct
     ; version : string
     ; dev : bool
     ; source : Source.t option
+    ; extra_sources : (Path.Local.t * Source.t) list
     }
 
-  let equal { name; version; dev; source }
+  let equal { name; version; dev; source; extra_sources }
       { name = other_name
       ; version = other_version
       ; dev = other_dev
       ; source = other_source
+      ; extra_sources = other_extra_sources
       } =
     Package_name.equal name other_name
     && String.equal version other_version
     && Bool.equal dev other_dev
     && Option.equal Source.equal source other_source
+    && List.equal
+         (Tuple.T2.equal Path.Local.equal Source.equal)
+         extra_sources other_extra_sources
 
   let remove_locs t =
-    { t with source = Option.map ~f:Source.remove_locs t.source }
+    { t with
+      source = Option.map ~f:Source.remove_locs t.source
+    ; extra_sources =
+        List.map t.extra_sources ~f:(fun (local, source) ->
+            (local, Source.remove_locs source))
+    }
 
-  let to_dyn { name; version; dev; source } =
+  let to_dyn { name; version; dev; source; extra_sources } =
     Dyn.record
       [ ("name", Package_name.to_dyn name)
       ; ("version", Dyn.string version)
       ; ("dev", Dyn.bool dev)
       ; ("source", Dyn.option Source.to_dyn source)
+      ; ( "extra_sources"
+        , Dyn.list (Dyn.pair Path.Local.to_dyn Source.to_dyn) extra_sources )
       ]
 end
 
@@ -177,6 +197,8 @@ module Pkg = struct
     let dev = "dev"
 
     let exported_env = "exported_env"
+
+    let extra_sources = "extra_sources"
   end
 
   let decode =
@@ -191,23 +213,37 @@ module Pkg = struct
        and+ exported_env =
          field Fields.exported_env ~default:[]
            (repeat Dune_lang.Action.Env_update.decode)
+       and+ extra_sources =
+         field Fields.extra_sources ~default:[]
+           (repeat
+              (pair (plain_string Path.Local.parse_string_exn) Source.decode))
        in
        fun ~lock_dir name ->
          let info =
-           let source =
-             Option.map source ~f:(fun f ->
-                 Path.source lock_dir |> Path.to_absolute_filename
-                 |> Path.External.of_string |> f)
+           let make_source f =
+             Path.source lock_dir |> Path.to_absolute_filename
+             |> Path.External.of_string |> f
+           in
+           let source = Option.map source ~f:make_source in
+           let extra_sources =
+             List.map extra_sources ~f:(fun (path, source) ->
+                 (path, make_source source))
            in
-           { Pkg_info.name; version; dev; source }
+           { Pkg_info.name; version; dev; source; extra_sources }
          in
          { build_command; deps; install_command; info; exported_env }
 
+  let encode_extra_source (local, source) =
+    List
+      [ Dune_sexp.atom_or_quoted_string (Path.Local.to_string local)
+      ; Source.encode source
+      ]
+
   let encode
       { build_command
       ; install_command
       ; deps
-      ; info = { Pkg_info.name = _; version; dev; source }
+      ; info = { Pkg_info.name = _; extra_sources; version; dev; source }
       ; exported_env
       } =
     let open Dune_lang.Encoder in
@@ -220,6 +256,7 @@ module Pkg = struct
       ; field_b Fields.dev dev
       ; field_l Fields.exported_env Dune_lang.Action.Env_update.encode
           exported_env
+      ; field_l Fields.extra_sources encode_extra_source extra_sources
       ]
 end
 

diff --git a/src/dune_pkg/lock_dir.mli b/src/dune_pkg/lock_dir.mli
@@ -4,12 +4,14 @@ open Import
 open Dune_lang
 
 module Source : sig
+  type fetch =
+    { url : Loc.t * string
+    ; checksum : (Loc.t * Checksum.t) option
+    }
+
   type t =
     | External_copy of Loc.t * Path.External.t
-    | Fetch of
-        { url : Loc.t * string
-        ; checksum : (Loc.t * Checksum.t) option
-        }
+    | Fetch of fetch
 end
 
 module Pkg_info : sig
@@ -18,6 +20,7 @@ module Pkg_info : sig
     ; version : string
     ; dev : bool
     ; source : Source.t option
+    ; extra_sources : (Path.Local.t * Source.t) list
     }
 end
 

diff --git a/src/dune_pkg/opam.ml b/src/dune_pkg/opam.ml
@@ -355,6 +355,7 @@ let opam_package_to_lock_file_pkg ~repo_state ~local_packages opam_package =
     ; version
     ; dev
     ; source = None
+    ; extra_sources = []
     }
   in
   let opam_file =

diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml
@@ -4,7 +4,6 @@ open Dune_pkg
 
 (* TODO
    - substitutions
-   - extra-files
    - post dependencies
    - build dependencies
    - cross compilation
@@ -127,6 +126,7 @@ module Paths = struct
   type t =
     { source_dir : Path.Build.t
     ; target_dir : Path.Build.t
+    ; extra_sources : Path.Build.t
     ; name : Package.Name.t
     ; install_roots : Path.t Install.Roots.t Lazy.t
     ; install_paths : Install.Paths.t Lazy.t
@@ -140,9 +140,19 @@ module Paths = struct
   let of_root name ~root =
     let source_dir = Path.Build.relative root "source" in
     let target_dir = Path.Build.relative root "target" in
+    let extra_sources = Path.Build.relative root "extra_source" in
     let install_roots = lazy (install_roots ~target_dir) in
     let install_paths = lazy (install_paths (Lazy.force install_roots) name) in
-    { source_dir; target_dir; name; install_paths; install_roots }
+    { source_dir
+    ; target_dir
+    ; extra_sources
+    ; name
+    ; install_paths
+    ; install_roots
+    }
+
+  let extra_source t extra_source =
+    Path.Build.append_local t.extra_sources extra_source
 
   let make name (ctx : Context_name.t) =
     let build_dir = Context_name.build_dir ctx in
@@ -1167,6 +1177,30 @@ let gen_rules context_name (pkg : Pkg.t) =
       in
       (Dep.Set.of_files source_files, rules)
   in
+  let extra_source_deps, extra_copy_rules =
+    List.map pkg.info.extra_sources ~f:(fun (local, fetch) ->
+        let extra_source = Paths.extra_source pkg.paths local in
+        let rule =
+          match (fetch : Source.t) with
+          | External_copy (loc, src) ->
+            ( loc
+            , Action_builder.copy ~src:(Path.external_ src) ~dst:extra_source )
+          | Fetch { url = (loc, _) as url; checksum } ->
+            let rule =
+              Fetch.action ~url ~target_dir:pkg.paths.source_dir ~checksum
+              |> Action.Full.make |> Action_builder.With_targets.return
+              |> Action_builder.With_targets.add_directories
+                   ~directory_targets:[ pkg.paths.source_dir ]
+            in
+            (loc, rule)
+        in
+        (Path.build extra_source, rule))
+    |> List.unzip
+  in
+  let copy_rules = copy_rules @ extra_copy_rules in
+  let source_deps =
+    Dep.Set.union source_deps (Dep.Set.of_files extra_source_deps)
+  in
   let* () =
     Memo.parallel_iter copy_rules ~f:(fun (loc, copy) -> rule ~loc copy)
   in
@@ -1184,6 +1218,14 @@ let gen_rules context_name (pkg : Pkg.t) =
               |> Action.Full.make |> Action_builder.With_targets.return
             ]
         in
+        let copy_action =
+          copy_action
+          @ List.map pkg.info.extra_sources ~f:(fun (local, _) ->
+                let src = Path.build (Paths.extra_source pkg.paths local) in
+                let dst = Path.Build.append_local pkg.paths.source_dir local in
+                Action.copy src dst |> Action.Full.make
+                |> Action_builder.With_targets.return)
+        in
         let* build_action =
           match Action_expander.build_command context_name pkg with
           | None -> Memo.return copy_action

diff --git a/test/blackbox-tests/test-cases/pkg/extra-sources.t b/test/blackbox-tests/test-cases/pkg/extra-sources.t
@@ -0,0 +1,27 @@
+Fetch from more than one source
+
+  $ mkdir dune.lock
+  $ cat >dune.lock/lock.dune <<EOF
+  > (lang package 0.1)
+  > EOF
+
+  $ mkdir foo
+  $ cat >foo/bar <<EOF
+  > this is bar
+  > EOF
+
+  $ cat >baz <<EOF
+  > this is baz
+  > EOF
+
+  $ cat >dune.lock/test.pkg <<EOF
+  > (source (copy $PWD/foo))
+  > (extra_sources (mybaz (copy $PWD/baz)))
+  > (build
+  >  (system "find . | sort -u"))
+  > EOF
+
+  $ dune build .pkg/test/target/
+  .
+  ./bar
+  ./mybaz