Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More clean-ups.

Lots of small changes, reworked a little bit the server API to look more to what is defined in the spec.
Tests are still failing ...
  • Loading branch information...
commit 85508722012bc937874bbee256cc65c7ae746c08 1 parent f5f4826
@samoht samoht authored
View
160 src/client.ml
@@ -46,51 +46,36 @@ module Client : CLIENT = struct
{ server : url
; home : Path.t (* ~/.opam *) }
+ let home = Path.init Globals.opam_path
+
(* Look into the content of ~/.opam/config to build the client state *)
let load_state () =
- let home = Path.init Globals.opam_path in
- let config = File.Config.find home (Path.config home) in
+ let config = File.Config.find (Path.config home) in
{ server = File.Config.sources config
; home }
- let update_aux t =
- let map =
- List.fold_left
- (fun map (n, v) ->
- let index_nv = Path.index_opam t.home (Some (n, v)) in
- if Path.file_exists index_nv then
- map
- else begin
- File.Cudf.add t.home index_nv
- (File.Cudf.cudf
- (Version Globals.opam_version)
- (match snd (RemoteServer.getOpam t.server (n, v)) with
- | None -> assert false
- | Some pkg -> pkg));
- N_map.modify_def V_set.empty n (V_set.add v) map
- end)
- N_map.empty
- (RemoteServer.getList t.server) in
-
- Printf.printf "%s\n"
- (BatIO.to_string
- (N_map.print
- (fun oc name -> BatString.print oc (Namespace.string_user_of_name name))
- (V_set.print (fun oc version -> BatString.print oc (Namespace.string_user_of_version version)))
- ) map)
+ let update_t t =
+ let packages = RemoteServer.getList t.server in
+ List.iter
+ (fun (n, v) ->
+ let opam_file = Path.index_opam t.home (Some (n, v)) in
+ if not (Path.file_exists opam_file) then
+ let opam = RemoteServer.getOpam t.server (n, v) in
+ Path.add opam_file (Path.File opam);
+ Printf.printf "New package available: %s\n%!" (Namespace.string_of_nv n v)
+ ) packages
let update () =
- update_aux (load_state ())
+ update_t (load_state ())
let init url =
log "init %s" (string_of_url url);
let config =
- File.Config.config
+ File.Config.create
(Version Globals.opam_version)
url
(Version Globals.ocaml_version) in
- let home = Path.init Globals.opam_path in
- File.Config.add home (Path.config home) config;
+ File.Config.add (Path.config home) config;
update ()
let indent_left s nb = s ^ String.make nb ' '
@@ -110,15 +95,14 @@ module Client : CLIENT = struct
let s_not_installed = "--" in
match package with
| None ->
- let install_set = NV_set.of_enum (BatList.enum (File.Installed.find t.home (Path.installed t.home))) in
+ (* Get all the installed packages *)
+ let install_set = NV_set.of_enum (BatList.enum (File.Installed.find (Path.installed t.home))) in
let map, max_n, max_v =
List.fold_left
(fun (map, max_n, max_v) n_v ->
let b = NV_set.mem n_v install_set in
NV_map.add n_v
- (b,
- File.Cudf.description
- (File.Cudf.package (File.Cudf.find t.home (Path.index_opam t.home (Some n_v)))))
+ (b, File.Opam.description (File.Opam.find (Path.index_opam t.home (Some n_v))))
map,
max max_n (String.length (Namespace.string_user_of_name (fst n_v))),
if b then max max_v (String.length (Namespace.string_user_of_version (snd n_v))) else max_v)
@@ -138,7 +122,7 @@ module Client : CLIENT = struct
let o_v =
BatOption.map
V_set.choose (* By definition, there is exactly 1 element, we choose it. *)
- (find_from_name (File.Installed.find t.home (Path.installed t.home))) in
+ (find_from_name (File.Installed.find (Path.installed t.home))) in
let v_set =
let v_set =
@@ -161,8 +145,7 @@ module Client : CLIENT = struct
; "description", "\n" ^
match o_v with None -> ""
| Some v ->
- File.Cudf.description
- (File.Cudf.package (File.Cudf.find t.home (Path.index_opam t.home (Some (name, v)))))
+ File.Opam.description (File.Opam.find (Path.index_opam t.home (Some (name, v))))
]
let confirm msg =
@@ -179,18 +162,17 @@ module Client : CLIENT = struct
if Path.file_exists p_targz then
Path.R_filename
(BatList.map (Path.concat p_build)
- (match Path.find t.home p_build with
+ (match Path.find p_build with
| Path.Directory l -> l
| _ -> []))
else
- let tgz = Path.extract_targz t.home
- (RemoteServer.getArchive t.server (RemoteServer.getOpam t.server (name, v))) in
- Path.add_rec t.home p_build tgz;
+ let tgz = Path.extract_targz (RemoteServer.getArchive t.server (name, v)) in
+ Path.add_rec p_build tgz;
tgz in
f_build t tgz;
- let to_install = File.To_install.find t.home (Path.to_install t.home (name, v)) in
+ let to_install = File.To_install.find (Path.to_install t.home (name, v)) in
let filename_of_path_relative t path =
Path.R_filename (File.To_install.filename_of_path_relative t.home
@@ -214,33 +196,33 @@ module Client : CLIENT = struct
if confirm (File.To_install.string_of_misc misc) then
let path_from = filename_of_path_relative t (File.To_install.path_from misc) in
List.iter
- (fun path_to -> Path.add_rec t.home path_to path_from)
+ (fun path_to -> Path.add_rec path_to path_from)
(File.To_install.filename_of_path_absolute t.home (File.To_install.path_to misc)))
(File.To_install.misc to_install)
let proceed_todelete t (n, v0) =
- let map_installed = N_map.of_enum (BatList.enum (File.Installed.find t.home (Path.installed t.home))) in
+ let map_installed = N_map.of_enum (BatList.enum (File.Installed.find (Path.installed t.home))) in
match N_map.Exceptionless.find n map_installed with
| Some v when v = v0 ->
iter_toinstall
(fun t _ -> t)
(fun t file -> function
| Path.R_filename l ->
- List.iter (fun f -> Path.remove t.home (Path.concat file (Path.basename f))) l
+ List.iter (fun f -> Path.remove (Path.concat file (Path.basename f))) l
| _ -> failwith "to complete !")
t
(n, v);
- File.Installed.add t.home (Path.installed t.home) (N_map.bindings (N_map.remove n map_installed))
+ File.Installed.add (Path.installed t.home) (N_map.bindings (N_map.remove n map_installed))
| _ -> ()
let proceed_torecompile t (name, v) =
iter_toinstall
(fun t tgz ->
- Path.add_rec t.home (Path.build t.home (Some (name, v))) tgz;
+ Path.add_rec (Path.build t.home (Some (name, v))) tgz;
Path.exec_buildsh t.home (name, v))
(fun t file contents ->
- Path.add_rec t.home file contents)
+ Path.add_rec file contents)
t
(name, v)
@@ -276,7 +258,7 @@ module Client : CLIENT = struct
let l_pkg, map_pkg =
List.fold_left
(fun (l, map) n_v ->
- let pkg = File.Cudf.package (File.Cudf.find t.home (Path.index_opam t.home (Some n_v))) in
+ let pkg = File.Opam.package (File.Opam.find (Path.index_opam t.home (Some n_v))) in
pkg :: l, PkgMap.add pkg n_v map) ([], PkgMap.empty) l_index in
let l =
BatList.map (Solver.solution_map (fun p -> PkgMap.find p map_pkg)) (Solver.resolve l_pkg request) in
@@ -304,7 +286,7 @@ module Client : CLIENT = struct
Printf.sprintf "Package \"%s\" not found. An update of package will be performed."
(Namespace.string_user_of_name name) in
if confirm msg then
- update_aux t
+ update_t t
| Some v ->
let _ = resolve t l_index { Solver.wish_install = [ vpkg_of_nv (name, V_set.max_elt v) ]
; wish_remove = []
@@ -314,7 +296,7 @@ module Client : CLIENT = struct
let remove name =
log "remove %s" (Namespace.string_of_name name);
let t = load_state () in
- let r = match BatList.Exceptionless.assoc name (File.Installed.find t.home (Path.installed t.home)) with
+ let r = match BatList.Exceptionless.assoc name (File.Installed.find (Path.installed t.home)) with
| None ->
let msg =
Printf.sprintf "Package \"%s\" not found. We will call the solver to see its output."
@@ -338,34 +320,36 @@ module Client : CLIENT = struct
resolve t (Path.index_opam_list t.home)
{ Solver.wish_install = []
; wish_remove = []
- ; wish_upgrade = BatList.map vpkg_of_nv (File.Installed.find t.home (Path.installed t.home)) }
+ ; wish_upgrade = BatList.map vpkg_of_nv (File.Installed.find (Path.installed t.home)) }
- let upload s_filename =
- log "upload %s" s_filename;
+ (* Upload reads NAME.opam to get the current package version.
+ Then it looks for NAME-VERSION.tar.gz in the same directory.
+ Then, it sends both NAME.opam and NAME-VERSION.tar.gz to the server *)
+ let upload name =
+ log "upload %s" name;
let t = load_state () in
- let filename = Path.package t.home s_filename in
- let o =
- let f msg v =
- let msg = Printf.sprintf "Path \"%s\" %s. It will be uploaded anyway." s_filename msg in
- if confirm msg then
- Some v
- else
- None in
- match Path.find t.home filename with
- | Path.File binary -> Some (Tar_gz binary)
- | Path.Directory _ -> f "is a directory" (Path.raw_targz filename)
- | Path.Not_exists -> f "has not been found" Empty in
-
- (* Upload the archive to the server *)
- match o with
- | Some v ->
- let package = Path.nv_of_extension Namespace.default_version (Path.basename filename) in
- let local_server = Server.init Globals.opam_path in
- (* Upload the archive to the remote server *)
- RemoteServer.newArchive t.server (RemoteServer.getOpam t.server package) v;
- (* Copy the archive in the client state *)
- Server.newArchive local_server (Server.getOpam local_server package) v
- | None -> ()
+
+ (* Get the current package version *)
+ let opam_filename = name ^ ".opam" in
+ let opam_binary = U.read_content opam_filename in
+ let opam = File.Opam.parse opam_binary in
+ let version = File.Opam.version opam in
+ let opam = binary opam_binary in
+
+ (* look for the archive *)
+ let archive_filename = Namespace.string_of_nv (Namespace.Name name) version ^ ".tar.gz" in
+ let archive =
+ if Sys.file_exists archive_filename then
+ Tar_gz (binary (U.read_content archive_filename))
+ else
+ Globals.error_and_exit "Cannot find %s" archive_filename in
+
+ (* Upload both files to the server and update the client
+ filesystem to reflect the new uploaded packages *)
+ let nv = Namespace.Name name, version in
+ let local_server = Server.init Globals.opam_path in
+ RemoteServer.newArchive t.server nv opam archive;
+ Server.newArchive local_server nv opam archive
type config_request = Dir
let config Dir name =
@@ -373,16 +357,14 @@ module Client : CLIENT = struct
let t = load_state () in
match find_from_name name (Path.index_opam_list t.home) with
- | None ->
- let msg =
- Printf.sprintf "Package \"%s\" not found. An update of package will be performed."
- (Namespace.string_user_of_name name) in
- if confirm msg then
- update_aux t
+ | None ->
+ let msg =
+ Printf.sprintf "Package \"%s\" not found. An update of package will be performed."
+ (Namespace.string_user_of_name name) in
+ if confirm msg then
+ update_t t
- | Some _ ->
- Printf.printf "-I %s"
- (match Path.ocaml_options_of_library t.home name with I s -> s)
+ | Some _ ->
+ Printf.printf "-I %s"
+ (match Path.ocaml_options_of_library t.home name with I s -> s)
end
-
-
View
352 src/file.ml
@@ -9,8 +9,17 @@ struct
sig
type t
- val find : Path.t -> Path.filename -> t
- val add : Path.t -> Path.filename -> t -> unit
+ (** Parse a string *)
+ val parse: string -> t
+
+ (** Return the content of a file as a string *)
+ val to_string: t -> string
+
+ (** Find a file. Raise [Not_found] is the file does not exists *)
+ val find : Path.filename -> t
+
+ (** Add a file *)
+ val add : Path.filename -> t -> unit
end
module type CONFIG =
@@ -20,13 +29,12 @@ struct
val version_of_string : string -> internal_version
(** destruct *)
- val package_manager : t -> internal_version
+ val opam_version : t -> internal_version
val sources : t -> url
val ocaml_version : t -> internal_version
-
(** construct *)
- val config : internal_version (* opam *) -> url -> internal_version (* ocaml *) -> t
+ val create : internal_version (* opam *) -> url -> internal_version (* ocaml *) -> t
end
let filter motif =
@@ -41,22 +49,25 @@ struct
module Config : CONFIG =
struct
- type t = { version : internal_version ; sources : url ; ocaml_version : internal_version }
+ type t =
+ { version : internal_version (* opam version *)
+ ; sources : url
+ ; ocaml_version : internal_version }
let version_of_string s = Version s
- let package_manager t = t.version
+ let opam_version t = t.version
let sources t = t.sources
let ocaml_version t = t.ocaml_version
- let config version sources ocaml_version = { version ; sources ; ocaml_version }
- let empty = {
+ let create version sources ocaml_version = { version ; sources ; ocaml_version }
+
+ let default = {
version = Version Globals.version;
sources = url Globals.default_hostname Globals.default_port ;
ocaml_version = Version Sys.ocaml_version
}
-
let to_string t =
Printf.sprintf "version: %s\nsources: %s\nocaml-version: %s\n"
(match t.version with Version s -> s)
@@ -66,124 +77,205 @@ struct
let log fmt =
Globals.log "FILE.CONFIG" fmt
- let find t f =
- log "read %s" (Path.string_of_filename f);
- let aux contents =
- let file = parse_colon contents in
- let version = try List.assoc "version" file with _ -> Globals.opam_version in
- let sources =
- try
- let sources = List.assoc "sources" file in
- let hostname, port = BatString.split sources ":" in
- url hostname (try int_of_string port with _ -> Globals.default_port)
- with _ ->
- url Globals.default_hostname Globals.default_port in
- let ocaml_version = try List.assoc "ocaml-version" file with _ -> Sys.ocaml_version in
- { version = Version version; sources; ocaml_version = Version ocaml_version } in
-
- let t = match Path.find_binary t f with
- | Path.File (Raw_binary s) -> aux s
+ let parse contents =
+ let file = parse_colon contents in
+ let version = try List.assoc "version" file with _ -> Globals.opam_version in
+ let sources =
+ try
+ let sources = List.assoc "sources" file in
+ let hostname, port = BatString.split sources ":" in
+ url hostname (try int_of_string port with _ -> Globals.default_port)
+ with _ ->
+ url Globals.default_hostname Globals.default_port in
+ let ocaml_version = try List.assoc "ocaml-version" file with _ -> Sys.ocaml_version in
+ { version = Version version
+ ; sources
+ ; ocaml_version = Version ocaml_version }
+
+ let find f =
+ log "find %s" (Path.string_of_filename f);
+ match Path.find_binary f with
+ | Path.File (Raw_binary s) -> parse s
| Path.Directory _ -> failwith (Printf.sprintf "%s is a directory" (Path.string_of_filename f))
- | Path.Not_exists -> failwith (Printf.sprintf "%s does not exist" (Path.string_of_filename f)) in
- log "contents:\n%s" (to_string t);
- t
-
- let add t f v = Path.add t f (Path.File (Binary (Raw_binary (to_string v))))
+ let add f v =
+ log "add %s" (Path.string_of_filename f);
+ Path.add f (Path.File (Binary (Raw_binary (to_string v))))
end
module type CUDF =
sig
include IO_FILE
- (** destruct *)
- val package : t -> Cudf.package
- val description : Cudf.package -> string
+ (** Constructor *)
+ val create: Cudf.preamble option -> Cudf.package list -> Cudf.request option -> t
- (** construct *)
- val new_package : name_version -> string (* description *) -> Cudf.package
- val cudf : internal_version (* package manager *) -> Cudf.package -> t
+ (** Getters *)
+ val packages: t -> Cudf.package list
end
+ (* If next modules wants to refer to Cudf *)
+ module C = Cudf
+
module Cudf : CUDF =
struct
- type package =
+ type t =
{ preamble : Cudf.preamble option
- ; pkg : Cudf.package list
+ ; pkgs : Cudf.package list
; request : Cudf.request option }
-
- type t =
- { opam_version : internal_version
- ; package : package }
+
+ let parse str =
+ let preamble, pkgs, request =
+ Cudf_parser.parse (Cudf_parser.from_IO_in_channel (IO.input_string str)) in
+ { preamble; pkgs; request }
+
+ let to_string t =
+ let oc = IO.output_string () in
+ (match t.preamble with
+ | Some preamble -> Cudf_printer.pp_io_preamble oc preamble
+ | None -> ());
+ IO.write oc '\n';
+ List.iter (Cudf_printer.pp_io_package oc) t.pkgs;
+ IO.write oc '\n';
+ (match t.request with
+ | Some request -> Cudf_printer.pp_io_request oc request
+ | None -> ());
+ IO.close_out oc
+
+ let create preamble pkgs request =
+ { preamble; pkgs; request }
+
+ let packages p = p.pkgs
+
+ let log fmt =
+ Globals.log "FILE.CONFIG" fmt
+
+ let find f =
+ log "find %s" (Path.string_of_filename f);
+ match Path.find_binary f with
+ | Path.File (Raw_binary s) ->
+ (try parse s
+ with _ ->
+ failwith ("Error while parsing " ^ Path.string_of_filename f))
+ | _ -> raise Not_found
+
+ let add f v =
+ log "add %s" (Path.string_of_filename f);
+ Path.add f (Path.File (Binary (Raw_binary (to_string v))))
+ end
+
+ module type OPAM = sig
+ include IO_FILE
+
+ (** destruct *)
+ val opam_version: t -> internal_version
+ val version : t -> Namespace.version
+ val description : t -> string
+ val package: t -> C.package
+
+ (** construct *)
+ val create : name_version -> string (* description *) -> t
+ end
+
+ module Opam : OPAM = struct
+
+ type t = {
+ opam_version: internal_version;
+ version: Namespace.version;
+ description: string;
+ cudf: Cudf.t;
+ }
+
+ let opam_version t = t.opam_version
+ let version t = t.version
+ let description t = t.description
let find_field key = function
- | [x] -> (try Some (List.assoc key x.Cudf.pkg_extra) with Not_found -> None)
- | _ -> None
+ | [x] -> (try Some (List.assoc key x.C.pkg_extra) with Not_found -> None)
+ | _ -> None
let package t =
- match t.package.pkg with
+ match Cudf.packages t with
| [ x ] -> x
- | _ -> Cudf.default_package
-
- let name p = match p.pkg with [x] -> x.Cudf.package | _ -> ""
- let version p = match p.pkg with [x] -> x.Cudf.version | _ -> min_int
+ | _ -> failwith "package: Bad format"
let s_description = "description"
- let description p =
- match find_field s_description [ p ] with
- | Some (`String s) -> s
- | _ -> ""
+ let s_user_version = "user-version"
+ let s_opam_version = "opam-version"
- let new_package (Name name, version) description =
- { Cudf.default_package with
- Cudf.package = name ;
- Cudf.version = version.cudf ;
- Cudf.pkg_extra = [ s_description, `String description ] }
+ let opam_version_pkg p =
+ match find_field s_opam_version [ p ] with
+ | Some (`String s) -> Version s
+ | _ -> Version Globals.opam_version
- let empty_preamble = Some { Cudf.default_preamble with Cudf.property = [ s_description, `String None ] }
+ let version_pkg p =
+ match find_field s_user_version [ p ] with
+ | Some (`String s) -> { Namespace.deb = s; cudf = p.C.version }
+ | _ -> failwith "Bad format"
- let cudf opam_version pkg = { opam_version ; package = { preamble = empty_preamble ; pkg = [ pkg ] ; request = None } }
+ let description_pkg p =
+ match find_field s_description [ p ] with
+ | Some (`String s) -> s
+ | _ -> ""
- let empty =
+ let package p =
+ match Cudf.packages p.cudf with
+ | [] -> failwith "Empty opam file"
+ | [ p ] -> p
+ | _ -> failwith "Too many packages"
+
+ let default_preamble =
+ Some { C.default_preamble with C.property = [ s_description, `String None ] }
+
+ let create (Name name, version) description =
+ let pkg = {
+ C.default_package with
+ C.package = name ;
+ version = version.Namespace.cudf ;
+ pkg_extra = [
+ s_description , `String description;
+ s_user_version, `String version.deb;
+ s_opam_version, `String Globals.opam_version;
+ ] } in
+ let cudf = Cudf.create default_preamble [pkg] None in
{ opam_version = Version Globals.opam_version
- ; package = { preamble = empty_preamble ; pkg = [] ; request = None } }
+ ; version
+ ; description
+ ; cudf }
+
+ let parse str =
+ let pkg = match Cudf.packages (Cudf.parse str) with
+ | [p] -> p
+ | _ -> failwith ("parse:" ^ str) in
+ let cudf = Cudf.create default_preamble [pkg] None in
+ { opam_version = opam_version_pkg pkg
+ ; version = version_pkg pkg
+ ; description = description_pkg pkg
+ ; cudf }
+
+ (* XXX: This need to be handled in a better way:
+ * opam-version MUST appear on the first line,
+ * and the version should be the user-version *)
+ let to_string t =
+ Cudf.to_string t.cudf
- let find t f =
- match Path.find_binary t f with
- | Path.File (Raw_binary s) ->
- (match
- try
- Some (Cudf_parser.parse (Cudf_parser.from_IO_in_channel (IO.input_string s)))
- with _ -> None
- with
- | None -> empty
- | Some (preamble, pkg, request) ->
- { opam_version =
- (match find_field "opam_version" pkg with
- | Some (`String v) -> Config.version_of_string v
- | _ -> empty.opam_version)
- ; package = { preamble ; pkg ; request } })
- | _ -> empty
+ let log fmt =
+ Globals.log "FILE.CONFIG" fmt
- let to_string t =
- let oc = IO.output_string () in
- let () =
- begin
- (match t.package.preamble with
- | Some preamble -> Cudf_printer.pp_io_preamble oc preamble
- | None -> ());
- IO.write oc '\n';
- List.iter (Cudf_printer.pp_io_package oc) t.package.pkg;
- IO.write oc '\n';
- (match t.package.request with
- | Some request -> Cudf_printer.pp_io_request oc request
- | None -> ());
- end in
- IO.close_out oc
+ let find f =
+ log "find %s" (Path.string_of_filename f);
+ match Path.find_binary f with
+ | Path.File (Raw_binary s) ->
+ (try parse s
+ with _ -> failwith ("Error while parsing " ^ Path.string_of_filename f))
+ | _ -> raise Not_found
- let add t f v = Path.add t f (Path.File (Binary (Raw_binary (to_string v))))
+ let add f v =
+ log "add %s" (Path.string_of_filename f);
+ Path.add f (Path.File (Binary (Raw_binary (to_string v))))
end
+
module type INSTALLED =
sig
include IO_FILE with type t = name_version list
@@ -194,10 +286,12 @@ struct
type t = name_version list
let empty = []
- let find t f =
- match Path.find_binary t f with
- | Path.File (Raw_binary s) ->
- BatList.map (fun (name, version) -> Name name, version_of_string name version) (parse_space s)
+ let parse s =
+ BatList.map (fun (name, version) -> Name name, version_of_string name version) (parse_space s)
+
+ let find f =
+ match Path.find_binary f with
+ | Path.File (Raw_binary s) -> parse s
| _ -> empty
let to_string =
@@ -208,7 +302,7 @@ struct
(Namespace.string_user_of_name name)
(Namespace.string_user_of_version version))))
- let add t f v = Path.add t f (Path.File (Binary (Raw_binary (to_string v))))
+ let add f v = Path.add f (Path.File (Binary (Raw_binary (to_string v))))
end
type basename_last =
@@ -277,7 +371,7 @@ struct
BatList.filter
(fun (B name) ->
(try Some (snd (BatString.split name ".")) with _ -> None) = Some suff)
- (match Path.find t f with Path.Directory l -> l | _ -> []))
+ (match Path.find f with Path.Directory l -> l | _ -> []))
let filename_of_path_relative t f = function
| Relative, l_b, suff -> filename_of_path t f l_b suff
@@ -304,34 +398,33 @@ struct
let relative_path_of_string = b_of_string Relative
- let find t f =
- match Path.find_binary t f with
- | Path.File (Raw_binary s) ->
-
- let l_lib_bin, l_misc =
- let l, f_while =
- BatString.nsplit s "\n",
- fun s ->
- match try Some (BatString.split "misc" (BatString.trim s)) with _ -> None with
- | Some ("", _) -> true
- | _ -> false in
- BatList.take_while f_while l, BatList.drop_while f_while l in
-
- (match filter ":" l_lib_bin with
- | ("lib", lib)
- :: ("bin", bin) :: _ ->
- { lib = BatList.map relative_path_of_string (BatString.nsplit lib ",")
- ; bin = relative_path_of_string bin
- ; misc =
- BatList.map
- (fun (s_path, s_fname) ->
- { p_from = relative_path_of_string s_path ; p_to = b_of_string Absolute s_fname })
- (filter " " l_misc) }
- | _ -> empty)
-
+ let parse s =
+ let l_lib_bin, l_misc =
+ let l, f_while =
+ BatString.nsplit s "\n",
+ fun s ->
+ match try Some (BatString.split "misc" (BatString.trim s)) with _ -> None with
+ | Some ("", _) -> true
+ | _ -> false in
+ BatList.take_while f_while l, BatList.drop_while f_while l in
+
+ (match filter ":" l_lib_bin with
+ | ("lib", lib)
+ :: ("bin", bin) :: _ ->
+ { lib = BatList.map relative_path_of_string (BatString.nsplit lib ",")
+ ; bin = relative_path_of_string bin
+ ; misc =
+ BatList.map
+ (fun (s_path, s_fname) ->
+ { p_from = relative_path_of_string s_path ; p_to = b_of_string Absolute s_fname })
+ (filter " " l_misc) }
+ | _ -> empty)
+
+ let find f =
+ match Path.find_binary f with
+ | Path.File (Raw_binary s) -> parse s
| _ -> empty
-
let to_string t =
let path_print oc (pref, l_base, base) =
@@ -356,6 +449,7 @@ misc:
path_print oc (misc.p_to);
end)) t.misc)
- let add t f v = Path.add t f (Path.File (Binary (Raw_binary (to_string v))))
+ let add f v =
+ Path.add f (Path.File (Binary (Raw_binary (to_string v))))
end
end
View
6 src/globals.ml
@@ -21,3 +21,9 @@ let error fmt =
Printf.kprintf (fun str ->
Printf.eprintf "ERROR: %s\n%!" str
) fmt
+
+let error_and_exit fmt =
+ Printf.kprintf (fun str ->
+ error "%s" str;
+ exit 1
+ ) fmt
View
4 src/ocp_get_server.ml
@@ -63,10 +63,10 @@ let fn t stdin stdout =
| IgetArchive opam ->
log id "getArchive";
protect (fun () -> OgetArchive (Server.getArchive t opam))
- | InewArchive (opam, archive) ->
+ | InewArchive (nv, opam, archive) ->
(* XXX: need to protect the server state mutation as it can be updated concurrently *)
log id "newArchive";
- protect (fun () -> Server.newArchive t opam archive; OnewArchive) in
+ protect (fun () -> Server.newArchive t nv opam archive; OnewArchive) in
output_value stdout output;
flush stdout
View
168 src/path.ml
@@ -26,14 +26,95 @@ type binary_data =
| Binary of raw_binary
| Filename of raw_filename
+let binary s = Binary (Raw_binary s)
+let filename s = Filename (Raw_filename s)
+
type 'a archive =
| Tar_gz of 'a
- | Empty
type basename = B of string
+(** Type used to represent an internal form of version, which is in
+ particular not related to the version of a particular package *)
type internal_version = Version of string
-(** Type used to represent an internal form of version, which is in particular not related to the version of a particular package *)
+
+module U = struct
+ let mkdir f f_to =
+ let rec aux f_to =
+ if Sys.file_exists f_to then
+ ()
+ else begin
+ aux (Filename.dirname f_to);
+ Unix.mkdir f_to 0o755;
+ end in
+ aux (Filename.dirname f_to);
+ f f_to
+
+ let link f_from = mkdir (Unix.link f_from)
+
+ let copy src dst =
+ log "Copying %s to %s" src dst;
+ let n = 1024 in
+ let b = String.create n in
+ let read = ref 0 in
+ let ic = open_in src in
+ let oc = open_out dst in
+ while !read <>0 do
+ read := input ic b 0 n;
+ output oc b 0 !read;
+ done;
+ close_in ic;
+ close_out oc
+
+ let read_content file =
+ let ic = open_in file in
+ let n = in_channel_length ic in
+ let s = String.create n in
+ really_input ic s 0 n;
+ close_in ic;
+ s
+
+ (**************************)
+ (* from ocplib-system ... *)
+ (**************************)
+
+ let in_dir dir fn =
+ let cwd = Unix.getcwd () in
+ Unix.chdir dir;
+ try
+ let r = fn () in
+ Unix.chdir cwd;
+ r
+ with e ->
+ Unix.chdir cwd;
+ raise e
+
+ let directories () =
+ let d = Sys.readdir (Unix.getcwd ()) in
+ let d = Array.to_list d in
+ List.filter (fun f -> try Sys.is_directory f with _ -> false) d
+
+ let files () =
+ let d = Sys.readdir (Unix.getcwd ()) in
+ let d = Array.to_list d in
+ List.filter (fun f -> try not (Sys.is_directory f) with _ -> true) d
+
+ let safe_unlink file =
+ try Unix.unlink file
+ with Unix.Unix_error _ -> ()
+
+ let rec safe_rmdir dir =
+ if Sys.file_exists dir then begin
+ in_dir dir (fun () ->
+ let dirs = directories () in
+ let files = files () in
+ List.iter safe_unlink files;
+ List.iter safe_rmdir dirs;
+ );
+ Unix.rmdir dir;
+ end
+end
+
module type PATH =
sig
@@ -44,7 +125,6 @@ sig
type 'a contents =
| Directory of basename list
| File of 'a
- | Not_exists
type 'a contents_rec =
| R_directory of (basename * 'a contents_rec) list
@@ -93,28 +173,28 @@ sig
val to_install : t -> name_version -> filename (* $HOME_OPAM_OVERSION/build/NAME-VERSION/NAME.install *)
- (** **)
+ (** Path utilities **)
(** Retrieves the contents from the hard disk. *)
- val find : t -> filename -> binary_data contents
+ val find : filename -> binary_data contents
(** see [find] *)
- val find_binary : t -> filename -> raw_binary contents
+ val find_binary : filename -> raw_binary contents
(** see [find] *)
- val find_filename : t -> filename -> raw_filename contents
+ val find_filename : filename -> raw_filename contents
(** Removes everything in [filename] if existed. *)
- val remove : t -> filename -> unit
+ val remove : filename -> unit
(** Removes everything in [filename] if existed, then write [contents] instead. *)
- val add : t -> filename -> binary_data contents -> unit
+ val add : filename -> binary_data contents -> unit
(** Removes everything in [filename] if existed, then write [contents_rec] inside [filename]. *)
- val add_rec : t -> filename -> binary_data contents_rec -> unit
+ val add_rec : filename -> binary_data contents_rec -> unit
(** Returns the same meaning as [archive] but in extracted form. *)
- val extract_targz : t -> binary_data archive -> binary_data contents_rec
+ val extract_targz : binary_data archive -> binary_data contents_rec
(** Considers the given [filename] as the contents of an [archive] already extracted. *)
val raw_targz : filename -> binary_data archive
@@ -161,7 +241,6 @@ module Path : PATH = struct
type 'a contents =
| Directory of basename list
| File of 'a
- | Not_exists
type 'a contents_rec =
| R_directory of (basename * 'a contents_rec) list
@@ -213,18 +292,19 @@ module Path : PATH = struct
let to_install t (n, v) = build t (Some (n, v)) /// B (Namespace.string_of_name n ^ ".install")
- let contents f_dir f_fic f_not_exists t f =
+ let contents f_dir f_fic f =
let fic = s_of_filename f in
if Sys.file_exists fic then
(if Sys.is_directory fic then f_dir else f_fic) fic
- else
- f_not_exists
+ else begin
+ log "%s does not exist" fic;
+ raise Not_found
+ end
let find_ f_fic =
contents
(fun fic -> Directory (BatList.of_enum (BatEnum.map (fun s -> B s) (BatSys.files_of fic))))
(fun fic -> File (f_fic fic))
- Not_exists
let find = find_ (fun fic -> Filename (Raw_filename fic))
@@ -247,12 +327,14 @@ module Path : PATH = struct
let file_exists f = Sys.file_exists (s_of_filename f)
let index_opam_list t =
- BatList.map (nv_of_extension Namespace.default_version)
- (match find t (index_opam t None) with
+ let files =
+ try match find (index_opam t None) with
| Directory l -> l
- | _ -> [])
+ | File _ -> [] (* XXX: ? *)
+ with Not_found -> [] in
+ List.map (nv_of_extension Namespace.default_version) files
- let remove t f =
+ let remove f =
let rec aux fic =
match (Unix.lstat fic).Unix.st_kind with
| Unix.S_DIR ->
@@ -262,34 +344,18 @@ module Path : PATH = struct
| _ -> failwith "to complete !" in
aux (s_of_filename f)
- module U = struct
- let mkdir f f_to =
- let rec aux f_to =
- if Sys.file_exists f_to then
- ()
- else begin
- aux (Filename.dirname f_to);
- Unix.mkdir f_to 0o755;
- end in
- aux (Filename.dirname f_to);
- f f_to
-
- let link f_from = mkdir (Unix.link f_from)
-
- end
-
- let add t f content =
+ let add f content =
log "add %s" (s_of_filename f);
match content with
| Directory d -> failwith "to complete !"
| File (Binary (Raw_binary cts)) ->
- let () = contents (fun _ -> failwith "to complete !") Unix.unlink () t f in
- let fic = s_of_filename f in
+ let fic = s_of_filename f in
+ U.safe_unlink fic;
U.mkdir (fun fic -> BatFile.with_file_out fic (fun oc -> BatString.print oc cts)) fic
- | File (Filename (Raw_filename fic)) ->
+ | File (Filename (Raw_filename fic)) ->
begin match (Unix.lstat fic).Unix.st_kind with
| Unix.S_DIR ->
- let () = contents (fun _ -> ()) (fun _ -> failwith "to complete !") () t f in
+ U.safe_rmdir fic;
let rec aux f_from f_to =
(match (Unix.lstat f_from).Unix.st_kind with
| Unix.S_DIR -> List.fold_left (fun _ b -> aux (f_from // b) (f_to // b)) () (BatSys.files_of f_from)
@@ -302,9 +368,11 @@ module Path : PATH = struct
U.link f_from f_to
| _ -> failwith "to complete !") in
aux fic (s_of_filename f)
+ | Unix.S_REG ->
+ U.safe_unlink fic;
+ U.copy fic (s_of_filename f)
| _ -> Printf.kprintf failwith "to complete ! copy the given filename %s" fic
end
- | Not_exists -> ()
let exec_buildsh t n_v =
let _ = Sys.chdir (s_of_filename (build t (Some n_v))) in
@@ -313,10 +381,9 @@ module Path : PATH = struct
let basename s = B (Filename.basename (s_of_filename s))
- let extract_targz t = function
+ let extract_targz = function
| Tar_gz (Binary _) -> failwith "to complete ! check if the \"dose\" project has been configured with the correct option to extract the gzip or bz2, then use similars functions to extract" (*IO.read_all (Common.Input.open_file fic)*)
| Tar_gz (Filename (Raw_filename fic)) -> R_filename [Raw fic]
- | Empty -> R_directory []
let raw_targz f = Tar_gz (Filename (Raw_filename (s_of_filename f)))
@@ -325,23 +392,22 @@ module Path : PATH = struct
let dirname = filename_map Filename.dirname
- let add_rec t f =
+ let add_rec f =
let () = (* check that [f] is not a file *)
contents
(fun _ -> ())
(fun _ -> failwith "to complete !")
- () t f in
+ f in
- let rec aux t f (* <- filename dir *) name (* name of the value that will be destructed*) = function
+ let rec aux f (* <- filename dir *) name (* name of the value that will be destructed*) = function
| R_directory l ->
let f = f /// name in
- List.iter (fun (b, cts) -> aux t f b cts) l
- | R_file cts -> add t (f /// name) (File cts)
+ List.iter (fun (b, cts) -> aux f b cts) l
+ | R_file cts -> add (f /// name) (File cts)
| R_filename l ->
List.iter
(fun fic ->
aux
- t
f
(basename fic)
(match (lstat fic).Unix.st_kind with
@@ -350,7 +416,7 @@ module Path : PATH = struct
f, R_filename [fic /// f]) (files_of fic))
| Unix.S_REG -> R_file (Filename (Raw_filename (s_of_filename fic)))
| _ -> failwith "to complete !")) l in
- aux t (dirname f) (basename f)
+ aux (dirname f) (basename f)
let ocaml_options_of_library t name =
I (Printf.sprintf "%s" (s_of_filename (lib t name)))
View
113 src/server.ml
@@ -7,91 +7,78 @@ module type SERVER =
sig
type t
- (** [None] : the current repository does not contain the package
- associated to the [name] and [version] *)
- type opam = name_version * Cudf.package option
-
(** Returns the list of the available versions for all packages. *)
val getList : t -> name_version list
(** Returns the representation of the OPAM file for the
corresponding package version. *)
- val getOpam : t -> name_version -> opam
+ val getOpam : t -> name_version -> binary_data
(** Returns the corresponding package archive. *)
- val getArchive : t -> opam -> binary_data archive
+ val getArchive : t -> name_version -> binary_data archive
(** Receives an upload, it contains an OPAM file and the
corresponding package archive. *)
- val newArchive : t -> opam -> binary_data archive -> unit
+ val newArchive : t -> name_version -> binary_data -> binary_data archive -> unit
end
type server_state =
- { mutable current_repository : Cudf.package NV_map.t
- ; home : Path.t (* ~/.opam-server *)
- ; version_package_manager : internal_version }
+ { home : Path.t (* ~/.opam-server *)
+ ; opam_version : internal_version }
module Server = struct
type t = server_state
- type opam = name_version * Cudf.package option
-
+ (* Return all the .opam files *)
let read_index home =
List.fold_left
- (fun map nv ->
- NV_map.add
- nv
- (File.Cudf.package (File.Cudf.find home (Path.index_opam home (Some nv))))
- map) NV_map.empty
+ (fun map nv -> NV_map.add nv (File.Opam.find (Path.index_opam home (Some nv))) map)
+ NV_map.empty
(Path.index_opam_list home)
+ let string_of_nv (n, v) = Namespace.string_of_nv n v
+
let init path =
- let home = Path.init path in
- { current_repository = read_index home
- ; home
- ; version_package_manager = Version Globals.opam_version }
-
- let getList t = BatList.map fst (NV_map.bindings t.current_repository)
- let getOpam t n_v = n_v, NV_map.Exceptionless.find n_v t.current_repository
- let getArchive t = function
- | _, None -> Empty
- | n_v, Some _ ->
- match Path.find t.home (Path.archives_targz t.home (Some n_v)) with
- | Path.File s -> Tar_gz s
- | _ -> Empty
-
- let newArchive t (n_v, o_pack) arch =
- Path.add
- t.home
- (Path.archives_targz t.home (Some n_v))
- (match arch with
- | Empty -> Path.Not_exists
- | Tar_gz s -> Path.File s);
-
- let new_package = File.Cudf.new_package n_v "" in
-
- File.Cudf.add
- t.home
- (Path.index_opam t.home (Some n_v))
- (File.Cudf.cudf t.version_package_manager new_package);
-
- match o_pack with
- | None -> t.current_repository <- NV_map.add n_v new_package t.current_repository
- | Some _ -> ()
+ { home = Path.init path
+ ; opam_version = Version Globals.opam_version }
+
+ let getList t =
+ Path.index_opam_list t.home
+
+ let getOpam t n_v =
+ let index = read_index t.home in
+ try binary (File.Opam.to_string (NV_map.find n_v index))
+ with Not_found -> failwith (string_of_nv n_v ^ " not found")
+
+ let getArchive t n_v =
+ match Path.find (Path.archives_targz t.home (Some n_v)) with
+ | Path.File s -> Tar_gz s
+ | _ -> failwith ("Cannot find " ^ string_of_nv n_v)
+
+ let newArchive t n_v opam archive =
+ let opam_file = Path.index_opam t.home (Some n_v) in
+ let archive_file = Path.archives_targz t.home (Some n_v) in
+ begin match opam with
+ | Binary (Raw_binary s) -> File.Opam.add opam_file (File.Opam.parse s)
+ | f -> Path.add opam_file (Path.File f)
+ end;
+ begin match archive with
+ | Tar_gz f -> Path.add archive_file (Path.File f)
+ end;
end
type input_api =
| IgetList
| IgetOpam of name_version
- | IgetArchive of Server.opam
- | InewArchive of Server.opam * binary_data archive
+ | IgetArchive of name_version
+ | InewArchive of name_version * binary_data * binary_data archive
type output_api =
| OgetList of name_version list
- | OgetOpam of Server.opam
+ | OgetOpam of binary_data
| OgetArchive of binary_data archive
| OnewArchive
| Oerror of string (* server error *)
@@ -99,7 +86,6 @@ type output_api =
module RemoteServer : SERVER with type t = url = struct
type t = url
- type opam = Server.opam
(* untyped message exchange *)
let send url (m : input_api) =
@@ -134,26 +120,17 @@ module RemoteServer : SERVER with type t = url = struct
| Oerror s -> error s
| _ -> dyn_error "getOpam"
- let getArchive t opam =
- match send t (IgetArchive opam) with
+ let getArchive t nv =
+ match send t (IgetArchive nv) with
| OgetArchive a -> a
| Oerror s -> error s
| _ -> dyn_error "getArchive"
- let read_content file =
- let ic = open_in file in
- let n = in_channel_length ic in
- let s = String.create n in
- really_input ic s 0 n;
- close_in ic;
- s
-
- let newArchive t opam archive =
+ let newArchive t nv opam archive =
let archive = match archive with
- | Tar_gz (Filename (Raw_filename s)) -> Tar_gz (Binary (Raw_binary (read_content s)))
- | Tar_gz _ -> archive
- | Empty -> error "cannot send empty archive" in
- match send t (InewArchive (opam, archive)) with
+ | Tar_gz (Filename (Raw_filename s)) -> Tar_gz (Binary (Raw_binary (U.read_content s)))
+ | Tar_gz _ -> archive in
+ match send t (InewArchive (nv, opam, archive)) with
| OnewArchive -> ()
| Oerror s -> error s
| _ -> dyn_error "newArchive"
View
8 tests/Makefile
@@ -13,10 +13,10 @@ init: fresh
$(OCPGET) init $(LOCALHOST)
upload: $(ARCHIVES) init
- cd packages && ../$(OCPGET) upload P1.opam
- cd packages && ../$(OCPGET) upload P2.opam
- cd packages && ../$(OCPGET) upload P3.opam
- cd packages && ../$(OCPGET) upload P4.opam
+ cd packages && ../$(OCPGET) upload P1
+ cd packages && ../$(OCPGET) upload P2
+ cd packages && ../$(OCPGET) upload P3
+ cd packages && ../$(OCPGET) upload P4
info: upload
$(OCPGET) info
Please sign in to comment.
Something went wrong with that request. Please try again.