Permalink
Browse files

Fix git and server backends

Now all the basic functional tests pass again.
  • Loading branch information...
samoht committed Aug 13, 2012
1 parent 705cfb3 commit cdb7aa84e5574428e340d4d8c0af3ec3a87499f4
View
@@ -9,6 +9,8 @@ things, used by Debian to manage their packages.
* ocaml
* curl
+* git
+* rsync
### Compiling OPAM
View
@@ -458,7 +458,7 @@ let update_package () =
)) (depends @ depopts)
) (get_available_current t);
if !has_error then
- Globals.exit 66
+ Globals.exit 1
let update () =
log "update";
View
@@ -124,22 +124,14 @@ module URL = struct
end
-module Installed = struct
+module Updated = struct
- let internal = "installed"
+ let internal = "updated"
type t = NV.Set.t
let empty = NV.Set.empty
- let check t =
- let map = NV.to_map t in
- N.Map.iter (fun n vs ->
- if V.Set.cardinal vs <> 1 then
- Globals.error_and_exit "Multiple versions installed for package %s: %s"
- (N.to_string n) (V.Set.to_string vs)
- ) map
-
let of_string f s =
let lines = Lines.of_string f s in
let map = ref empty in
@@ -152,7 +144,6 @@ module Installed = struct
!map
let to_string _ t =
- check t;
let buf = Buffer.create 1024 in
NV.Set.iter
(fun nv -> Printf.bprintf buf "%s %s\n" (N.to_string (NV.name nv)) (V.to_string (NV.version nv)))
@@ -161,19 +152,31 @@ module Installed = struct
end
-module Reinstall = struct
+module Installed = struct
- include Installed
+ include Updated
- let internal = "reinstall"
+ let internal = "installed"
+
+ let check t =
+ let map = NV.to_map t in
+ N.Map.iter (fun n vs ->
+ if V.Set.cardinal vs <> 1 then
+ Globals.error_and_exit "Multiple versions installed for package %s: %s"
+ (N.to_string n) (V.Set.to_string vs)
+ ) map
+
+ let to_string f t =
+ check t;
+ Updated.to_string f t
end
-module Updated = struct
+module Reinstall = struct
include Installed
- let internal = "updated"
+ let internal = "reinstall"
end
@@ -5,6 +5,6 @@ open Repositories
let () =
let d = Repositories.read_download_info () in
- match Filename.download d.remote_filename d.local_path with
+ match Filename.download (Filename.create d.remote_dir d.basename) d.local_dir with
| None -> exit 1
| Some f -> Printf.printf "%s" (Filename.to_string f)
View
@@ -7,11 +7,11 @@ let log fmt = Globals.log "git-download" fmt
let git_clone_or_update git_dir d =
log "git-clone-or-update %s" (Dirname.to_string git_dir);
- let url = Filename.to_string d.remote_filename in
+ let url = Filename.to_string (Filename.create d.remote_dir d.basename) in
(* If the git repo is not already there, then clone it *)
if not (Dirname.exists git_dir) then (
let err = Run.command [
- "git" ; "clone" ; url ; NV.to_string d.nv
+ "git" ; "clone" ; "-q"; url ; NV.to_string d.nv
] in
if err <> 0 then
Globals.error_and_exit "%s is not a valid git url" url
@@ -22,6 +22,6 @@ let git_clone_or_update git_dir d =
let () =
let d = Repositories.read_download_info () in
- let git_dir = d.local_path / NV.to_string d.nv in
+ let git_dir = d.local_dir / NV.to_string d.nv in
git_clone_or_update git_dir d;
Printf.printf "%s\n%!" (Dirname.to_string git_dir)
View
@@ -1,27 +1,29 @@
(* Download scrip for rsync-ed repositories *)
let check_suffix = Filename.check_suffix
+module F = Filename
open Types
open Repo_helpers
open Repositories
let is_archive f =
- let f = Filename.to_string f in
+ let f = Basename.to_string f in
List.exists
(fun suff -> check_suffix f suff)
[ "tgz"; "bgz"; "tar.gz"; "tar.bz2" ]
let () =
let d = Repositories.read_download_info () in
- if not (is_archive d.remote_filename) then (
- let remote_dir = Dirname.of_string (Filename.to_string d.remote_filename) in
- let local_dir = d.local_path / NV.to_string d.nv in
+ if not (is_archive d.basename) then (
+ let remote_dir = d.remote_dir / Basename.to_string d.basename in
+ let local_dir = d.local_dir / NV.to_string d.nv in
let _files = Rsync.rsync_dirs remote_dir local_dir in
Printf.printf "%s\n%!" (Dirname.to_string local_dir)
) else (
- let local_file = Filename.create d.local_path (Filename.basename d.remote_filename) in
- let _file = Rsync.rsync_file d.remote_filename local_file in
+ let remote_file = Filename.create d.remote_dir d.basename in
+ let local_file = d.local_dir // F.basename (Basename.to_string d.basename) in
+ let _file = Rsync.rsync_file remote_file local_file in
Printf.printf "%s\n%!" (Filename.to_string local_file)
)
@@ -1,23 +1,20 @@
(* Download script for OPAM server repositories *)
-let _ =
- if Array.length Sys.argv <> 3 then (
- Printf.eprintf "Usage: %s <remote-address> <package>" Sys.argv.(0);
- exit 1
- )
+module F = Filename
open Types
+open Repositories
open Protocol
open Unix
-let local_path = Path.R.of_dirname (Dirname.cwd ())
-let remote_address =
- try inet_addr_of_string Sys.argv.(1)
- with _ ->
- (gethostbyname Sys.argv.(1)).h_addr_list.(0)
-
-let package = NV.of_string Sys.argv.(2)
-
let () =
- let archive = Client.get_archive remote_address package in
- Filename.write (Path.R.archive local_path package) archive
+ let d = Repositories.read_download_info () in
+ let remote_address =
+ let server = Dirname.to_string d.remote_dir in
+ try inet_addr_of_string server
+ with _ ->
+ (gethostbyname server).h_addr_list.(0) in
+ let archive = Client.get_archive remote_address d.nv in
+ let local_file = d.local_dir // F.basename (Basename.to_string d.basename) in
+ Filename.write local_file archive;
+ Globals.msg "%s\n%!" (Filename.to_string local_file)
View
@@ -19,32 +19,30 @@ let remote_address =
(gethostbyname Sys.argv.(1)).h_addr_list.(0)
let () =
- let s = Client.get_list remote_address in
- let opams =
- NV.Set.fold (fun nv accu ->
- (nv, Client.get_opam remote_address nv) :: accu
- ) s [] in
- let descrs =
- NV.Set.fold (fun nv accu ->
- (nv, Client.get_descr remote_address nv) :: accu
- ) s [] in
- let available = Path.R.available_packages local_path in
- let updates = ref NV.Set.empty in
- List.iter (fun (nv,c) ->
+ let server_list = Client.get_list remote_address in
+ let client_list = Path.R.available_packages local_path in
+ let updates = NV.Set.diff server_list client_list in
+ log "server-list=%s" (NV.Set.to_string server_list);
+ log "client-list=%s" (NV.Set.to_string client_list);
+ log "updates=%s" (NV.Set.to_string updates);
+ NV.Set.iter (fun nv ->
(* filter out already existing packages *)
- if not (NV.Set.mem nv available) then (
- updates := NV.Set.add nv !updates;
- File.OPAM.write (Path.R.opam local_path nv) c
+ if not (NV.Set.mem nv client_list) then (
+ let opam = Client.get_opam remote_address nv in
+ let descr = Client.get_descr remote_address nv in
+ File.OPAM.write (Path.R.opam local_path nv) opam;
+ File.Descr.write (Path.R.descr local_path nv) descr;
)
- ) opams;
- List.iter (fun (nv,c) ->
- (* filter out already existing packages *)
- if not (NV.Set.mem nv available) then (
- updates := NV.Set.add nv !updates;
- File.Descr.write (Path.R.descr local_path nv) c
+ ) server_list;
+ NV.Set.iter (fun nv ->
+ if not (NV.Set.mem nv server_list) then (
+ Filename.remove (Path.R.opam local_path nv);
+ Filename.remove (Path.R.descr local_path nv);
+ Filename.remove (Path.R.archive local_path nv);
)
- ) descrs;
- File.Updated.write (Path.R.updated local_path) !updates;
+ ) client_list;
+ File.Updated.write (Path.R.updated local_path) updates;
+
let compilers = Client.get_compilers remote_address in
List.iter (fun c ->
let filename = Path.R.compiler local_path (File.Comp.name c) in
View
@@ -44,24 +44,29 @@ let upload r =
run "upload" r []
type download_info = {
- local_path : dirname;
- remote_filename: filename;
- nv : nv;
+ local_dir : dirname;
+ remote_dir: dirname;
+ basename : basename;
+ nv : nv;
}
let string_of_download_info d =
- Printf.sprintf "<remote_filename=%s nv=%s>"
- (Filename.to_string d.remote_filename) (NV.to_string d.nv)
+ Printf.sprintf "<local_dir=%s remote_dir=%s basename=%s nv=%s>"
+ (Dirname.to_string d.local_dir)
+ (Dirname.to_string d.remote_dir)
+ (Basename.to_string d.basename)
+ (NV.to_string d.nv)
let read_download_info () =
- if Array.length Sys.argv <> 3 then (
- Printf.eprintf "Usage: %s <remote-filename> <package>" Sys.argv.(0);
+ if Array.length Sys.argv <> 4 then (
+ Printf.eprintf "Usage: %s <remote-server> <filenane> <package>" Sys.argv.(0);
exit 1
);
- let local_path = Dirname.cwd () in
- let remote_filename = Filename.of_string Sys.argv.(1) in
- let nv = NV.of_string Sys.argv.(2) in
- { local_path; remote_filename; nv }
+ let local_dir = Dirname.cwd () in
+ let remote_dir = Dirname.raw Sys.argv.(1) in
+ let basename = Basename.of_string Sys.argv.(2) in
+ let nv = NV.of_string Sys.argv.(3) in
+ { local_dir; remote_dir; basename; nv }
type file = D of dirname | F of filename | UpToDate
@@ -73,25 +78,34 @@ let file filename =
let download_one kind d =
let cmd = Printf.sprintf "opam-%s-download" kind in
- let output = Dirname.in_dir d.local_path (fun () ->
+ let output = Dirname.in_dir d.local_dir (fun () ->
Run.read_command_output [
- cmd; Filename.to_string d.remote_filename; NV.to_string d.nv;
+ cmd;
+ Dirname.to_string d.remote_dir;
+ Basename.to_string d.basename;
+ NV.to_string d.nv;
]) in
match output with
| None -> None
| Some [] -> Some UpToDate
| Some (f::_) -> Some (file f)
-let rec download_iter local_path nv = function
+let rec download_iter local_dir nv = function
| [] -> None
- | (remote_filename ,kind) :: t ->
- let d = { local_path; remote_filename; nv } in
+ | (remote_dir, basename, kind) :: t ->
+ let d = { local_dir; remote_dir; basename; nv } in
match download_one kind d with
- | None -> download_iter local_path nv t
+ | None -> download_iter local_dir nv t
| r -> r
let kind_of_repository r =
- if Dirname.exists (Repository.address r) then "rsync" else "curl"
+ match Repository.kind r with
+ | "server" -> "server"
+ | x ->
+ if Dirname.exists (Repository.address r) then
+ "rsync"
+ else
+ x
(* Download the archive on the OPAM server.
If it is not there, then:
@@ -104,27 +118,31 @@ let download r nv =
let local_repo = Path.R.create r in
(* If the archive is on the server, download it directly *)
- let remote_filename = Path.R.archive remote_repo nv in
+ let remote_dir = Repository.address r in
+ let remote_file = Path.R.archive remote_repo nv in
+ let basename =
+ Basename.of_string (Filename.remove_prefix remote_dir remote_file) in
let kind = kind_of_repository r in
let d = {
- local_path = Path.R.archives_dir local_repo;
- remote_filename;
+ local_dir = Path.R.archives_dir local_repo;
+ remote_dir;
+ basename;
nv;
} in
match download_one kind d with
| Some UpToDate ->
- log "%s is already downloaded and up-to-date"
- (Filename.to_string remote_filename);
+ log "%s is already downloaded and up-to-date on %s"
+ (Basename.to_string basename) (Dirname.to_string remote_dir);
| Some (F local_file) ->
log "Downloaded %s" (Filename.to_string local_file)
| Some (D _) ->
Globals.error_and_exit
- "Got unexpected folder while downloading %s"
- (Filename.to_string remote_filename)
+ "Got unexpected folder while downloading %s on %s"
+ (Basename.to_string basename) (Dirname.to_string remote_dir)
| None ->
log
- "%s is not on the server, need to build it"
- (Filename.to_string remote_filename);
+ "%s is not on available on %s, need to build it"
+ (Basename.to_string basename) (Dirname.to_string remote_dir);
let url_f = Path.R.url local_repo nv in
let tmp_dir = Path.R.tmp_dir local_repo nv in
let extract_dir = tmp_dir / NV.to_string nv in
@@ -135,14 +153,19 @@ let download r nv =
is specified *)
let urls = File.URL.read url_f in
let urls =
+ let mk s k = Filename.dirname s, Filename.basename s, k in
List.map (function
- | (f,Some k) -> (f,k)
- | (f,None) -> (f, kind)
+ | (f,Some k) -> mk f k
+ | (f,None) -> mk f kind
) urls in
let urls_s =
String.concat " "
(List.map
- (fun (f,k) -> Printf.sprintf "%s:%s" (Filename.to_string f) k)
+ (fun (d,b,k) ->
+ Printf.sprintf "%s:%s:%s"
+ (Dirname.to_string d)
+ (Basename.to_string b)
+ k)
urls) in
log "downloading %s" urls_s;
match download_iter tmp_dir nv urls with
Oops, something went wrong.

0 comments on commit cdb7aa8

Please sign in to comment.