Various fixes to the server logics

* the client was always trying to connect to localhost
* if the server was having an error, the client would just seen a disconnection without knowing why. This is now fixed.
* and more debugging messages

src/file.ml

@@ -56,7 +56,18 @@ struct
       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)
+        (string_of_url t.sources)
+        (match t.ocaml_version with Version s -> s)
+
+    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.default_opam_version in
@@ -70,7 +81,7 @@ struct
         let ocaml_version = try List.assoc "ocaml-version" file with _ -> Sys.ocaml_version in
         { version = Version version; sources; ocaml_version = Version ocaml_version } in
 
-      match Path.find t f with
+      let t = match Path.find t f with
       | Path.File (Binary s)   -> aux s
       | Path.File (Filename s) ->
           let contents =
@@ -82,13 +93,10 @@ struct
             s in
           aux contents
       | 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))
+      | Path.Not_exists  -> failwith (Printf.sprintf "%s does not exist" (Path.string_of_filename f)) in
 
-    let to_string t =
-      Printf.sprintf "version: %s\nsources: %s\nocaml-version: %s\n"
-        (match t.version with Version s -> s)
-        (string_of_url t.sources)
-        (match t.ocaml_version with Version s -> s)
+      log "contents:\n%s" (to_string t);
+      t
 
     let add t f v = Path.add t f (Path.File (Binary (to_string v)))
   end

src/globals.ml

@@ -16,3 +16,8 @@ let log section fmt =
     if !debug then
       Printf.eprintf " %-20s %s\n%!" section str
   ) fmt
+
+let error fmt =
+  Printf.kprintf (fun str ->
+    Printf.eprintf "ERROR: %s\n%!" str
+  ) fmt

src/ocp_get_server.ml

@@ -46,24 +46,28 @@ let request = ref 0
 let log fmt =
   Globals.log (Printf.sprintf "REQUEST-%d" !request) fmt
 
+let protect f =
+  try f ()
+  with e -> Oerror (Printexc.to_string e)
+
 let fn t stdin stdout =
   incr request;
   log "Processing an incoming request";
 
   let output = match (input_value stdin : input_api) with
   | IgetList                    ->
       log "getList";
-      OgetList (Server.getList t)
+      protect (fun () -> OgetList (Server.getList t))
   | IgetOpam name_version       ->
       log "getOpam";
-      OgetOpam (Server.getOpam t name_version)
+      protect (fun () -> OgetOpam (Server.getOpam t name_version))
   | IgetArchive opam            ->
       log "getArchive";
-      OgetArchive (Server.getArchive t opam)
+      protect (fun () -> OgetArchive (Server.getArchive t opam))
   | InewArchive (opam, archive) ->
       (* XXX: need to protect the server state mutation as it can be updated concurrently *)
       log "newArchive";
-      Server.newArchive t opam archive; OnewArchive in 
+      protect (fun () -> Server.newArchive t opam archive; OnewArchive) in 
 
   output_value stdout output;
   flush stdout

src/server.ml

@@ -90,6 +90,7 @@ type output_api =
   | OgetOpam of Server.opam
   | OgetArchive of binary_data archive
   | OnewArchive
+  | Oerror of string (* server error *)
 
 module RemoteServer : SERVER with type t = url = struct
 
@@ -98,16 +99,15 @@ module RemoteServer : SERVER with type t = url = struct
 
   (* untyped message exchange *)
   let send url (m : input_api) =
-    let host = (gethostbyname(gethostname ())).h_addr_list.(0) in
+    let host = (gethostbyname url.hostname).h_addr_list.(0) in
     let addr = ADDR_INET (host, url.port) in
     try
       let stdin, stdout = open_connection addr in
       output_value stdout m;
       flush stdout;
       (input_value stdin : output_api)
     with _ ->
-      Printf.eprintf
-        "ERROR: The server (%s) is unreachable. Please check your network configuration.\n%!"
+      Globals.error "The server (%s) is unreachable. Please check your network configuration."
         (string_of_url url);
       exit 1
 
@@ -117,21 +117,25 @@ module RemoteServer : SERVER with type t = url = struct
   let getList t =
     match send t IgetList with
     | OgetList nl -> nl
+    | Oerror s    -> error s
     | _ -> error "getList"
 
   let getOpam t name_version =
     match send t (IgetOpam name_version) with
     | OgetOpam o -> o
+    | Oerror s   -> error s
     | _ -> error "getOpam"
 
   let getArchive t opam =
     match send t (IgetArchive opam) with
     | OgetArchive a -> a
+    | Oerror s      -> error s
     | _ -> error "getArchive"
 
   let newArchive t opam archive =
     match send t (InewArchive (opam, archive)) with
     | OnewArchive -> ()
+    | Oerror s    -> error s
     | _ -> error "newArchive"
 
 end

tests/packages/Makefile

@@ -9,10 +9,10 @@ all: upload
 	@
 
 upload: $(ARCHIVES)
-	$(OCPGET) upload P1
-	$(OCPGET) upload P2
-	$(OCPGET) upload P3
-	$(OCPGET) upload P4
+	$(OCPGET) upload P1.opam
+	$(OCPGET) upload P2.opam
+	$(OCPGET) upload P3.opam
+	$(OCPGET) upload P4.opam
 
 %.tar.gz: %
 	tar cz $^ > $@