From ae319091e76ae78fee2716f4ad3efdfbbed2c18c Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 14 Aug 2012 22:59:13 +0200 Subject: [PATCH] Fix test suite for the git backend with the new architecture --- src/file.ml | 30 ++++++++++++ src/file.mli | 3 ++ src/repo/curl.ml | 2 +- src/repo/git.ml | 98 ++++++++++++++++++++++++++++++---------- src/repo/git/download.ml | 27 ----------- src/repo/git/init.ml | 35 -------------- src/repo/git/update.ml | 61 ------------------------- src/repo/git/upload.ml | 4 -- src/repo/rsync.ml | 18 ++++---- src/repositories.ml | 26 +++++++++-- src/types.ml | 15 ++++-- src/types.mli | 2 +- 12 files changed, 151 insertions(+), 170 deletions(-) delete mode 100644 src/repo/git/download.ml delete mode 100644 src/repo/git/init.ml delete mode 100644 src/repo/git/update.ml delete mode 100644 src/repo/git/upload.ml diff --git a/src/file.ml b/src/file.ml index ecbe8f028f2..d25453683fa 100644 --- a/src/file.ml +++ b/src/file.ml @@ -73,6 +73,31 @@ end module X = struct +module Filenames = struct + + let internal = "filenames" + + type t = Filename.Set.t + + let empty = Filename.Set.empty + + let of_string f s = + let lines = Lines.of_string f s in + let lines = Utils.filter_map (function + | [] -> None + | [f] -> Some (Filename.of_string f) + | s -> + Globals.error_and_exit "%S is not a valid filename" (String.concat " " s) + ) lines in + Filename.Set.of_list lines + + let to_string f s = + let lines = + List.map (fun f -> [Filename.to_string f]) (Filename.Set.elements s) in + Lines.to_string f lines + +end + module Urls_txt = struct let internal = "urls-txt" @@ -1301,3 +1326,8 @@ module Urls_txt = struct include Urls_txt include Make(Urls_txt) end + +module Filenames = struct + include Filenames + include Make(Filenames) +end diff --git a/src/file.mli b/src/file.mli index cbe440c4231..32b2c30b324 100644 --- a/src/file.mli +++ b/src/file.mli @@ -378,3 +378,6 @@ end (** {2 urls.txt file *} *) module Urls_txt: IO_FILE with type t = (basename * int * string) list + +(** List of filenames *) +module Filenames: IO_FILE with type t = Filename.Set.t diff --git a/src/repo/curl.ml b/src/repo/curl.ml index 30c3bca05e1..3b3592366cd 100644 --- a/src/repo/curl.ml +++ b/src/repo/curl.ml @@ -113,7 +113,7 @@ module B = struct else begin let local_file = Filename.Map.find remote_file state.remote_local in if is_up_to_date state local_file then - Up_to_date + Up_to_date local_file else begin log "dowloading %s" (Filename.to_string remote_file); let local_dir = Filename.dirname local_file in diff --git a/src/repo/git.ml b/src/repo/git.ml index 70793a1ca10..db6443f91a3 100644 --- a/src/repo/git.ml +++ b/src/repo/git.ml @@ -1,5 +1,4 @@ open Types -open Repo_helpers let log fmt = Globals.log "git" fmt @@ -29,37 +28,90 @@ let git_diff local_path = Run.read_command_output [ "git" ; "diff" ; "remotes/origin/master" ; "--name-only" ] with - | Some fs -> fs + | 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 remote_diff state = - let fs = git_diff state.local_path in - Filename.Set.of_list (List.map ((//) state.remote_path) fs) +let git_init local_path remote_path = + Dirname.mkdir local_path; + Dirname.in_dir local_path (fun () -> + let repo = Dirname.to_string remote_path 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 + ) -module Repo = struct +let check_updates local_path = + if Dirname.exists (local_path / ".git") then begin + git_fetch local_path; + let files = git_diff local_path in + git_merge local_path; + Some files + end else + None - (* The list of modified files *) - type t = Filename.Set.t +module B = struct - let make state = - log "make_state"; - if Dirname.exists (state.local_path / ".git") then begin - git_fetch state.local_path; - remote_diff state; - end else - Filename.Set.empty + let updates r = + Path.R.root r // "last-git-updates" + + let init r = + let local_repo = Path.R.create r in + git_init (Path.R.root local_repo) (Repository.address r); + File.Filenames.write (updates local_repo) (Filename.Set.empty) - let sync state = - let diff = make state in - if not (Filename.Set.is_empty diff) then - git_merge state.local_path; - diff + let check_file r file = + let local_repo = Path.R.create r in + let updates = File.Filenames.read (updates local_repo) in + if Filename.Set.mem file updates then + Result file + else if Filename.exists file then + Up_to_date file + else + Not_available + + let download_archive r nv = + let local_repo = Path.R.create r in + let archive = Path.R.archive local_repo nv in + check_file r archive + + let download_file r nv filename = + let local_repo = Path.R.create r in + let basename = Filename.basename filename in + let file = Path.R.tmp_dir local_repo nv // Basename.to_string basename in + check_file r file + + let rec download_dir r nv dirname = + let local_repo = Path.R.create r in + let basename = Dirname.basename dirname in + let dir = Path.R.tmp_dir local_repo nv / Basename.to_string basename in + match check_updates dir with + | None -> + git_init dir dirname; + download_dir r nv dirname + | Some f -> + if Filename.Set.empty = f then + Up_to_date dir + else + Result dir + + let update r = + let local_path = Path.R.root (Path.R.create r) in + match check_updates local_path with + | Some f -> f + | None -> + Globals.error_and_exit + "The repository %s is not initialized correctly" + (Repository.to_string r) - let upload state dirname = + let upload_dir state dirname = let files = Filename.rec_list dirname in let err = Run.commands [ [ "git"; "add"; Dirname.to_string dirname; ]; @@ -73,5 +125,5 @@ module Repo = struct end -module M = Repo_helpers.Make(Repo) -include M +let () = + Repositories.register_backend "git" (module B: Repositories.BACKEND) diff --git a/src/repo/git/download.ml b/src/repo/git/download.ml deleted file mode 100644 index 362d8a3711b..00000000000 --- a/src/repo/git/download.ml +++ /dev/null @@ -1,27 +0,0 @@ -(* Download script for git repositories *) - -open Types -open Repositories - -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 (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" ; "-q"; url ; NV.to_string d.nv - ] in - if err <> 0 then - Globals.error_and_exit "%s is not a valid git url" url - ) else if Git.git_diff git_dir <> [] then ( - Git.git_fetch git_dir; - Git.git_merge git_dir; - ) - -let () = - let d = Repositories.read_download_info () 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) diff --git a/src/repo/git/init.ml b/src/repo/git/init.ml deleted file mode 100644 index cff2c7a2e66..00000000000 --- a/src/repo/git/init.ml +++ /dev/null @@ -1,35 +0,0 @@ -(* Init script for git repositories *) - -(* Git repositories should have the following structure: - - opam/ contains the OPAM files - - descr/ contains the description files - - url/$name.$version contains the git url for package - $name.version - - git/$name.$version/ will contain the git repo for the - package $name.$version when it will - be cloned -*) - -let _ = - if Array.length Sys.argv <> 2 then ( - Printf.eprintf "Usage: %s " Sys.argv.(0); - exit 1 - ) - -open Types -open Repo_helpers -open Git - -let git_init t = - let repo = Dirname.to_string t.remote_path 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 - -let () = - let t = Repo_helpers.make_state () in - git_init t diff --git a/src/repo/git/update.ml b/src/repo/git/update.ml deleted file mode 100644 index 50d12d22da0..00000000000 --- a/src/repo/git/update.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Update script for git repositories *) - -(* The update script: - - pull the main repo to see if some new packages are available - - pull each git sub-repo to see if the package has been updated -*) - -open Types -open Repo_helpers - -open Types - -let () = - let state = Repo_helpers.make_state () in - let updates = Git.get_updates state in - File.Updated.write (Path.R.updated state.local_repo) updates - -(* - (* Look at new packages *) - (* re-clone the repository if the url has changed *) - let url_updates = - Filename.Set.filter (fun f -> - Filename.basename f = Basename.of_string "url" - ) repo_updates in - let url_updates = - Utils.filter_map (fun url -> - if Sys.file_exists url then begin - let package = Stdlib_filename.basename url in - Run.remove_dir (Stdlib_filename.concat "git" package); - let err = Run.command ["opam-git-download"; remote_address; package ] in - if err <> 0 then begin - Globals.error "Cannot download package %s" package; - exit err - end; - Some (NV.of_string package) - end else - None - ) url_updates in - let url_updates = NV.Set.of_list url_updates in - - let repo_updates = - Utils.filter_map (fun f -> NV.of_filename (Filename.of_string f)) repo_updates in - let repo_updates = NV.Set.of_list repo_updates in - update local_path; - - (* Look at already cloned packages *) - let dirs = Run.directories_with_links repositories in - let updates = List.filter needs_update dirs in - let updates = - Utils.filter_map (fun d -> - match NV.of_dirname (Dirname.of_string d) with - | None -> None - | Some nv -> update d; Some nv - ) updates in - let updates = List.fold_right NV.Set.add updates NV.Set.empty in - - (* Write $opam/repo/$repo/updated *) - File.Updated.write - (Path.R.updated (Path.R.of_dirname (Dirname.of_string local_path))) - (repo_updates ++ url_updates ++ updates) -*) diff --git a/src/repo/git/upload.ml b/src/repo/git/upload.ml deleted file mode 100644 index e99db45fde4..00000000000 --- a/src/repo/git/upload.ml +++ /dev/null @@ -1,4 +0,0 @@ -(* Upload script for git repositories *) - -let () = - Globals.error_and_exit "Upload capacity is not available for GIT repositories" diff --git a/src/repo/rsync.ml b/src/repo/rsync.ml index 500370e8eb4..6444d529563 100644 --- a/src/repo/rsync.ml +++ b/src/repo/rsync.ml @@ -21,7 +21,7 @@ let rsync ?(delete=true) src dst = with | None -> Not_available | Some l -> match trim l with - | [] -> Up_to_date + | [] -> Up_to_date [] | lines -> List.iter (fun f -> log "updated: %s %s" (Run.cwd ()) f) lines; Result lines @@ -32,7 +32,7 @@ let rsync_dirs ?delete src dst = let dst_files0 = Filename.rec_list dst in match rsync ?delete src_s dst_s with | Not_available -> Not_available - | Up_to_date -> Up_to_date + | Up_to_date _ -> Up_to_date dst | Result lines -> let src_files = Filename.rec_list src in let dst_files = Filename.rec_list dst in @@ -52,8 +52,8 @@ let rsync_file src dst = with | None -> Not_available | Some l -> match trim l with - | [] -> Up_to_date - | [f] -> Result (Filename.of_string f) + | [] -> Up_to_date dst + | [x] -> assert (Filename.to_string dst = x); Result dst | l -> Globals.error_and_exit "unknown rsync output: {%s}" @@ -89,8 +89,8 @@ module B = struct let sync_dir fn = match rsync_dirs ~delete:true (fn remote_repo) (fn local_repo) with | Not_available - | Up_to_date -> Filename.Set.empty - | Result dir -> + | Up_to_date _ -> Filename.Set.empty + | Result dir -> let files = Filename.rec_list dir in Filename.Set.of_list files in let archives = @@ -98,7 +98,7 @@ module B = struct let updates = NV.Set.filter (fun nv -> match download_archive r nv with | Not_available -> true - | Up_to_date -> false + | Up_to_date _ -> false | Result _ -> true ) available_packages in List.map (Path.R.archive local_repo) (NV.Set.elements updates) in @@ -120,8 +120,8 @@ module B = struct Globals.error_and_exit "Cannot upload %s to %s" (Dirname.to_string local_dir) (Repository.to_string r) - | Up_to_date -> Filename.Set.empty - | Result dir -> + | Up_to_date _ -> Filename.Set.empty + | Result dir -> let files = Filename.rec_list dir in Filename.Set.of_list files else diff --git a/src/repositories.ml b/src/repositories.ml index d0165ba5ddc..e77f172205a 100644 --- a/src/repositories.ml +++ b/src/repositories.ml @@ -36,6 +36,7 @@ let register_backend name backend = Hashtbl.replace backends name backend let init r = + log "init %s" (Repository.to_string r); let root = Path.R.create r in let module B = (val find_backend r: BACKEND) in Dirname.mkdir (Path.R.root root); @@ -50,6 +51,7 @@ let nv_set_of_files files = NV.Set.of_list (Utils.filter_map NV.of_filename (Filename.Set.elements files)) let upload r = + log "upload %s" (Repository.to_string r); let root = Path.R.create r in let module B = (val find_backend r: BACKEND) in let files = B.upload_dir r (Path.R.upload_dir root) in @@ -60,18 +62,26 @@ let upload r = ) packages let download_file r nv f = + log "download_file %s %s %s" + (Repository.to_string r) + (NV.to_string nv) + (Filename.to_string f); let module B = (val find_backend r: BACKEND) in B.download_file r nv f let download_dir r nv d = + log "download_dir %s %s %s" + (Repository.to_string r) + (NV.to_string nv) + (Dirname.to_string d); let module B = (val find_backend r: BACKEND) in B.download_dir r nv d let download_one r nv url = let map fn = function | Result x -> Result (fn x) - | Not_available -> Not_available - | Up_to_date -> Up_to_date in + | Up_to_date x -> Up_to_date (fn x) + | Not_available -> Not_available in let f x = F x in let d x = D x in if Run.is_tar_archive url then @@ -101,19 +111,21 @@ let download r nv = (* If the archive is on the server, download it directly *) match B.download_archive r nv with - | Up_to_date -> + | Up_to_date local_file -> log "The archive for %s is already downloaded and up-to-date" (NV.to_string nv) | Result local_file -> log "Downloaded %s successfully" (Filename.to_string local_file) | Not_available -> - log "The archive for %s is not on available, need to build it" + log "The archive for %s is not available, need to build it" (NV.to_string nv); (* download the archive upstream if the upstream address is specified *) let url_f = Path.R.url local_repo nv in let download_dir = Path.R.tmp_dir local_repo nv in + Dirname.mkdir download_dir; + Dirname.with_tmp_dir (fun extract_root -> let extract_dir = extract_root / NV.to_string nv in @@ -128,12 +140,13 @@ let download r nv = match Dirname.in_dir download_dir (fun () -> download_one r2 nv url) with | Not_available -> Globals.error_and_exit "Cannot get %s" url - | Up_to_date -> () + | Up_to_date (F local_archive) | Result (F local_archive) -> log "extracting %s to %s" (Filename.to_string local_archive) (Dirname.to_string extract_dir); Filename.extract local_archive extract_dir + | Up_to_date (D local_dir) | Result (D local_dir) -> log "copying %s to %s" (Dirname.to_string local_dir) @@ -145,6 +158,8 @@ let download r nv = (* Eventually add the files//* to the extracted dir *) log "Adding the files to the archive"; let files = Path.R.available_files local_repo nv in + if not (Dirname.exists extract_dir) then + Dirname.mkdir extract_dir; List.iter (fun f -> Filename.copy_in f extract_dir) files; (* And finally create the final archive *) @@ -162,6 +177,7 @@ let download r nv = (* XXX: clean-up + update when the url change *) (* XXX: update when the thing pointed by the url change *) let update r = + log "update %s" (Repository.to_string r); let root = Path.R.create r in let module B = (val find_backend r: BACKEND) in let files = B.update r in diff --git a/src/types.ml b/src/types.ml index b231ac8de17..59b28c261da 100644 --- a/src/types.ml +++ b/src/types.ml @@ -182,9 +182,16 @@ end = struct Globals.exit err let copy src dst = - let err = Run.command [ "cp"; to_string src ^ "/*"; to_string dst ] in - if err <> 0 then - Globals.exit err + with_tmp_dir (fun tmp -> + let err = Run.command [ "cp"; "-a"; Filename.concat (to_string src) ""; to_string tmp ] in + if err <> 0 then + Globals.exit err; + match list tmp with + | [f] -> + rmdir dst; + move f dst + | _ -> Globals.error_and_exit "Error while copying %s to %s" (to_string src) (to_string dst) + ) let basename dirname = Basename.of_string (Filename.basename (to_string dirname)) @@ -391,7 +398,7 @@ end type filename = Filename.t type 'a download = - | Up_to_date + | Up_to_date of 'a | Not_available | Result of 'a diff --git a/src/types.mli b/src/types.mli index bb6066cf8da..6038ea5ece0 100644 --- a/src/types.mli +++ b/src/types.mli @@ -258,7 +258,7 @@ type file = (** Download result *) type 'a download = - | Up_to_date + | Up_to_date of 'a | Not_available | Result of 'a