Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Improve the reporting of errors

Now the sub-processes states are kept until all the processing is done, and the errors are displayed at the end.

This also help the error-recovery: in case of upgrade, we reinstall the old package; in case of reinstall we are a bit stuck and we remove all packages depending on this one. This solution is not yet perfect, as it may lead to some inconsistent global state. Hopefuly this will not happen very often ...

This commit fixes #130 and partially fixes #131
  • Loading branch information...
commit a30a0b95f1b364a0bb8d56a8104669749388b873 1 parent 583460e
@samoht samoht authored
View
478 src/client.ml
@@ -448,15 +448,14 @@ let update_packages t ~show_packages =
Globals.msg "Synchronizing %s with %s ...\n" (NV.to_string nv) (Dirname.to_string p);
(* XXX: make it more generic *)
if Dirname.exists build then
- match
- Run.read_command_output
- [ "rsync"; "-arv"; Dirname.to_string p ^ "/"; Dirname.to_string build ]
- with
- | None -> None
- | Some lines ->
- match Utils.rsync_trim lines with
- | [] -> None
- | l -> Some nv
+ try
+ let lines = Run.read_command_output
+ [ "rsync"; "-arv"; "--exclude"; "'.git/*'"; Dirname.to_string p ^ "/"; Dirname.to_string build ] in
+ match Utils.rsync_trim lines with
+ | [] -> None
+ | l -> Some nv
+ with _ ->
+ None
else
None
else
@@ -669,52 +668,37 @@ let init_ocaml t quiet alias ocaml_version =
let comp_src = File.Comp.src comp in
let build_dir = Path.C.build_ocaml alias_p in
Dirname.with_tmp_dir (fun download_dir ->
- begin match Filename.download comp_src download_dir with
- | None -> Globals.error_and_exit "Cannot download %s" (Filename.to_string comp_src)
- | Some f -> Filename.extract f build_dir
- end;
+ let file = Filename.download comp_src download_dir in
+ Filename.extract file build_dir;
let patches = File.Comp.patches comp in
- let patches =
- Utils.filter_map (fun f ->
- match Filename.download f build_dir with
- | None -> Globals.error_and_exit "Cannot download %s" (Filename.to_string f)
- | Some f -> Some f
- ) patches in
- List.iter (fun f ->
- if not (Filename.patch f build_dir) then
- Globals.error_and_exit "Cannot apply %s" (Filename.to_string f)
- ) patches;
- let err =
- let t =
- { t with
- compiler = alias_p;
- installed =
- let name = N.of_string Globals.default_package in
- let version = V.of_string (Alias.to_string alias) in
- let nv = NV.create name version in
- NV.Set.add nv NV.Set.empty } in
- install_conf_ocaml_config t;
- if File.Comp.configure comp @ File.Comp.make comp <> [] then begin
- Dirname.exec build_dir
- [ ( "./configure" :: File.Comp.configure comp )
- @ [ "-prefix"; Dirname.to_string alias_p_dir ]
- (*-bindir %s/bin -libdir %s/lib -mandir %s/man*)
- (* NOTE In case it exists 2 '-prefix', in general the script
- ./configure will only consider the last one, others will be
- discarded. *)
- ; ( "make" :: File.Comp.make comp )
- ; [ "make" ; "install" ]
- ]
- end else begin
- let builds =
- List.map (List.map (substitute_string t)) (File.Comp.build comp) in
- Dirname.exec build_dir builds
- end in
- if err <> 0 then
- Globals.error_and_exit
- "The compilation of compiler version %s failed"
- (OCaml_V.to_string ocaml_version)
- )
+ let patches = List.map (fun f -> Filename.download f build_dir) patches in
+ List.iter (fun f -> Filename.patch f build_dir) patches;
+ let t =
+ { t with
+ compiler = alias_p;
+ installed =
+ let name = N.of_string Globals.default_package in
+ let version = V.of_string (Alias.to_string alias) in
+ let nv = NV.create name version in
+ NV.Set.add nv NV.Set.empty } in
+ install_conf_ocaml_config t;
+ if File.Comp.configure comp @ File.Comp.make comp <> [] then begin
+ Dirname.exec build_dir
+ [ ( "./configure" :: File.Comp.configure comp )
+ @ [ "-prefix"; Dirname.to_string alias_p_dir ]
+ (*-bindir %s/bin -libdir %s/lib -mandir %s/man*)
+ (* NOTE In case it exists 2 '-prefix', in general the script
+ ./configure will only consider the last one, others will be
+ discarded. *)
+ ; ( "make" :: File.Comp.make comp )
+ ; [ "make" ; "install" ]
+ ]
+ end else begin
+ let builds =
+ List.map (List.map (substitute_string t)) (File.Comp.build comp) in
+ Dirname.exec build_dir builds
+ end;
+ );
end;
(* write the new version in the configuration file *)
@@ -865,112 +849,113 @@ let info package =
let proceed_toinstall t nv =
Globals.msg "Installing %s ...\n" (NV.to_string nv);
- let t = load_state () in
- let name = NV.name nv in
- let opam_f = Path.G.opam t.global nv in
- let opam = File.OPAM.read opam_f in
- let config_f = Path.C.build_config t.compiler nv in
- let config = File.Dot_config.safe_read config_f in
- let install_f = Path.C.build_install t.compiler nv in
- let install = File.Dot_install.safe_read install_f in
-
- Dirname.chdir (Path.C.build t.compiler nv);
-
- (* check that libraries and syntax extensions specified in .opam and
- .config are in sync *)
- let check kind config_sections opam_sections =
- List.iter (fun cs ->
- if not (List.mem cs opam_sections) then
- Globals.error_and_exit "The %s %s does not appear in %s"
- kind (Section.to_string cs) (Filename.to_string opam_f)
- ) config_sections;
- List.iter (fun os ->
- if not (List.mem os config_sections) then
- Globals.error_and_exit "The %s %s does not appear in %s"
- kind (Section.to_string os) (Filename.to_string config_f)
- ) opam_sections in
- if not (Filename.exists config_f) &&
- (File.OPAM.libraries opam <> [] || File.OPAM.syntax opam <> []) then
- Globals.error_and_exit
- "%s does not exists but %s defines some libraries and syntax extensions"
- (Filename.to_string config_f)
- (Filename.to_string opam_f);
- check "library"
- (File.Dot_config.Library.available config)
- (File.OPAM.libraries opam);
- check "syntax"
- (File.Dot_config.Syntax.available config)
- (File.OPAM.syntax opam);
-
- (* check that depends (in .opam) and requires (in .config) fields
- are in almost in sync *)
- (* NOTES: the check is partial as we don't know which clause is valid
- in depends (XXX there is surely a way to get it from the solver) *)
- let local_sections = File.Dot_config.Section.available config in
- let libraries_in_opam =
- List.fold_left (fun accu l ->
- List.fold_left (fun accu ((n,_),_) ->
- let n = N.of_string n in
- let nv = find_installed_package_by_name t n in
- let opam = File.OPAM.read (Path.G.opam t.global nv) in
- let libs = File.OPAM.libraries opam in
- let syntax = File.OPAM.syntax opam in
- List.fold_right Section.Set.add (libs @ syntax) accu
- ) accu l
- ) Section.Set.empty (File.OPAM.depends opam) in
- let libraries_in_config =
- List.fold_left (fun accu s ->
- List.fold_left (fun accu r ->
- Section.Set.add r accu
- ) accu (File.Dot_config.Section.requires config s)
- ) Section.Set.empty local_sections in
- Section.Set.iter (fun s ->
- if not (List.mem s local_sections)
- && not (Section.Set.mem s libraries_in_opam) then
- let config_f = Filename.to_string (Path.C.build_config t.compiler nv) in
- let opam_f = Filename.to_string (Path.G.opam t.global nv) in
- let local_sections = List.map Section.to_string local_sections in
- let opam_sections = List.map Section.to_string (Section.Set.elements libraries_in_opam) in
+ Dirname.in_dir (Path.C.build t.compiler nv) (fun () ->
+
+ let t = load_state () in
+ let name = NV.name nv in
+ let opam_f = Path.G.opam t.global nv in
+ let opam = File.OPAM.read opam_f in
+ let config_f = Path.C.build_config t.compiler nv in
+ let config = File.Dot_config.safe_read config_f in
+ let install_f = Path.C.build_install t.compiler nv in
+ let install = File.Dot_install.safe_read install_f in
+
+ (* check that libraries and syntax extensions specified in .opam and
+ .config are in sync *)
+ let check kind config_sections opam_sections =
+ List.iter (fun cs ->
+ if not (List.mem cs opam_sections) then
+ Globals.error_and_exit "The %s %s does not appear in %s"
+ kind (Section.to_string cs) (Filename.to_string opam_f)
+ ) config_sections;
+ List.iter (fun os ->
+ if not (List.mem os config_sections) then
+ Globals.error_and_exit "The %s %s does not appear in %s"
+ kind (Section.to_string os) (Filename.to_string config_f)
+ ) opam_sections in
+ if not (Filename.exists config_f)
+ && (File.OPAM.libraries opam <> [] || File.OPAM.syntax opam <> []) then
Globals.error_and_exit
- "%s appears as a library dependency in %s, but:\n\
+ "%s does not exists but %s defines some libraries and syntax extensions"
+ (Filename.to_string config_f)
+ (Filename.to_string opam_f);
+ check "library"
+ (File.Dot_config.Library.available config)
+ (File.OPAM.libraries opam);
+ check "syntax"
+ (File.Dot_config.Syntax.available config)
+ (File.OPAM.syntax opam);
+
+ (* check that depends (in .opam) and requires (in .config) fields
+ are in almost in sync *)
+ (* NOTES: the check is partial as we don't know which clause is valid
+ in depends (XXX there is surely a way to get it from the solver) *)
+ let local_sections = File.Dot_config.Section.available config in
+ let libraries_in_opam =
+ List.fold_left (fun accu l ->
+ List.fold_left (fun accu ((n,_),_) ->
+ let n = N.of_string n in
+ let nv = find_installed_package_by_name t n in
+ let opam = File.OPAM.read (Path.G.opam t.global nv) in
+ let libs = File.OPAM.libraries opam in
+ let syntax = File.OPAM.syntax opam in
+ List.fold_right Section.Set.add (libs @ syntax) accu
+ ) accu l
+ ) Section.Set.empty (File.OPAM.depends opam) in
+ let libraries_in_config =
+ List.fold_left (fun accu s ->
+ List.fold_left (fun accu r ->
+ Section.Set.add r accu
+ ) accu (File.Dot_config.Section.requires config s)
+ ) Section.Set.empty local_sections in
+ Section.Set.iter (fun s ->
+ if not (List.mem s local_sections)
+ && not (Section.Set.mem s libraries_in_opam) then
+ let config_f = Filename.to_string (Path.C.build_config t.compiler nv) in
+ let opam_f = Filename.to_string (Path.G.opam t.global nv) in
+ let local_sections = List.map Section.to_string local_sections in
+ let opam_sections = List.map Section.to_string (Section.Set.elements libraries_in_opam) in
+ Globals.error_and_exit
+ "%s appears as a library dependency in %s, but:\n\
- %s defines the libraries {%s}\n\
- Packages in %s defines the libraries {%s}"
- (Section.to_string s) config_f
- config_f (String.concat ", " local_sections)
- opam_f (String.concat ", " opam_sections)
- ) libraries_in_config;
-
- (* .install *)
- File.Dot_install.write (Path.C.install t.compiler name) install;
-
- (* .config *)
- File.Dot_config.write (Path.C.config t.compiler name) config;
-
- (* lib *)
- let lib = Path.C.lib t.compiler name in
- List.iter (fun f -> Filename.copy_in f lib) (File.Dot_install.lib install);
-
- (* toplevel *)
- let toplevel = Path.C.toplevel t.compiler in
- List.iter (fun f -> Filename.copy_in f toplevel) (File.Dot_install.toplevel install);
-
- (* bin *)
- List.iter (fun (src, dst) ->
- let dst = Path.C.bin t.compiler // (Basename.to_string dst) in
- Filename.copy src dst
- ) (File.Dot_install.bin install);
-
- (* misc *)
- List.iter
- (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
+ (Section.to_string s) config_f
+ config_f (String.concat ", " local_sections)
+ opam_f (String.concat ", " opam_sections)
+ ) libraries_in_config;
+
+ (* .install *)
+ File.Dot_install.write (Path.C.install t.compiler name) install;
+
+ (* .config *)
+ File.Dot_config.write (Path.C.config t.compiler name) config;
+
+ (* lib *)
+ let lib = Path.C.lib t.compiler name in
+ List.iter (fun f -> Filename.copy_in f lib) (File.Dot_install.lib install);
+
+ (* toplevel *)
+ let toplevel = Path.C.toplevel t.compiler in
+ List.iter (fun f -> Filename.copy_in f toplevel) (File.Dot_install.toplevel install);
+
+ (* bin *)
+ List.iter (fun (src, dst) ->
+ let dst = Path.C.bin t.compiler // (Basename.to_string dst) in
+ Filename.copy src dst
+ ) (File.Dot_install.bin install);
+
+ (* misc *)
+ List.iter
+ (fun (src, dst) ->
+ if Filename.exists dst && confirm "Overwriting %s ?" (Filename.to_string dst) then
Filename.copy src dst
- end
- ) (File.Dot_install.misc install)
+ 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.Dot_install.misc install)
+ )
let pinned_path t nv =
let name = NV.name nv in
@@ -1020,17 +1005,15 @@ let extract_package t nv =
match pinned_path t nv with
| None ->
let archive = get_archive t nv in
- Globals.msg "Extracting ...\n";
+ Globals.msg "Extracting %s ...\n" (Filename.to_string archive);
Filename.extract archive p_build;
p_build
| Some p ->
(* XXX: make it a bit more generic ... *)
Globals.msg "Synchronizing %s with %s ...\n" (NV.to_string nv) (Dirname.to_string p);
- let err = Run.command [ "rsync"; "-arv"; Dirname.to_string p ^ "/"; Dirname.to_string p_build ] in
+ Run.command [ "rsync"; "-arv"; "--exclude"; "'.git/*'"; Dirname.to_string p ^ "/"; Dirname.to_string p_build ];
let files = get_files t nv in
List.iter (fun f -> Filename.copy_in f p_build) files;
- if err <> 0 then
- Globals.error_and_exit "Cannot synchronize %s with %s." (Dirname.to_string p) (Dirname.to_string p_build);
p_build
let proceed_todelete t nv =
@@ -1044,13 +1027,17 @@ let proceed_todelete t nv =
let opam = File.OPAM.read opam_f in
let remove = List.map (List.map (substitute_string t)) (File.OPAM.remove opam) in
let p_build = Path.C.build t.compiler nv in
- if not (Dirname.exists p_build) then
- ignore (extract_package t nv);
(* We try to run the remove scripts in the folder where it was extracted
- If it does not exist, we don't really care. *)
- let err = Dirname.exec ~add_to_path:[Path.C.bin t.compiler] p_build remove in
- if err <> 0 then
- Globals.error_and_exit "Cannot uninstall %s" (NV.to_string nv);
+ If it does not exist, we try to download and extract the archive again,
+ if that fails, we don't really care. *)
+ if not (Dirname.exists p_build) then (
+ try ignore (extract_package t nv)
+ with _ -> Dirname.mkdir p_build;
+ );
+ begin
+ try Dirname.exec ~add_to_path:[Path.C.bin t.compiler] p_build remove
+ with _ -> ();
+ end;
Dirname.rmdir p_build;
);
@@ -1148,8 +1135,11 @@ let print_env_warning () =
Globals.msg "\nTo update your environment variables, you can now run:
\n\ $ eval `opam config -env`\n\n"
+(* In case of error, simply return the error traces, and let the
+ repo in a state that the user can explore.
+ Do not try to recover yet. *)
let rec proceed_tochange t nv_old nv =
- Globals.msg "==== %s ====\n" (NV.to_string nv);
+ Globals.msg "\n=-=-= %s =-=-=\n" (NV.to_string nv);
(* First, uninstall any previous version *)
(match nv_old with
@@ -1172,8 +1162,9 @@ let rec proceed_tochange t nv_old nv =
(* Substitute the configuration files. We should be in the right
directory to get the correct absolute path for the substitution
files (see [substitute_file] and [Filename.of_basename]. *)
- Dirname.chdir (Path.C.build t.compiler nv);
- List.iter (substitute_file t) (File.OPAM.substs opam);
+ Dirname.in_dir (Path.C.build t.compiler nv) (fun () ->
+ List.iter (substitute_file t) (File.OPAM.substs opam)
+ );
(* Generate an environnement file *)
let env_f = Path.C.build_env t.compiler nv in
@@ -1190,38 +1181,29 @@ let rec proceed_tochange t nv_old nv =
(File.OPAM.build opam) in
let commands_s = List.map (fun cmd -> String.concat " " cmd) commands in
Globals.msg "Build commands:\n %s\n" (String.concat "\n " commands_s);
- let err =
+ try
Dirname.exec
~add_to_env:env.add_to_env
~add_to_path:[env.add_to_path]
p_build
- commands in
- if err = 0 then
- try proceed_toinstall t nv
- with e ->
- proceed_todelete t nv;
- let p_build = prepare_package () in
- Globals.error "Installation failed in %s." (Dirname.to_string p_build);
- raise e
- else (
+ commands;
+ proceed_toinstall t nv;
+ with e ->
proceed_todelete t nv;
let p_build = prepare_package () in
- match nv_old with
+ begin match nv_old with
| None ->
- Globals.error_and_exit "Compilation failed in %s." (Dirname.to_string p_build)
+ Globals.error
+ "The compilation of %s failed in %s."
+ (NV.to_string nv)
+ (Dirname.to_string p_build)
| Some nv_old ->
- if nv_old = nv then
- Globals.error_and_exit "Recompilation failed in %s." (Dirname.to_string p_build)
- else
- (* try to restore the previous erased [nv_old] version *)
- try
- Globals.error "Compilation of %s failed in %s. Restoring previous working version (%s) ..."
- (NV.to_string nv) (Dirname.to_string p_build) (NV.to_string nv_old);
- proceed_tochange t None nv_old
- with _ ->
- (* XXX: determine if it is because some dependencies have been deleted or not... *)
- Globals.error_and_exit "Restoring %s failed" (NV.to_string nv_old)
- )
+ Globals.error
+ "The recompilation of %s failed in %s."
+ (NV.to_string nv)
+ (Dirname.to_string p_build)
+ end;
+ raise e
(* We need to clean-up things before recompiling. *)
let proceed_torecompile t nv =
@@ -1396,7 +1378,8 @@ module Heuristic = struct
let apply_solution t sol =
if Solver.solution_is_empty sol then
- true
+ (* The current state satisfies the request contraints *)
+ OK
else (
Globals.msg "The following actions will be performed:\n";
print_solution sol;
@@ -1419,11 +1402,7 @@ module Heuristic = struct
to_remove;
let continue =
- (* if only one package to install and none to remove,
- or one package to remove and none to install
- or at most one package to reinstall
- then no need to confirm *)
- if to_install + to_reinstall + to_remove <= 1 then
+ if to_install + to_reinstall + to_remove + to_upgrade <= 1 then
true
else
confirm "Do you want to continue ?" in
@@ -1431,21 +1410,26 @@ module Heuristic = struct
if continue then (
let installed = ref t.installed in
+ (* This function should be called by the parent process only, as it modifies
+ the global state of OPAM *)
let write_installed () =
File.Installed.write (Path.C.installed t.compiler) !installed in
- (* Delete some packages *)
+ (* Delete the requested packages in the parent process *)
(* 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 ()
+ try
+ proceed_todelete t nv;
+ installed := NV.Set.remove nv !installed;
+ write_installed ()
+ with _ ->
+ ()
end)
sol.to_remove;
- (* Install or recompile some packages on the child process *)
+ (* Installation and recompilation are done by child processes *)
let child n =
let t = load_state () in
match action n with
@@ -1466,34 +1450,80 @@ module Heuristic = struct
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
+ (* Try to recover from errors.
+ XXX: this is higly experimental. *)
+ let recover_from_error (n, _) = match action n with
+ | To_change (Some o, _) ->
+ proceed_toinstall t o;
+ installed := NV.Set.add o !installed;
+ write_installed ()
+ | To_change (None, _) -> ()
+ | To_recompile nv ->
+ (* this case is quite tricky. We have to remove all the packages
+ depending in nv, as they will be broken if nv is uninstalled. *)
+ let universe =
+ Solver.U
+ (NV.Set.fold
+ (fun nv l -> (debpkg_of_nv `remove t nv) :: l)
+ (get_available_current t) []) in
+ let depends =
+ Solver.filter_forward_dependencies ~depopts:true universe
+ (Solver.P [debpkg_of_nv `remove t nv]) in
+ let depends = NV.Set.of_list (List.rev_map NV.of_dpkg depends) in
+ let depends = NV.Set.filter (fun nv -> NV.Set.mem nv t.installed) depends in
+ NV.Set.iter (proceed_todelete t) depends;
+ installed := NV.Set.diff !installed depends;
+ write_installed ();
+ | To_delete nv -> assert false in
+
+ let display_error (n, error) =
+ let f action nv =
+ Globals.error "[ERROR] while %s %s" action (NV.to_string nv);
+ match error with
+ | Parallel.Process_error r -> Process.display_error_message r
+ | Parallel.Internal_error s -> Globals.error " %s" s in
match action n with
- | To_change (Some _, nv) -> f "upgrading/downgrading" nv
+ | To_change (Some o, nv) -> f "upgrading to" nv
| To_change (None, nv) -> f "installing" nv
- | To_recompile nv ->
- installed := NV.Set.remove nv !installed;
- write_installed ();
- f "recompiling" nv
- | To_delete _ -> assert false in
+ | To_recompile nv -> f "recompiling" nv
+ | To_delete nv -> f "removing" nv in
+
+ let string_of_errors errors =
+ let actions = List.map action (List.map fst errors) in
+ let packages =
+ List.map (function
+ | To_change (_,nv)
+ | To_recompile nv
+ | To_delete nv -> nv
+ ) actions in
+ match packages with
+ | [] -> assert false
+ | [h] -> NV.to_string h
+ | l -> NV.Set.to_string (NV.Set.of_list l) in
let cores = File.Config.cores t.config in
- try PA_graph.Parallel.iter cores sol.to_add ~pre ~child ~post
- with PA_graph.Parallel.Errors n -> List.iter error n
- );
- continue
+ try
+ PA_graph.Parallel.iter cores sol.to_add ~pre ~child ~post;
+ OK
+ with PA_graph.Parallel.Errors (errors, remaining) ->
+ Globals.msg "\n";
+ if remaining <> [] then (
+ Globals.error
+ "Due to some errors while processing %s, the following action will NOT been proceeded:"
+ (string_of_errors errors);
+ List.iter (fun n -> Globals.error "%s" (string_of_action (action n))) remaining;
+ );
+ List.iter recover_from_error errors;
+ List.iter display_error errors;
+ Globals.exit 2
+ ) else
+ Aborted
)
let apply_solutions t =
let rec aux = function
- | x :: xs ->
- let solution_found = apply_solution t x in
- if solution_found then
- OK
- else
- Aborted (* aux xs *)
- | [] -> No_solution in
+ | [] -> No_solution
+ | x::_ -> apply_solution t x in
aux
let resolve action_k t l_request =
View
6 src/opam.ml
@@ -438,15 +438,15 @@ let () =
List.iter SubCommand.register commands;
try ArgExt.parse ~man:"opam" global_args
with e ->
- Globals.msg " '%s' failed\n" (String.concat " " (Array.to_list Sys.argv));
+ Globals.error " '%s' failed\n" (String.concat " " (Array.to_list Sys.argv));
match e with
| Bad (cmd, msg) ->
ArgExt.pp_print_help (ArgExt.SubCommand cmd) Format.err_formatter global_args ();
- Globals.msg "%s\n" msg;
+ Globals.error "%s" msg;
exit 1;
| Failure ("no subcommand defined" as s) ->
ArgExt.pp_print_help ArgExt.NoSubCommand Format.err_formatter global_args ();
- Globals.msg "%s\n" s;
+ Globals.error "%s" s;
exit 2
| Globals.Exit i -> exit i
| e -> raise e
View
94 src/parallel.ml
@@ -23,6 +23,10 @@ module type G = sig
val string_of_vertex: V.t -> string
end
+type error =
+ | Process_error of Process.result
+ | Internal_error of string
+
module type SIG = sig
module G : G
@@ -38,7 +42,7 @@ module type SIG = sig
post:(G.V.t -> unit) ->
unit
- exception Errors of G.V.t list
+ exception Errors of (G.V.t * error) list * G.V.t list
end
@@ -52,7 +56,7 @@ module Make (G : G) = struct
type t = {
graph : G.t ;
- visited_node: IntSet.t ; (* [int] represents the hash of [G.V.t] *)
+ visited_node: S.t ;
roots : S.t ;
degree : int M.t ;
}
@@ -82,15 +86,15 @@ module Make (G : G) = struct
todo
)
) graph S.empty in
- { graph ; roots ; degree = !degree ; visited_node = IntSet.empty }
+ { graph ; roots ; degree = !degree ; visited_node = S.empty }
let visit t x =
- if IntSet.mem (G.V.hash x) t.visited_node then
+ if S.mem 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
+ let t = { t with visited_node = S.add 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
@@ -142,29 +146,67 @@ module Make (G : G) = struct
) in
aux ()
- exception Errors of G.V.t list
+ exception Errors of (G.V.t * error) list * G.V.t list
+
+ let (--) = S.diff
+ let (++) = S.union
+ let (=|=) s1 s2 =
+ S.cardinal s1 = S.cardinal s2
+
+ let (/) = Filename.concat
+ let pid_dir = Filename.temp_dir_name / "opam.pid"
+ let pid_file pid = pid_dir / string_of_int pid
+
+ let write_error r =
+ Run.mkdir pid_dir;
+ let pid = Unix.getpid () in
+ log "write_error[%d]" pid;
+ let oc = open_out_bin (pid_file pid) in
+ Marshal.to_channel oc r [];
+ close_out oc
+
+ let read_error pid =
+ log "read_error[%d]" pid;
+ let ic = open_in_bin (pid_file pid) in
+ let r : error = Marshal.from_channel ic in
+ close_in ic;
+ r
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
- let errors = ref S.empty in
-
+ let errors = ref M.empty in
+
+ (* All the node with a current worker currently doing some processing. *)
+ let worker_nodes () =
+ IntMap.fold (fun _ n accu -> S.add n accu) !pids S.empty in
+ (* All the error nodes. *)
+ let error_nodes () =
+ M.fold (fun n _ accu -> S.add n accu) !errors S.empty in
+ (* All the node not successfully proceeded. This include error worker and error nodes. *)
+ let remaining_nodes () =
+ G.fold_vertex S.add !t.graph S.empty in
+
log "Iterate over %d task(s) with %d process(es)" (G.nb_vertex g) n;
(* nslots is the number of free slots *)
let rec loop nslots =
- if S.is_empty !t.roots || not (S.is_empty !errors) && S.compare !t.roots !errors = 0 then
+ if IntMap.is_empty !pids
+ && (S.is_empty !t.roots || not (M.is_empty !errors) && !t.roots =|= error_nodes ()) then
(* Nothing more to do *)
- if S.is_empty !errors then
+ if M.is_empty !errors then
log "loop completed (without errors)"
else
- raise (Errors (S.elements !errors))
+ let remaining = remaining_nodes () -- error_nodes () in
+ raise (Errors (M.bindings !errors, S.elements remaining))
+
+ else if nslots <= 0 || (worker_nodes () ++ error_nodes ()) =|= !t.roots then (
- else if nslots <= 0 || IntMap.cardinal !pids + S.cardinal !errors = S.cardinal !t.roots then (
- (* if no slots are available, wait for a child process to finish *)
+ (* if either 1/ no slots are available or 2/ no action can be performed,
+ then wait for a child process to finish its work *)
log "waiting for a child process to finish";
let pid, status = wait !pids in
let n = IntMap.find pid !pids in
@@ -174,20 +216,18 @@ module Make (G : G) = struct
t := visit !t n;
post n
| _ ->
- errors := S.add n !errors);
- loop (succ nslots)
+ let error = read_error pid in
+ errors := M.add n error !errors);
+ loop (nslots + 1)
) else (
+ (* otherwise, if the todo list is empty, then refill it *)
if S.is_empty !todo then (
log "refilling the TODO list";
- (* otherwise, if the todo list is empty, refill it if *)
- todo :=
- S.fold S.remove !errors
- (IntMap.fold (fun _ n accu -> S.remove n accu) !pids !t.roots)
+ todo := !t.roots -- worker_nodes () -- error_nodes ();
);
(* finally, if the todo list contains at least a node action,
- not yet processed with errors,
then simply process it *)
let n = S.choose !todo in
todo := S.remove n !todo;
@@ -195,13 +235,19 @@ module Make (G : G) = struct
| -1 -> Globals.error_and_exit "Cannot fork a new process"
| 0 ->
log "Spawning a new process";
+ let aux p =
+ write_error p;
+ exit 1 in
begin
try child n; log "OK"; exit 0
- with
- | Globals.Exit _ -> exit 1
+ with
+ | Run.Process_error p -> aux (Process_error p)
+ | Run.Internal_error s -> aux (Internal_error s)
| e ->
- Globals.error "%s" (Printexc.to_string e);
- exit 1
+ let b = Printexc.get_backtrace () in
+ let e = Printexc.to_string e in
+ let error = if b = "" then e else Printf.sprintf "%s\n%s" e b in
+ aux (Internal_error error)
end
| pid ->
log "Creating process %d" pid;
View
7 src/parallel.mli
@@ -23,6 +23,10 @@ module type G = sig
val string_of_vertex: V.t -> string
end
+type error =
+ | Process_error of Process.result
+ | Internal_error of string
+
(** Functor signature *)
module type SIG = sig
@@ -39,7 +43,8 @@ module type SIG = sig
post:(G.V.t -> unit) ->
unit
- exception Errors of G.V.t list
+ (** Errors ([errors], [remaining]) *)
+ exception Errors of (G.V.t * error) list * G.V.t list
end
View
19 src/process.ml
@@ -124,8 +124,8 @@ let wait p =
| _ -> iter () in
iter ()
with e ->
- Printf.printf "Exception %s in waitpid\n%!" (Printexc.to_string e);
- raise (Globals.Exit 2)
+ Globals.error "Exception %s in waitpid" (Printexc.to_string e);
+ Globals.exit 2
let output_lines oc lines =
List.iter (fun line ->
@@ -147,8 +147,8 @@ let run ?env ~verbose ~name cmd args =
(* Write info file *)
let chan = open_out info in
output_lines chan
- [ String.concat " " (cmd :: args) ;
- Unix.getcwd () ;
+ [ Printf.sprintf "[RUN] %S" (String.concat " " (cmd :: args)) ;
+ Printf.sprintf "[CWD] %S" (Unix.getcwd ()) ;
String.concat "\n" (Array.to_list env)
];
close_out chan;
@@ -156,8 +156,8 @@ let run ?env ~verbose ~name cmd args =
let p = create ~env ~info ~stdout ~stderr ~verbose cmd args in
wait p
with e ->
- Printf.printf "Exception %s in run\n%!" (Printexc.to_string e);
- raise (Globals.Exit 2)
+ Globals.error "Exception %s in run" (Printexc.to_string e);
+ Globals.exit 2
let is_success r = r.r_code = 0
@@ -174,3 +174,10 @@ let clean_files r =
option_iter safe_unlink r.r_proc.p_stdout;
option_iter safe_unlink r.r_proc.p_stderr;
option_iter safe_unlink r.r_proc.p_info
+
+let display_error_message r =
+ if is_failure r then (
+ List.iter (Globals.error "= %s") r.r_info;
+ List.iter (Globals.error ". %s") r.r_stdout;
+ List.iter (Globals.error "* %s") r.r_stderr;
+ )
View
2  src/process.mli
@@ -67,3 +67,5 @@ val clean_files : result -> unit
(** {2 Misc} *)
val read_lines: string -> string list
+
+val display_error_message: result -> unit
View
66 src/repo/curl.ml
@@ -33,9 +33,7 @@ let make_state ~download_index remote_path =
let index =
if download_index then (
Filename.remove local_index_file;
- match Filename.download index_file local_path with
- | None -> Globals.error_and_exit "Cannot get urls.txt"
- | Some f -> f
+ Filename.download index_file local_path
) else
local_index_file in
let remote_local, local_remote, local_files, file_permissions, file_digests =
@@ -75,17 +73,14 @@ module B = struct
let init address =
let state = make_state ~download_index:true address in
- let warning () =
- Globals.msg "Cannot find index.tar.gz on the OPAM repository.\n\
- Initialisation might take some time ...\n" in
-
(* Download index.tar.gz *)
- try match Filename.download state.remote_index_archive state.local_path with
- | None -> warning ()
- | Some _ ->
- (* Untar the files *)
- Filename.extract_in state.local_index_archive state.local_path
- with _ -> warning ()
+ try
+ let file = Filename.download state.remote_index_archive state.local_path in
+ Filename.extract_in file state.local_path
+ with _ ->
+ Globals.msg
+ "Cannot find index.tar.gz on the OPAM repository.\n\
+ Initialisation might take some time ...\n"
let curl ~remote_file ~local_file =
log "dowloading %s" (Filename.to_string remote_file);
@@ -146,33 +141,32 @@ module B = struct
let local_dir = Filename.dirname local_file in
Dirname.mkdir local_dir;
Globals.msg "Downloading %s ...\n" (Filename.to_string remote_file);
- match Filename.download remote_file local_dir with
- | None -> Globals.error_and_exit "Cannot download %s" (Filename.to_string remote_file);
- | Some local_file ->
- if not (Filename.exists local_file) then
- (* This may happen with empty files *)
- Filename.touch local_file;
- begin
- try
- let perm = List.assoc local_file state.file_permissions in
- Filename.chmod local_file perm
- with Not_found ->
- ()
- end;
- if not (is_up_to_date state local_file) then
- Globals.error_and_exit "Wrong checksum for %s" (Filename.to_string remote_file);
- Result local_file
+ let local_file = Filename.download remote_file local_dir in
+ if not (Filename.exists local_file) then
+ (* This may happen with empty files *)
+ Filename.touch local_file;
+ begin
+ try
+ let perm = List.assoc local_file state.file_permissions in
+ Filename.chmod local_file perm
+ with Not_found ->
+ ()
+ end;
+ if not (is_up_to_date state local_file) then
+ Run.internal_error "Wrong checksum for %s" (Filename.to_string remote_file);
+ Result local_file
end
end
- (* XXX: use checksums *)
let download_file nv remote_file =
let local_repo = Path.R.cwd () in
let dest_dir = Path.R.tmp_dir local_repo nv in
Globals.msg "Downloading %s ...\n" (Filename.to_string remote_file);
- match Filename.download remote_file dest_dir with
- | None -> Not_available
- | Some f -> Result f
+ try
+ let file = Filename.download remote_file dest_dir in
+ Result file
+ with _ ->
+ Not_available
let not_supported action =
failwith (action ^ ": not supported by CURL backend")
@@ -206,11 +200,9 @@ let make_index_tar_gz local_repo =
Dirname.in_dir (Path.R.root local_repo) (fun () ->
let dirs = [ "compilers"; "packages" ] in
let dirs = List.filter Sys.file_exists dirs in
- let err = Run.command [
+ Run.command [
"sh"; "-c"; "tar cz " ^ (String.concat " " dirs) ^ "> index.tar.gz"
- ] in
- if err <> 0 then
- Globals.error_and_exit "Cannot create index.tar.gz";
+ ]
)
let () =
View
51 src/repo/git.ml
@@ -5,46 +5,29 @@ let log fmt = Globals.log "GIT" fmt
let git_fetch local_path remote_address =
Globals.msg "Fetching %s ...\n" (Dirname.to_string remote_address);
Dirname.in_dir local_path (fun () ->
- let err = Run.command [ "git" ; "fetch" ; "origin" ] in
- if err <> 0 then
- Globals.error_and_exit
- "Cannot fetch git repository %s"
- (Dirname.to_string local_path)
+ Run.command [ "git" ; "fetch" ; "origin" ]
)
let git_merge local_path =
Dirname.in_dir local_path (fun () ->
- let err = Run.command [ "git" ; "merge" ; "origin/master" ] in
- if err <> 0 then
- Globals.error_and_exit
- "Cannot update git repository %s"
- (Dirname.to_string local_path)
- )
+ Run.command [ "git" ; "merge" ; "origin/master" ]
+ )
(* Return the list of modified files of the git repository located
at [dirname] *)
let git_diff local_path =
Dirname.in_dir local_path (fun () ->
- match
- Run.read_command_output
- [ "git" ; "diff" ; "remotes/origin/master" ; "--name-only" ]
- with
- | Some fs -> Filename.Set.of_list (List.map Filename.of_string fs)
- | None ->
- Globals.error_and_exit
- "Cannot diff git repository %s"
- (Dirname.to_string local_path)
+ let lines = Run.read_command_output
+ [ "git" ; "diff" ; "remotes/origin/master" ; "--name-only" ] in
+ Filename.Set.of_list (List.map Filename.of_string lines)
)
let git_init address =
let repo = Dirname.to_string address in
- let err =
- Run.commands [
- [ "git" ; "init" ] ;
- [ "git" ; "remote" ; "add" ; "origin" ; repo ] ;
- ] in
- if err <> 0 then
- Globals.error_and_exit "Cannot clone %s" repo
+ Run.commands [
+ [ "git" ; "init" ] ;
+ [ "git" ; "remote" ; "add" ; "origin" ; repo ] ;
+ ]
let check_updates local_path remote_address=
if Dirname.exists (local_path / ".git") then begin
@@ -112,14 +95,14 @@ module B = struct
let upload_dir ~address dirname =
let files = Filename.rec_list dirname in
- let err = Run.commands [
- [ "git"; "add"; Dirname.to_string dirname; ];
- [ "git"; "commit"; "-a"; "-m"; "upload new files" ];
- [ "git"; "push"; "origin"; "master" ]
- ] in
- if err = 0 then
+ try
+ Run.commands [
+ [ "git"; "add"; Dirname.to_string dirname; ];
+ [ "git"; "commit"; "-a"; "-m"; "upload new files" ];
+ [ "git"; "push"; "origin"; "master" ]
+ ];
Filename.Set.of_list files
- else
+ with _ ->
Filename.Set.empty
end
View
27 src/repo/rsync.ml
@@ -9,15 +9,16 @@ let rsync ?(delete=true) src dst =
Run.mkdir src;
Run.mkdir dst;
let delete = if delete then ["--delete"] else [] in
- match
- Run.read_command_output (["rsync" ; "-arv"; src; dst] @ delete)
- with
- | None -> Not_available
- | Some l -> match Utils.rsync_trim l with
+ try
+ let lines = Run.read_command_output (["rsync" ; "-arv"; src; dst] @ delete) in
+ match Utils.rsync_trim lines with
| [] -> Up_to_date []
| lines ->
- List.iter (fun f -> log "updated: %s %s" (Run.cwd ()) f) lines;
+ let cwd = Unix.getcwd () in
+ List.iter (fun l -> log "updated: %s %s" cwd l) lines;
Result lines
+ with _ ->
+ Not_available
) else
Up_to_date []
@@ -41,19 +42,19 @@ let rsync_dirs ?delete src dst =
let rsync_file src dst =
log "rsync_file src=%s dst=%s" (Filename.to_string src) (Filename.to_string dst);
- match
- Run.read_command_output [
+ try
+ let lines = Run.read_command_output [
"rsync"; "-av"; Filename.to_string src; Filename.to_string dst;
- ]
- with
- | None -> Not_available
- | Some l -> match Utils.rsync_trim l with
+ ] in
+ match Utils.rsync_trim lines with
| [] -> Up_to_date dst
| [x] -> Result dst
| l ->
- Globals.error_and_exit
+ Run.internal_error
"unknown rsync output: {%s}"
(String.concat ", " l)
+ with _ ->
+ Not_available
module B = struct
View
6 src/repositories.ml
@@ -183,11 +183,9 @@ let make_archive nv =
Dirname.mkdir (Path.R.archives_dir local_repo);
let local_archive = Path.R.archive local_repo nv in
log "Creating the archive files in %s" (Filename.to_string local_archive);
- let err = Dirname.exec extract_root [
+ Dirname.exec extract_root [
[ "tar" ; "czf" ; Filename.to_string local_archive ; NV.to_string nv ]
- ] in
- if err <> 0 then
- Globals.error_and_exit "Cannot compress %s" (Dirname.to_string extract_dir)
+ ]
)
(* Download the archive on the OPAM server.
View
140 src/run.ml
@@ -13,6 +13,15 @@
(* *)
(***********************************************************************)
+exception Process_error of Process.result
+exception Internal_error of string
+
+let internal_error fmt =
+ Printf.kprintf (fun str -> raise (Internal_error str)) fmt
+
+let process_error r =
+ raise (Process_error r)
+
module Sys2 = struct
open Unix
@@ -97,22 +106,16 @@ let write file contents =
output_string oc contents;
close_out oc
-let cwd = Unix.getcwd
-
let chdir dir =
- if Sys.file_exists dir then
+ if Sys.file_exists dir then (
Unix.chdir dir
- else
- Globals.error_and_exit "%s does not exist!" dir
+ ) else
+ internal_error "%s does not exist!" dir
let in_dir dir fn =
let reset_cwd =
- try
- let cwd = Unix.getcwd () in
- fun () -> chdir cwd
- with _ ->
- (* can happen when the current directory has been deleted *)
- fun () -> () in
+ let cwd = Unix.getcwd () in
+ fun () -> chdir cwd in
chdir dir;
try
let r = fn () in
@@ -183,7 +186,7 @@ let remove file =
let getchdir s =
let p = Unix.getcwd () in
- let () = chdir s in
+ chdir s;
p
let rec root path =
@@ -255,37 +258,22 @@ let run_process ?verbose ?(add_to_env=[]) ?(add_to_path=[]) = function
Process.clean_files r;
r
-let display_error_message r =
- if Process.is_failure r then (
- let command = r.Process.r_proc.Process.p_name :: r.Process.r_proc.Process.p_args in
- Globals.error "Command %S failed:" (String.concat " " command);
- List.iter (Globals.msg "+ %s\n") r.Process.r_stdout;
- List.iter (Globals.msg "= %s\n") r.Process.r_info;
- List.iter (Globals.msg "- %s\n") r.Process.r_stderr;
- )
-
let command ?verbose ?(add_to_env=[]) ?(add_to_path=[]) cmd =
let r = run_process ?verbose ~add_to_env ~add_to_path cmd in
- display_error_message r;
- r.Process.r_code
-
-let fold f =
- List.fold_left (fun err cmd ->
- match err, cmd with
- | _ , [] -> err
- | 0 , _ -> f cmd
- | err, _ -> err
- ) 0
+ if Process.is_success r then
+ ()
+ else
+ process_error r
-let commands ?verbose ?(add_to_env=[]) ?(add_to_path = []) =
- fold (command ?verbose ~add_to_env ~add_to_path)
+let commands ?verbose ?(add_to_env=[]) ?(add_to_path = []) commands =
+ List.iter (command ?verbose ~add_to_env ~add_to_path) commands
let read_command_output ?(add_to_env=[]) ?(add_to_path=[]) cmd =
let r = run_process ~add_to_env ~add_to_path cmd in
- if Process.is_failure r then
- None
+ if Process.is_success r then
+ r.Process.r_stdout
else
- Some r.Process.r_stdout
+ process_error r
module Tar = struct
@@ -326,19 +314,15 @@ let extract file dst =
log "%s contains %d files: %s" file (List.length files) (String.concat ", " files); *)
with_tmp_dir (fun tmp_dir ->
match Tar.extract_function file with
- | None -> Globals.error_and_exit "%s is not a valid archive" file
+ | None -> internal_error "%s is not a valid archive" file
| Some f ->
- let err = f tmp_dir in
- if err <> 0 then
- Globals.error_and_exit "Error while extracting %s" file;
- if Sys.file_exists dst then
- Globals.error_and_exit "Cannot overwrite %s" dst;
+ f tmp_dir;
+ if Sys.file_exists dst then internal_error "Cannot overwrite %s" dst;
match directories_strict tmp_dir with
| [x] ->
mkdir (Filename.dirname dst);
- let err = command [ "mv"; x; dst] in
- if err <> 0 then Globals.error_and_exit "Cannot mv %s to %s" x dst
- | _ -> Globals.error_and_exit "The archive contains mutliple root directories"
+ command [ "mv"; x; dst]
+ | _ -> internal_error "The archive contains mutliple root directories"
)
let extract_in file dst =
@@ -346,11 +330,8 @@ let extract_in file dst =
if not (Sys.file_exists dst) then
Globals.error_and_exit "%s does not exist" file;
match Tar.extract_function file with
- | None -> Globals.error_and_exit "%s is not a valid archive" file
- | Some f ->
- let err = f dst in
- if err <> 0 then
- Globals.error_and_exit "Error while extracting %s" file
+ | None -> internal_error "%s is not a valid archive" file
+ | Some f -> f dst
let link src dst =
log "linking %s to %s" src dst;
@@ -412,45 +393,46 @@ let with_flock f =
raise e
let ocaml_version () =
- match read_command_output [ "ocamlc" ; "-version" ] with
- | None -> None
- | Some s -> Some (Utils.string_strip (List.hd s))
+ try
+ match read_command_output [ "ocamlc" ; "-version" ] with
+ | h::_ -> Some (Utils.string_strip h)
+ | [] -> internal_error "ocamlc -version"
+ with _ ->
+ None
let ocamlc_where () =
- match read_command_output [ "ocamlc"; "-where" ] with
- | None -> None
- | Some s -> Some (Utils.string_strip (List.hd s))
+ try
+ match read_command_output [ "ocamlc"; "-where" ] with
+ | h::_ -> Some (Utils.string_strip h)
+ | [] -> internal_error "ocamlc -where"
+ with _ ->
+ None
let download_command =
- let err_curl = command ~verbose:false ["which"; "curl"] in
- if err_curl = 0 then
- (fun src -> [ "curl"; "--insecure" ; "-OL"; src ])
- else
- let err_wget = command ~verbose:false ["which"; "wget"] in
- if err_wget = 0 then
+ try
+ command ~verbose:false ["which"; "curl"];
+ (fun src -> [ "curl"; "--insecure" ; "-OL"; src ])
+ with Process_error _ ->
+ try
+ command ~verbose:false ["which"; "wget"];
(fun src -> [ "wget"; "--no-check-certificate" ; src ])
- else
- Globals.error_and_exit "Cannot find curl nor wget"
+ with Process_error _ ->
+ internal_error "Cannot find curl nor wget"
let download ~filename:src ~dirname:dst =
let cmd = download_command src in
let dst_file = dst / Filename.basename src in
log "download %s in %s (%b)" src dst_file (src = dst_file);
- let e =
- if dst_file = src then
- 0
- else if Sys.file_exists src then
- commands [
- [ "rm"; "-f"; dst_file ];
- [ "cp"; src; dst ]
- ]
- else
- in_dir dst (fun () -> command cmd) in
- if e = 0 then
- Some dst_file
+ if dst_file = src then
+ ()
+ else if Sys.file_exists src then
+ commands [
+ [ "rm"; "-f"; dst_file ];
+ [ "cp"; src; dst ]
+ ]
else
- None
+ in_dir dst (fun () -> command cmd);
+ dst_file
let patch p =
- let err = command ["patch"; "-p0"; "-i"; p] in
- err = 0
+ command ["patch"; "-p0"; "-i"; p]
View
30 src/run.mli
@@ -15,6 +15,20 @@
(** Low-level untyped system operations. *)
+(** Exception raised when subprocess fails *)
+exception Process_error of Process.result
+
+(** raise [Process_error] *)
+val process_error: Process.result -> 'a
+
+(** Exception raised when a computation in the current process
+ fails. *)
+exception Internal_error of string
+
+(** Raise [Internal_error] *)
+val internal_error: ('a, unit, string, 'b) format4 -> 'a
+
+
(** [with_tmp_dir fn] executes [fn] in a tempory directory *)
val with_tmp_dir: (string -> 'a) -> 'a
@@ -79,7 +93,7 @@ type command = string list
val command:
?verbose:bool ->
?add_to_env:(string*string) list ->
- ?add_to_path:string list -> command -> int
+ ?add_to_path:string list -> command -> unit
(** [commands ~add_to_path cmds] executes the commands [cmds]
in a context where $PATH contains [add_to_path] at the beginning.
@@ -87,13 +101,13 @@ val command:
val commands:
?verbose:bool ->
?add_to_env:(string*string) list ->
- ?add_to_path:string list -> command list -> int
+ ?add_to_path:string list -> command list -> unit
(** [read_command_output cmd] executes the command [cmd] and return
the lines from stdout *)
val read_command_output:
?add_to_env:(string*string) list ->
- ?add_to_path:string list -> command -> string list option
+ ?add_to_path:string list -> command -> string list
(** Test whether the file is an archive, by looking as its extension *)
val is_tar_archive: string -> bool
@@ -107,9 +121,6 @@ val extract: string -> string -> unit
[dirname]. [dirname] should already exists. *)
val extract_in: string -> string -> unit
-(** Return the current working directory *)
-val cwd: unit -> string
-
(** Create a directory. Do not fail if the directory already
exist. *)
val mkdir: string -> unit
@@ -131,8 +142,7 @@ val with_flock: (unit -> unit) -> unit
(** {2 Function used only by the switch commnand} *)
(** download compiler sources *)
-val download: filename:string -> dirname:string -> string option
+val download: filename:string -> dirname:string -> string
-(** Apply a patch file in the current directory. Return whether the
- patch has been applied succesfully. *)
-val patch: string -> bool
+(** Apply a patch file in the current directory. *)
+val patch: string -> unit
View
5 src/scripts/opam_repo_convert.ml
@@ -258,9 +258,8 @@ module URL_X = struct
let remote_file = Utils.string_strip (Raw.to_string t) in
let checksum =
Dirname.with_tmp_dir (fun tmp_dir ->
- match Filename.download (Filename.raw remote_file) tmp_dir with
- | None -> Globals.error_and_exit "Cannot download %s" remote_file
- | Some local_file -> Filename.digest local_file
+ let local_file = Filename.download (Filename.raw remote_file) tmp_dir in
+ Filename.digest local_file
) in
File.URL.create ~checksum remote_file
end
View
3  src/solver.mli
@@ -33,6 +33,9 @@ type action =
(** The package is already installed, but it must be recompiled. *)
| To_recompile of NV.t
+(** Pretty-printing of actions *)
+val string_of_action: action -> string
+
(** Package with associated build action *)
type package_action
View
48 src/types.ml
@@ -137,8 +137,7 @@ module Dirname: sig
val in_dir: t -> (unit -> 'a) -> 'a
val exec: t ->
?add_to_env:(string*string) list ->
- ?add_to_path:t list -> string list list -> int
- val chdir: t -> unit
+ ?add_to_path:t list -> string list list -> unit
val move: t -> t -> unit
val copy: t -> t -> unit
val dirname: t -> t
@@ -173,7 +172,7 @@ end = struct
Run.remove (to_string dirname)
let cwd () =
- of_string (Run.cwd ())
+ of_string (Unix.getcwd ())
let mkdir dirname =
Run.mkdir (to_string dirname)
@@ -196,19 +195,12 @@ end = struct
~add_to_path:(List.map of_string add_to_path)
cmds)
- let chdir dirname =
- Run.chdir (to_string dirname)
-
let move src dst =
- let err = Run.command [ "mv"; to_string src; to_string dst ] in
- if err <> 0 then
- Globals.exit err
+ Run.command [ "mv"; to_string src; to_string dst ]
let copy src dst =
with_tmp_dir (fun tmp ->
- let err = Run.command [ "rsync"; "-a"; Filename.concat (to_string src) "/"; to_string tmp ] in
- if err <> 0 then
- Globals.exit err;
+ Run.command [ "rsync"; "-a"; Filename.concat (to_string src) "/"; to_string tmp ];
match list tmp with
| [f] ->
rmdir dst;
@@ -277,9 +269,9 @@ module Filename: sig
val extract_in: t -> dirname -> unit
val starts_with: dirname -> t -> bool
val remove_prefix: prefix:dirname -> t -> string
- val download: t -> dirname -> t option
- val download_iter: t list -> dirname -> t option
- val patch: t -> dirname -> bool
+ val download: t -> dirname -> t
+ val download_iter: t list -> dirname -> t
+ val patch: t -> dirname -> unit
val digest: t -> Digest.t
val touch: t -> unit
val chmod: t -> int -> unit
@@ -370,9 +362,7 @@ end = struct
Run.copy (to_string src) (to_string dst)
let move src dst =
- let err = Run.command [ "mv"; to_string src; to_string dst ] in
- if err <> 0 then
- Globals.exit err
+ Run.command [ "mv"; to_string src; to_string dst ]
let link src dst =
if Globals.os = Globals.Win32 then
@@ -404,17 +394,17 @@ end = struct
let download filename dirname =
Dirname.mkdir dirname;
- match Run.download ~filename:(to_string filename) ~dirname:(Dirname.to_string dirname) with
- | None -> None
- | Some f -> Some (of_string f)
-
- let rec download_iter filenames dirname =
- match filenames with
- | [] -> None
- | h::t ->
- match download h dirname with
- | None -> download_iter t dirname
- | x -> x
+ let file = Run.download ~filename:(to_string filename) ~dirname:(Dirname.to_string dirname) in
+ of_string file
+
+ let download_iter filenames dirname =
+ let rec aux = function
+ | [] ->
+ Run.internal_error "Cannot download %s" (String.concat ", " (List.map to_string filenames))
+ | h::t ->
+ try download h dirname
+ with _ -> aux t in
+ aux filenames
let patch filename dirname =
Dirname.in_dir dirname (fun () -> Run.patch (to_string filename))
View
11 src/types.mli
@@ -120,10 +120,7 @@ module Dirname: sig
(** Execute a list of commands in a given directory *)
val exec: t
-> ?add_to_env:(string * string) list
- -> ?add_to_path:t list -> string list list -> int
-
- (** Change the current directory *)
- val chdir: t -> unit
+ -> ?add_to_path:t list -> string list list -> unit
(** Move a directory *)
val move: t -> t -> unit
@@ -254,13 +251,13 @@ module Filename: sig
(** download a remote file in a given directory. Return the location
of the downloaded file if the download is successful. *)
- val download: t -> dirname -> t option
+ val download: t -> dirname -> t
(** iterate downloads until one is sucessful *)
- val download_iter: t list -> dirname -> t option
+ val download_iter: t list -> dirname -> t
(** Apply a patch to a directory *)
- val patch: t -> dirname -> bool
+ val patch: t -> dirname -> unit
(** Compute the MD5 digest of a file *)
val digest: t -> string
View
17 src/utils.ml
@@ -22,9 +22,20 @@ let filter_map f l =
| Some x -> loop (x::accu) t in
loop [] l
-module IntMap = Map.Make(struct type t = int let compare = compare end)
-module StringMap = Map.Make(struct type t = string let compare = compare end)
-module IntSet = Set.Make(struct type t = int let compare = compare end)
+module OInt = struct
+ type t = int
+ let compare = compare
+end
+
+module IntMap = Map.Make(OInt)
+module IntSet = Set.Make(OInt)
+
+module OString = struct
+ type t = string
+ let compare = compare
+end
+
+module StringMap = Map.Make(OString)
let (|>) f g x = g (f x)
Please sign in to comment.
Something went wrong with that request. Please try again.