Use the same code path for local and remote syncs

In the Copy module, local syncs do a direct copy and that's it. Remote
syncs meanwhile check for already transferred files, check for partially
transferred resumable files, can use the rsync algorithm and an external
copyprog.

Make local and remote syncs use the same code path. The functionality
for both cases is now the same, but since the code was optimized for the
remote case then there could be some optimization opportunities for
local syncs. This is something this patch does not include.

Author: tleedjarv

src/copy.ml

@@ -144,7 +144,7 @@ let rec fingerprintPrefix fspath path offset len accu =
   end
 
 let fingerprintPrefixRemotely =
-  Remote.registerServerCmd
+  Remote.registerServerCmd'
     "fingerprintSubfile"
     (fun _ (fspath, path, len) ->
        Lwt.return (fingerprintPrefix fspath path 0L len []))
@@ -461,7 +461,7 @@ let compress conn
        Util.convertUnixErrorsToTransient "transferring file contents"
          (fun () -> raise e))
 
-let compressRemotely = Remote.registerServerCmd "compress" compress
+let compressRemotely = Remote.registerServerCmd' "compress" compress
 
 let close_all infd outfd =
   Util.convertUnixErrorsToTransient
@@ -957,17 +957,10 @@ let file rootFrom pathFrom rootTo fspathTo pathTo realPathTo
       (Fspath.toDebugString fspathTo) (Path.toString pathTo)
       (Props.toString desc));
   let timer = Trace.startTimer "Transmitting file" in
-  begin match rootFrom, rootTo with
-    (Common.Local, fspathFrom), (Common.Local, realFspathTo) ->
-      localFile
-        fspathFrom pathFrom fspathTo pathTo realPathTo
-        update desc (Osx.ressLength ress) (Some id);
-        paranoidCheck fspathTo pathTo realPathTo desc fp ress
-  | _ ->
-      transferFile
-        rootFrom pathFrom rootTo fspathTo pathTo realPathTo
-        update desc fp ress id
-  end >>= fun status ->
+  transferFile
+    rootFrom pathFrom rootTo fspathTo pathTo realPathTo
+    update desc fp ress id
+  >>= fun status ->
   Trace.showTimer timer;
   match status with
     TransferSucceeded info ->

src/remote.ml

@@ -602,7 +602,7 @@ type servercmd =
 let serverCmds = ref (Util.StringMap.empty : servercmd Util.StringMap.t)
 
 type serverstream =
-  connection -> Bytearray.t -> unit
+  connection option -> Bytearray.t -> unit
 let serverStreams = ref (Util.StringMap.empty : serverstream Util.StringMap.t)
 
 type header =
@@ -660,7 +660,7 @@ let processStream conn id cmdName buf =
         try Util.StringMap.find cmdName !serverStreams
         with Not_found -> raise (Util.Fatal (cmdName ^ " not registered!"))
       in
-      cmd conn buf;
+      cmd (Some conn) buf;
       Lwt.return ()
     with e ->
       Hashtbl.add streamError id e;
@@ -789,6 +789,17 @@ let registerServerCmd name f =
   registerSpecialServerCmd
     name defaultMarshalingFunctions defaultMarshalingFunctions f
 
+(* Same as [registerServerCmd] but returns a function that runs either
+   the proxy or the local version, depending on whether the call is to
+   the local host (in this case [conn] is None) or a remote one. *)
+let registerServerCmd' name f =
+  let serverSide = (fun conn args -> f (Some conn) args) in
+  let client0 = registerServerCmd name serverSide in
+  fun conn args ->
+    match conn with
+    | None -> f None args
+    | Some conn -> client0 conn args
+
 (* RegisterHostCmd is a simpler version of registerClientServer [registerServerCmd?].
    It is used to create remote procedure calls: the only communication
    between the client and server is the sending of arguments from
@@ -826,16 +837,16 @@ let registerRootCmd (cmdName : string) (cmd : (Fspath.t * 'a) -> 'b) =
   fun root args -> r (hostOfRoot root) ((snd root), args)
 
 let registerRootCmdWithConnection
-  (cmdName : string) (cmd : connection -> 'a -> 'b) =
-  let client0 = registerServerCmd cmdName cmd in
+  (cmdName : string) (cmd : connection option -> 'a -> 'b) =
+  let serverSide = (fun conn args -> cmd (Some conn) args) in
+  let client0 = registerServerCmd cmdName serverSide in
   (* Return a function that runs either the proxy or the local version,
      depending on whether the call is to the local host or a remote one *)
   fun localRoot remoteRoot args ->
-    match (hostOfRoot localRoot) with
-      "" -> let conn = hostConnection (hostOfRoot remoteRoot) in
-            cmd conn args
-    | _  -> let conn = hostConnection (hostOfRoot localRoot) in
-            client0 conn args
+    match hostOfRoot localRoot, hostOfRoot remoteRoot with
+    | "", "" -> cmd None args
+    | "", _ ->  cmd (Some (connectionToRoot remoteRoot)) args
+    | _  -> client0 (connectionToRoot localRoot) args
 
 let streamReg = Lwt_util.make_region 1
 
@@ -849,12 +860,12 @@ let streamingActivated =
 let registerStreamCmd
     (cmdName : string)
     marshalingFunctionsArgs
-    (serverSide : connection -> 'a -> unit)
+    (serverSide : connection option -> 'a -> unit)
     =
   let cmd =
     registerSpecialServerCmd
       cmdName marshalingFunctionsArgs defaultMarshalingFunctions
-      (fun conn v -> serverSide conn v; Lwt.return ())
+      (fun conn v -> serverSide (Some conn) v; Lwt.return ())
   in
   let ping =
     registerServerCmd (cmdName ^ "Ping")
@@ -889,7 +900,7 @@ let registerStreamCmd
     in
     dumpIdle conn request
   in
-  fun conn sender ->
+  let proxy conn sender =
     if not (Prefs.read streamingActivated) then
       sender (fun v -> cmd conn v)
     else begin
@@ -905,6 +916,11 @@ let registerStreamCmd
              Util.msg "Pinging remote end after streaming error\n");
            ping conn id >>= fun () -> Lwt.fail e)
     end
+  in
+  fun conn sender ->
+    match conn with
+    | None -> sender (fun v -> Lwt.return (serverSide conn v))
+    | Some conn -> proxy conn sender
 
 let commandAvailable =
   registerRootCmd "commandAvailable"

src/remote.mli

@@ -91,6 +91,8 @@ val connectionToRoot : Common.root -> connection
 
 val registerServerCmd :
   string -> (connection -> 'a -> 'b Lwt.t) -> connection -> 'a -> 'b Lwt.t
+val registerServerCmd' :
+  string -> (connection option -> 'a -> 'b Lwt.t) -> connection option -> 'a -> 'b Lwt.t
 val registerSpecialServerCmd :
   string ->
   ('a ->
@@ -109,7 +111,7 @@ val encodeInt : int -> Bytearray.t * int * int
 val decodeInt : Bytearray.t -> int -> int
 val registerRootCmdWithConnection :
     string                          (* command name *)
- -> (connection -> 'a -> 'b Lwt.t)  (* local command *)
+ -> (connection option -> 'a -> 'b Lwt.t)  (* local command *)
  ->    Common.root                  (* root on which the command is executed *)
     -> Common.root                  (* other root *)
     -> 'a                           (* additional arguments *)
@@ -122,5 +124,5 @@ val registerStreamCmd :
   ('a ->
    (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
   (Bytearray.t -> int -> 'a) ->
-  (connection -> 'a -> unit) ->
-  connection -> (('a -> unit Lwt.t) -> 'b Lwt.t) -> 'b Lwt.t
+  (connection option -> 'a -> unit) ->
+  connection option -> (('a -> unit Lwt.t) -> 'b Lwt.t) -> 'b Lwt.t