Improvements to error catching and reporting

src/.depend

@@ -1342,7 +1342,6 @@ uigtk2.cmo : \
     ubase/prefs.cmi \
     pixmaps.cmo \
     path.cmi \
-    os.cmi \
     lwt/lwt_util.cmi \
     lwt/lwt_unix.cmi \
     lwt/lwt.cmi \
@@ -1369,7 +1368,6 @@ uigtk2.cmx : \
     ubase/prefs.cmx \
     pixmaps.cmx \
     path.cmx \
-    os.cmx \
     lwt/lwt_util.cmx \
     lwt/lwt_unix.cmx \
     lwt/lwt.cmx \

src/clroot.ml

@@ -89,7 +89,7 @@ let getProtocolSlashSlash s =
                   (Printf.sprintf "protocol unison has been deprecated, use file, ssh, rsh, or socket instead" ))
       | _ ->
           raise(Invalid_argument
-                  (Printf.sprintf "unrecognized protocol %s" protocolName)) in
+                  (Printf.sprintf "\"%s\": unrecognized protocol %s" s protocolName)) in
     Some(protocol,remainder)
   else if Str.string_match slashSlashRegexp s 0
   then Some(File,String.sub s 2 (String.length s - 2))
@@ -100,7 +100,7 @@ let getProtocolSlashSlash s =
       "file:" | "ssh:" | "rsh:" | "socket:" ->
         raise(Util.Fatal
                 (Printf.sprintf
-                   "ill-formed root specification %s (%s must be followed by //)"
+                   "ill-formed root specification \"%s\" (%s must be followed by //)"
                    s matched))
     | _ -> None
   else None
@@ -150,6 +150,7 @@ let getPort s =
    and path is guaranteed to be non-empty
 *)
 let parseUri s =
+  let s = Util.trimWhitespace s in
   match getProtocolSlashSlash s with
     None ->
       (File,None,None,None,Some s)
@@ -199,7 +200,7 @@ let cannotAbbrevFileRx = Rx.rx "(file:|ssh:|rsh:|socket:).*"
 let networkNameRx = Rx.rx "//.*"
 (* Main external printing function *)
 let clroot2string = function
-  ConnectLocal None -> "."
+| ConnectLocal None | ConnectLocal (Some "") -> "."
 | ConnectLocal(Some s) ->
     if Rx.match_string cannotAbbrevFileRx s
     then if Rx.match_string networkNameRx s
@@ -243,7 +244,7 @@ let fixHost = function
 let parseRoot string =
   let illegal2 s = raise(Prefs.IllegalValue
                            (Printf.sprintf
-                              "%s: %s" string s)) in
+                              "\"%s\": %s" string s)) in
   let (protocol,user,host,port,path) = parseUri string in
   let clroot =
     match protocol,user,host,port with

src/compat403.ml

@@ -1,5 +1,7 @@
 (* Functions added in OCaml 4.03 *)
 
+type ('a,'b) result = Ok of 'a | Error of 'b
+
 module String = struct
   include String
 

src/fspath.ml

@@ -261,7 +261,7 @@ let canonizeFspath p0 =
           let parent' = begin
             (try Fs.chdir parent with
                Sys_error why2 -> raise (Util.Fatal (Printf.sprintf
-                 "Cannot find canonical name of %s: unable to cd either to it\
+                 "Cannot find canonical name of %s: unable to cd either to it \
 (%s)\nor to its parent %s\n(%s)" p why parent why2)));
             Fs.getcwd() end in
           Fs.chdir original;

src/globals.ml

@@ -51,8 +51,11 @@ let rawRootPair () =
 
 let theroots = ref []
 
+let uninstallRoots () = theroots := []
+
 open Lwt
 let installRoots termInteract =
+  let () = uninstallRoots () in (* Clear out potential old roots *)
   let roots = rawRoots () in
   if Safelist.length roots <> 2 then
     raise (Util.Fatal (Printf.sprintf
@@ -66,13 +69,22 @@ let installRoots termInteract =
        cont >>= (fun l ->
        return (r' :: l))))
     roots (return []) >>= (fun roots' ->
+  let () = match roots' with
+           | [r1; r2] when r1 = r2 ->
+               raise (Util.Fatal (Printf.sprintf
+                   ("That's no good, the roots appear to be the same! Here's "
+                 ^^ "what I found:\nFirst root: %s\nSecond root: %s")
+                   (Common.root2string r1) (Common.root2string r2)))
+           | _ -> ()
+  in
   theroots := roots';
   Negotiate.features (Common.sortRoots roots') >>=
   return)
 
 (* Alternate interface, should replace old interface eventually *)
 let installRoots2 () =
   debug (fun () -> Util.msg "Installing roots...");
+  let () = uninstallRoots () in (* Clear out potential old roots *)
   let roots = rawRoots () in
   theroots :=
     Safelist.map Remote.canonize ((Safelist.map Clroot.parseRoot) roots);

src/globals.mli

@@ -16,6 +16,9 @@ val installRoots : (string -> string -> string) option -> unit Lwt.t
 (* An alternate method (under development?) *)
 val installRoots2 : unit -> unit
 
+(* Clear previously installed roots; typically used when switching profiles  *)
+val uninstallRoots : unit -> unit
+
 (* The roots of the synchronization (with names canonized, but in the same   *)
 (* order as the user gave them)                                              *)
 val roots : unit -> Common.root * Common.root

src/remote.ml

@@ -1417,7 +1417,7 @@ let printAddr host addr =
   | Unix.ADDR_INET (s, p) ->
       Format.sprintf "%s[%s]:%d" host (Unix.string_of_inet_addr s) p
 
-let buildSocket host port kind ai =
+let buildSocket host port kind ?(err="") ai =
   let attemptCreation ai =
     Lwt.catch
       (fun () ->
@@ -1459,12 +1459,13 @@ let buildSocket host port kind ai =
            Unix.Unix_error (error, _, _) ->
              begin match error with
                Unix.EAFNOSUPPORT | Unix.EPROTONOSUPPORT | Unix.EINVAL ->
-                 ()
+                 Lwt.return None
              | _  ->
                  let msg =
                    match kind with
                      `Connect ->
-                       Printf.sprintf "Can't connect to server %s: %s\n"
+                       Printf.sprintf "%s%s: %s\n"
+                         err
                          (printAddr host ai.Unix.ai_addr)
                          (Unix.error_message error)
                    | `Bind when ai.Unix.ai_family <> Unix.PF_UNIX ->
@@ -1483,9 +1484,8 @@ let buildSocket host port kind ai =
                          port
                          (Unix.error_message error)
                  in
-                 Util.warn msg
-              end;
-              Lwt.return None
+                 Lwt.fail (Util.Fatal msg)
+             end
          | _ ->
              Lwt.fail e)
   in
@@ -1503,28 +1503,26 @@ let buildConnectSocketUnix path =
   (* Unix domain socket path from [Clroot] is enclosed in curly braces.
      Extract the real path. *)
   let path = String.sub path 1 ((String.length path) - 2) in
-  buildSocket "" path `Connect (makeUnixSocketAi path) >>= function
+  let err = "Can't connect to Unix domain socket on path " in
+  buildSocket "" path `Connect ~err (makeUnixSocketAi path) >>= function
   | None ->
-      Lwt.fail (Util.Fatal
-        (Printf.sprintf "Can't connect to Unix domain socket on path %s" path))
+      Lwt.fail (Util.Fatal (err ^ path))
   | Some x ->
       Lwt.return x
 
 let buildConnectSocket host port =
   let isHost = String.length host > 0 && host.[0] <> '{' in
   if not isHost then buildConnectSocketUnix host else
-  let attemptCreation ai = buildSocket host port `Connect ai in
+  let err = "Failed to connect to the server on host " in
+  let attemptCreation ai = buildSocket host port `Connect ~err ai in
   let options = [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ] in
   findFirst attemptCreation (Unix.getaddrinfo host port options) >>= fun res ->
   match res with
     Some socket ->
       Lwt.return socket
   | None ->
-      let msg =
-        Printf.sprintf
-          "Failed to connect to the server on host %s:%s" host port
-      in
-      Lwt.fail (Util.Fatal msg)
+      let hostport = Printf.sprintf "%s:%s" host port in
+      Lwt.fail (Util.Fatal (err ^ hostport))
 
 (* [at_exit] does not provide reliable cleanup (why?), so this
    complex mechanism is needed to unlink Unix domain sockets