Permalink
Browse files

[opam server] start implementing the OPAM server repository pluggin.

It compiles, but untested. Morever 'opam-server-download' and 'opam-server-upload' are missing.

Most of the code is here, need to test it and finish to write more boring script stuff...
  • Loading branch information...
1 parent 5dd9306 commit c8822551aada51968d670f80e3916bba4469fd37 @samoht samoht committed May 15, 2012
View
@@ -2,9 +2,10 @@ BIN = /usr/local/bin
OCPBUILD ?= ./_obuild/unixrun ./boot/ocp-build.boot
OCAMLC=ocamlc
SRC_EXT=src_ext
-TARGETS = opam \
+TARGETS = opam opam-server \
opam-rsync-init opam-rsync-update opam-rsync-download opam-rsync-upload \
- opam-git-init opam-git-update opam-git-download opam-git-upload
+ opam-git-init opam-git-update opam-git-download opam-git-upload \
+ opam-server-init opam-server-update opam-server-download opam-server-upload
.PHONY: all
View
@@ -91,3 +91,39 @@ begin program "opam-git-upload"
requires = [ "opam-lib" ]
end
+
+(* SERVER *)
+begin library "opam-server-lib"
+ files = [
+ "src/repo/server/protocol.ml"
+ "src/repo/server/key.ml"
+ "src/repo/server/daemon.ml"
+ "src/repo/server/client.ml"
+ ]
+ requires = [ "opam-lib" ]
+end
+
+begin program "opam-server"
+ files = [ "src/repo/server/server.ml" ]
+ requires = [ "opam-server-lib" ]
+end
+
+begin program "opam-server-init"
+ files = [ "src/repo/server/init.ml" ]
+ requires = [ "opam-server-lib" ]
+end
+
+begin program "opam-server-update"
+ files = [ "src/repo/server/update.ml" ]
+ requires = [ "opam-server-lib" ]
+end
+
+begin program "opam-server-download"
+ files = [ "src/repo/server/download.ml" ]
+ requires = [ "opam-server-lib" ]
+end
+
+begin program "opam-server-upload"
+ files = [ "src/repo/server/upload.ml" ]
+ requires = [ "opam-server-lib" ]
+end
View
Binary file not shown.
View
@@ -1155,26 +1155,24 @@ \subsection{Binary Protocol}
\hline
0 & \verb+ClientVersion+ & \verb+version: string+ & Send the client version to the server \\
\hline
-1 & \verb+InitList+ & -- & Ask for the list of all available OPAM files \\
+1 & \verb+GetList+ & -- & Ask for the list of all available OPAM files \\
\hline
-2 & \verb+UpdateList+ & -- & Ask for the list of updated OPAM files \\
-\hline
-3 & \verb+GetOPAM+ & \verb+name : string+ & Ask for the binary representation of \\
+2 & \verb+GetOPAM+ & \verb+name : string+ & Ask for the binary representation of \\
& & \verb+version: string+ & a given OPAM file \\
\hline
-4 & \verb+GetDescr+ & \verb+name : string+ & Ask for the binary representation of \\
+3 & \verb+GetDescr+ & \verb+name : string+ & Ask for the binary representation of \\
& & \verb+version: string+ & a given description file \\
\hline
-5 & \verb+GetArchive+ & \verb+name : string+ & Ask for the binary representation of \\
+4 & \verb+GetArchive+ & \verb+name : string+ & Ask for the binary representation of \\
& & \verb+version: string+ & a given archive file \\
\hline
-6 & \verb+NewPackage+ & \verb+name : string+ & Create a new package on the server. \\
+5 & \verb+NewPackage+ & \verb+name : string+ & Create a new package on the server. \\
& & \verb+version: string+ & The client should provide the OPAM and \\
& & \verb+opam : string+ & descr files and the source archive. \\
& & \verb+descr : string+ & \\
& & \verb+archive: string+ & \\
\hline
-7 & \verb+NewVersion+ & \verb+name : string+ & Upload a new version of an already existing \\
+6 & \verb+NewVersion+ & \verb+name : string+ & Upload a new version of an already existing \\
& & \verb+version: string+ & package on the server. The client \\
& & \verb+opam : string+ & should also provide a security key\\
& & \verb+descr : string+ & \\
@@ -1202,8 +1200,8 @@ \subsection{Binary Protocol}
1 & \verb+PackageList+ & \verb+list : (string*string) list+ & Return the list of available \\
& & & package names and versions \\
\hline
-2 & \verb+OPAM+ & \verb+opam : string+ & Return an OPAM file
-\\
+2 & \verb+OPAM+ & \verb+opam : string+ & Return an OPAM file \\
+\hline
3 & \verb+Descr+ & \verb+descr : string+ & Return an OPAM file \\
\hline
4 & \verb+Archive+ & \verb+archive: string+ & Return an archive file \\
View
@@ -687,6 +687,14 @@ module Make (F : F) = struct
else
F.empty
+ let filename = Filename.of_string "/dummy/"
+
+ let of_raw raw =
+ F.of_string filename raw
+
+ let to_raw t =
+ F.to_string filename t
+
end
open X
@@ -697,6 +705,8 @@ module type IO_FILE = sig
val write: filename -> t -> unit
val read : filename -> t
val safe_read: filename -> t
+ val to_raw: t -> raw
+ val of_raw: raw -> t
end
module Config = struct
View
@@ -20,6 +20,12 @@ module type IO_FILE = sig
(** Read file contents. Return [empty] if the file does not exist. *)
val safe_read: filename -> t
+ (** Return the file contents *)
+ val to_raw: t -> raw
+
+ (** Convert a raw string into a file *)
+ val of_raw: raw -> t
+
end
(** Configuration file: [$opam/config] *)
View
@@ -0,0 +1,91 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+open Unix
+open Protocol
+open Types
+
+let rpc host =
+ let addr = ADDR_INET (host, default_port) in
+ process_client (open_connection addr)
+
+let protocol_error x msg = match x with
+ | Error r -> Globals.error_and_exit "Protocol error: %s (%s)" msg r
+ | _ -> Globals.error_and_exit "Protocol error: %s" msg
+
+let client_version host =
+ let req = ClientVersion Globals.opam_version in
+ match rpc host req with
+ | ServerVersion v ->
+ if v <> Globals.opam_version then
+ Globals.error_and_exit "API versions differ!"
+ | x -> protocol_error x "client_version"
+
+let get_list host =
+ client_version host;
+ match rpc host GetList with
+ | PackageList l ->
+ List.fold_left (fun accu (n,v) ->
+ NV.Set.add (NV.create (N.of_string n) (V.of_string v)) accu
+ ) NV.Set.empty l
+ | x -> protocol_error x "get_list"
+
+let get_opam host nv =
+ client_version host;
+ let req = GetOPAM (N.to_string (NV.name nv), V.to_string (NV.version nv)) in
+ match rpc host req with
+ | OPAM s -> File.OPAM.of_raw (Raw.of_string s)
+ | x -> protocol_error x "get_opam"
+
+let get_descr host nv =
+ client_version host;
+ let req = GetDescr (N.to_string (NV.name nv), V.to_string (NV.version nv)) in
+ match rpc host req with
+ | Descr s -> File.Descr.of_raw (Raw.of_string s)
+ | x -> protocol_error x "get_descr"
+
+let get_archive host nv =
+ client_version host;
+ let req = GetArchive (N.to_string (NV.name nv), V.to_string (NV.version nv)) in
+ match rpc host req with
+ | Archive s -> Raw.of_string s
+ | x -> protocol_error x "get_archive"
+
+let new_package host opam descr archive =
+ client_version host;
+ let n = File.OPAM.name opam in
+ let v = File.OPAM.version opam in
+ let req = NewPackage (N.to_string n, V.to_string v,
+ Raw.to_string (File.OPAM.to_raw opam),
+ Raw.to_string (File.Descr.to_raw descr),
+ Raw.to_string archive) in
+ match rpc host req with
+ | Key s -> Key.of_string s
+ | x -> protocol_error x "new_package"
+
+let new_version host opam descr archive key =
+ client_version host;
+ let n = File.OPAM.name opam in
+ let v = File.OPAM.version opam in
+ let req = NewVersion (N.to_string n, V.to_string v,
+ Raw.to_string (File.OPAM.to_raw opam),
+ Raw.to_string (File.Descr.to_raw descr),
+ Raw.to_string archive,
+ Key.to_string key) in
+ match rpc host req with
+ | OK -> ()
+ | x -> protocol_error x "new_package"
+
+
View
@@ -0,0 +1,36 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+(** Client-side for OPAM server repositories *)
+
+open Types
+
+(** Get the list of available packages *)
+val get_list: Unix.inet_addr -> NV.Set.t
+
+(** Get an OPAM file *)
+val get_opam: Unix.inet_addr -> nv -> File.OPAM.t
+
+(** Get a desrciption file *)
+val get_descr: Unix.inet_addr -> nv -> File.Descr.t
+
+(** Get an archive file *)
+val get_archive: Unix.inet_addr -> nv -> raw
+
+(** Upload a new package *)
+val new_package: Unix.inet_addr -> File.OPAM.t -> File.Descr.t -> raw -> Key.t
+
+(** Upload a new package version *)
+val new_version: Unix.inet_addr -> File.OPAM.t -> File.Descr.t -> raw -> Key.t -> unit
View
@@ -0,0 +1,87 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+open Protocol
+open Types
+
+let log fmt = Globals.log "DAEMON" fmt
+
+type t = {
+ (* ~/.opam-server/ *)
+ global: Path.G.t;
+
+ (* ~/.opam-server/opam/ files *)
+ available: NV.Set.t
+}
+
+let load_state () =
+ let global = Path.G.create (Dirname.of_string !Globals.root_path) in
+ let available = Path.G.available global in
+ { global; available }
+
+let get_file n v fn =
+ let t = load_state () in
+ let nv = NV.create (N.of_string n) (V.of_string v) in
+ Run.read (Filename.to_string (fn t.global nv))
+
+let write_files n v o d a =
+ let t = load_state () in
+ let nv = NV.create (N.of_string n) (V.of_string v) in
+ let write fn c =
+ Run.write (Filename.to_string (fn t.global nv)) c in
+ write Path.G.opam o;
+ write Path.G.descr d;
+ write Path.G.archive a
+
+let process_request id = function
+ | ClientVersion v ->
+ log "ClientVersion %s" v;
+ if v = Globals.opam_version then
+ ServerVersion v
+ else
+ Error "Wrong API version"
+ | GetList ->
+ log "GetList";
+ let t = load_state () in
+ let l = NV.Set.fold (fun nv l ->
+ (N.to_string (NV.name nv), V.to_string (NV.version nv)) :: l
+ ) t.available [] in
+ PackageList (List.rev l)
+ | GetOPAM (n,v) ->
+ log "GetOPAM (%s,%s)" n v;
+ OPAM (get_file n v Path.G.opam)
+ | GetDescr (n,v) ->
+ log "GetDescr (%s,%s)" n v;
+ Descr (get_file n v Path.G.descr)
+ | GetArchive (n,v) ->
+ log "GetArchive (%s,%s)" n v;
+ Archive (get_file n v Path.G.archive)
+ | NewPackage (n,v,o,d,a) ->
+ log "NewPackage (%s,%s,%s,%s,_)" n v o d;
+ write_files n v o d a;
+ let key = Key.create () in
+ Key.write (N.of_string n) key;
+ Key (Key.to_string key)
+ | NewVersion (n,v,o,d,a,k) ->
+ log "NewVersion (%s,%s,%s,%s,_,%s)" n v o d k;
+ let key = Key.read (N.of_string n) in
+ if key = (Digest.string k) then (
+ write_files n v o d a;
+ OK
+ ) else
+ Error "Wrong key"
+
+let process (stdin, stdout) fn =
+ process_server (stdin, stdout) fn
View
@@ -0,0 +1,28 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+(** Server daemon *)
+
+open Protocol
+
+(** Main request processing function. [process_request id req]
+ processes the client request [req] and procuces a server
+ answer. Eventual log messages are tagged with [id]. *)
+val process_request: string -> client_to_server -> server_to_client
+
+(** Synchronous processing of client requests. [process channels fn]
+ will read incoming requests on channels, compute the server
+ response using [fn] and write the result to the channels. *)
+val process: (in_channel * out_channel) -> (client_to_server -> server_to_client) -> unit
@@ -0,0 +1,4 @@
+(* Download script for OPAM server repositories *)
+
+let _ =
+ failwith "TODO"
Oops, something went wrong.

0 comments on commit c882255

Please sign in to comment.