Permalink
Browse files

It is possible to have a list of possible servers (mixing git repo an…

…d normal OPAM servers).

init/update/list works fine. Currently, the only way to add a new server is to edit ~./opam/config manually.
  • Loading branch information...
1 parent 0acb675 commit 45abc3dc9f2be5e6d19962f5c31b26b614c1277f @samoht samoht committed Mar 27, 2012
Showing with 178 additions and 97 deletions.
  1. +15 −2 ocp-get.ocp
  2. +82 −32 src/client.ml
  3. +25 −30 src/file.ml
  4. +6 −10 src/file_format.ml
  5. +11 −5 src/ocp_get.ml
  6. +22 −6 src/path.ml
  7. +13 −11 src/run.ml
  8. +4 −1 src/server.ml
View
@@ -174,15 +174,20 @@ begin library "dose"
end
begin library "ocp-get-lib"
+(*
+ ocamlc = [ "ocp-ocamlc.opt" ]
+ ocamlopt = [ "ocp-ocamlopt.opt" ]
+*)
dirname = [ "src" ]
comp += [ "-annot" ]
files = [
"globals.ml"
+ "uri.ml"
+ "namespace.ml"
+ "run.ml"
"file_format.ml"
"lexer.mll"
"parser.mly"
- "namespace.ml"
- "run.ml"
"path.ml"
"file.ml"
"protocol.ml"
@@ -200,6 +205,10 @@ begin library "ocp-get-lib"
end
begin program "ocp-get"
+(*
+ ocamlc = [ "ocp-ocamlc.opt" ]
+ ocamlopt = [ "ocp-ocamlopt.opt" ]
+*)
dirname = [ "src" ]
comp += [ "-annot" ]
files = [
@@ -211,6 +220,10 @@ begin program "ocp-get"
end
begin program "ocp-get-server"
+(*
+ ocamlc = [ "ocp-ocamlc.opt" ]
+ ocamlopt = [ "ocp-ocamlopt.opt" ]
+*)
dirname = [ "src" ]
comp += [ "-annot" ]
files = [ "ocp_get_server.ml" ]
View
@@ -18,6 +18,7 @@ open Namespace
open Path
open Server
open Solver
+open Uri
let log fmt =
Globals.log "CLIENT" fmt
@@ -27,7 +28,7 @@ sig
type t
(** Initializes the client a consistent state. *)
- val init : git:bool -> url -> unit
+ val init : url list -> unit
(** Displays all available packages *)
val list : unit -> unit
@@ -61,8 +62,7 @@ module Client : CLIENT = struct
open File
type t =
- { server : url
- ; git : bool
+ { servers: url list
; home : Path.t (* ~/.opam *) }
(* Look into the content of ~/.opam/config to build the client state *)
@@ -71,27 +71,30 @@ module Client : CLIENT = struct
let load_state () =
let home = Path.init !Globals.root_path in
let config = File.Config.find_err (Path.config home) in
- let server = File.Config.sources config in
- let git = File.Config.git config in
- { server ; git; home }
-
- let update_remote t =
- let packages = RemoteServer.getList t.server in
+ let servers = File.Config.sources config in
+ { servers ; home }
+
+ let update_remote server home =
+ log "update-remote-server %s%s"
+ server.hostname
+ (match server.port with Some p -> ":" ^ string_of_int p | None -> "");
+ let packages = RemoteServer.getList server in
List.iter
(fun (n, v) ->
- let spec_f = Path.index t.home (Some (n, v)) in
+ let spec_f = Path.index home (Some (n, v)) in
if not (Path.file_exists spec_f) then
- let spec = RemoteServer.getSpec t.server (n, v) in
+ let spec = RemoteServer.getSpec server (n, v) in
Path.add spec_f (Path.File (Binary spec));
- Globals.msg "New package available: %s" (Namespace.string_of_nv n v)
+ Globals.msg "New package available: %s\n" (Namespace.string_of_nv n v)
) packages
- let update_git t =
- let index_path = Path.string_of_filename (Path.index t.home None) in
+ let update_git server home =
+ log "update-git-server %s" server.hostname;
+ let index_path = Path.string_of_filename (Path.index home None) in
if not (Sys.file_exists index_path) then
- let err = Run.Git.clone t.server.hostname index_path in
+ let err = Run.Git.clone server.hostname index_path in
if err <> 0 then
- Globals.error_and_exit "%s: unknown git repository" t.server.hostname;
+ Globals.error_and_exit "%s: unknown git repository" server.hostname;
let newfiles = Run.Git.get_updates index_path in
Run.Git.update index_path;
let package_of_file file =
@@ -107,18 +110,19 @@ module Client : CLIENT = struct
NV_set.empty
newfiles in
NV_set.iter (fun (n, v) ->
- Globals.msg "New package available: %s" (Namespace.string_of_nv n v)
+ Globals.msg "New package available: %s\n" (Namespace.string_of_nv n v)
) packages
let update () =
let t = load_state () in
- if t.git then
- update_git t
- else
- update_remote t
-
- let init ~git url =
- log "init %b %s" git (string_of_url url);
+ let one server =
+ match server.uri with
+ | Some Git -> update_git server t.home
+ | _ -> update_remote server t.home in
+ List.iter one t.servers
+
+ let init urls =
+ log "init %s" (String.concat " " (List.map string_of_url urls));
let home = Path.init !Globals.root_path in
let config_f = Path.config home in
match File.Config.find config_f with
@@ -128,8 +132,7 @@ module Client : CLIENT = struct
let config =
File.Config.create
Globals.api_version
- git
- url
+ urls
(Version Globals.ocaml_version) in
File.Config.add config_f config;
File.Installed.add (Path.installed home) File.Installed.empty;
@@ -340,6 +343,16 @@ module Client : CLIENT = struct
let parallel (Solver.P l) = List.exists action l in
List.exists parallel l
+ (* Iterate over the list of servers to find one with the corresponding archive *)
+ let getArchive servers nv =
+ let rec aux = function
+ | [] -> None
+ | h::t ->
+ match RemoteServer.getArchive h nv with
+ | None -> aux t
+ | Some a -> Some a in
+ aux servers
+
let proceed_tochange t nv_old (name, v as nv) =
(* First, uninstall any previous version *)
(match nv_old with
@@ -351,7 +364,9 @@ module Client : CLIENT = struct
(* Then, untar the archive *)
let p_build = Path.build t.home (Some nv) in
Path.remove p_build;
- let archive = match RemoteServer.getArchive t.server nv with
+ (* XXX: maybe we want to follow the external urls first *)
+ (* XXX: at one point, we would need to check SHA1 consistencies as well *)
+ let archive = match getArchive t.servers nv with
| Some tgz -> Archive tgz
| None ->
let urls = File.Spec.urls spec in
@@ -504,7 +519,39 @@ module Client : CLIENT = struct
| None -> assert false (* an already installed package must figure in the index *)
| Some v -> vpkg_of_nv (name, V_set.max_elt v))
(N_map.bindings installed) } ]
-
+
+ (* XXX: ask the user on which repo she wants to upload the new package *)
+ (* XXX: hanlde git repo as well ... *)
+ let iter_upload_server fn servers =
+ let one server =
+ if server.uri = Some Git then
+ None
+ else begin
+ if List.length servers <= 1 || confirm (Printf.sprintf "Upload to %s ?" server.hostname) then
+ Some (fn server)
+ else
+ None
+ end in
+ List.fold_left (fun k server ->
+ let nk = one server in
+ if k <> None && k <> nk then
+ Globals.error_and_exit "upload keys differ!"
+ else
+ nk
+ ) None servers
+
+ let newArchive servers nv spec archive =
+ iter_upload_server (fun server ->
+ RemoteServer.newArchive server nv spec archive
+ ) servers
+
+ let updateArchive servers nv spec archive k =
+ let (_ : unit option) =
+ iter_upload_server (fun server ->
+ RemoteServer.updateArchive server nv spec archive k
+ ) servers in
+ ()
+
(* Upload reads NAME.spec (or NAME if it ends .spec) to get the current package version.
Then it looks for NAME-VERSION.tar.gz in the same directory (if it exists).
If not, it looks for provided URLs.
@@ -536,7 +583,7 @@ module Client : CLIENT = struct
if urls = [] then
Globals.error_and_exit "No location specified for %s" archive_filename
else
- let is_local_patch = function External ((Run.Config | Run.Install), _) -> true | _ -> false in
+ let is_local_patch = function External ((Config|Install), _) -> true | _ -> false in
match File.Spec.patches spec with
| patches when patches <> [] && List.for_all is_local_patch patches ->
(* the ".spec" being processed contains only local patches *)
@@ -562,11 +609,14 @@ module Client : CLIENT = struct
let o_key = File.Security_key.find (Path.keys t.home name) in
match o_key with
| None ->
- let k = RemoteServer.newArchive t.server (name, version) spec_b archive in
- let _ = Server.newArchive local_server (name, version) spec_b archive in
+ let k1 = newArchive t.servers (name, version) spec_b archive in
+ let k2 = Server.newArchive local_server (name, version) spec_b archive in
+ let k = match k1 with
+ | None -> k2
+ | Some k -> k in
File.Security_key.add (Path.keys t.home name) k
| Some k ->
- RemoteServer.updateArchive t.server (name, version) spec_b archive k;
+ updateArchive t.servers (name, version) spec_b archive k;
Server.updateArchive local_server (name, version) spec_b archive k
type config_request = Include | Bytelink | Asmlink
View
@@ -18,6 +18,7 @@ open ExtList
open Namespace
open Path
open File_format
+open Uri
type ('a, 'b) text =
| Parsed of 'a
@@ -139,15 +140,13 @@ struct
(** destruct *)
val opam_version : t -> int
- val sources : t -> url
+ val sources : t -> url list
val ocaml_version : t -> internal_version
- val git : t -> bool
(** construct *)
val create :
int (* opam *) ->
- bool (* git *) ->
- url ->
+ url list ->
internal_version (* ocaml *) ->
t
end
@@ -158,31 +157,27 @@ struct
type t =
{ version : int (* opam version *)
- ; git : bool (* git repo *)
- ; sources : url
+ ; sources : url list
; ocaml_version : internal_version }
let version_of_string s = Version s
let opam_version t = t.version
- let git t = t.git
let sources t = t.sources
let ocaml_version t = t.ocaml_version
- let create version git sources ocaml_version = { version ; git ; sources ; ocaml_version }
+ let create version sources ocaml_version = { version ; sources ; ocaml_version }
let empty = {
version = Globals.api_version;
- git = false;
- sources = url Globals.default_hostname Globals.default_port ;
+ sources = [url Globals.default_hostname];
ocaml_version = Version Sys.ocaml_version
}
let to_string t =
- Printf.sprintf "version: %d\ngit: %b\nsources: %s\nocaml-version: %s\n"
+ Printf.sprintf "version: %d\nsources: %s\nocaml-version: %s\n"
t.version
- t.git
- (string_of_url t.sources)
+ (String.concat ", " (List.map string_of_url t.sources))
(match t.ocaml_version with Version s -> s)
let parse contents =
@@ -198,19 +193,22 @@ struct
Globals.error_and_exit
"Fatal error: invalid value for 'version' field in %s/config. Exit"
!Globals.root_path in
- let git = match Parse.Exceptionless.assoc_parsed "git" file with
- | None -> false
- | Some b -> bool_of_string b in
let sources =
- try
- let sources = Parse.assoc_parsed "sources" file in
- let hostname, port = BatString.split sources ":" in
- url hostname (try int_of_string port with Not_found -> Globals.default_port)
- with _ ->
- url Globals.default_hostname Globals.default_port in
+ Parse.assoc_parsed "sources" file in
+ let sources =
+ try List.map String.strip (String.nsplit sources ",")
+ with _ -> [sources] in
+ let one source =
+ let uri, hostname = uri_of_url source in
+ let hostname, port =
+ try
+ let u, p = BatString.split hostname ":" in
+ u, Some (int_of_string p)
+ with Not_found -> hostname, None in
+ url ?uri ?port hostname in
+ let sources = List.map one sources in
let ocaml_version = try Parse.assoc_parsed "ocaml-version" file with Not_found -> Sys.ocaml_version in
{ version = version
- ; git
; sources
; ocaml_version = Version ocaml_version }
end
@@ -330,12 +328,9 @@ struct
(String.concat "; " (List.map ps l)) in
let plf k l =
pl k (List.map (function
- | Internal s -> sprintf "local://%s" s
- | External (Run.Http_wget, s) -> sprintf "http://%s" s
- | External (Run.Http_ftp, s) -> sprintf "http://%s" s
- | External (Run.Git, s) -> sprintf "git://%s" s
- | External (Run.Config, s) -> sprintf "config://%s" s
- | External (Run.Install, s) -> sprintf "install://%s" s) l) in
+ | Internal s -> sprintf "local://%s" s
+ | External (uri, s) -> sprintf "%s%s" (string_of_uri uri) s
+ ) l) in
sprintf "@%d\n\npackage %S {\n%s%s%s%s\n}\n"
Globals.api_version t.name
@@ -347,7 +342,7 @@ struct
let filter_external_patches t =
{ t with patches =
List.filter (function
- | External ((Run.Config | Run.Install), _) -> false
+ | External ((Config|Install), _) -> false
| _ -> true) t.patches }
let parse str =
View
@@ -14,6 +14,7 @@
(***********************************************************************)
open ExtString
+open Uri
type content =
| String of string
@@ -66,13 +67,8 @@ let rec string_of_content = function
let parse_l_url =
List.map (fun s ->
- try
- let s1, s2 = String.split s "://" in
- match s1 with
- | "http" -> Path.External ((match Globals.os with Globals.Darwin -> Run.Http_ftp | _ -> Run.Http_wget), s2)
- | "local" -> Path.Internal s2
- | "git" -> Path.External (Run.Git, s2)
- | "config" -> Path.External (Run.Config, s2)
- | "install" -> Path.External (Run.Install, s2)
- | _ -> failwith "to complete !"
- with Invalid_string -> Printf.kprintf failwith "to complete : %S" s)
+ match uri_of_url s with
+ | None , s2
+ | Some Local, s2 -> Path.Internal s2
+ | Some uri , s2 -> Path.External (uri, s2)
+ )
Oops, something went wrong.

0 comments on commit 45abc3d

Please sign in to comment.