rework uploading data to be in terms of CONNECTION-UPLOAD

Incremental updates of items of prerequisite data was not implemented, so the
previous meaning of CONNECTION-UPLOAD was not achieving much.  This simplifies
the core implementation, should still allow connection types to implement the
method to provide optimisations, and provides a way to implement copying items
of prerequisite data into chroots.

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

7 files changed, 60 insertions, 71 deletions

diff --git a/doc/ideas.rst b/doc/ideas.rst
index aadba1d..d32ffed 100644
--- a/doc/ideas.rst
+++ b/doc/ideas.rst
@@ -24,6 +24,14 @@ Connections
   then we can have more specific connection types which take other arguments
   and construct the full command.
 
+- It might be possible to write an implementation of CONNECTION-UPLOAD for
+  SSH-CONNECTION which can optimise a common case.  If it can see that it is
+  the only item in the connection chain, and there is an old version of an
+  item of prerequisite data to upload already on the remote side, it can move
+  that old version to a temporary name, rsync the new version directly to the
+  temporary name so that rsync can do an incremental update, and then rename
+  the file to the new version.
+
 Data sources
 ------------
 
diff --git a/src/connection.lisp b/src/connection.lisp
index b1c81c1..6e322ba 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -147,15 +147,6 @@ if they need to handle streams and strings differently."))
   (let ((*connection* (slot-value connection 'parent)))
     (call-next-method)))
 
-(defgeneric connection-upload (connection from to)
-  (:documentation "Subroutine to upload files to the host.
-
-Only used for uploading prerequisite data, only across the first hop of a
-connection, and only to caches.  The point of this function is to allow
-specifying a more efficient alternative to CONNECTION-WRITEFILE when data is
-in a file on disc rather than in memory, and we are uploading directly from
-the root Lisp's machine.  For example, using rsync(1) over SSH."))
-
 (defgeneric connection-teardown (connection)
   (:documentation "Subroutine to disconnect from the host."))
 
diff --git a/src/connection/chroot/shell.lisp b/src/connection/chroot/shell.lisp
index 3d75fbf..2a73bcd 100644
--- a/src/connection/chroot/shell.lisp
+++ b/src/connection/chroot/shell.lisp
@@ -31,7 +31,3 @@
   (format nil "chroot ~A sh -c ~A"
           (escape-sh-token (slot-value connection 'root))
           (escape-sh-token cmd)))
-
-(defmethod connection-upload ((connection shell-chroot-connection) from to)
-  (mrun "cp" from (merge-pathnames to (ensure-directory-pathname
-                                       (slot-value connection 'root)))))
diff --git a/src/connection/local.lisp b/src/connection/local.lisp
index 68705b0..745c40c 100644
--- a/src/connection/local.lisp
+++ b/src/connection/local.lisp
@@ -66,6 +66,3 @@ root Lisp is running on, as the root Lisp's uid."))
                                       :element-type type)
            (copy-stream-to-stream content stream :element-type type)))))
     (run-program `("mv" ,temp ,path))))
-
-(defmethod connection-upload ((connection local-connection) from to)
-  (copy-file from to))
diff --git a/src/connection/ssh.lisp b/src/connection/ssh.lisp
index 5b89e27..e885ba9 100644
--- a/src/connection/ssh.lisp
+++ b/src/connection/ssh.lisp
@@ -46,7 +46,3 @@
   (format nil "ssh ~A ~A"
           (ssh-host connection)
           (escape-sh-token (format nil "sh -c ~A" (escape-sh-token cmd)))))
-
-;; rsync it straight to to its destination so rsync can do incremental updates
-(defmethod connection-upload ((c ssh-connection) from to)
-  (mrun "rsync" "-Pavc" from (format nil "~A:~A" (ssh-host c) to)))
diff --git a/src/connection/sudo.lisp b/src/connection/sudo.lisp
index 66e0695..5ff326d 100644
--- a/src/connection/sudo.lisp
+++ b/src/connection/sudo.lisp
@@ -87,6 +87,3 @@
                             :element-type (stream-element-type input)))
                        input)
                       input)))
-
-(defmethod connection-upload ((c sudo-connection) from to)
-  (connection-run c #?"cp ${from} ${to}" nil))
diff --git a/src/data.lisp b/src/data.lisp
index 3c163c6..bb5e5bf 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -188,9 +188,55 @@ This function is for implementation of REGISTER-DATA-SOURCE to check for
 clashes.  It should not be called by properties."
   (if (query-data-sources iden1 iden2) t nil))
 
-;; called by implementations of ESTABLISH-CONNECTION which start up remote
-;; Lisp images
-(defun upload-all-prerequisite-data ()
+(defgeneric connection-upload (connection data)
+  (:documentation
+   "Subroutine to upload an item of prerequisite data to the remote cache.
+The default implementation will work for any connection which implements
+CONNECTION-WRITEFILE and CONNECTION-RUN, but connection types which work by
+calling CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM will need their own
+implementation."))
+
+(defmethod connection-upload :around ((connection connection) (data data))
+  (when (subtypep (class-of connection)
+                  'consfigurator.connection.local:local-connection)
+    (error
+     "Attempt to upload data to the root Lisp or reupload to remote Lisp.
+This is not allowed for security reasons."))
+  (with-slots (iden1 iden2 data-version) data
+    (let* ((*connection* connection)
+           (dest (remote-data-pathname iden1 iden2)))
+      (mrun "mkdir" "-p" dest)
+      (with-remote-current-directory (dest)
+        (informat 1 "~&Uploading (~@{~S~^ ~}) ... " iden1 iden2 data-version)
+        (call-next-method)
+        (inform 1 "done." :fresh-line nil)))))
+
+(defmethod connection-upload ((conn connection) (data string-data))
+  (writefile (string->filename (data-version data)) (data-string data)))
+
+(defmethod connection-upload ((conn connection) (data file-data))
+  (let ((source (unix-namestring (data-file data)))
+        (dest (string->filename (data-version data))))
+    (flet ((upload (from to)
+             (with-open-file (stream from :element-type '(unsigned-byte 8))
+               (writefile to stream))))
+      (if (string-prefix-p "text/" (data-mime data))
+          (let ((dest (strcat dest ".gz")))
+            (with-temporary-file (:pathname tmp)
+              (run-program
+               (strcat "gzip -c " (escape-sh-token source)) :output tmp)
+              (upload tmp dest)
+              (mrun "gunzip" dest)))
+          (upload source dest)))))
+
+(defmethod connection-upload :after ((connection connection) (data data))
+  (with-slots (iden1 iden2 data-version) data
+    (push (list iden1 iden2 (remote-data-pathname iden1 iden2 data-version))
+          (slot-value connection 'cached-data))))
+
+;; called by implementations of ESTABLISH-CONNECTION which call
+;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM
+(defun upload-all-prerequisite-data (&optional (connection *connection*))
   (macrolet ((highest-version-in-cache (cache)
                `(third (car (remove-if-not (lambda (c)
                                              (and (string= (first c) iden1)
@@ -217,7 +263,7 @@ clashes.  It should not be called by properties."
                       (version< highest-remote-cached-version
                                 highest-source-version)))
             do (connection-clear-data-cache iden1 iden2)
-               (connection-upload-data (funcall highest-source))
+               (connection-upload connection (funcall highest-source))
           else if (and highest-local-cached-version
                        (or (not highest-remote-cached-version)
                            (version< highest-remote-cached-version
@@ -227,7 +273,8 @@ clashes.  It should not be called by properties."
                                  iden2
                                  highest-local-cached-version)))
                       (connection-clear-data-cache iden1 iden2)
-                      (connection-upload-data
+                      (connection-upload
+                       connection
                        (make-instance 'file-data
                                       :iden1 iden1
                                       :iden2 iden2
@@ -274,49 +321,6 @@ no risk of clashes between fresly generated files and cached copies of files."
 (defun remote-data-pathname (&rest args)
   (apply #'data-pathname (get-remote-data-cache-dir) args))
 
-(defun connection-try-upload (from to)
-  "Wrapper around CONNECTION-UPLOAD to ensure it gets used only when
-appropriate.  Falls back to CONNECTION-WRITEFILE."
-  (if (and (subtypep (type-of (slot-value *connection* 'parent))
-                     'consfigurator.connection.local:local-connection)
-           (find-method #'connection-upload
-                        '()
-                        (mapcar #'class-of (list *connection* t t))
-                        nil))
-      (connection-upload *connection* from to)
-      (with-open-file (s from :element-type '(unsigned-byte 8))
-        (connection-writefile *connection* to s #o077))))
-
-(defmethod connection-upload-data :around ((data data))
-  (when (subtypep (class-of *connection*)
-                  'consfigurator.connection.local:local-connection)
-    (error "Attempt to upload data to the root Lisp; this is not allowed"))
-  (with-slots (iden1 iden2 data-version) data
-    (let ((*dest* (remote-data-pathname iden1 iden2 data-version)))
-      (declare (special *dest*))
-      (mrun "mkdir" "-p" (pathname-directory-pathname *dest*))
-      (informat 1 "~&Uploading (~@{~S~^ ~}) ... " iden1 iden2 data-version)
-      (call-next-method)
-      (push (list iden1 iden2 *dest*) (slot-value *connection* 'cached-data))
-      (inform 1 "done." :fresh-line nil))))
-
-(defmethod connection-upload-data ((data file-data))
-  (declare (special *dest*))
-  (let ((source (unix-namestring (data-file data))))
-    (if (string-prefix-p "text/" (data-mime data))
-        (let ((dest (strcat (unix-namestring *dest*) ".gz")))
-          (with-temporary-file (:pathname tmp)
-            (run-program (strcat "gzip --rsyncable -c "
-                                 (escape-sh-token source))
-                         :output tmp)
-            (connection-try-upload tmp (unix-namestring dest))
-            (mrun "gunzip" "--keep" dest)))
-        (connection-try-upload source *dest*))))
-
-(defmethod connection-upload-data ((data string-data))
-  (declare (special *dest*))
-  (connection-writefile *connection* *dest* (data-string data) #o077))
-
 (defun connection-clear-data-cache (iden1 iden2)
   (let ((dir (ensure-directory-pathname (remote-data-pathname iden1 iden2))))
     (mrun (strcat "rm -f "