Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More WIP.

Extract the parallel build bits out, start cleaning up client.ml (halfway).
  • Loading branch information...
commit ba39c278369f8fcbf8c202b3dcfa48e5abbcb616 1 parent ac99a15
@samoht samoht authored
View
12 Makefile
@@ -2,11 +2,11 @@ OCPBUILD ?= ./_obuild/unixrun ./boot/ocp-build.boot
OCAMLC=ocamlc
SRC_EXT=src_ext
-TARGET = opam
+TARGETS = opam
.PHONY: all
-all: ./_obuild/unixrun compile link clone
+all: ./_obuild/unixrun compile clone $(TARGETS)
@
scan: ./_obuild/unixrun
@@ -25,15 +25,9 @@ bootstrap: _obuild/unixrun _obuild/opam/opam.byte
rm -f boot/opam.boot
ocp-bytehack -static _obuild/opam/opam.byte -o boot/opam.boot
-link: opam
- @
-
-_obuild/opam/opam.asm _obuild/opam/opam.byte:
+opam:
$(OCPBUILD) opam
-opam: _obuild/opam/opam.asm
- ln -s $^ opam
-
compile: ./_obuild/unixrun clone
$(OCPBUILD) -init -scan -sanitize $(TARGET)
View
3  opam.ocp
@@ -13,8 +13,9 @@ begin library "opam-lib"
files = [
"globals.ml"
"utils.ml"
- "types.ml"
"run.ml"
+ "parallel.ml"
+ "types.ml"
"file_format.ml"
"lexer.mll"
"linelexer.mll"
View
590 src/client.ml
@@ -14,7 +14,6 @@
(***********************************************************************)
open Types
-open Path
open Solver
let log fmt =
@@ -89,86 +88,50 @@ module Client : CLIENT = struct
open File
type t = {
- global : Path.Global.t; (* ~/.opam/ *)
- compiler : Path.Compiler.t; (* ~/.opam/<oversion>/ *)
- config : File.Config.t; (* ~/.opam/config contents *)
+ global : Path.G.t; (* ~/.opam/ *)
+ compiler : Path.C.t; (* ~/.opam/$oversion/ *)
+ repositories: (repository * Path.R.t) list; (* ~/.opam/repo/$repo/ *)
+ installed : NV.Set.t; (* ~/.opam/$oversion/installed contents *)
+ config : File.Config.t; (* ~/.opam/config contents *)
+ repo_index : File.Repo_index.t; (* ~/.opam/repo/index contents *)
}
(* Look into the content of ~/.opam/config to build the client state *)
(* Do not call RemoteServer functions here, as it implies a
network roundtrip *)
let load_state () =
- let global = Global.create (d !Globals.root_path) in
- let config = File.Config.read (Global.config global) in
+ let global = Path.G.create (d !Globals.root_path) in
+ let config = File.Config.read (Path.G.config global) in
let ocaml_version = File.Config.ocaml_version config in
- let compiler = Compiler.create (Global.root global) ocaml_version in
- { global; compiler; config }
-
- let update_remote server home =
- log "update-remote-server %s%s"
- server.hostname
- (match server.port with Some p -> ":" ^ string_of_int p | None -> "");
- let packages = RemoteServer.getList server in
- List.iter
- (fun (n, v) ->
- let spec_f = Path.index home (Some (n, v)) in
- if not (Path.file_exists spec_f) then
- let spec = RemoteServer.getSpec server (n, v) in
- Path.add spec_f (Path.File (Binary spec));
- Globals.msg "New package available: %s\n" (Namespace.string_of_nv n v)
- ) packages
-
- let update_git server home =
- log "update-git-server %s" server.hostname;
- let index_path = Path.string_of_filename (Path.index home None) in
- if not (Sys.file_exists index_path) then begin
- Unix.mkdir index_path 0o750;
- Run.Git.init index_path;
- end;
- Run.Git.safe_remote_add index_path server.hostname;
- let newfiles = Run.Git.get_updates index_path in
- Run.Git.update index_path;
- let package_of_file file =
- if Filename.check_suffix file ".spec" then
- Some (Namespace.nv_of_string (Filename.chop_extension file))
- else
- None in
- let packages = List.fold_left
- (fun accu file ->
- match package_of_file file with
- | None -> accu
- | Some nv -> NV_set.add nv accu)
- NV_set.empty
- newfiles in
- NV_set.iter (fun (n, v) ->
- Globals.msg "New package available: %s\n" (Namespace.string_of_nv n v)
- ) packages
+ let compiler = Path.C.create global ocaml_version in
+ let repositories = File.Config.repositories config in
+ let repositories = List.map (fun r -> r, Path.R.create global r) repositories in
+ let repo_index = File.Repo_index.read (Path.G.repo_index global) in
+ let installed = File.Installed.read (Path.C.installed compiler) in
+ { global; compiler; repositories; installed; repo_index; config }
let update () =
let t = load_state () in
- let one server =
- match server.uri with
- | Some Git -> update_git server t.home
- | _ -> update_remote server t.home in
- List.iter one t.servers
-
- let init urls =
- log "init %s" (String.concat " " (List.map string_of_url urls));
- let home = Path.init !Globals.root_path in
- let config_f = Path.config home in
- match File.Config.find config_f with
- | Some c ->
- Globals.error_and_exit "%s already exist" (Path.string_of_filename config_f)
- | None ->
- let ocaml_version = Version (Run.Ocamlc.version (match !Globals.ocamlc with None -> Run.Ocamlc.from_path | Some s -> Run.Ocamlc.init s)) in
- let config = File.Config.create Globals.api_version urls ocaml_version in
- File.Config.add config_f config;
- let home = Path.O.set_version home ocaml_version in
- File.Installed.add (Path.O.installed home) File.Installed.empty;
- try update ()
- with Connection_error msg ->
- Run.U.safe_rmdir !Globals.root_path;
- Globals.error_and_exit "%s" msg
+ List.map (fun (r,p) -> Repositories.opam_update p r) t.repositories
+
+ let init repos =
+ log "init %s" (String.concat " " (List.map Repository.to_string repos));
+ let root = Path.G.create (Dirname.of_string !Globals.root_path) in
+ let config_f = Path.G.config root in
+ if Filename.exists config_f then
+ Globals.error_and_exit "%s already exist" (Filename.to_string config_f)
+ else
+ let opam_version = OPAM_V.of_string Globals.opam_version in
+ let ocaml_version = OCaml_V.of_string Sys.ocaml_version in
+ let config = File.Config.create opam_version repos ocaml_version in
+ File.Config.write config_f config;
+ let compiler = Path.C.create root ocaml_version in
+ File.Installed.write (Path.C.installed compiler) File.Installed.empty;
+ let repositories = File.Config.repositories config in
+ List.iter (fun r ->
+ let p = Path.R.create root r in
+ Repositories.opam_init p r
+ ) repositories
let indent_left s nb =
let nb = nb - String.length s in
@@ -184,12 +147,8 @@ module Client : CLIENT = struct
else
String.make nb ' ' ^ s
- let find_from_name name l =
- N_map.Exceptionless.find
- name
- (List.fold_left
- (fun map (n, v) ->
- N_map.modify_def V_set.empty n (V_set.add v) map) N_map.empty l)
+ let find_from_name name l =
+ List.find_all (fun (n,_) -> n = name) l
let s_not_installed = "--"
@@ -197,214 +156,157 @@ module Client : CLIENT = struct
log "list";
let t = load_state () in
(* Get all the installed packages *)
- let installed = File.Installed.find_err (Path.O.installed t.home) in
- let install_set = NV_set.of_list installed in
+ let installed = File.Installed.read (Path.C.installed t.compiler) in
let map, max_n, max_v =
- List.fold_left
- (fun (map, max_n, max_v) (name, version as n_v) ->
- match N_map.Exceptionless.find name map with
- | Some (Some _, _) -> map, max_n, max_v
- | _ ->
- (* If the packet has not been processed yet or
- if it has been processed but the version processed was not installed *)
- let installed = NV_set.mem n_v install_set in
- let index = File.Spec.find_err (Path.index t.home (Some n_v)) in
- let map =
- N_map.add name ((if installed then Some version else None), File.Spec.description index) map in
- let max_n = max max_n (String.length (Namespace.string_of_name (fst n_v))) in
- let max_v =
- if installed then
- max max_v (String.length (Namespace.string_of_version (snd n_v)))
- else
- max_v in
- map, max_n, max_v)
- (N_map.empty, min_int, String.length s_not_installed)
- (Path.index_list t.home) in
-
- N_map.iter (fun name (version, description) ->
- let description = match description with
- | [] -> ""
- | h::_ -> h in
+ NV.Set.fold
+ (fun nv (map, max_n, max_v) ->
+ let name = NV.name nv in
+ let version = NV.version nv in
+ if N.Map.mem name map then
+ map, max_n, max_v
+ else
+ (* If the packet has not been processed yet or
+ if it has been processed but the version processed was not installed *)
+ let is_installed = NV.Set.mem nv installed in
+ let descr_f = File.Descr.read (Path.G.descr t.global nv) in
+ let synopsis = File.Descr.synopsis descr_f in
+ let map = N.Map.add name ((if is_installed then Some version else None), synopsis) map in
+ let max_n = max max_n (String.length (N.to_string name)) in
+ let max_v = if is_installed then max max_v (String.length (V.to_string version)) else max_v in
+ map, max_n, max_v)
+ (Path.G.available t.global)
+ (N.Map.empty, min_int, String.length s_not_installed)
+ in
+
+ N.Map.iter (fun name (version, description) ->
let version = match version with
- | None -> s_not_installed
- | Some v -> Namespace.string_of_version v in
+ | None -> s_not_installed
+ | Some v -> V.to_string v in
Globals.msg "%s %s %s\n"
- (indent_left (Namespace.string_of_name name) max_n)
+ (indent_left (N.to_string name) max_n)
(indent_right version max_v)
description) map
let info package =
- log "info %s" (Namespace.string_of_name package);
+ log "info %s" (N.to_string package);
let t = load_state () in
- let find_from_name = find_from_name package in
- let installed = File.Installed.find_err (Path.O.installed t.home) in
- let o_v =
- Option.map
- V_set.choose (* By definition, there is exactly 1 element, we choose it. *)
- (find_from_name installed) in
+
+ let o_v =
+ let installed = File.Installed.read (Path.C.installed t.compiler) in
+ try Some (V.Set.choose (N.Map.find package (NV.to_map installed)))
+ with Not_found -> None in
let v_set =
+ let available = Path.G.available t.global in
let v_set =
- match find_from_name (Path.index_list t.home) with
- | None -> V_set.empty
- | Some v -> v in
+ try N.Map.find package (NV.to_map available)
+ with Not_found ->
+ Globals.error_and_exit "unknown package %s" (N.to_string package) in
match o_v with
- | None -> v_set
- | Some v -> V_set.remove v v_set in
+ | None -> v_set
+ | Some v -> V.Set.remove v v_set in
List.iter
- (fun (tit, desc) -> Globals.msg "%s: %s\n" tit desc)
- ( ("package ", Namespace.string_of_name package)
-
- :: ("version ",
- match o_v with
- | None -> s_not_installed
- | Some v -> Namespace.string_of_version v)
-
- :: ("versions ", V_set.to_string Namespace.string_of_version v_set)
-
- ::
- match
- match o_v with
- | None -> if V_set.is_empty v_set then None else Some (V_set.max_elt v_set)
- | Some v -> Some v
- with
- | None -> []
- | Some v ->
-
- [ "description", "\n " ^
- let opam =
- File.Spec.find_err (Path.index t.home (Some (package, v))) in
- String.concat "" (File.Spec.description opam) ]
+ (fun (tit, desc) -> Globals.msg "%12s: %s\n" tit desc)
+ ( ("package", N.to_string package)
+
+ :: ("version",
+ match o_v with
+ | None -> s_not_installed
+ | Some v -> V.to_string v)
+
+ :: ("versions",
+ String.concat " " (List.map V.to_string (V.Set.elements v_set)))
+
+ :: let latest = match o_v with
+ | None -> V.Set.max_elt v_set
+ | Some v -> v in
+ let descr = File.Descr.read (Path.G.descr t.global (NV.create package latest)) in
+ [ "description", "\n " ^ File.Descr.full descr ]
)
- let confirm msg =
- Globals.msg "%s [Y/n] " msg;
- match read_line () with
- | "y" | "Y"
- | "" -> true
- | _ -> false
-
- let iter_toinstall f_add_rec t (name, v) =
+ let confirm fmt =
+ Printf.kprintf (fun msg ->
+ Globals.msg "%s [Y/n] " msg;
+ match read_line () with
+ | "y" | "Y"
+ | "" -> true
+ | _ -> false
+ ) fmt
- let to_install = File.To_install.find_err (Path.O.to_install t.home (name, v)) in
+ let proceed_toinstall t nv =
- let filename_of_path_relative t path =
- Path.R_filename (File.To_install.filename_of_path_relative
- (Path.O.build t.home (Some (name, v)))
- path) in
-
- let add_rec f_lib t path =
- f_add_rec
- (f_lib t.home name (* warning : we assume that this result is a directory *))
- (filename_of_path_relative t path) in
+ let name = NV.name nv in
+ let to_install = File.To_install.read (Path.C.install t.compiler name) in
(* lib *)
- List.iter (add_rec Path.O.lib t) (File.To_install.lib to_install);
+ let lib = Path.C.lib t.compiler name in
+ List.iter (fun f -> Filename.copy_in f lib) (File.To_install.lib to_install);
(* bin *)
- List.iter (fun m ->
- let root = Path.O.build t.home (Some (name, v)) in
- let src = File.To_install.path_from m in
- let src = match File.To_install.filename_of_path_relative root src with
- | [f] -> f
- | _ -> Globals.error_and_exit "'bin' files cannot contain * patterns" in
-
- let dst = File.To_install.path_to m in
- let dst = match dst with
- | (Relative, [], Exact s) -> Path.concat (Path.O.bin t.home) (B s)
- | p -> Globals.error_and_exit "invalid program name %s" (string_of_path p) in
-
- (* XXX: use the API *)
- Run.U.copy (Path.string_of_filename src) (Path.string_of_filename dst)
- ) (File.To_install.bin to_install);
+ List.iter (fun (src, dst) -> Filename.copy src dst) (File.To_install.bin to_install);
(* misc *)
List.iter
- (fun misc ->
- Globals.msg "Copy %s.\n" (File.To_install.string_of_move misc);
- if confirm "Continue ?" then
- let path_from =
- filename_of_path_relative t (File.To_install.path_from misc) in
- List.iter
- (fun path_to -> f_add_rec path_to path_from)
- (File.To_install.filename_of_path_absolute
- (File.To_install.path_to misc)))
- (File.To_install.misc to_install)
-
- let proceed_todelete t (n, v0) map_installed =
- log "deleting %s" (Namespace.to_string (n, v0));
- match N_map.Exceptionless.find n map_installed with
- | Some v when v = v0 ->
- (* Remove the libraries *)
- Path.remove (Path.O.lib t.home n);
-
- (* Remove the binaries *)
- let to_install =
- File.To_install.find_err (Path.O.to_install t.home (n, v0)) in
- let bins =
- let file m =
- File.To_install.filename_of_path
- (Path.O.bin t.home)
- (File.To_install.path_to m) in
- List.flatten (List.map file (File.To_install.bin to_install)) in
- List.iter Path.remove bins;
-
- List.iter
- (fun misc ->
- List.iter
- (fun path_to ->
- Globals.msg "The complete directory '%s' will be removed.\n" (Path.string_of_filename path_to);
- if confirm "Continue ?" then
- Path.remove path_to)
- (File.To_install.filename_of_path_absolute
- (File.To_install.path_to misc)))
- (File.To_install.misc to_install)
-
- | _ -> assert false (* check for example if the solver has returned a wrong version or not *)
-
- (* Iterate over the list of servers to find one with the corresponding archive *)
- let getArchive servers nv =
- let rec aux = function
- | [] -> None
- | h::t ->
- if h.uri = Some Git then
- None
- else match RemoteServer.getArchive h nv with
- | None -> aux t
- | Some a -> Some a in
- aux servers
+ (fun (src, dst) ->
+ if Filename.exists dst && confirm "Overwriting %s ?" (Filename.to_string dst) then
+ Filename.copy src dst
+ else begin
+ Globals.msg "Installing %s to %s.\n" (Filename.to_string src) (Filename.to_string dst);
+ if confirm "Continue ?" then
+ Filename.copy src dst
+ end
+ ) (File.To_install.misc to_install)
- let proceed_tochange t nv_old (name, v as nv) =
- let map_installed = File.Installed.Map.find (Path.O.installed t.home) in
+ let proceed_todelete t nv =
+ log "deleting %s" (NV.to_string nv);
+ let name = NV.name nv in
+
+ (* Remove the libraries *)
+ Dirname.remove (Path.C.lib t.compiler name);
+
+ (* Remove the binaries *)
+ let to_install = File.To_install.read (Path.C.install t.compiler name) in
+ List.iter (fun (_,dst) -> Filename.remove dst) (File.To_install.bin to_install);
+
+ (* Remove the misc files *)
+ List.iter (fun (_,dst) ->
+ if Filename.exists dst then begin
+ Globals.msg "Removing %s." (Filename.to_string dst);
+ if confirm "Continue ?" then
+ Filename.remove dst
+ end
+ ) (File.To_install.misc to_install)
+
+ let get_archive t nv =
+ log "get_archive %s" (NV.to_string nv);
+ let name = NV.name nv in
+ let repo = N.Map.find name t.repo_index in
+ let src = Path.R.archive (List.assoc repo t.repositories) nv in
+ let dst = Path.G.archive t.global nv in
+ Filename.link src dst;
+ dst
+
+ let proceed_tochange t nv_old nv =
(* First, uninstall any previous version *)
(match nv_old with
- | Was_installed nv_old -> proceed_todelete t nv_old map_installed
- | Was_not_installed -> ());
-
- let spec = File.Spec.find_err (Path.index t.home (Some nv)) in
+ | Was_installed nv_old -> proceed_todelete t nv_old
+ | Was_not_installed -> ());
(* Then, untar the archive *)
- let p_build = Path.O.build t.home (Some nv) in
- Path.remove p_build;
- (* XXX: maybe we want to follow the external urls first *)
- (* XXX: at one point, we would need to check SHA1 consistencies as well *)
- let archive = match getArchive t.servers nv with
- | Some tgz -> Archive tgz
- | None ->
- let sources = File.Spec.sources spec in
- let patches = File.Spec.patches spec in
- Links { sources; patches } in
- let archive = Path.extract nv archive in
- log "Process %s archive" (Namespace.to_string nv);
- Path.add_rec p_build archive;
+ let p_build = Path.C.build t.compiler nv in
+ Dirname.remove p_build;
+ Filename.extract (get_archive t nv) p_build;
(* Call the build script and copy the output files *)
- let buildsh = File.Spec.make spec in
- log "Run %s" (File.Spec.string_of_command buildsh);
- let err = Path.exec t.home nv buildsh in
+ let opam = File.OPAM.read (Path.G.opam t.global nv) in
+ let commands =
+ List.map
+ (fun cmd -> String.concat " " (List.map (Printf.sprintf "'%s'") cmd))
+ (File.OPAM.build opam) in
+ let err = Run.commands commands in
if err = 0 then
- iter_toinstall Path.add_rec t nv
+ proceed_toinstall t nv
else
Globals.error_and_exit
"Compilation failed with error %d" err
@@ -416,111 +318,105 @@ module Client : CLIENT = struct
let proceed_torecompile t nv =
proceed_tochange t (Was_installed nv) nv
- let debpkg_of_nv t map_installed =
+ let debpkg_of_nv t =
List.map
- (fun n_v ->
- let opam = File.Spec.find_err (Path.index t.home (Some n_v)) in
- File.Spec.to_package opam
- (match N_map.Exceptionless.find (fst n_v) map_installed with
- | Some v -> v = snd n_v
- | _ -> false))
+ (fun nv ->
+ let opam = File.OPAM.read (Path.G.opam t.global nv) in
+ let installed = NV.Set.mem nv t.installed in
+ File.OPAM.to_package opam installed)
let resolve t l_index map_installed request =
- let l_pkg = debpkg_of_nv t map_installed l_index in
+ let l_pkg = debpkg_of_nv t l_index in
match Solver.resolve_list l_pkg request with
| [] -> Globals.msg "No solution has been found.\n"
| l ->
- let nb_sol = List.length l in
-
- let rec aux pos =
- Globals.msg "[%d/%d] The following solution has been found:\n" pos nb_sol;
- function
- | [x] ->
- (* Only 1 solution exists *)
- Action.solution_print Namespace.to_string x;
- if Solver.delete_or_update x then
- if confirm "Continue ?" then
- Some x
- else
- None
- else
- Some x
-
- | x :: xs ->
- (* Multiple solution exist *)
- Action.solution_print Namespace.to_string x;
- if Solver.delete_or_update x then
- if confirm "Continue ? (press [n] to try another solution)" then
- Some x
- else
- aux (succ pos) xs
- else
- Some x
-
- | [] -> assert false in
-
- match aux 1 l with
- | Some sol ->
- begin
- List.iter
- (fun nv ->
- File.Installed.Map.modify_def (Path.O.installed t.home)
- (fun map_installed ->
- let () = proceed_todelete t nv map_installed in
- (* Remove the package from the installed package file *)
- N_map.remove (fst nv) map_installed))
- sol.Action.to_remove;
-
- (let module Graph = Action.NV_graph.PG_topo_para in
- let module Process = Run.Process_multi in
- let include_state = List.map (fun x -> Process.Not_yet_begun, x) in
- let rec aux proc graph = function
- | [] -> ()
- | l ->
- let proc, l, (v_end, ()) = Process.filter_finished proc l in
- let () =
- (* NOTE we modify here the location of [Path.O.installed], by adding an element.
- This side effect is not important for futur concurrent execution in [Process.filter_finished]
- because we suppose that each call to [Path.O.installed] is done with a different (name, version) as argument. *)
- match v_end with
- | { Action.NV_graph.PkgV.action = Action.To_change (Was_not_installed, (name, v)) ; _ } ->
- (* Mark the packet as installed *)
- File.Installed.Map.modify_def (Path.O.installed t.home) (N_map.add name v)
- | _ -> () in
- let graph, children = Graph.children graph v_end in
- aux proc graph (List.concat [ l ; include_state children ]) in
- let graph, root = Graph.root sol.Action.to_add in
- aux
- (Process.init
- Process.cores
- (function { Action.NV_graph.PkgV.action ; _ } ->
- (* WARNING side effects should be carefully studied as this function is executed concurrently *)
- match action with
- | Action.To_change (o, n_v) -> proceed_tochange t o n_v
- | Action.To_delete _ -> assert false
- | Action.To_recompile n_v -> proceed_torecompile t n_v)
-
- (function { Action.NV_graph.PkgV.action ; _ } ->
- let f msg (name, v) =
- Printf.sprintf "(%s) %s-%s" msg (Namespace.string_of_name name) (Namespace.string_of_version v) in
- match action with
- | Action.To_change (Was_installed _, nv) -> f "Change" nv
- | Action.To_change (Was_not_installed, nv) -> f "Instal" nv
- | Action.To_recompile nv -> f "Recomp" nv
- | Action.To_delete _ -> assert false))
- graph
- (include_state root));
- end
- | None -> ()
+ let nb_sol = List.length l in
+
+ let rec aux pos =
+ Globals.msg "[%d/%d] The following solution has been found:\n" pos nb_sol;
+ function
+ | [x] ->
+ (* Only 1 solution exists *)
+ print_solution NV.to_string x;
+ if Solver.delete_or_update x then
+ if confirm "Continue ?" then
+ Some x
+ else
+ None
+ else
+ Some x
+
+ | x :: xs ->
+ (* Multiple solution exist *)
+ print_solution NV.to_string x;
+ if Solver.delete_or_update x then
+ if confirm "Continue ? (press [n] to try another solution)" then
+ Some x
+ else
+ aux (succ pos) xs
+ else
+ Some x
+
+ | [] -> assert false in
- let vpkg_of_nv (name, v) =
- Namespace.string_of_name name, Some ("=", Namespace.string_of_version v)
+ match aux 1 l with
+ | None -> ()
+ | Some sol ->
+
+ let installed = ref t.installed in
+ let write_installed () =
+ File.Installed.write (Path.C.installed t.compiler) !installed in
+
+ (* Delete some packages *)
+ (* In case of errors, we try to keep the list of installed packages up-to-date *)
+ List.iter
+ (fun nv ->
+ if NV.Set.mem nv !installed then begin
+ proceed_todelete t nv;
+ installed := NV.Set.remove nv !installed;
+ write_installed ()
+ end)
+ sol.to_remove;
+
+ (* Install or recompile some packages on the child process *)
+ let child n = match n.action with
+ | To_change (o, nv) -> proceed_tochange t o nv
+ | To_recompile nv -> proceed_torecompile t nv
+ | To_delete _ -> assert false in
+
+ let pre _ = () in
+
+ (* Update the installed file in the parent process *)
+ let post n = match n.action with
+ | To_delete _ -> assert false
+ | To_recompile _ -> ()
+ | To_change (Was_not_installed, nv) ->
+ installed := NV.Set.add nv !installed;
+ write_installed ()
+ | To_change (Was_installed o, nv) ->
+ installed := NV.Set.add nv (NV.Set.remove o !installed);
+ write_installed () in
+
+ let error n =
+ let f msg nv =
+ Globals.error_and_exit "Command failed while %s %s" msg (NV.to_string nv) in
+ match n.action with
+ | To_change (Was_installed _, nv) -> f "upgrading" nv
+ | To_change (Was_not_installed, nv) -> f "installing" nv
+ | To_recompile nv -> f "recompiling" nv
+ | To_delete _ -> assert false in
+
+ try G.P.iter Globals.cores sol.to_add ~pre ~child ~post
+ with G.P.Error n -> error n
+
+ let vpkg_of_nv nv =
+ let name = NV.name nv in
+ let version = NV.version nv in
+ N.to_string name, Some ("=", V.to_string version)
let unknown_package name =
- Globals.error_and_exit
- "Unable to locate package \"%s\"\n"
- (Namespace.string_of_name name)
+ Globals.error_and_exit "Unable to locate package %S\n" (N.to_string name)
let install name =
log "install %s" name;
View
240 src/file.ml
@@ -14,7 +14,7 @@
(***********************************************************************)
open Types
-open Path
+open Utils
open File_format
exception Parsing of string
@@ -84,19 +84,19 @@ end = struct
end
module Installed : sig
- include IO_FILE with type t = V.t N.Map.t
+ include IO_FILE with type t = NV.Set.t
end = struct
let kind = "installed"
- type t = V.t N.Map.t
+ type t = NV.Set.t
- let empty = N.Map.empty
+ let empty = NV.Set.empty
let of_string f s =
let lines = Lines.of_string f s in
let map = ref empty in
- let add n v = map := N.Map.add n v !map in
+ let add n v = map := NV.Set.add (NV.create n v) !map in
List.iter (function
| [name; version] -> add (N.of_string name) (V.of_string version)
| _ -> Globals.error_and_exit "installed"
@@ -105,17 +105,80 @@ end = struct
let to_string _ t =
let buf = Buffer.create 1024 in
- N.Map.iter
- (fun n v -> Printf.bprintf buf "%s %s\n" (N.to_string n) (V.to_string v))
+ NV.Set.iter
+ (fun nv -> Printf.bprintf buf "%s %s\n" (N.to_string (NV.name nv)) (V.to_string (NV.version nv)))
t;
Raw.of_string (Buffer.contents buf)
end
-module Cudf = struct
- include Cudf
- let find_field x key =
- try Some (List.assoc key x.Cudf.pkg_extra) with Not_found -> None
+module Reinstall : sig
+ include IO_FILE with type t = NV.Set.t
+end = struct
+ include Installed
+end
+
+module Repo_index : sig
+
+ include IO_FILE with type t = repository N.Map.t
+
+end = struct
+
+ let kind = "repo-index"
+
+ type t = repository N.Map.t
+
+ let empty = N.Map.empty
+
+ let of_string filename str =
+ let lines = Lines.of_string filename str in
+ List.fold_left (fun map -> function
+ | [name_s; repo_s] ->
+ let repo = Repository.of_string repo_s in
+ let name = N.of_string name_s in
+ if N.Map.mem name map then
+ Globals.error_and_exit "multiple lines for package %s" name_s
+ else
+ N.Map.add name repo map
+ | x ->
+ Globals.error_and_exit "'%s' is not a valid repository index line" (String.concat " " x)
+ ) N.Map.empty lines
+
+ let to_string filename map =
+ let lines = N.Map.fold (fun name repo lines ->
+ [ N.to_string name; Repository.to_string repo] :: lines
+ ) map [] in
+ Lines.to_string filename (List.rev lines)
+
+end
+
+module Descr : sig
+
+ include IO_FILE
+
+ val synopsis: t -> string
+ val full: t -> string
+
+end = struct
+
+ let kind = "descr"
+
+ type t = Lines.t
+
+ let empty = []
+
+ let synopsis = function
+ | [] -> ""
+ | h::_ -> String.concat " " h
+
+ let full l =
+ let one l = String.concat " " l in
+ String.concat "\n" (List.map one l)
+
+ let of_string = Lines.of_string
+
+ let to_string = Lines.to_string
+
end
module Syntax : sig
@@ -153,12 +216,12 @@ module Config : sig
type repository = Types.repository
(** destruct *)
- val opam_version : t -> V.t
- val repositories : t -> repository list
- val ocaml_version : t -> V.t
+ val opam_version : t -> OPAM_V.t
+ val repositories : t -> repository list
+ val ocaml_version : t -> OCaml_V.t
(** construct *)
- val create : V.t (* opam *) -> repository list -> V.t (* ocaml *) -> t
+ val create : OPAM_V.t -> repository list -> OCaml_V.t -> t
end = struct
@@ -166,19 +229,19 @@ end = struct
type repository = Types.repository
- let to_repo (repo_name, repo_kind) =
- let repo_kind = match repo_kind with
+ let to_repo (name, kind) =
+ let kind = match kind with
| None -> Globals.default_repository_kind
| Some k -> k in
- { repo_name; repo_kind }
+ Repository.create ~name ~kind
let of_repo r =
- Option (String r.repo_name, [ String r.repo_kind ])
+ Option (String (Repository.name r), [ String (Repository.kind r)])
type t = {
- opam_version : V.t ; (* opam version *)
+ opam_version : OPAM_V.t ;
repositories : repository list ;
- ocaml_version : V.t ;
+ ocaml_version : OCaml_V.t ;
}
let opam_version t = t.opam_version
@@ -189,12 +252,11 @@ end = struct
{ opam_version ; repositories ; ocaml_version }
let empty = {
- opam_version = V.of_string Globals.opam_version;
- repositories = [ {
- repo_name = Globals.default_repository_name;
- repo_kind = Globals.default_repository_kind;
- } ];
- ocaml_version = V.of_string Sys.ocaml_version;
+ opam_version = OPAM_V.of_string Globals.opam_version;
+ repositories = [ Repository.create
+ ~name:Globals.default_repository_name
+ ~kind:Globals.default_repository_kind ];
+ ocaml_version = OCaml_V.of_string Sys.ocaml_version;
}
open File_format
@@ -213,20 +275,20 @@ end = struct
let s = Syntax.of_string filename f in
Syntax.check s valid_fields;
let opam_version =
- assoc s.contents s_opam_version (parse_string |> V.of_string) in
+ assoc s.contents s_opam_version (parse_string |> OPAM_V.of_string) in
let repositories =
assoc s.contents s_repositories (parse_list (parse_string_option |> to_repo)) in
let ocaml_version =
- assoc s.contents s_ocaml_version (parse_string |> V.of_string) in
+ assoc s.contents s_ocaml_version (parse_string |> OCaml_V.of_string) in
{ opam_version; repositories; ocaml_version }
let to_string filename t =
let s = {
filename = Filename.to_string filename;
contents = [
- Variable (s_opam_version , String (V.to_string t.opam_version));
+ Variable (s_opam_version , String (OPAM_V.to_string t.opam_version));
Variable (s_repositories , make_list of_repo t.repositories);
- Variable (s_ocaml_version, String (V.to_string t.ocaml_version));
+ Variable (s_ocaml_version, String (OCaml_V.to_string t.ocaml_version));
]
} in
Syntax.to_string filename s
@@ -378,50 +440,34 @@ end = struct
depends; conflicts; libraries; syntax }
end
-module Install : sig
+module To_install : sig
include IO_FILE
- type move = {
- src: filename;
- dst: filename;
- dst_kind: [`absolute|`relative];
- }
-
(** destruct *)
val lib: t -> filename list
- val bin: t -> move list
- val misc: t -> move list
-
- val string_of_move : move -> string
+ val bin: t -> (filename * filename) list
+ val misc: t -> (filename * filename) list
end = struct
let kind = "install"
- type move = {
- src: filename;
- dst: filename;
- dst_kind: [`absolute|`relative];
- }
-
type t = {
- lib : Filename.t list ;
- bin : move list ;
- misc: move list ;
+ lib : filename list ;
+ bin : (filename * filename) list ;
+ misc: (filename * filename) list ;
}
+ let string_of_move (src, dst) =
+ let src = Filename.to_string src in
+ let dst = Filename.to_string dst in
+ Printf.sprintf "%s => %s" src dst
+
let lib t = t.lib
let bin t = t.bin
let misc t = t.misc
- let string_of_move m =
- let src = Filename.to_string m.src in
- let dst = match m.dst_kind with
- | `absolute -> Filename.to_string m.dst
- | `relative -> Printf.sprintf "R:%s" (Filename.to_string m.dst) in
- Printf.sprintf "%s => %s" src dst
-
let empty = {
lib = [] ;
bin = [] ;
@@ -440,11 +486,11 @@ end = struct
let to_string filename t =
let string f = String (Filename.to_string f) in
- let make_move m =
- if m.src = m.dst then
- string m.src
+ let make_move (src, dst) =
+ if src = dst then
+ string src
else
- Option (string m.src, [string m.dst]) in
+ Option (string src, [string dst]) in
let s = {
filename = Filename.to_string filename;
contents = [
@@ -458,22 +504,13 @@ end = struct
let of_string filename str =
let s = Syntax.of_string filename str in
Syntax.check s valid_fields;
- let parse_move dst_kind v =
+ let parse_move v =
match parse_string_option v with
- | s, None ->
- let f = Filename.of_string s in
- { src = f; dst = f; dst_kind = `relative }
- | src, Some dst ->
- { src = Filename.of_string src;
- dst = Filename.of_string dst;
- dst_kind
- } in
- let lib =
- assoc_list s.contents s_lib (parse_list (parse_string |> Filename.of_string)) in
- let bin =
- assoc_list s.contents s_bin (parse_list (parse_move `relative)) in
- let misc =
- assoc_list s.contents s_misc (parse_list (parse_move `absolute)) in
+ | s , None -> let f = Filename.of_string s in (f, f)
+ | src, Some dst -> (Filename.of_string src, Filename.of_string dst) in
+ let lib = assoc_list s.contents s_lib (parse_list (parse_string |> Filename.of_string)) in
+ let bin = assoc_list s.contents s_bin (parse_list parse_move) in
+ let misc = assoc_list s.contents s_misc (parse_list parse_move) in
{ lib; bin; misc }
end
@@ -628,6 +665,7 @@ end = struct
end
module Make (F : IO_FILE) = struct
+
let log = Globals.log ("FILE." ^ F.kind)
(** Write some contents to a file *)
@@ -643,14 +681,52 @@ module Make (F : IO_FILE) = struct
F.of_string f (Filename.read f)
else
Globals.error_and_exit "File %s does not exit" (Filename.to_string f)
+
end
module File = struct
- module Config = struct include Config include Make (Config) end
- module OPAM = struct include OPAM include Make (OPAM) end
- module Install = struct include Install include Make (Install) end
- module PConfig = struct include PConfig include Make (PConfig) end
- module Installed = struct include Installed include Make (Installed) end
+ module Config = struct
+ include Config
+ include Make (Config)
+ end
+
+ module Repo_index = struct
+ include Repo_index
+ include Make (Repo_index)
+ end
+
+ module Descr = struct
+ include Descr
+ include Make (Descr)
+ end
+
+ module Reinstall = struct
+ include Reinstall
+ include Make (Reinstall)
+ end
+
+ module OPAM = struct
+ include OPAM
+ include Make (OPAM)
+ end
+
+ module To_install = struct
+ include To_install
+ include Make (To_install)
+ end
+
+ module PConfig = struct
+ include PConfig
+ include Make (PConfig)
+ end
+
+ module Installed = struct
+ include Installed
+ include Make (Installed)
+ end
+
end
+
+open File
View
2  src/file_format.ml
@@ -126,8 +126,6 @@ let rec parse_or fns v =
try h v
with _ -> parse_or t v
-let (|>) f g x = g (f x)
-
let make_string str = String str
let make_ident str = Ident str
View
6 src/globals.ml
@@ -66,8 +66,7 @@ type os =
| Win32
| Unix
-let os =
- match Sys.os_type with
+let os = match Sys.os_type with
| "Unix" -> begin
match input_line (Unix.open_process_in "uname -s") with
| "Darwin" -> Darwin
@@ -78,3 +77,6 @@ let os =
| "Win32" -> Win32
| "Cygwin" -> Cygwin
| _ -> assert false
+
+(* XXX: put that in ~/.opam/config *)
+let cores = 4
View
164 src/parallel.ml
@@ -0,0 +1,164 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+open Utils
+
+module type G = sig
+ include Graph.Sig.G
+ include Graph.Topological.G with type t := t and module V := V
+end
+
+module type PARALLEL = sig
+
+ module G : G
+
+ (** [iter n t pre child paren] parallel iteration on [n]
+ cores. [child] is evaluated in a remote process and when it as
+ finished, whereas [pre] and [post] are evaluated on the current
+ process (respectively before and after the child process has
+ been created). *)
+ val iter: int -> G.t ->
+ pre:(G.V.t -> unit) ->
+ child:(G.V.t -> unit) ->
+ post:(G.V.t -> unit) ->
+ unit
+
+ exception Error of G.V.t
+
+end
+
+module Make (G : G) : PARALLEL with module G = G = struct
+
+ module G = G
+
+ module V = struct include G.V let compare = compare end
+ module M = Map.Make (V)
+ module S = Set.Make (V)
+
+ type t = {
+ graph : G.t ;
+ visited_node: IntSet.t ; (* [int] represents the hash of [G.V.t] *)
+ queue_size : int ;
+ roots : S.t ;
+ degree : int M.t ;
+ }
+
+ let init graph =
+ let degree = ref M.empty in
+ let add_degree v d = degree := M.add v d !degree in
+ let roots, queue_size =
+ G.fold_vertex
+ (fun v (todo, queue_size) ->
+ let d = G.in_degree graph v in
+ if d = 0 then
+ S.add v todo, succ queue_size
+ else (
+ add_degree v d;
+ todo, queue_size
+ )
+ )
+ graph
+ (S.empty, 0) in
+ { graph ; roots ; degree = !degree ; queue_size ; visited_node = IntSet.empty }
+
+ let visit t x =
+ if IntSet.mem (G.V.hash x) t.visited_node then
+ invalid_arg "This node has already been visited.";
+ if not (S.mem x t.roots) then
+ invalid_arg "This node is not a root node";
+ (* Add the node to the list of visited nodes *)
+ let t = { t with visited_node = IntSet.add (G.V.hash x) t.visited_node } in
+ (* Remove the node from the list of root nodes *)
+ let roots = S.remove x t.roots in
+ let degree = ref t.degree in
+ let remove_degree x = degree := M.remove x !degree in
+ let replace_degree x d = degree := M.add x d (M.remove x !degree) in
+ (* Update the children of the node by decreasing by 1 their in-degree *)
+ let roots, queue_size =
+ G.fold_succ
+ (fun x (l, queue_size) ->
+ let d = M.find x t.degree in
+ if d = 1 then (
+ remove_degree x;
+ S.add x l, succ queue_size
+ ) else (
+ replace_degree x (d-1);
+ l, queue_size
+ ))
+ t.graph
+ x
+ (roots, pred t.queue_size) in
+ { t with queue_size; roots }
+
+ (* the [Unix.wait] might return a processus which has not been created
+ by [Unix.fork]. [wait pids] waits until a process in [pids]
+ terminates. *)
+ (* XXX: this will not work under windows *)
+ let wait pids =
+ let rec aux () =
+ let pid, status = Unix.wait () in
+ if IntMap.mem pid pids then
+ pid, status
+ else
+ aux () in
+ aux ()
+
+ exception Error of G.V.t
+
+ let iter n g ~pre ~child ~post =
+ let t = ref (init g) in
+ let pids = ref IntMap.empty in
+ let todo = ref (!t.roots) in
+
+ (* nslots is the number of free slots *)
+ let rec loop nslots =
+
+ if nslots <= 0 then
+
+ (* if no slots are available, wait for a child process to finish *)
+ let pid, status = wait !pids in
+ let n = IntMap.find pid !pids in
+ match status with
+ | Unix.WEXITED 0 ->
+ pids := IntMap.remove pid !pids;
+ t := visit !t n;
+ post n;
+ loop (nslots + 1)
+ | _ -> raise (Error n)
+
+ else
+
+ (* otherwise, look at the todo list *)
+ if S.is_empty !todo then begin
+ (* refill the todo list if it is empty *)
+ if not (S.is_empty !t.roots) then begin
+ todo := IntMap.fold (fun _ n accu -> S.remove n accu) !pids !t.roots;
+ loop nslots
+ end
+ end else begin
+ (* if the todo list contains at least a node action, process it *)
+ let n = S.choose !todo in
+ todo := S.remove n !todo;
+ match Unix.fork () with
+ | 0 -> child n; exit 0
+ | pid ->
+ pids := IntMap.add pid n !pids;
+ pre n;
+ loop (nslots - 1)
+ end
+ in
+ loop n
+
+end
View
156 src/path.ml
@@ -13,98 +13,10 @@
(* *)
(***********************************************************************)
-open ExtList
-open ExtString
open Types
let log fmt = Globals.log "PATH" fmt
-module Dirname : Abstract = Base
-type dirname = Dirname.t
-let d str = Dirname.of_string str
-
-module Basename : Abstract = Base
-type basename = Basename.t
-let b str = Basename.of_string str
-
-(* Raw file contents *)
-module Raw : Abstract = Base
-
-(* Keep a link to [Filename] for the standard library *)
-module F = Filename
-
-(* non-directory files *)
-module Filename : sig
-
- include Abstract
-
- val create: dirname -> basename -> t
-
- (** Retrieves the contents from the hard disk. *)
- val read : t -> Raw.t
-
- (** Removes everything in [filename] if existed. *)
- val remove : t -> unit
-
- (** Removes everything in [filename] if existed, then write [contents] instead. *)
- val write : t -> Raw.t -> unit
-
- (** see [Sys.file_exists] *)
- val exists : t -> bool
-
- (** Apply a function on the contents of a file *)
- val with_raw: (Raw.t -> 'a) -> t -> 'a
-
-end = struct
-
- type t = {
- dirname: Dirname.t;
- basename: Basename.t;
- }
-
- let create dirname basename = { dirname; basename }
-
- let to_string t =
- F.concat (Dirname.to_string t.dirname) (Basename.to_string t.basename)
-
- let of_string s =
- let dirname = Filename.dirname s in
- let basename = Filename.basename s in
- {
- dirname = Dirname.of_string dirname;
- basename = Basename.of_string basename;
- }
-
- let read filename =
- let str = Run.read (to_string filename) in
- Raw.of_string str
-
- let write filename raw =
- Run.write (to_string filename) (Raw.to_string raw)
-
- let remove filename =
- Run.safe_rm (to_string filename)
-
- let exists filename =
- Sys.file_exists (to_string filename)
-
- let with_raw fn filename =
- let raw = read filename in
- fn raw
-
- module O = struct type tmp = t type t = tmp let compare = compare end
- module Map = Map.Make(O)
- module Set = Set.Make(O)
-end
-type filename = Filename.t
-
-let (/) d1 d2 =
- let s1 = Dirname.to_string d1 in
- let s2 = Dirname.to_string d2 in
- Dirname.of_string (F.concat s1 s2)
-
-let (//) = Filename.create
-
(** Global state *)
module type GLOBAL = sig
@@ -121,7 +33,10 @@ module type GLOBAL = sig
(** OPAM files: [$opam/opam/$NAME.$VERSION.opam] *)
val opam: t -> NV.t -> filename
-
+
+ (** List all the available packages: [$opam/opam/$NAME.$VERSION.opam] *)
+ val available: t -> NV.Set.t
+
(** Description file: [$opam/descr/$NAME.$VERSION] *)
val descr: t -> NV.t -> filename
@@ -136,9 +51,12 @@ module type GLOBAL = sig
(** Archives files folder: [$opam/archives/] *)
val archive_dir: t -> dirname
+
+ (** Return the repository index: [$opam/repo/index] *)
+ val repo_index: t -> filename
end
-module Global : GLOBAL = struct
+module G : GLOBAL = struct
type t = dirname
let create opam = opam
@@ -153,6 +71,11 @@ module Global : GLOBAL = struct
let opam t nv = opam_dir t // b (NV.to_string nv)
+ let available t =
+ let files = Filename.list (opam_dir t) in
+ let files = List.filter (fun f -> Filename.check_suffix f ".opam") files in
+ List.fold_left (fun set file -> NV.Set.add (NV.of_file file) set) NV.Set.empty files
+
let descr_dir t = t / d "descr"
let descr t nv = descr_dir t // b (NV.to_string nv)
@@ -160,6 +83,9 @@ module Global : GLOBAL = struct
let archive_dir t = t / d "archive"
let archive t nv = archive_dir t // b (NV.to_string nv ^ ".tar.gz")
+
+ let repo_index t = t / d "repo" // b "index"
+
end
(** Compiler-version related state *)
@@ -168,7 +94,7 @@ module type COMPILER = sig
(** Contains [$opam] and [$OVERSION] *)
type t
- val create: dirname -> V.t -> t
+ val create: G.t -> OCaml_V.t -> t
(** Installed libraries for the package: [$opam/$OVERSION/lib/NAME] *)
val lib: t -> N.t -> dirname
@@ -201,47 +127,47 @@ module type COMPILER = sig
(** Configuration folder: [$opam/$OVERSION/config] *)
val config_dir: t -> dirname
+
end
-module Compiler : COMPILER = struct
+module C : COMPILER = struct
type t = dirname
- let create opam oversion =
- Dirname.of_string (V.to_string oversion)
+ let create global oversion =
+ let root = G.root global in
+ root / d (OCaml_V.to_string oversion)
+
+ let lib t n = t / d "lib" / d (N.to_string n)
- let lib t n = t / d "lib" / d (N.to_string n)
+ let bin t = t / d "bin"
- let bin t = t / d "bin"
+ let installed t = t // b "installed"
- let installed t = t // b "installed"
+ let build_dir t = t / d "build"
- let build_dir t = t / d "build"
+ let build t nv = build_dir t / d (NV.to_string nv)
- let build t nv = build_dir t / d (NV.to_string nv)
+ let install_dir t = t / d "install"
- let install_dir t = t / d "install"
+ let install t n = install_dir t // b (N.to_string n ^ ".install")
- let install t n = install_dir t // b (N.to_string n ^ ".install")
+ let reinstall t = t // b "reinstall"
- let reinstall t = t // b "reinstall"
+ let config_dir t = t / d "config"
- let config_dir t = t / d "config"
+ let config t n = config_dir t // b (N.to_string n ^ ".config")
- let config t n = config_dir t // b (N.to_string n ^ ".config")
end
module type REPOSITORY = sig
type t
- val create: dirname -> repository -> t
+ val create: G.t -> repository -> t
(** Return the repository folder: [$opam/repo/$repo] *)
val root: t -> dirname
- (** Return the repository index: [$opam/repo/index] *)
- val index: t -> dirname
-
(** Return the repository kind: [$opam/repo/$repo/kind] *)
val kind: t -> filename
@@ -277,21 +203,21 @@ module type REPOSITORY = sig
end
-module Repository : REPOSITORY = struct
+module R : REPOSITORY = struct
type t = {
root: dirname; (* [$opam/] *)
repo: dirname; (* [$opam/repo/$repo] *)
}
- let create root r = {
- root;
- repo = root / d "repo" / d r.repo_name;
- }
+ let create global r =
+ let root = G.root global in
+ {
+ root;
+ repo = root / d "repo" / d (Repository.name r);
+ }
let root t = t.repo
- let index t = t.root / d "repo" / d "index"
-
let kind t = t.repo // b "kind"
let address t = t.repo // b "address"
View
24 src/repositories.ml
@@ -14,47 +14,45 @@
(***********************************************************************)
open Types
-open Path
let log fmt = Globals.log "REPO" fmt
module Script = struct
- let opam_init r = Printf.sprintf "opam-%s-init" r.repo_kind
- let opam_update r = Printf.sprintf "opam-%s-update" r.repo_kind
- let opam_download r = Printf.sprintf "opam-%s-download" r.repo_kind
- let opam_upload r = Printf.sprintf "opam-%s-upload" r.repo_kind
+ let opam_init r = Printf.sprintf "opam-%s-init" (Repository.kind r)
+ let opam_update r = Printf.sprintf "opam-%s-update" (Repository.kind r)
+ let opam_download r = Printf.sprintf "opam-%s-download" (Repository.kind r)
+ let opam_upload r = Printf.sprintf "opam-%s-upload" (Repository.kind r)
end
let run fn root repo =
- let path = Repository.root (Repository.create root repo) in
+ let path = Path.R.root root in
let i = Run.in_dir (Dirname.to_string path) (fun () ->
Run.command "%s" (fn repo);
- ) () in
+ ) in
if i <> 0 then
Globals.error_and_exit "%s failed" (fn repo)
-let opam_init root r =
- log "opam-init: %s" (string_of_repository r);
+let opam_init root r =
+ log "opam-init: %s" (Repository.to_string r);
run Script.opam_init root r;
(* XXX *)
()
(* Generic repository pluggins *)
let opam_update root r =
- log "opam-update: %s" (string_of_repository r);
+ log "opam-update: %s" (Repository.to_string r);
run Script.opam_update root r;
(* XXX *)
()
let opam_download root r =
- log "opam-download: %s" (string_of_repository r);
+ log "opam-download: %s" (Repository.to_string r);
run Script.opam_download root r;
(* XXX *)
()
let opam_upload root r =
- log "opam-upload: %s" (string_of_repository r);
+ log "opam-upload: %s" (Repository.to_string r);
run Script.opam_upload root r;
(* XXX *)
()
-
View
127 src/run.ml
@@ -13,22 +13,17 @@
(* *)
(***********************************************************************)
-open ExtString
-open ExtList
-open Types
-
let log fmt = Globals.log "RUN" fmt
let tmp_dir = Filename.concat Filename.temp_dir_name "opam-archives"
-let mkdir f f_to =
- let rec aux f_to =
- if not (Sys.file_exists f_to) then begin
- aux (Filename.dirname f_to);
- Unix.mkdir f_to 0o755;
+let mkdir dir =
+ let rec aux dir =
+ if not (Sys.file_exists dir) then begin
+ aux (Filename.dirname dir);
+ Unix.mkdir dir 0o755;
end in
- aux (Filename.dirname f_to);
- f f_to
+ aux dir
let copy src dst =
log "Copying %s to %s" src dst;
@@ -41,7 +36,8 @@ let copy src dst =
open_out_bin dst
else
let perm = (Unix.stat src).Unix.st_perm in
- mkdir (open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] perm) dst
+ mkdir (Filename.dirname dst);
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] perm dst
in
while !read <>0 do
read := input ic b 0 n;
@@ -49,7 +45,7 @@ let copy src dst =
done;
close_in ic;
close_out oc
-
+
let read file =
let ic = open_in file in
let n = in_channel_length ic in
@@ -63,64 +59,47 @@ let write file contents =
output_string oc contents;
close_out oc
-(* the [Unix.wait] could return a processus which has not been
- created by [Unix.fork]. This part waits until a known pid is
- returned. *)
-(* XXX: this will not work under windows *)
-let wait map_pid =
- let open BatMap in
- let rec aux () =
- let pid, error = Unix.wait () in
- if IntMap.mem pid map_pid then
- pid, error
- else
- aux () in
- aux ()
-
-(**************************)
-(* from ocplib-system ... *)
-(**************************)
-let in_dir dir fn x =
+let in_dir dir fn =
let cwd = Unix.getcwd () in
Unix.chdir dir;
try
- let r = fn x in
+ let r = fn () in
Unix.chdir cwd;
r
with e ->
Unix.chdir cwd;
raise e
-let directories () =
- let d = Sys.readdir (Unix.getcwd ()) in
- let d = Array.to_list d in
- List.filter (fun f -> try Sys.is_directory f with _ -> false) d
+let directories dir =
+ in_dir dir (fun () ->
+ let d = Sys.readdir (Unix.getcwd ()) in
+ let d = Array.to_list d in
+ List.filter (fun f -> try Sys.is_directory f with _ -> false) d
+ )
-let files () =
- let d = Sys.readdir (Unix.getcwd ()) in
- let d = Array.to_list d in
- List.filter (fun f -> try not (Sys.is_directory f) with _ -> true) d
+let files dir =
+ in_dir dir (fun () ->
+ let d = Sys.readdir (Unix.getcwd ()) in
+ let d = Array.to_list d in
+ List.filter (fun f -> try not (Sys.is_directory f) with _ -> true) d
+ )
-let safe_unlink file =
+let remove_file file =
try Unix.unlink file
with Unix.Unix_error _ -> ()
-let rec safe_rmdir dir =
+let rec remove_dir dir =
if Sys.file_exists dir then begin
- in_dir dir (fun () ->
- let dirs = directories () in
- let files = files () in
- List.iter safe_unlink files;
- List.iter safe_rmdir dirs;
- ) ();
+ List.iter remove_file (files dir);
+ List.iter remove_dir (directories dir);
Unix.rmdir dir;
end
-let safe_rm file =
+let remove file =
if Sys.file_exists file && Sys.is_directory file then
- safe_rmdir file
+ remove_dir file
else
- safe_unlink file
+ remove_file file
let getchdir s =
let p = Unix.getcwd () in
@@ -130,9 +109,9 @@ let getchdir s =
let rec root path =
let d = Filename.dirname path in
if d = path || d = "" || d = "." then
- path
+ path
else
- root d
+ root d
(* XXX: the function might block for ever for some channels kinds *)
let read_lines ic =
@@ -179,7 +158,7 @@ let add_path bins =
let path = ref "<not set>" in
let env = Unix.environment () in
for i = 0 to Array.length env - 1 do
- let k,v = String.split env.(i) "=" in
+ let k,v = ExtString.String.split env.(i) "=" in
if k = "PATH" then
let new_path = match List.filter Sys.file_exists bins with
| [] -> v
@@ -227,45 +206,39 @@ let is_archive file =
| Some s -> fun _ -> Some s
| None -> fun (ext, c) ->
if List.exists (Filename.check_suffix file) ext then
- Some (Printf.kprintf Sys.command "tar xvf%c %s -C %s" c file)
+ Some (command "tar xvf%c %s -C %s" c file)
else
None)
None
[ [ "tar.gz" ; "tgz" ], 'z'
; [ "tar.bz2" ; "tbz" ], 'j' ]
-let untar file nv =
+let extract file dst =
log "untar %s" file;
let files = read_command_output ("tar tf " ^ file) in
log "%d files found: %s" (List.length files) (String.concat ", " files);
- let dirname = NV.to_string nv in
let aux name =
- if String.starts_with name dirname then
- Filename.concat tmp_dir name, name
+ if root name = Filename.basename dst then
+ Filename.concat tmp_dir name, Filename.concat dst name
else
let root = root name in
let n = String.length root in
let rest = String.sub name n (String.length name - n) in
- Filename.concat tmp_dir name, dirname ^ rest in
+ Filename.concat tmp_dir name, dst ^ rest in
let moves = List.map aux files in
- if not (Sys.file_exists tmp_dir) then
- Unix.mkdir tmp_dir 0o750;
+ mkdir tmp_dir;
let err =
match is_archive file with
| Some f_cmd -> f_cmd tmp_dir
| None -> Globals.error_and_exit "%s is not a valid archive" file in
- List.iter (fun (src, dst) ->
- mkdir (copy src) dst
- ) moves;
- err
-
-
-
-
-
-
-
-
-
-
-
+ if err <> 0 then
+ Globals.error_and_exit "Error while extracting %s" file
+ else
+ List.iter (fun (src, dst) ->
+ mkdir (Filename.dirname dst);
+ copy src dst
+ ) moves
+
+let link src dst =
+ log "Linking %s to %s" src dst;
+ Unix.link src dst
View
59 src/run.mli
@@ -0,0 +1,59 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+(** [copy src dst] copies [src] to [dst] *)
+val copy: string -> string -> unit
+
+(** [link src dst] links [src] to [dst] *)
+val link: string -> string -> unit
+
+(** [real_path p] returns the real path associated to [p]: [..] are
+ expanded and relative paths become absolute. *)
+val real_path: string -> string
+
+(** [read filename] returns the contents of [filename] *)
+val read: string -> string
+
+(** [write filename contents] write [contents] to [filename] *)
+val write: string -> string -> unit
+
+(** [remove filename] removes [filename]. Works whether [filename] is
+ a file or a directory *)
+val remove: string -> unit
+
+(** [remove_file filename] removes [filename]. Works only for normal
+ files *)
+val remove_file: string -> unit
+
+(** [remove_dir filename] removes [filename]. Works only for
+ directory. *)
+val remove_dir: string -> unit
+
+(** [in_dir dir fn] evaluates [fn] in the directory [dir] *)
+val in_dir: string -> (unit -> 'a) -> 'a
+
+(** [files dir] returns the files in the directory [dir] *)
+val files: string -> string list
+
+(** [command fmt] executes the command [fmt] *)
+val command: ('a, unit, string, int) format4 -> 'a
+
+(** [commands cmds] executes the commands [cmds]. It stops whenever
+ one command fails. *)
+val commands: string list -> int
+
+(** [extract filename dirname] untar the archive [filename] to
+ [dirname] *)
+val extract: string -> string -> unit
View
0  src/ocp_get_server.ml → src/server/opam_server.ml
File renamed without changes
View
374 src/solver.ml
@@ -18,195 +18,87 @@ open Path
let log fmt = Globals.log "SOLVER" fmt
-module Parallel_fold =
-struct
+type 'a installed_status =
+ | Was_installed of 'a
+ | Was_not_installed
- module type G =
- sig
- include Graph.Topological.G
- val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a
- val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
- end
-
- module type TOPOLOGICAL =
- sig
-
- (** This module considers the graph to fold as a forest where the
- children of each node are topologically ordered after their
- parent. *)
-
- module G : G
- module S : Set.S with type elt = G.V.t
-
- (** Optimized structure to get easily all the nodes with null
- in-degree *)
- type t
+type 'a request =
+ { wish_install : 'a list
+ ; wish_remove : 'a list
+ ; wish_upgrade : 'a list }
- (** Create an optimized structure *)
- val init: G.t -> t
+type 'a action =
+ (* The package must be installed. The package could have been present or not,
+ but if present, it is another version than the proposed solution. *)
+ | To_change of 'a installed_status * 'a
- (** Get the null in-degree nodes from the optimized structure *)
- val roots: t -> S.t
+ (* The package must be deleted. *)
+ | To_delete of 'a
- (** [remove t n] removes the node [n] from [t] and returns the new
- optimized structure. It raises [Invalid_argument _] if [n] is
- neither a root node or if has already been visited *)
- val remove : t -> G.V.t -> t
+ (* The package is already installed, but it must be recompiled. *)
+ | To_recompile of 'a
- end
-
- module Make (G : G) : TOPOLOGICAL with module G = G = struct
-
- module V = struct include G.V let compare = compare end
- module M = Map.Make (V)
- module S = Set.Make (V)
-
- module G = G
-
- module IntSet = Set.Make (struct type t = int let compare = compare end)
-
- type 'a plist = 'a list (* nodes with minimal in-degree are proposed simultaneously *)
- type t = {
- graph : G.t ;
- visited_node : IntSet.t ; (* [int] represents the hash of [G.V.t] *)
- queue_size : int ;
- roots : S.t ;
- degree : int M.t ;
- }
-
- let roots t = t.roots
-
- let init graph =
- let degree = ref M.empty in
- let add_degree v d = degree := M.add v d !degree in
- let roots, queue_size =
- G.fold_vertex
- (fun v (todo, queue_size) ->
- let d = G.in_degree graph v in
- if d = 0 then
- S.add v todo, succ queue_size
- else (
- add_degree v d;
- todo, queue_size
- )
- )
- graph
- (S.empty, 0) in
- { graph ; roots ; degree = !degree ; queue_size ; visited_node = IntSet.empty }
-
- let remove t x =
- if IntSet.mem (G.V.hash x) t.visited_node then
- invalid_arg "This node has already been visited.";
- if not (S.mem x t.roots) then
- invalid_arg "This node is not a root node";
- (* Add the node to the list of visited nodes *)
- let t = { t with visited_node = IntSet.add (G.V.hash x) t.visited_node } in
- (* Remove the node from the list of root nodes *)
- let roots = S.remove x t.roots in
- let degree = ref t.degree in
- let remove_degree x = degree := M.remove x !degree in
- let replace_degree x d = degree := M.add x d (M.remove x !degree) in
- (* Update the children of the node by decreasing by 1 their in-degree *)
- let roots, queue_size =
- G.fold_succ
- (fun x (l, queue_size) ->
- let d = M.find x t.degree in
- if d = 1 then (
- remove_degree x;
- S.add x l, succ queue_size
- ) else (
- replace_degree x (d-1);
- l, queue_size
- ))
- t.graph
- x
- (roots, pred t.queue_size) in
- { t with queue_size; roots }
+type package_action =
+ { cudf : Cudf.package
+ ; action : NV.t action }
- end
-end
+(* Graphs of actions *)
+module G = struct
-module Action =
-struct
+ module PkgV = struct
- type 'a installed_status =
- | Was_installed of 'a
- | Was_not_installed
+ type t = package_action
- type 'a request =
- { wish_install : 'a list
- ; wish_remove : 'a list
- ; wish_upgrade : 'a list }
+ let compare t1 t2 =
+ Algo.Defaultgraphs.PackageGraph.PkgV.compare t1.cudf t2.cudf
- type 'a action =
- (* The package must be installed. The package could have been present or not,
- but if present, it is another version than the proposed solution. *)
- | To_change of 'a installed_status * 'a
+ let hash t =
+ Algo.Defaultgraphs.PackageGraph.PkgV.hash t.cudf
- (* The package must be deleted. *)
- | To_delete of 'a
+ let equal t1 t2 =
+ Algo.Defaultgraphs.PackageGraph.PkgV.equal t1.cudf t2.cudf
- (* The package is already installed, but it must be recompiled. *)
- | To_recompile of 'a
-
- module NV_graph =
- struct
- module PkgV =
- struct
- type t =
- { cudf : Cudf.package
- ; action : NV.t action }
- (* NOTE the field [action] currently does not need to contain a boolean sum type
- (i.e. something isomorphic to [name_version action option] where [None] means an action not to perform)
- because the graph containing all these nodes is composed of 2 parts :
- 1. starting from the root, all the nodes that we ignore,
- 2. when we encounter a node action, every children is an action (not a node to ignore). *)
-
- module PkgV = Algo.Defaultgraphs.PackageGraph.PkgV
-
- let compare t1 t2 = PkgV.compare t1.cudf t2.cudf
- let hash t = PkgV.hash t.cudf
- let equal t1 t2 = PkgV.equal t1.cudf t2.cudf
- end
-
- module PG = Graph.Imperative.Digraph.ConcreteBidirectional (PkgV)
- module PG_topo = Graph.Topological.Make (PG)
-(* module PG_topo_para = Parallel_fold.Make (PG) *)
end
- type solution =
- { to_remove : NV.t list
- ; to_add : NV_graph.PG.t }
-
- let map_action f = function
- | To_change (Was_installed p1, p2) -> To_change (Was_installed (f p1), f p2)
- | To_change (Was_not_installed, p) -> To_change (Was_not_installed, f p)
- | To_delete p -> To_delete (f p)
- | To_recompile p -> To_recompile (f p)
-
- let print_solution f t =
- let pf = Globals.msg in
- if t.to_remove = [] && NV_graph.PG.is_empty t.to_add then
- pf "No actions will be performed, the current state satisfies the request.\n"
- else
- let pf f = Printf.kprintf (pf " %s") f in
- begin
- List.iter (fun p -> pf "Remove: %s\n" (f p)) t.to_remove;
- NV_graph.PG_topo.iter
- (let open NV_graph.PkgV in function { action ; _ } ->
- match action with
- | To_recompile p -> pf "Recompile: %s\n" (f p)
- | To_delete p -> assert false (* items to delete are listed above *)
- | To_change (Was_not_installed, p) -> pf "Install: %s\n" (f p)
- | To_change (Was_installed o, p) -> pf "Update: %s (Remove) -> %s (Install)\n" (f o) (f p))
- t.to_add;
- end
+ module PG = Graph.Imperative.Digraph.ConcreteBidirectional (PkgV)
+ module T = Graph.Topological.Make (PG)
+ module P = Parallel.Make(struct
+ include PG
+ include T
+ end)
+ include PG
end
-open Action
+type solution =
+ { to_remove : NV.t list
+ ; to_add : G.t }
+
+let map_action f = function
+ | To_change (Was_installed p1, p2) -> To_change (Was_installed (f p1), f p2)
+ | To_change (Was_not_installed, p) -> To_change (Was_not_installed, f p)
+ | To_delete p -> To_delete (f p)
+ | To_recompile p -> To_recompile (f p)
+
+let print_solution f t =
+ let pf = Globals.msg in
+ if t.to_remove = [] && G.is_empty t.to_add then
+ pf "No actions will be performed, the current state satisfies the request.\n"
+ else
+ let pf f = Printf.kprintf (pf " %s") f in
+ begin
+ List.iter (fun p -> pf "Remove: %s\n" (f p)) t.to_remove;
+ G.T.iter
+ (function { action ; _ } ->
+ match action with
+ | To_recompile p -> pf "Recompile: %s\n" (f p)
+ | To_delete p -> assert false (* items to delete are in t.remove *)
+ | To_change (Was_not_installed, p) -> pf "Install: %s\n" (f p)
+ | To_change (Was_installed o, p) -> pf "Update: %s (Remove) -> %s (Install)\n" (f o) (f p)
+ ) t.to_add;
+ end
+
+module type SOLVER = sig
-module type SOLVER =
-sig
val request_map : ('a -> 'b) -> 'a request -> 'b request
(** Given a description of packages, return a solution preserving
@@ -378,8 +270,9 @@ module Solver : SOLVER = struct
let tocudf table pkg =
l