Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More file spliting.

Now ocp-get is composed of:

a library: ocp-get-lib
a server: ocp-get-server (which depends upon ocp-get-lib)
a client: ocp-get (which depends upon ocp-get-lib)
  • Loading branch information...
commit 2c9a85c738fd19eb656daae6d99f54a3c185ad3a 1 parent ace4354
Thomas Gazagnaire samoht authored
2  Makefile
View
@@ -47,7 +47,7 @@ ocamlgraph:
clean:
$(OCPBUILD) -clean
- rm -rf src/*.annot
+ rm -rf src/*.annot bat/*.annot
ocaml-re:
git clone https://github.com/avsm/ocaml-re
10 ocp-get.ocp
View
@@ -183,14 +183,18 @@ end
begin program "ocp-get"
dirname = [ "src" ]
- comp = [ "-annot" ]
- files = [ "ocp.ml" ]
+ comp = [ "-annot" ]
+ files = [
+ "solver.ml"
+ "client.ml"
+ "ocp_get.ml"
+ ]
requires = [ "ocp-get-lib" ]
end
begin program "ocp-get-server"
dirname = [ "src" ]
- comp = [ "-annot" ]
+ comp = [ "-annot" ]
files = [ "ocp_get_server.ml" ]
requires = [ "ocp-get-lib" ]
end
287 src/ocp.ml → src/client.ml
View
@@ -1,248 +1,7 @@
open Namespace
open Path
open Server
-
-type 'a installed_status =
- | Was_installed of 'a
- | Was_not_installed
-
-module type SOLVER =
-sig
- type 'a request =
- { wish_install : 'a list
- ; wish_remove : 'a list
- ; wish_upgrade : 'a list }
-
- type ('a, 'b) action =
- | To_change of 'a
- (* Version to install. The package could have been present or not,
- but if present, it is another version than the proposed solution. *)
- | To_delete of 'b (* The package has been installed. *)
- | To_recompile of 'b (* The package is already installed, we just recompile it. *)
-
- type 'a parallel = P of 'a list (* order irrelevant : elements are considered in parallel *)
-
- type 'a solution =
- ( 'a (* old *) installed_status * 'a (* new *)
- , 'a (* old *) )
- action parallel list
- (** Sequence describing the action to perform.
- Order natural : first element to execute is the first element of the list. *)
-
- val solution_print : ('a BatIO.output -> 'b -> unit) -> 'a BatIO.output -> 'b solution -> unit
- val solution_map : ('a -> 'b) -> 'a solution -> 'b solution
-
- val resolve : Cudf.package list -> Cudf_types.vpkg request -> Cudf.package solution list
- (** Given a description of packages, it returns a list of solution preserving the consistency of the initial description. *)
-end
-
-module Solver = struct
-
- type 'a request =
- { wish_install : 'a list
- ; wish_remove : 'a list
- ; wish_upgrade : 'a list }
-
- type ('a, 'b) action =
- | To_change of 'a
- | To_delete of 'b
- | To_recompile of 'b
-
- type 'a parallel = P of 'a list
-
- type 'a solution =
- ( 'a (* old *) installed_status * 'a (* new *)
- , 'a (* old *) )
- action parallel list
-
- let solution_map f =
- BatList.map (function P l -> P (BatList.map (function
- | To_change (o_p, p) -> To_change ((match o_p with
- | Was_installed p -> Was_installed (f p)
- | Was_not_installed -> Was_not_installed), f p)
- | To_delete p -> To_delete (f p)
- | To_recompile p -> To_recompile (f p)) l))
-
- let solution_print f =
- BatList.print ~first:"" ~last:"" ~sep:", "
- (fun oc (P l) ->
- BatList.print ~first:"" ~last:"" ~sep:", "
- (fun oc act ->
- let f_act s l_p =
- begin
- BatString.print oc (Printf.sprintf "%s : " s);
- BatList.print f oc l_p;
- end in
- match act with
- | To_change (o_v_old, p_new) ->
- f_act "change"
- (match o_v_old with
- | Was_not_installed -> [ p_new ]
- | Was_installed p_old -> [ p_old ; p_new ])
- | To_recompile _ -> ()
- | To_delete v -> f_act "remove" [v]) oc l)
-
- module type CUDFDIFF =
- sig
- val resolve_diff : Cudf.package list -> Cudf_types.vpkg request ->
- (Cudf.package installed_status * Cudf.package, Cudf.package) action list option
-
- val resolve_summary : Cudf.package list -> Cudf_types.vpkg request ->
- ( Cudf.package list
- * (Cudf.package * Cudf.package) list
- * (Cudf.package * Cudf.package) list
- * Cudf.package list ) option
- end
-
- module CudfDiff : CUDFDIFF = struct
-
- let to_cudf_doc l_pkg req =
- None, l_pkg, { Cudf.request_id = ""
- ; install = req.wish_install
- ; remove = req.wish_remove
- ; upgrade = req.wish_upgrade
- ; req_extra = [] }
-
-
- let cudf_resolve l_pkg req =
- let open Algo in
- let r = Depsolver.check_request (to_cudf_doc l_pkg req) in
- if Diagnostic.is_solution r then
- match r with
- | { Diagnostic.result = Diagnostic.Success f } -> Some (f ~all:true ())
- | _ -> assert false
- else
- None
-
- module Cudf_set = struct
- module S = Common.CudfAdd.Cudf_set
-
- let choose_one s =
- match S.cardinal s with
- | 0 -> raise Not_found
- | 1 -> S.choose s
- | _ ->
- failwith "to complete ! Determine if it suffices to remove one arbitrary element from the \"removed\" class, or remove completely every element."
-
- include S
- end
-
- let resolve f_diff l_pkg_pb req =
- BatOption.bind
- (fun l_pkg_sol ->
- let univ_init = Cudf.load_universe l_pkg_pb in
- BatOption.bind
- (f_diff univ_init)
- (try Some (Common.CudfDiff.diff univ_init (Cudf.load_universe l_pkg_sol))
- with Cudf.Constraint_violation _ -> None))
- (cudf_resolve l_pkg_pb req)
-
- let resolve_diff =
- resolve
- (fun _ diff ->
- match
- Hashtbl.fold (fun pkgname s acc ->
- let add x = x :: acc in
- match
- (try Some (Cudf_set.choose_one s.Common.CudfDiff.removed) with Not_found -> None),
- try Some (Cudf_set.choose s.Common.CudfDiff.installed) with Not_found -> None
- with
- | None, Some p -> add (To_change (Was_not_installed, p))
- | Some p, None -> add (To_delete p)
- | Some p_old, Some p_new -> add (To_change (Was_installed p_old, p_new))
- | None, None -> acc) diff []
- with
- | [] -> None
- | l -> Some l)
-
- let resolve_summary = resolve (fun univ_init diff -> Some (Common.CudfDiff.summary univ_init diff))
- end
-
- module Graph =
- struct
- open Algo
-
- module PG =
- struct
- module G = Defaultgraphs.PackageGraph.G
- let union g1 g2 =
- let g1 = G.copy g1 in
- let () =
- begin
- G.iter_vertex (G.add_vertex g1) g2;
- G.iter_edges (G.add_edge g1) g2;
- end in
- g1
- include G
- end
- module PO = Defaultgraphs.GraphOper (PG)
-
- module PG_bfs =
- struct
- include Graph.Traverse.Bfs (PG)
- let fold f acc g =
- let rec aux acc iter =
- match try Some (get iter, step iter) with Exit -> None with
- | None -> acc
- | Some (x, iter) -> aux (f acc x) iter in
- aux acc (start g)
- end
-
- module O_pkg = struct type t = Cudf.package let compare = compare end
- module PkgMap = BatMap.Make (O_pkg)
- module PkgSet = BatSet.Make (O_pkg)
-
- let dep_reduction v =
- let g = Defaultgraphs.PackageGraph.dependency_graph (Cudf.load_universe v) in
- let () = PO.transitive_reduction g in
- g
-
- let resolve l_pkg_pb req =
- [ match
- BatOption.bind
- (let cons pkg act = Some (pkg, act) in
- fun l ->
- let graph_installed = dep_reduction (Cudf.get_packages ~filter:(fun p -> p.Cudf.installed) (Cudf.load_universe l_pkg_pb)) in
-
- let l_del_p, l_del =
- BatList.split
- (BatList.filter_map (function
- | To_delete pkg as act -> cons pkg act
- | _ -> None) l) in
-
- let map_add =
- PkgMap.of_enum (BatList.enum (BatList.filter_map (function
- | To_change (_, pkg) as act -> cons pkg act
- | To_delete _ -> None
- | To_recompile _ -> assert false) l)) in
-
- let _, l_act =
- PG_bfs.fold
- (fun (set_recompile, l_act) pkg ->
- let add_succ_rem pkg set act =
- List.fold_left (fun set x -> PkgSet.add x set) (PkgSet.remove pkg set) (PG.succ graph_installed pkg), act :: l_act in
-
- match PkgMap.Exceptionless.find pkg map_add with
- | Some act ->
- add_succ_rem pkg set_recompile act
- | None ->
- if PkgSet.mem pkg set_recompile then
- add_succ_rem pkg set_recompile (To_recompile pkg)
- else
- set_recompile, l_act) (PkgSet.empty, List.rev l_del)
- (let graph_installed = PG.copy graph_installed in
- let () = List.iter (PG.remove_vertex graph_installed) l_del_p in
- PG.union graph_installed (dep_reduction (BatList.of_enum (PkgMap.keys map_add)))) in
- Some (List.rev l_act))
- (CudfDiff.resolve_diff l_pkg_pb req)
- with
- | None -> []
- | Some l -> BatList.map (fun x -> P [ x ]) l ]
- end
-
- let resolve = Graph.resolve
-end
-
+open Solver
module type CLIENT =
sig
@@ -604,47 +363,3 @@ module Client = struct
| I s -> s) }
end
-
-open Namespace
-(*
-let filename_of_string s =
- List.fold_left
- (fun t s -> Path.concat t (B s))
- Path.root
- (BatString.nsplit (BatString.strip ~chars:"/" s) "/")
-*)
-let _ =
- let client = Client.init0 () in
- let f x =
- let _ = Printf.printf "(* command not found *)\n%!" in
- x in
- match Array.to_list Sys.argv with
- | [] -> f client
- | _ :: l ->
- match l with
-
- | "init" :: host :: port :: [] ->
- let port =
- try int_of_string port
- with _ -> failwith (port ^ " is not a valid port") in
- Client.init client (Some (url host port))
- | "init" :: host :: [] -> Client.init client (Some (url host Globals.default_port))
- | "init" :: _ -> Client.init client None
-
- | "info" :: name :: _ -> Client.info client (Some (Name name))
- | "info" :: _ -> Client.info client None
-
- | "config" :: name :: []
- | "config" :: _ :: name :: _ -> Client.config client Client.Dir (Name name)
-
- | "install" :: name :: _ -> Client.install client (Name name)
-
- | "update" :: _ -> Client.update client
-
- | "upgrade" :: _ -> Client.upgrade client
-
- | "upload" :: s :: _ -> Client.upload client s; client
-
- | "remove" :: name :: _ -> Client.remove client (Name name)
-
- | _ -> f client
48 src/ocp_get.ml
View
@@ -0,0 +1,48 @@
+open Namespace.Namespace
+open Path
+open Server
+open Solver
+open Client
+
+(*
+let filename_of_string s =
+ List.fold_left
+ (fun t s -> Path.concat t (B s))
+ Path.root
+ (BatString.nsplit (BatString.strip ~chars:"/" s) "/")
+*)
+let _ =
+ let client = Client.init0 () in
+ let f x =
+ let _ = Printf.printf "(* command not found *)\n%!" in
+ x in
+ match Array.to_list Sys.argv with
+ | [] -> f client
+ | _ :: l ->
+ match l with
+
+ | "init" :: host :: port :: [] ->
+ let port =
+ try int_of_string port
+ with _ -> failwith (port ^ " is not a valid port") in
+ Client.init client (Some (url host port))
+ | "init" :: host :: [] -> Client.init client (Some (url host Globals.default_port))
+ | "init" :: _ -> Client.init client None
+
+ | "info" :: name :: _ -> Client.info client (Some (Name name))
+ | "info" :: _ -> Client.info client None
+
+ | "config" :: name :: []
+ | "config" :: _ :: name :: _ -> Client.config client Client.Dir (Name name)
+
+ | "install" :: name :: _ -> Client.install client (Name name)
+
+ | "update" :: _ -> Client.update client
+
+ | "upgrade" :: _ -> Client.upgrade client
+
+ | "upload" :: s :: _ -> Client.upload client s; client
+
+ | "remove" :: name :: _ -> Client.remove client (Name name)
+
+ | _ -> f client
244 src/solver.ml
View
@@ -0,0 +1,244 @@
+open Namespace
+open Path
+open Server
+
+type 'a installed_status =
+ | Was_installed of 'a
+ | Was_not_installed
+
+module type SOLVER =
+sig
+ type 'a request =
+ { wish_install : 'a list
+ ; wish_remove : 'a list
+ ; wish_upgrade : 'a list }
+
+ type ('a, 'b) action =
+ | To_change of 'a
+ (* Version to install. The package could have been present or not,
+ but if present, it is another version than the proposed solution. *)
+ | To_delete of 'b (* The package has been installed. *)
+ | To_recompile of 'b (* The package is already installed, we just recompile it. *)
+
+ type 'a parallel = P of 'a list (* order irrelevant : elements are considered in parallel *)
+
+ type 'a solution =
+ ( 'a (* old *) installed_status * 'a (* new *)
+ , 'a (* old *) )
+ action parallel list
+ (** Sequence describing the action to perform.
+ Order natural : first element to execute is the first element of the list. *)
+
+ val solution_print : ('a BatIO.output -> 'b -> unit) -> 'a BatIO.output -> 'b solution -> unit
+ val solution_map : ('a -> 'b) -> 'a solution -> 'b solution
+
+ val resolve : Cudf.package list -> Cudf_types.vpkg request -> Cudf.package solution list
+ (** Given a description of packages, it returns a list of solution preserving the consistency of the initial description. *)
+end
+
+module Solver = struct
+
+ type 'a request =
+ { wish_install : 'a list
+ ; wish_remove : 'a list
+ ; wish_upgrade : 'a list }
+
+ type ('a, 'b) action =
+ | To_change of 'a
+ | To_delete of 'b
+ | To_recompile of 'b
+
+ type 'a parallel = P of 'a list
+
+ type 'a solution =
+ ( 'a (* old *) installed_status * 'a (* new *)
+ , 'a (* old *) )
+ action parallel list
+
+ let solution_map f =
+ BatList.map (function P l -> P (BatList.map (function
+ | To_change (o_p, p) -> To_change ((match o_p with
+ | Was_installed p -> Was_installed (f p)
+ | Was_not_installed -> Was_not_installed), f p)
+ | To_delete p -> To_delete (f p)
+ | To_recompile p -> To_recompile (f p)) l))
+
+ let solution_print f =
+ BatList.print ~first:"" ~last:"" ~sep:", "
+ (fun oc (P l) ->
+ BatList.print ~first:"" ~last:"" ~sep:", "
+ (fun oc act ->
+ let f_act s l_p =
+ begin
+ BatString.print oc (Printf.sprintf "%s : " s);
+ BatList.print f oc l_p;
+ end in
+ match act with
+ | To_change (o_v_old, p_new) ->
+ f_act "change"
+ (match o_v_old with
+ | Was_not_installed -> [ p_new ]
+ | Was_installed p_old -> [ p_old ; p_new ])
+ | To_recompile _ -> ()
+ | To_delete v -> f_act "remove" [v]) oc l)
+
+ module type CUDFDIFF =
+ sig
+ val resolve_diff : Cudf.package list -> Cudf_types.vpkg request ->
+ (Cudf.package installed_status * Cudf.package, Cudf.package) action list option
+
+ val resolve_summary : Cudf.package list -> Cudf_types.vpkg request ->
+ ( Cudf.package list
+ * (Cudf.package * Cudf.package) list
+ * (Cudf.package * Cudf.package) list
+ * Cudf.package list ) option
+ end
+
+ module CudfDiff : CUDFDIFF = struct
+
+ let to_cudf_doc l_pkg req =
+ None, l_pkg, { Cudf.request_id = ""
+ ; install = req.wish_install
+ ; remove = req.wish_remove
+ ; upgrade = req.wish_upgrade
+ ; req_extra = [] }
+
+
+ let cudf_resolve l_pkg req =
+ let open Algo in
+ let r = Depsolver.check_request (to_cudf_doc l_pkg req) in
+ if Diagnostic.is_solution r then
+ match r with
+ | { Diagnostic.result = Diagnostic.Success f } -> Some (f ~all:true ())
+ | _ -> assert false
+ else
+ None
+
+ module Cudf_set = struct
+ module S = Common.CudfAdd.Cudf_set
+
+ let choose_one s =
+ match S.cardinal s with
+ | 0 -> raise Not_found
+ | 1 -> S.choose s
+ | _ ->
+ failwith "to complete ! Determine if it suffices to remove one arbitrary element from the \"removed\" class, or remove completely every element."
+
+ include S
+ end
+
+ let resolve f_diff l_pkg_pb req =
+ BatOption.bind
+ (fun l_pkg_sol ->
+ let univ_init = Cudf.load_universe l_pkg_pb in
+ BatOption.bind
+ (f_diff univ_init)
+ (try Some (Common.CudfDiff.diff univ_init (Cudf.load_universe l_pkg_sol))
+ with Cudf.Constraint_violation _ -> None))
+ (cudf_resolve l_pkg_pb req)
+
+ let resolve_diff =
+ resolve
+ (fun _ diff ->
+ match
+ Hashtbl.fold (fun pkgname s acc ->
+ let add x = x :: acc in
+ match
+ (try Some (Cudf_set.choose_one s.Common.CudfDiff.removed) with Not_found -> None),
+ try Some (Cudf_set.choose s.Common.CudfDiff.installed) with Not_found -> None
+ with
+ | None, Some p -> add (To_change (Was_not_installed, p))
+ | Some p, None -> add (To_delete p)
+ | Some p_old, Some p_new -> add (To_change (Was_installed p_old, p_new))
+ | None, None -> acc) diff []
+ with
+ | [] -> None
+ | l -> Some l)
+
+ let resolve_summary = resolve (fun univ_init diff -> Some (Common.CudfDiff.summary univ_init diff))
+ end
+
+ module Graph =
+ struct
+ open Algo
+
+ module PG =
+ struct
+ module G = Defaultgraphs.PackageGraph.G
+ let union g1 g2 =
+ let g1 = G.copy g1 in
+ let () =
+ begin
+ G.iter_vertex (G.add_vertex g1) g2;
+ G.iter_edges (G.add_edge g1) g2;
+ end in
+ g1
+ include G
+ end
+ module PO = Defaultgraphs.GraphOper (PG)
+
+ module PG_bfs =
+ struct
+ include Graph.Traverse.Bfs (PG)
+ let fold f acc g =
+ let rec aux acc iter =
+ match try Some (get iter, step iter) with Exit -> None with
+ | None -> acc
+ | Some (x, iter) -> aux (f acc x) iter in
+ aux acc (start g)
+ end
+
+ module O_pkg = struct type t = Cudf.package let compare = compare end
+ module PkgMap = BatMap.Make (O_pkg)
+ module PkgSet = BatSet.Make (O_pkg)
+
+ let dep_reduction v =
+ let g = Defaultgraphs.PackageGraph.dependency_graph (Cudf.load_universe v) in
+ let () = PO.transitive_reduction g in
+ g
+
+ let resolve l_pkg_pb req =
+ [ match
+ BatOption.bind
+ (let cons pkg act = Some (pkg, act) in
+ fun l ->
+ let graph_installed = dep_reduction (Cudf.get_packages ~filter:(fun p -> p.Cudf.installed) (Cudf.load_universe l_pkg_pb)) in
+
+ let l_del_p, l_del =
+ BatList.split
+ (BatList.filter_map (function
+ | To_delete pkg as act -> cons pkg act
+ | _ -> None) l) in
+
+ let map_add =
+ PkgMap.of_enum (BatList.enum (BatList.filter_map (function
+ | To_change (_, pkg) as act -> cons pkg act
+ | To_delete _ -> None
+ | To_recompile _ -> assert false) l)) in
+
+ let _, l_act =
+ PG_bfs.fold
+ (fun (set_recompile, l_act) pkg ->
+ let add_succ_rem pkg set act =
+ List.fold_left (fun set x -> PkgSet.add x set) (PkgSet.remove pkg set) (PG.succ graph_installed pkg), act :: l_act in
+
+ match PkgMap.Exceptionless.find pkg map_add with
+ | Some act ->
+ add_succ_rem pkg set_recompile act
+ | None ->
+ if PkgSet.mem pkg set_recompile then
+ add_succ_rem pkg set_recompile (To_recompile pkg)
+ else
+ set_recompile, l_act) (PkgSet.empty, List.rev l_del)
+ (let graph_installed = PG.copy graph_installed in
+ let () = List.iter (PG.remove_vertex graph_installed) l_del_p in
+ PG.union graph_installed (dep_reduction (BatList.of_enum (PkgMap.keys map_add)))) in
+ Some (List.rev l_act))
+ (CudfDiff.resolve_diff l_pkg_pb req)
+ with
+ | None -> []
+ | Some l -> BatList.map (fun x -> P [ x ]) l ]
+ end
+
+ let resolve = Graph.resolve
+end
Please sign in to comment.
Something went wrong with that request. Please try again.