feature(pkg): Opam repositories from dune-workspace

Signed-off-by: Marek Kubica <[email protected]>

bin/pkg.ml

@@ -1,6 +1,8 @@
 open Import
 module Lock_dir = Dune_pkg.Lock_dir
 module Fetch = Dune_pkg.Fetch
+module Opam_repo = Dune_pkg.Opam_repo
+module Repository_id = Dune_pkg.Repository_id
 
 module Lock = struct
   module Opam_repository_path = struct
@@ -96,8 +98,16 @@ module Lock = struct
       ; version_preference : Version_preference.t
       ; solver_env : Dune_pkg.Solver_env.t
       ; context_common : Dune_rules.Workspace.Context.Common.t
+      ; repos :
+          Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t
       }
 
+    let repositories_of_workspace (workspace : Workspace.t) =
+      List.map workspace.repos ~f:(fun repo ->
+        Dune_pkg.Pkg_workspace.Repository.name repo, repo)
+      |> Dune_pkg.Pkg_workspace.Repository.Name.Map.of_list_exn
+    ;;
+
     let choose ~context_name_arg ~all_contexts_arg ~version_preference_arg =
       let open Fiber.O in
       match context_name_arg, all_contexts_arg with
@@ -134,6 +144,7 @@ module Lock = struct
                    ~from_context:version_preference_context
              ; solver_env = Option.value solver_env ~default:Dune_pkg.Solver_env.default
              ; context_common
+             ; repos = repositories_of_workspace workspace
              }
            ]
          | Some (Opam _) ->
@@ -162,6 +173,7 @@ module Lock = struct
                     ~from_context:version_preference_context
               ; context_common
               ; solver_env = Option.value solver_env ~default:Dune_pkg.Solver_env.default
+              ; repos = repositories_of_workspace workspace
               }
           | Opam _ -> None)
     ;;
@@ -346,72 +358,107 @@ module Lock = struct
       (* a list of thunks that will perform all the file IO side
          effects after performing validation so that if materializing any
          lockdir would fail then no side effect takes place. *)
-      (let+ opam_file_map =
+      (let* local_packages =
          let+ dune_package_map =
            let+ source_dir = Memo.run (Source_tree.root ()) in
            let project = Source_tree.Dir.project source_dir in
            Dune_project.packages project
          in
          opam_file_map_of_dune_package_map dune_package_map
-       and+ repo, repo_id =
-         let+ opam_repo_dir, repo_id =
-           match opam_repository_path with
-           | Some path ->
-             (* TODO determine repo_id here *)
-             let repo_id = Dune_pkg.Repository_id.of_path path in
-             Fiber.return (path, repo_id)
-           | None ->
-             let repo =
-               Option.map ~f:Fetch.Opam_repository.of_url opam_repository_url
-               |> Option.value ~default:Fetch.Opam_repository.default
-             in
-             let+ opam_repository = Fetch.Opam_repository.path repo in
-             (match opam_repository with
-              | Ok { path; repo_id } -> path, repo_id
-              | Error _ ->
-                User_error.raise
-                  [ Pp.textf "Can't determine the location of the opam-repository" ])
-         in
-         Dune_pkg.Opam_repo.of_opam_repo_dir_path opam_repo_dir, repo_id
        in
-       (* TODO figure out the loc situation *)
-       let repo_id = Option.map ~f:(fun repo_id -> Loc.none, repo_id) repo_id in
-       List.map
-         per_context
-         ~f:
-           (fun
-             { Per_context.lock_dir_path
-             ; version_preference
-             ; solver_env = solver_env_from_context
-             ; context_common = { name = context_name; _ }
-             }
-           ->
-           let solver_env =
-             merge_current_system_bindings_into_solver_env_from_context
-               ~context_name
-               ~solver_env_from_context
-               ~sys_bindings_from_current_system
-               ~use_env_from_current_system
-           in
-           match
-             Dune_pkg.Opam_solver.solve_lock_dir
-               solver_env
-               version_preference
-               (repo, repo_id)
-               ~local_packages:opam_file_map
-           with
-           | Error (`Diagnostic_message message) -> Error (context_name, message)
-           | Ok { Dune_pkg.Opam_solver.Solver_result.summary; lock_dir; files } ->
-             let summary_message =
-               Dune_pkg.Opam_solver.Summary.selected_packages_message
-                 summary
-                 ~lock_dir_path
-               |> User_message.pp
+       let* solutions =
+         List.map
+           per_context
+           ~f:
+             (fun
+               { Per_context.lock_dir_path
+               ; version_preference
+               ; repos
+               ; solver_env = solver_env_from_context
+               ; context_common = { name = context_name; _ }
+               }
+             ->
+             let solver_env =
+               merge_current_system_bindings_into_solver_env_from_context
+                 ~context_name
+                 ~solver_env_from_context
+                 ~sys_bindings_from_current_system
+                 ~use_env_from_current_system
+             in
+             let+ repos =
+               match opam_repository_path, opam_repository_url with
+               | Some _, Some _ ->
+                 (* in theory you can set both, but how to prioritize them? *)
+                 User_error.raise
+                   [ Pp.text "Can't specify both path and URL to an opam-repository" ]
+               | Some path, None ->
+                 let repo_id = Repository_id.of_path path in
+                 Fiber.return
+                 @@ [ Opam_repo.of_opam_repo_dir_path ~source:None ~repo_id path ]
+               | None, Some url ->
+                 let repo = Fetch.Opam_repository.of_url url in
+                 let+ opam_repository = Fetch.Opam_repository.path repo in
+                 (match opam_repository with
+                  | Ok { path; repo_id } ->
+                    [ Opam_repo.of_opam_repo_dir_path
+                        ~source:(Some (OpamUrl.to_string url))
+                        ~repo_id
+                        path
+                    ]
+                  | Error _ ->
+                    User_error.raise
+                      [ Pp.text "Can't determine the location of the opam-repository" ])
+               | None, None ->
+                 (* read from workspace *)
+                 solver_env
+                 |> Dune_pkg.Solver_env.repos
+                 |> List.map ~f:(fun name ->
+                   match Dune_pkg.Pkg_workspace.Repository.Name.Map.find repos name with
+                   | None ->
+                     (* TODO: have loc for this failure? *)
+                     User_error.raise
+                       [ Pp.textf "Repository '%s' is not a known repository"
+                         @@ Dune_pkg.Pkg_workspace.Repository.Name.to_string name
+                       ]
+                   | Some repo ->
+                     let url = Dune_pkg.Pkg_workspace.Repository.opam_url repo in
+                     let repo = Fetch.Opam_repository.of_url url in
+                     let+ opam_repository = Fetch.Opam_repository.path repo in
+                     (match opam_repository with
+                      | Ok { path; repo_id } ->
+                        Opam_repo.of_opam_repo_dir_path
+                          ~source:(Some (OpamUrl.to_string url))
+                          ~repo_id
+                          path
+                      | Error _ ->
+                        User_error.raise
+                          [ Pp.textf
+                              "Can't determine the location of the opam-repository '%s'"
+                            @@ Dune_pkg.Pkg_workspace.Repository.Name.to_string name
+                          ]))
+                 |> Fiber.all_concurrently
              in
-             Ok
-               ( Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir
-               , summary_message ))
-       |> Result.List.all)
+             match
+               Dune_pkg.Opam_solver.solve_lock_dir
+                 solver_env
+                 version_preference
+                 repos
+                 ~local_packages
+             with
+             | Error (`Diagnostic_message message) -> Error (context_name, message)
+             | Ok { Dune_pkg.Opam_solver.Solver_result.summary; lock_dir; files } ->
+               let summary_message =
+                 Dune_pkg.Opam_solver.Summary.selected_packages_message
+                   summary
+                   ~lock_dir_path
+                 |> User_message.pp
+               in
+               Ok
+                 ( Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir
+                 , summary_message ))
+         |> Fiber.all_concurrently
+       in
+       Result.List.all solutions |> Fiber.return)
       >>| function
       | Error (context_name, message) ->
         User_error.raise

src/dune_pkg/dune_pkg.ml

@@ -10,3 +10,4 @@ module Solver_env = Solver_env
 module Substs = Substs
 module Sys_poll = Sys_poll
 module Version_preference = Version_preference
+module Pkg_workspace = Workspace

src/dune_pkg/lock_dir.ml

@@ -261,40 +261,91 @@ module Pkg = struct
   ;;
 end
 
+module Repositories = struct
+  type t =
+    { complete : bool
+    ; used : Opam_repo.Serializable.t list option
+    }
+
+  let equal { complete; used } t =
+    Bool.equal complete t.complete
+    && Option.equal (List.equal Opam_repo.Serializable.equal) used t.used
+  ;;
+
+  let to_dyn { complete; used } =
+    Dyn.record
+      [ "complete", Dyn.bool complete
+      ; "used", Dyn.option (Dyn.list Opam_repo.Serializable.to_dyn) used
+      ]
+  ;;
+
+  let encode_used used =
+    let open Encoder in
+    List.map ~f:(fun repo -> list sexp @@ Opam_repo.Serializable.encode repo) used
+  ;;
+
+  let encode { complete; used } =
+    let open Encoder in
+    let base = list sexp [ string "complete"; bool complete ] in
+    [ base ]
+    @
+    match used with
+    | None -> []
+    | Some [] -> [ list sexp [ string "used" ] ]
+    | Some used -> [ list sexp (string "used" :: encode_used used) ]
+  ;;
+
+  let decode =
+    let open Decoder in
+    fields
+      (let+ complete = field "complete" bool
+       and+ used = field_o "used" (repeat (enter Opam_repo.Serializable.decode)) in
+       { complete; used })
+  ;;
+end
+
 type t =
   { version : Syntax.Version.t
   ; packages : Pkg.t Package_name.Map.t
   ; ocaml : (Loc.t * Package_name.t) option
-  ; repo_id : (Loc.t * Repository_id.t) option
+  ; repos : Repositories.t
   }
 
 let remove_locs t =
   { t with
     packages = Package_name.Map.map t.packages ~f:Pkg.remove_locs
   ; ocaml = Option.map t.ocaml ~f:(fun (_, ocaml) -> Loc.none, ocaml)
-  ; repo_id = Option.map t.repo_id ~f:(fun (_, repo_id) -> Loc.none, repo_id)
   }
 ;;
 
-let equal { version; packages; ocaml; repo_id } t =
+let equal { version; packages; ocaml; repos } t =
   Syntax.Version.equal version t.version
   && Option.equal (Tuple.T2.equal Loc.equal Package_name.equal) ocaml t.ocaml
-  && Option.equal (Tuple.T2.equal Loc.equal Repository_id.equal) repo_id t.repo_id
+  && Repositories.equal repos t.repos
   && Package_name.Map.equal packages t.packages ~equal:Pkg.equal
 ;;
 
-let to_dyn { version; packages; ocaml; repo_id } =
+let to_dyn { version; packages; ocaml; repos } =
   Dyn.record
     [ "version", Syntax.Version.to_dyn version
     ; "packages", Package_name.Map.to_dyn Pkg.to_dyn packages
     ; "ocaml", Dyn.option (Tuple.T2.to_dyn Loc.to_dyn_hum Package_name.to_dyn) ocaml
-    ; "repo_id", Dyn.option (Tuple.T2.to_dyn Loc.to_dyn_hum Repository_id.to_dyn) repo_id
+    ; "repos", Repositories.to_dyn repos
     ]
 ;;
 
-let create_latest_version packages ~ocaml ~repo_id =
+let create_latest_version packages ~ocaml ~repos =
   let version = Syntax.greatest_supported_version Dune_lang.Pkg.syntax in
-  { version; packages; ocaml; repo_id }
+  let complete, used =
+    match repos with
+    | None -> true, None
+    | Some repos ->
+      let used = List.filter_map repos ~f:Opam_repo.serializable in
+      let complete = Int.equal (List.length repos) (List.length used) in
+      complete, Some used
+  in
+  let repos : Repositories.t = { complete; used } in
+  { version; packages; ocaml; repos }
 ;;
 
 let default_path = Path.Source.(relative root "dune.lock")
@@ -304,7 +355,7 @@ module Metadata = Dune_sexp.Versioned_file.Make (Unit)
 
 let () = Metadata.Lang.register Dune_lang.Pkg.syntax ()
 
-let encode_metadata { version; ocaml; repo_id; packages = _ } =
+let encode_metadata { version; ocaml; repos; packages = _ } =
   let open Encoder in
   let base =
     list
@@ -318,10 +369,15 @@ let encode_metadata { version; ocaml; repo_id; packages = _ } =
   @ (match ocaml with
      | None -> []
      | Some ocaml -> [ list sexp [ string "ocaml"; Package_name.encode (snd ocaml) ] ])
-  @
-  match repo_id with
-  | None -> []
-  | Some repo_id -> [ list sexp [ string "repo_id"; Repository_id.encode (snd repo_id) ] ]
+  @ [ list sexp (string "repositories" :: Repositories.encode repos) ]
+;;
+
+let decode_metadata =
+  let open Decoder in
+  fields
+    (let+ ocaml = field_o "ocaml" (located Package_name.decode)
+     and+ repos = field "repositories" Repositories.decode in
+     ocaml, repos)
 ;;
 
 module Package_filename = struct
@@ -361,8 +417,8 @@ module Write_disk = struct
          (match Path.exists metadata_path && not (Path.is_directory metadata_path) with
           | false -> Error `No_metadata_file
           | true ->
-            (match Metadata.load metadata_path ~f:(Fun.const (Decoder.return ())) with
-             | Ok () -> Ok `Is_existing_lock_dir
+            (match Metadata.load metadata_path ~f:(Fun.const decode_metadata) with
+             | Ok _unused -> Ok `Is_existing_lock_dir
              | Error exn -> Error (`Failed_to_parse_metadata exn))))
   ;;
 
@@ -443,22 +499,17 @@ module Make_load (Io : sig
 struct
   let load_metadata metadata_file_path =
     let open Io.O in
-    let+ syntax, version, ocaml, repo_id =
+    let+ syntax, version, ocaml, repos =
       Io.with_lexbuf_from_file metadata_file_path ~f:(fun lexbuf ->
         Metadata.parse_contents
           lexbuf
           ~f:(fun { Metadata.Lang.Instance.syntax; data = (); version } ->
             let open Decoder in
-            let+ ocaml, repo_id =
-              fields
-                (let+ ocaml = field_o "ocaml" (located Package_name.decode)
-                 and+ repo_id = field_o "repo_id" (located Repository_id.decode) in
-                 ocaml, repo_id)
-            in
-            syntax, version, ocaml, repo_id))
+            let+ ocaml, repos = decode_metadata in
+            syntax, version, ocaml, repos))
     in
     if String.equal (Syntax.name syntax) (Syntax.name Dune_lang.Pkg.syntax)
-    then version, ocaml, repo_id
+    then version, ocaml, repos
     else
       User_error.raise
         [ Pp.textf
@@ -506,7 +557,7 @@ struct
   let load lock_dir_path =
     let open Io.O in
     check_path lock_dir_path;
-    let* version, ocaml, repo_id =
+    let* version, ocaml, repos =
       load_metadata (Path.Source.relative lock_dir_path metadata)
     in
     let+ packages =
@@ -522,7 +573,7 @@ struct
         package_name, pkg)
       >>| Package_name.Map.of_list_exn
     in
-    { version; packages; ocaml; repo_id }
+    { version; packages; ocaml; repos }
   ;;
 end