Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Simplification of backends code

Now everything is in one file for each backend, with the same BACKEND signature to satisfy - this means it's easier to deploy (as you don't have dozains of binaries to copy at the right place), it's easier to reason about (as you have type constraints, instead of having to read on stdout after calling a script) and it's easier to evolve, as you can easily add new functions if needed.

Currenlty, only the curl and the rsync backend are ported over the new interface, and rsync is passing the test-suite.
  • Loading branch information...
commit 0c21f91b98bacfd43048df082bd9dd054cac1725 1 parent cdb7aa8
@samoht samoht authored
View
35 opam.ocp
@@ -24,7 +24,6 @@ begin library "opam-lib"
"file.ml"
"path.ml"
"repositories.ml"
- "repo/repo_helpers.ml"
]
requires = [
@@ -40,6 +39,9 @@ end
begin program "opam"
dirname = [ "src" ]
files = [
+ "repo/curl.ml"
+ "repo/rsync.ml"
+ "repo/git.ml"
"solver.ml"
"client.ml"
"opam.ml"
@@ -49,6 +51,9 @@ end
(* Repository Scripts *)
+(*
+
+
(* RSYNC *)
begin library "opam-rsync-lib"
files = [ "src/repo/rsync/rsync.ml" ]
@@ -75,32 +80,6 @@ begin program "opam-rsync-upload"
requires = [ "opam-rsync-lib" ]
end
-(* CURL *)
-begin library "opam-curl-lib"
- files = [ "src/repo/curl/curl.ml" ]
- requires = [ "opam-lib" ]
-end
-
-begin program "opam-curl-init"
- files = [ "src/repo/curl/init.ml" ]
- requires = [ "opam-curl-lib" ]
-end
-
-begin program "opam-curl-update"
- files = [ "src/repo/curl/update.ml" ]
- requires = [ "opam-curl-lib" ]
-end
-
-begin program "opam-curl-download"
- files = [ "src/repo/curl/download.ml" ]
- requires = [ "opam-curl-lib" ]
-end
-
-begin program "opam-curl-upload"
- files = [ "src/repo/curl/upload.ml" ]
- requires = [ "opam-curl-lib" ]
-end
-
(* GIT *)
begin library "opam-git-lib"
@@ -172,6 +151,8 @@ begin program "opam-server-upload"
requires = [ "opam-server-lib" ]
end
+*)
+
(* Helpers *)
begin program "opam-mk-config"
View
36 src/file.ml
@@ -101,26 +101,38 @@ module URL = struct
let internal = "url"
- type t = (filename * string option) list
+ type t = {
+ url : string;
+ kind : string option;
+ checksum: string option;
+ }
- let empty = []
+ let empty = {
+ url = "<none>";
+ kind = None;
+ checksum= None;
+ }
+
+ let url t = t.url
+ let kind t = t.kind
let of_string f s =
let lines = Lines.of_string f s in
- Utils.filter_map (function
+ let lines = Utils.filter_map (function
| [] -> None
- | [url] ->
- let url = Filename.of_string url in
- Some (url, None)
- | [url;kind] -> Some (Filename.of_string url, Some kind)
+ | [url] -> Some {url; kind=None; checksum=None}
+ | [url;kind] -> Some {url; kind=Some kind; checksum=None}
| h -> Globals.error_and_exit "%s is not a valid url" (String.concat " " h)
- ) lines
+ ) lines in
+ match lines with
+ | [x] -> x
+ | _ -> Globals.error_and_exit "too many lines (%d)" (List.length lines)
let to_string f t =
- let lines = List.map (function
- | (f,None) -> [Filename.to_string f]
- | (f,Some k) -> [Filename.to_string f; k]) t in
- Lines.to_string f lines
+ let line = match t.kind with
+ | None -> [t.url]
+ | Some k -> [t.url; k] in
+ Lines.to_string f [line]
end
View
10 src/file.mli
@@ -366,7 +366,15 @@ module Subst: sig
end
(** {2 Urls for OPAM repositories *)
-module URL: IO_FILE with type t = (filename * string option) list
+module URL: sig
+
+ include IO_FILE
+
+ val url: t -> string
+
+ val kind: t -> string option
+
+end
(** {2 urls.txt file *} *)
module Urls_txt: IO_FILE with type t = (basename * int * string) list
View
158 src/repo/curl.ml
@@ -0,0 +1,158 @@
+open Types
+
+let log msg = Globals.log "curl" msg
+
+type state = {
+ remote_repo : Path.R.t;
+ remote_path : dirname;
+ local_repo : Path.R.t;
+ local_path : dirname;
+ index_file : filename;
+ local_index_archive : filename;
+ remote_index_archive: filename;
+ local_files : Filename.Set.t;
+ remote_local : filename Filename.Map.t;
+ local_remote : filename Filename.Map.t;
+ file_permissions : (filename * int) list;
+ file_digests : (filename * string) list;
+}
+
+let make_state r =
+ let remote_path = Repository.address r in
+ let remote_repo = Path.R.of_dirname remote_path in
+ let local_repo = Path.R.create r in
+ let local_path = Path.R.root local_repo in
+ let index_file = remote_path // "urls.txt" in
+ let local_index_archive = local_path // "index.tar.gz" in
+ let remote_index_archive = remote_path // "index.tar.gz" in
+ let remote_local, local_remote, local_files, file_permissions, file_digests =
+ match Filename.download index_file local_path with
+ | None -> Globals.error_and_exit "Cannot get urls.txt"
+ | Some local_file ->
+ let urls = File.Urls_txt.read local_file in
+ let remote_local, local_remote, locals, perms, digests =
+ List.fold_left(fun (rl, lr, locals, perms, digests) (base,perm,digest) ->
+ let remote = Filename.create remote_path base in
+ let local = Filename.create (Dirname.cwd()) base in
+ Filename.Map.add remote local rl,
+ Filename.Map.add local remote lr,
+ Filename.Set.add local locals,
+ (local, perm) :: perms,
+ (local, digest) :: digests
+ ) (Filename.Map.empty, Filename.Map.empty, Filename.Set.empty, [], [])
+ urls in
+ remote_local, local_remote, locals, perms, digests in
+ {
+ remote_repo; remote_path; local_repo; local_path;
+ index_file; local_index_archive; remote_index_archive;
+ local_files; remote_local; local_remote;
+ file_permissions; file_digests;
+ }
+
+
+let is_up_to_date state local_file =
+ List.mem_assoc local_file state.file_digests
+ && Filename.exists local_file
+ && List.assoc local_file state.file_digests = Filename.digest local_file
+
+module B = struct
+
+ let init r =
+ let state = make_state r 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 ()
+
+ let curl ~remote_file ~local_file =
+ log "dowloading %s" (Filename.to_string remote_file);
+ let local_dir = Filename.dirname local_file in
+ Dirname.mkdir local_dir;
+ Filename.download remote_file local_dir
+
+ let update r =
+ let state = make_state r in
+ log "dir local_dir=%s remote_dir=%s"
+ (Dirname.to_string state.local_path)
+ (Dirname.to_string state.remote_path);
+ if state.local_path <> state.remote_path then begin
+ let (--) = Filename.Set.diff in
+ let current = Filename.Set.of_list (Filename.list state.local_path) in
+ let to_keep = Filename.Set.filter (is_up_to_date state) state.local_files in
+ let to_delete = current -- to_keep in
+ let new_files = state.local_files -- to_keep in
+ log "current: %s" (Filename.Set.to_string current);
+ log "to_keep: %s" (Filename.Set.to_string to_keep);
+ log "to_delete: %s" (Filename.Set.to_string to_delete);
+ log "new_files: %s" (Filename.Set.to_string new_files);
+ Filename.Set.iter Filename.remove to_delete;
+ if Filename.Set.cardinal new_files > 4 then
+ init r
+ else
+ Filename.Set.iter (fun local_file ->
+ let remote_file = Filename.Map.find local_file state.local_remote in
+ ignore (curl ~remote_file ~local_file)
+ ) new_files;
+ new_files
+ end else
+ Filename.Set.empty
+
+ let download_archive r nv =
+ let remote_repo = Path.R.of_dirname (Repository.address r) in
+ let remote_file = Path.R.archive remote_repo nv in
+ let state = make_state r in
+ if not (Filename.Map.mem remote_file state.remote_local) then
+ Not_available
+ 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
+ else begin
+ log "dowloading %s" (Filename.to_string remote_file);
+ let local_dir = Filename.dirname local_file in
+ Dirname.mkdir local_dir;
+ 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;
+ Result local_file
+ end
+ end
+
+ (* XXX: use checksums *)
+ let download_file r nv remote_file =
+ let root = Path.R.create r in
+ let local_dir = Path.R.tmp_dir root nv in
+ match Filename.download remote_file local_dir with
+ | None -> Not_available
+ | Some f -> Result f
+
+ let not_supported action =
+ failwith (action ^ " is not supported by CURL backend")
+
+ let download_dir r nv remote_dir =
+ not_supported "download_dir"
+
+ let upload_dir state remote_dir =
+ not_supported "upload"
+
+end
+
+let () =
+ Repositories.register_backend "curl" (module B : Repositories.BACKEND)
View
112 src/repo/curl/curl.ml
@@ -1,112 +0,0 @@
-let script_name = Filename.basename Sys.argv.(0)
-
-open Types
-open Repo_helpers
-
-let log msg = Globals.log script_name msg
-
-type state = {
- index_file : filename;
- local_index_archive : filename;
- remote_index_archive: filename;
- remote_files : Filename.Set.t;
- file_permissions : (filename * int) list;
- file_digests : (filename * string) list;
-}
-
-let make_state state =
- let index_file = state.remote_path // "urls.txt" in
- let local_index_archive = state.local_path // "index.tar.gz" in
- let remote_index_archive = state.remote_path // "index.tar.gz" in
- let remote_files, file_permissions, file_digests =
- match Filename.download index_file state.local_path with
- | None -> Globals.error_and_exit "Cannot get urls.txt"
- | Some local_file ->
- let urls = File.Urls_txt.read local_file in
- let files, perms, digests =
- List.fold_left (fun (files, perms, digests) (base,perm,digest) ->
- let file = Filename.create (Dirname.cwd()) base in
- Filename.Set.add file files,
- (file,perm) :: perms,
- (file,digest) :: digests
- ) (Filename.Set.empty, [], []) urls in
- files, perms, digests in
- {
- index_file; local_index_archive; remote_index_archive;
- remote_files; file_permissions; file_digests;
- }
-
-module Repo = struct
-
- type t = state
-
- (* all the local files which mirror a remote file *)
- let active_local_files state t =
- Filename.Set.map (local_of_remote_file state) t.remote_files
-
- let same_digest _ t ~local_file ~remote_file =
- List.mem_assoc remote_file t.file_digests
- && Filename.exists local_file
- && List.assoc remote_file t.file_digests = Filename.digest local_file
-
- let file state t remote_file =
- if not (Filename.Set.mem remote_file t.remote_files) then
- None
- else begin
- let local_file = local_of_remote_file state remote_file in
- if same_digest state t ~local_file ~remote_file then
- (* Do not overwrite the file if it is already there, with the right contents *)
- Some local_file
- else begin
- log "dowloading %s" (Filename.to_string remote_file);
- let local_dir = Filename.dirname local_file in
- Dirname.mkdir local_dir;
- 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 remote_file t.file_permissions in
- Filename.chmod local_file perm
- with Not_found ->
- ()
- end;
- Some local_file
- end
- end
-
- (* sync remote_dir with the corresponding local_dir*)
- let sync state =
- let t = make_state state in
- log "dir local_dir=%s remote_dir=%s"
- (Dirname.to_string state.local_path)
- (Dirname.to_string state.remote_path);
- if state.local_path <> state.remote_path then begin
- let current = Filename.Set.of_list (Filename.list state.local_path) in
- log "current: %s" (Filename.Set.to_string current);
- let to_keep = Filename.Set.filter (fun local_file ->
- let remote_file = remote_of_local_file state local_file in
- same_digest state t ~local_file ~remote_file
- ) (active_local_files state t) in
- log "to_keep: %s" (Filename.Set.to_string to_keep);
- let to_delete = Filename.Set.diff current to_keep in
- log "to_delete: %s" (Filename.Set.to_string to_delete);
- Filename.Set.iter Filename.remove to_delete;
- Filename.Set.filter (fun f ->
- match file state t f with
- | Some _ -> true
- | None -> false
- ) t.remote_files
- end else
- Filename.Set.empty
-
- let upload state remote_dir =
- Globals.error_and_exit "Upload is not available for CURL backends"
-
-end
-
-module M = Repo_helpers.Make(Repo)
-include M
View
10 src/repo/curl/download.ml
@@ -1,10 +0,0 @@
-(* Download scrip for curl-ed repositories *)
-
-open Types
-open Repositories
-
-let () =
- let d = Repositories.read_download_info () in
- 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
20 src/repo/curl/init.ml
@@ -1,20 +0,0 @@
-(* Init scrip for curl-ed repositories *)
-
-open Types
-open Repo_helpers
-open Curl
-
-let () =
- let state = Repo_helpers.make_state () in
- let curl_state = Curl.make_state state in
-
- (* Download index.tar.gz *)
- let warning () =
- Globals.msg "Cannot find index.tar.gz on the OPAM repository.\nInitialisation might take some time ...\n" in
-
- try match Filename.download curl_state.remote_index_archive state.local_path with
- | None -> warning ()
- | Some _ ->
- (* Untar the files *)
- Filename.extract_in curl_state.local_index_archive state.local_path
- with _ -> warning ()
View
10 src/repo/curl/update.ml
@@ -1,10 +0,0 @@
-(* Update scrip for curl repositories *)
-
-open Types
-open Repo_helpers
-open Curl
-
-let () =
- let state = Repo_helpers.make_state () in
- let updates = Curl.get_updates state in
- File.Updated.write (Path.R.updated state.local_repo) updates;
View
4 src/repo/curl/upload.ml
@@ -1,4 +0,0 @@
-(* Upload scrip for rsync-ed repositories *)
-
-let () =
- Globals.error_and_exit "CURL does not support upload"
View
0  src/repo/git/git.ml → src/repo/git.ml
File renamed without changes
View
133 src/repo/rsync.ml
@@ -0,0 +1,133 @@
+let (+) = Filename.concat
+open Types
+
+let log fmt = Globals.log "rsync" fmt
+
+(* if rsync -arv return 4 lines, this means that no files have changed *)
+let trim = function
+ | [] -> []
+ | _ :: t ->
+ match List.rev t with
+ | _ :: _ :: _ :: l -> l
+ | _ -> []
+
+let rsync ?(delete=true) src dst =
+ log "rsync: delete:%b src:%s dst:%s" delete 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 trim l with
+ | [] -> Up_to_date
+ | lines ->
+ List.iter (fun f -> log "updated: %s %s" (Run.cwd ()) f) lines;
+ Result lines
+
+let rsync_dirs ?delete src dst =
+ let src_s = Dirname.to_string src + "" in
+ let dst_s = Dirname.to_string dst in
+ 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
+ | Result lines ->
+ let src_files = Filename.rec_list src in
+ let dst_files = Filename.rec_list dst in
+ if delete = Some true && List.length src_files <> List.length dst_files then (
+ List.iter (fun f -> Globals.msg "src-file: %s\n" (Filename.to_string f)) src_files;
+ List.iter (fun f -> Globals.msg "dst-file0: %s\n" (Filename.to_string f)) dst_files0;
+ List.iter (fun f -> Globals.msg "dst-file: %s\n" (Filename.to_string f)) dst_files;
+ Globals.error_and_exit "rsync_dir failed!"
+ );
+ Result dst
+
+let rsync_file src dst =
+ match
+ Run.read_command_output [
+ "rsync"; "-av"; Filename.to_string src; Filename.to_string dst;
+ ]
+ with
+ | None -> Not_available
+ | Some l -> match trim l with
+ | [] -> Up_to_date
+ | [f] -> Result (Filename.of_string f)
+ | l ->
+ Globals.error_and_exit
+ "unknown rsync output: {%s}"
+ (String.concat ", " l)
+
+module B = struct
+
+ let init r = ()
+
+ let download_file r nv remote_file =
+ let local_repo = Path.R.create r in
+ let tmp_dir = Path.R.tmp_dir local_repo nv in
+ let local_file = Filename.create tmp_dir (Filename.basename remote_file) in
+ rsync_file remote_file local_file
+
+ let download_dir r nv remote_dir =
+ let local_repo = Path.R.create r in
+ let tmp_dir = Path.R.tmp_dir local_repo nv in
+ let local_dir = tmp_dir / Basename.to_string (Dirname.basename remote_dir) in
+ rsync_dirs ~delete:true remote_dir local_dir
+
+ let download_archive r nv =
+ let remote_repo = Path.R.of_dirname (Repository.address r) in
+ let remote_file = Path.R.archive remote_repo nv in
+ let local_repo = Path.R.create r in
+ let local_file = Path.R.archive local_repo nv in
+ rsync_file remote_file local_file
+
+
+ let update r =
+ let remote_repo = Path.R.of_dirname (Repository.address r) in
+ let local_repo = Path.R.create r in
+ 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 ->
+ let files = Filename.rec_list dir in
+ Filename.Set.of_list files in
+ let archives =
+ let available_packages = Path.R.available_packages local_repo in
+ let updates = NV.Set.filter (fun nv ->
+ match download_archive r nv with
+ | Not_available -> true
+ | Up_to_date -> false
+ | Result _ -> true
+ ) available_packages in
+ List.map (Path.R.archive local_repo) (NV.Set.elements updates) in
+ let (++) = Filename.Set.union in
+ Filename.Set.of_list archives
+ ++ sync_dir Path.R.packages_dir
+ ++ sync_dir Path.R.compilers_dir
+
+ let upload_dir r local_dir =
+ let remote_repo = Path.R.of_dirname (Repository.address r) in
+ let remote_dir = Path.R.root remote_repo in
+ (* we assume that rsync is only used locally *)
+ if Dirname.exists (Dirname.dirname remote_dir)
+ && not (Dirname.exists remote_dir) then
+ Dirname.mkdir remote_dir;
+ if Dirname.exists local_dir then
+ match rsync_dirs ~delete:false local_dir remote_dir with
+ | Not_available ->
+ 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 ->
+ let files = Filename.rec_list dir in
+ Filename.Set.of_list files
+ else
+ Filename.Set.empty
+
+end
+
+let () =
+ Repositories.register_backend "rsync" (module B: Repositories.BACKEND)
View
29 src/repo/rsync/download.ml
@@ -1,29 +0,0 @@
-(* 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 = 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.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 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)
- )
View
4 src/repo/rsync/init.ml
@@ -1,4 +0,0 @@
-(* Init scrip for rsync-ed repositories *)
-
-let () =
- ()
View
75 src/repo/rsync/rsync.ml
@@ -1,75 +0,0 @@
-let (+) = Filename.concat
-
-module F = Filename
-open Repo_helpers
-open Types
-
-let log fmt = Globals.log "rsync" fmt
-
-(* if rsync -arv return 4 lines, this means that no files have changed *)
-let trim = function
- | [] -> []
- | _ :: t ->
- match List.rev t with
- | _ :: _ :: _ :: l -> l
- | _ -> []
-
-let rsync ?(delete=true) src dst =
- log "rsync: delete:%b src:%s dst:%s" delete 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 -> []
- | Some lines ->
- let lines = trim lines in
- List.iter (fun f -> log "updated: %s %s" (Run.cwd ()) f) lines;
- lines
-
-let rsync_dirs ?delete src dst =
- let src_s = Dirname.to_string src + "" in
- let dst_s = Dirname.to_string dst in
- let dst_files0 = Filename.rec_list dst in
- let lines = rsync ?delete src_s dst_s in
- let src_files = Filename.rec_list src in
- let dst_files = Filename.rec_list dst in
- if delete = Some true && List.length src_files <> List.length dst_files then (
- List.iter (fun f -> Globals.msg "src-file: %s\n" (Filename.to_string f)) src_files;
- List.iter (fun f -> Globals.msg "dst-file0: %s\n" (Filename.to_string f)) dst_files0;
- List.iter (fun f -> Globals.msg "dst-file: %s\n" (Filename.to_string f)) dst_files;
- Globals.error_and_exit "rsync_dir failed!"
- );
- Filename.Set.of_list (List.map Filename.of_string lines)
-
-let rsync_file src dst =
- (* We assume that we rsync locally *)
- Filename.copy src dst
-
-module Repo = struct
-
- type t = unit
-
- let (++) = Filename.Set.union
-
- let sync state =
- let aux fn = rsync_dirs ~delete:true (fn state.remote_repo) (fn state.local_repo) in
- aux Path.R.packages_dir ++ aux Path.R.compilers_dir
-
- let upload state remote_dir =
- log "Upload.dir %s" (Dirname.to_string remote_dir);
- let local_dir = Repo_helpers.local_of_remote_dir state remote_dir in
- (* we assume that rsync is only used locally *)
- if Dirname.exists (Dirname.dirname remote_dir)
- && not (Dirname.exists remote_dir) then
- Dirname.mkdir remote_dir;
- if Dirname.exists local_dir then
- rsync_dirs ~delete:false local_dir remote_dir
- else
- Filename.Set.empty
-
-end
-
-module M = Repo_helpers.Make(Repo)
-include M
View
9 src/repo/rsync/update.ml
@@ -1,9 +0,0 @@
-(* Update scrip for rsync-ed repositories *)
-
-open Types
-open Repo_helpers
-
-let () =
- let state = Repo_helpers.make_state () in
- let updates = Rsync.get_updates state in
- File.Updated.write (Path.R.updated state.local_repo) updates
View
11 src/repo/rsync/upload.ml
@@ -1,11 +0,0 @@
-(* Upload scrip for rsync-ed repositories *)
-
-open Types
-open Repo_helpers
-
-let log fmt = Globals.log "rsync-upload" fmt
-
-let () =
- let state = Repo_helpers.make_state () in
- let updates = Rsync.upload state in
- Globals.msg "%d packages uploaded %s\n" (NV.Set.cardinal updates) (NV.Set.to_string updates)
View
242 src/repositories.ml
@@ -17,86 +17,67 @@ open Types
let log fmt = Globals.log "REPO" fmt
-let run cmd repo args =
- log "opam-%s: %s %s" cmd (Repository.to_string repo) (String.concat " " args);
- let path = Path.R.root (Path.R.create repo) in
- let cmd = Printf.sprintf "opam-%s-%s" (Repository.kind repo) cmd in
- let i = Run.in_dir (Dirname.to_string path) (fun () ->
- Run.command ( cmd :: Dirname.to_string (Repository.address repo) :: args );
- ) in
- if i <> 0 then
- Globals.error_and_exit "%s failed" cmd
+type kind = string
+module type BACKEND = sig
+ val init: repository -> unit
+ val update: repository -> Filename.Set.t
+ val download_archive: repository -> nv -> filename download
+ val download_file: repository -> nv -> filename -> filename download
+ val download_dir: repository -> nv -> dirname -> dirname download
+ val upload_dir: repository -> dirname -> Filename.Set.t
+end
+
+let backends = Hashtbl.create 8
+
+let find_backend r =
+ Hashtbl.find backends (Repository.kind r)
+
+let register_backend name backend =
+ Hashtbl.replace backends name backend
let init r =
let root = Path.R.create r in
+ let module B = (val find_backend r: BACKEND) in
Dirname.mkdir (Path.R.root root);
- run "init" r [];
File.Repo_config.write (Path.R.config root) r;
Dirname.mkdir (Path.R.packages_dir root);
Dirname.mkdir (Path.R.archives_dir root);
Dirname.mkdir (Path.R.compilers_dir root);
- Dirname.mkdir (Path.R.upload_dir root)
+ Dirname.mkdir (Path.R.upload_dir root);
+ B.init r
-let update r =
- run "update" r []
+let nv_set_of_files files =
+ NV.Set.of_list (Utils.filter_map NV.of_filename (Filename.Set.elements files))
let upload r =
- run "upload" r []
-
-type download_info = {
- local_dir : dirname;
- remote_dir: dirname;
- basename : basename;
- nv : nv;
-}
-
-let string_of_download_info d =
- 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 <> 4 then (
- Printf.eprintf "Usage: %s <remote-server> <filenane> <package>" Sys.argv.(0);
- exit 1
- );
- 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
-
-let file filename =
- if not (Sys.is_directory filename) then
- F (Filename.of_string filename)
+ 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
+ let packages = nv_set_of_files files in
+ Globals.msg "The following packages have been uploaded:\n";
+ NV.Set.iter (fun nv ->
+ Globals.msg " - %s\n" (NV.to_string nv)
+ ) packages
+
+let download_file r nv f =
+ let module B = (val find_backend r: BACKEND) in
+ B.download_file r nv f
+
+let download_dir r nv 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
+ let f x = F x in
+ let d x = D x in
+ if Run.is_tar_archive url then
+ map f (download_file r nv (Filename.raw url))
else
- D (Dirname.of_string filename)
-
-let download_one kind d =
- let cmd = Printf.sprintf "opam-%s-download" kind in
- let output = Dirname.in_dir d.local_dir (fun () ->
- Run.read_command_output [
- 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_dir nv = function
- | [] -> None
- | (remote_dir, basename, kind) :: t ->
- let d = { local_dir; remote_dir; basename; nv } in
- match download_one kind d with
- | None -> download_iter local_dir nv t
- | r -> r
+ map d (download_dir r nv (Dirname.raw url))
let kind_of_repository r =
match Repository.kind r with
@@ -105,7 +86,7 @@ let kind_of_repository r =
if Dirname.exists (Repository.address r) then
"rsync"
else
- x
+ "curl"
(* Download the archive on the OPAM server.
If it is not there, then:
@@ -114,78 +95,51 @@ let kind_of_repository r =
* create a new tarball *)
let download r nv =
log "download %s %s" (Repository.to_string r) (NV.to_string nv);
- let remote_repo = Path.R.of_dirname (Repository.address r) in
let local_repo = Path.R.create r in
+ let module B = (val find_backend r: BACKEND) in
(* If the archive is on the server, download it directly *)
- 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_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 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 on %s"
- (Basename.to_string basename) (Dirname.to_string remote_dir)
- | None ->
- log
- "%s is not on available on %s, need to build it"
- (Basename.to_string basename) (Dirname.to_string remote_dir);
+
+ match B.download_archive r nv with
+ | Up_to_date ->
+ 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"
+ (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 tmp_dir = Path.R.tmp_dir local_repo nv in
- let extract_dir = tmp_dir / NV.to_string nv in
- Dirname.mkdir tmp_dir;
-
- if Filename.exists url_f then begin
- (* download the archive upstream if the upstream address
- 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) -> mk f k
- | (f,None) -> mk f kind
- ) urls in
- let urls_s =
- String.concat " "
- (List.map
- (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
-
- | None -> Globals.error_and_exit "Cannot get %s" urls_s
-
- | Some UpToDate -> ()
-
- | Some (F local_archive) ->
- log "extracting %s to %s"
- (Filename.to_string local_archive)
- (Dirname.to_string tmp_dir);
- Filename.extract local_archive extract_dir
-
- | Some (D local_dir) ->
- log "copying %s to %s"
- (Dirname.to_string local_dir)
- (Dirname.to_string tmp_dir);
- if local_dir <> extract_dir then
- Dirname.move local_dir extract_dir
+ let download_dir = Path.R.tmp_dir local_repo nv in
+ Dirname.with_tmp_dir (fun extract_root ->
+ let extract_dir = extract_root / NV.to_string nv in
+
+ if Filename.exists url_f then begin
+ let url = File.URL.read url_f in
+ let kind = match File.URL.kind url with
+ | None -> kind_of_repository r
+ | Some k -> k in
+ let url = File.URL.url url in
+ log "downloading %s:%s" url kind;
+ let r2 = Repository.with_kind r kind in
+
+ 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 -> ()
+ | 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
+ | Result (D local_dir) ->
+ log "copying %s to %s"
+ (Dirname.to_string local_dir)
+ (Dirname.to_string extract_dir);
+ if local_dir <> extract_dir then
+ Dirname.copy local_dir extract_dir
end;
(* Eventually add the files/<package>/* to the extracted dir *)
@@ -198,10 +152,18 @@ let download r nv =
the archive has been repacked by opam *)
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 tmp_dir [
+ let err = 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 tmp_dir)
+ Globals.error_and_exit "Cannot compress %s" (Dirname.to_string extract_dir)
+ )
-(* check whether an archive have changed *)
+(* XXX: clean-up + update when the url change *)
+(* XXX: update when the thing pointed by the url change *)
+let update r =
+ let root = Path.R.create r in
+ let module B = (val find_backend r: BACKEND) in
+ let files = B.update r in
+ let packages = nv_set_of_files files in
+ File.Updated.write (Path.R.updated root) packages
View
46 src/repositories.mli
@@ -20,27 +20,41 @@
open Types
-(** Run {i opam-$kind-init} in {i $opam/repo/$repo} *)
+type kind = string
+
+(** Backend signature *)
+module type BACKEND = sig
+
+ (** Initialize the repository *)
+ val init: repository -> unit
+
+ (** Update the repository. Return the list of updated files *)
+ val update: repository -> Filename.Set.t
+
+ (** Download the package archive on the server *)
+ val download_archive: repository -> nv -> filename download
+
+ (** Download a file *)
+ val download_file: repository -> nv -> filename -> filename download
+
+ (** Download a directory *)
+ val download_dir: repository -> nv -> dirname -> dirname download
+
+ (** Upload a local directory *)
+ val upload_dir: repository -> dirname -> Filename.Set.t
+end
+
+(** Register a repository backend *)
+val register_backend: kind -> (module BACKEND) -> unit
+
+(** Initialize {i $opam/repo/$repo} *)
val init: repository -> unit
-(** Run {i opam-$kind-update} in {i $opam/repo/$repo} *)
+(** Updated {i $opam/repo/$repo} *)
val update: repository -> unit
(** Run {i opam-$kind-download} in {i $opam/repo/$repo} *)
val download: repository -> nv -> unit
-(** Run {i opam-$kind-upload} in {i $opam/repo/$repo} *)
+(** Upload the content of {i $opam/repo/$repo/upload} *)
val upload: repository -> unit
-
-(** {2 Download script helpers} *)
-
-(** State associated to a download command *)
-type download_info = {
- local_dir : dirname;
- remote_dir: dirname;
- basename : basename;
- nv : nv;
-}
-
-(** Read argv and build a download info record *)
-val read_download_info: unit -> download_info
View
33 src/run.ml
@@ -267,7 +267,8 @@ let read_command_output ?(add_to_env=[]) ?(add_to_path=[]) cmd =
Some r.Process.r_stdout
module Tar = struct
- let extract =
+
+ let extensions =
[ [ "tar.gz" ; "tgz" ], 'z'
; [ "tar.bz2" ; "tbz" ], 'j' ]
@@ -275,27 +276,35 @@ module Tar = struct
List.exists (Filename.check_suffix file) ext
let assoc file =
- snd (List.find (function ext, _ -> match_ext file ext) extract)
+ snd (List.find (function ext, _ -> match_ext file ext) extensions)
+
+ let is_archive f =
+ List.exists
+ (fun suff -> Filename.check_suffix f suff)
+ (List.concat (List.map fst extensions))
- let is_archive file =
+ let extract_function file =
List.fold_left
(function
- | Some s -> fun _ -> Some s
- | None -> fun (ext, c) ->
- if match_ext file ext then
- Some (fun dir -> command [ "tar" ; Printf.sprintf "xf%c" c ; file; "-C" ; dir ])
- else
- None)
+ | Some s -> (fun _ -> Some s)
+ | None ->
+ (fun (ext, c) ->
+ if match_ext file ext then
+ Some (fun dir -> command [ "tar" ; Printf.sprintf "xf%c" c ; file; "-C" ; dir ])
+ else
+ None))
None
- extract
+ extensions
end
+let is_tar_archive = Tar.is_archive
+
let extract file dst =
log "extract %s %s" file dst;
(* let files = read_command_output [ "tar" ; "tf" ; file ] in
log "%s contains %d files: %s" file (List.length files) (String.concat ", " files); *)
with_tmp_dir (fun tmp_dir ->
- match Tar.is_archive file with
+ match Tar.extract_function file with
| None -> Globals.error_and_exit "%s is not a valid archive" file
| Some f ->
let err = f tmp_dir in
@@ -315,7 +324,7 @@ let extract_in file dst =
log "extract_in %s %s" file dst;
if not (Sys.file_exists dst) then
Globals.error_and_exit "%s does not exist" file;
- match Tar.is_archive file with
+ 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
View
3  src/run.mli
@@ -93,6 +93,9 @@ val read_command_output:
?add_to_env:(string*string) list ->
?add_to_path:string list -> command -> string list option
+(** Test whether the file is an archive, by looking as its extension *)
+val is_tar_archive: string -> bool
+
(** [extract filename dirname] extracts the archive [filename] into
[dirname]. [dirname] should not exists and [filename] should
contain only one top-level directory.*)
View
10 src/types.ml
@@ -363,6 +363,7 @@ end = struct
Dirname.remove_prefix ~prefix filename
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)
@@ -389,6 +390,15 @@ end = struct
end
type filename = Filename.t
+type 'a download =
+ | Up_to_date
+ | Not_available
+ | Result of 'a
+
+type file =
+ | D of dirname
+ | F of filename
+
let (/) d1 s2 =
let s1 = Dirname.to_string d1 in
Dirname.raw (F.concat s1 s2)
View
12 src/types.mli
@@ -250,6 +250,18 @@ end
(** Shortcut to file names *)
type filename = Filename.t
+(** Generalized file type *)
+type file =
+ | D of dirname
+ | F of filename
+
+
+(** Download result *)
+type 'a download =
+ | Up_to_date
+ | Not_available
+ | Result of 'a
+
(** Concatenate a directory and a string to create a filename *)
val (//): dirname -> string -> filename
Please sign in to comment.
Something went wrong with that request. Please try again.