[nongnu] elpa/hyperdrive 24df174711 13/13: Merge branch 'mirror-compare-mtime'

[ELPA Syncer]

branch: elpa/hyperdrive
commit 24df17471135af154cf282556797ac0193ae7393
Merge: b5651bcfd1 114bc1e7bc
Author: Adam Porter <adam@alphapapa.net>
Commit: Adam Porter <adam@alphapapa.net>

    Merge branch 'mirror-compare-mtime'
---
 hyperdrive-lib.el    |  2 ++
 hyperdrive-mirror.el | 74 ++++++++++++++++++++++++++++++++++++++--------------
 hyperdrive-vars.el   | 16 ++++++++++++
 hyperdrive.el        |  7 ++---
 4 files changed, 76 insertions(+), 23 deletions(-)

diff --git a/hyperdrive-lib.el b/hyperdrive-lib.el
index c0c4a945e3..5b94325de1 100644
--- a/hyperdrive-lib.el
+++ b/hyperdrive-lib.el
@@ -314,6 +314,7 @@ Intended to be used as hash table key in 
`hyperdrive-version-ranges'."
 (defun hyperdrive-purge-version-ranges (hyperdrive)
   "Purge all version range data for HYPERDRIVE."
   (maphash (lambda (key _val)
+             ;; NOTE: The KEY starts with the key and ends with a path, so we 
compare as prefix.
              (when (string-prefix-p (hyperdrive-public-key hyperdrive) key)
                (remhash key hyperdrive-version-ranges)))
            hyperdrive-version-ranges)
@@ -1037,6 +1038,7 @@ DEFAULT and INITIAL-INPUT are passed to `read-string' 
as-is."
 (cl-defun hyperdrive-persist (hyperdrive &key purge)
   "Persist HYPERDRIVE in `hyperdrive-hyperdrives'.
 With PURGE, delete hash table entry for HYPERDRIVE."
+  ;; TODO: Make separate function for purging persisted data.
   (if purge
       (remhash (hyperdrive-public-key hyperdrive) hyperdrive-hyperdrives)
     (puthash (hyperdrive-public-key hyperdrive) hyperdrive 
hyperdrive-hyperdrives))
diff --git a/hyperdrive-mirror.el b/hyperdrive-mirror.el
index 8baf041dff..1278ddfba8 100644
--- a/hyperdrive-mirror.el
+++ b/hyperdrive-mirror.el
@@ -32,12 +32,13 @@
 
 ;;;; Variables
 
+;; TODO: Consolidate these two local variables into one?
 (defvar-local hyperdrive-mirror-parent-entry nil
   "Parent entry for `hyperdrive-mirror-mode' buffer.")
 (put 'hyperdrive-mirror-parent-entry 'permanent-local t)
 
-(defvar-local hyperdrive-mirror-already-uploaded nil
-  "Non-nil if files in `hyperdrive-mirror-mode' buffer have already been 
uploaded.")
+(defvar-local hyperdrive-mirror-query nil
+  "List of arguments passed to `hyperdrive-mirror', excluding 
\\+`no-confirm'.")
 
 ;;;; Functions
 
@@ -47,26 +48,33 @@
 FILES-AND-URLS is structured like `tabulated-list-entries'.  After
 uploading files, open PARENT-ENTRY."
   (let* ((count 0)
+         (upload-files-and-urls (cl-remove-if-not (pcase-lambda (`(,_id 
[,status ,_file ,_url]))
+                                                    (string-match-p (rx (or 
"new" "newer")) status))
+                                                  files-and-urls))
          (progress-reporter
-          (make-progress-reporter (format "Uploading %s files: " (length 
files-and-urls)) 0 (length files-and-urls)))
+          (make-progress-reporter (format "Uploading %s files: " (length 
upload-files-and-urls)) 0 (length upload-files-and-urls)))
          (queue (make-plz-queue
                  :limit hyperdrive-queue-size
                  :finally (lambda ()
                             (progress-reporter-done progress-reporter)
                             (hyperdrive-open parent-entry)
                             (with-current-buffer (get-buffer-create 
"*hyperdrive-mirror*")
-                              (setq-local hyperdrive-mirror-already-uploaded 
t))))))
-    (pcase-dolist (`(,_id [,file ,url]) files-and-urls)
+                              (revert-buffer nil t))))))
+    (unless upload-files-and-urls
+      (hyperdrive-user-error "No new/newer files to upload"))
+    (pcase-dolist (`(,_id [,_status ,file ,url]) upload-files-and-urls)
       (hyperdrive-upload-file file (hyperdrive-url-entry url)
         :queue queue
         ;; TODO: Error handling (e.g. in case one or more files fails to 
upload).
         :then (lambda (_)
                 (progress-reporter-update progress-reporter (cl-incf 
count)))))))
 
-;;;; Commands
+(defun hyperdrive-mirror-revert-buffer (&optional _ignore-auto _noconfirm)
+  "Revert `hyperdrive-mirror-mode' buffer.
+Runs `hyperdrive-mirror' again with the same query."
+  (apply #'hyperdrive-mirror hyperdrive-mirror-query))
 
-;; TODO: Don't overwrite a hyperdrive file with the same
-;; contents. Should we keep a cache of uploaded files and mtimes?
+;;;; Commands
 
 ;;;###autoload
 (cl-defun hyperdrive-mirror
@@ -135,12 +143,36 @@ predicate and set NO-CONFIRM to t."
          (files-and-urls
           ;; Structured according to `tabulated-list-entries'
           (mapcar (lambda (file)
-                    (let ((url (hyperdrive-entry-url
-                                (hyperdrive-entry-create
-                                 :hyperdrive hyperdrive
-                                 :path (expand-file-name (file-relative-name 
file source) target-dir)
-                                 :encode t))))
-                      (list url (vector file url))))
+                    (let* ((entry (hyperdrive-entry-create
+                                   :hyperdrive hyperdrive
+                                   :path (expand-file-name (file-relative-name 
file source) target-dir)
+                                   :encode t))
+                           (status-no-properties
+                            (condition-case err
+                                (let ((drive-mtime (hyperdrive-entry-mtime 
(hyperdrive-fill entry :then 'sync)))
+                                      (local-mtime 
(file-attribute-modification-time (file-attributes file))))
+                                  (cond
+                                   ((time-equal-p drive-mtime local-mtime) 
"same")
+                                   ((time-less-p drive-mtime local-mtime) 
"newer")
+                                   (t "older")))
+                              (plz-error
+                               (pcase (caddr err)
+                                 ((app plz-error-response (cl-struct 
plz-response (status 404)))
+                                  ;; Entry doesn't exist: Set `status' to 
`new'.
+                                  (hyperdrive-update-nonexistent-version-range 
entry)
+                                  "new")
+                                 (_
+                                  ;; Re-signal error.
+                                  (signal (car err) (cdr err)))))))
+                           (status
+                            (propertize (format "%-7s" status-no-properties)
+                                        'face (pcase-exhaustive 
status-no-properties
+                                                ("new" 'hyperdrive-mirror-new)
+                                                ("newer" 
'hyperdrive-mirror-newer)
+                                                ("older" 
'hyperdrive-mirror-older)
+                                                ("same" 
'hyperdrive-mirror-same))))
+                           (url (hyperdrive-entry-url entry)))
+                      (list url (vector status file url))))
                   files)))
     (unless files
       (hyperdrive-user-error "No files selected for mirroring (double-check 
predicate)"))
@@ -148,7 +180,8 @@ predicate and set NO-CONFIRM to t."
         (hyperdrive--mirror files-and-urls parent-entry)
       (pop-to-buffer (get-buffer-create "*hyperdrive-mirror*"))
       (hyperdrive-mirror-mode)
-      (setq-local hyperdrive-mirror-already-uploaded nil)
+      (setq-local hyperdrive-mirror-query
+                  `(,source ,hyperdrive :target-dir ,target-dir :predicate 
,predicate))
       (setq-local hyperdrive-mirror-parent-entry parent-entry)
       (setf tabulated-list-entries files-and-urls)
       (tabulated-list-print))))
@@ -158,8 +191,7 @@ predicate and set NO-CONFIRM to t."
   (declare (modes hyperdrive-mirror-mode))
   (interactive)
   (if (and tabulated-list-entries hyperdrive-mirror-parent-entry)
-      (when (or (not hyperdrive-mirror-already-uploaded) (yes-or-no-p "Already 
uploaded files.  Upload again?"))
-        (hyperdrive--mirror tabulated-list-entries 
hyperdrive-mirror-parent-entry))
+      (hyperdrive--mirror tabulated-list-entries 
hyperdrive-mirror-parent-entry)
     (hyperdrive-user-error "Missing information about files to upload.  Are 
you in a \"*hyperdrive-mirror*\" buffer?")))
 
 ;;;; Mode
@@ -174,9 +206,11 @@ predicate and set NO-CONFIRM to t."
   "Major mode for buffers for mirror local directories to a hyperdrive."
   :group 'hyperdrive
   :interactive nil
-  ;; TODO: When possible, use vtable.el (currently only available in Emacs 
>=29)
-  (setq tabulated-list-format [("From file" 60 t)
-                               ("To URL" 60 t)])
+  ;; TODO: When possible, use vtable.el (currently only available in Emacs 
>=29) (or maybe taxy-magit-section)
+  (setq tabulated-list-format [("Status" 7 t)
+                               ("From file" 60 t)
+                               ("To URL" 60 t)]
+        revert-buffer-function #'hyperdrive-mirror-revert-buffer)
   (tabulated-list-init-header))
 
 ;;;; Footer
diff --git a/hyperdrive-vars.el b/hyperdrive-vars.el
index 4cf376c1ef..f1541117c6 100644
--- a/hyperdrive-vars.el
+++ b/hyperdrive-vars.el
@@ -218,6 +218,22 @@ an existing buffer at the same version, or make a new 
buffer."
 (defface hyperdrive-history-unknown '((t (:foreground "black" :background 
"yellow")))
   "Marker for entries with unknown existence in `hyperdrive-history' buffers.")
 
+(defface hyperdrive-mirror-new '((t (:foreground "black" :background "green")))
+  "Face for files with \"new\" status in `hyperdrive-mirror' buffers."
+  :group 'hyperdrive-faces)
+
+(defface hyperdrive-mirror-same '((t (:foreground "black" :background "red")))
+  "Face for files with \"same\" status in `hyperdrive-mirror' buffers."
+  :group 'hyperdrive-faces)
+
+(defface hyperdrive-mirror-newer '((t (:foreground "black" :background 
"yellow")))
+  "Face for files with \"newer\" status in `hyperdrive-mirror' buffers."
+  :group 'hyperdrive-faces)
+
+(defface hyperdrive-mirror-older '((t (:foreground "black" :background 
"purple")))
+  "Face for files with \"older\" status in `hyperdrive-mirror' buffers."
+  :group 'hyperdrive-faces)
+
 (defface hyperdrive-button
   ;; Inspired by cus-edit.el's `custom-button' face.
   ;; NOTE: This face is not currently used, but
diff --git a/hyperdrive.el b/hyperdrive.el
index e7fac8896b..a0a390be18 100644
--- a/hyperdrive.el
+++ b/hyperdrive.el
@@ -543,9 +543,10 @@ recurse, passing NO-RECURSE t to 
`hyperdrive-next-version'."
       (if (hyperdrive--entry-directory-p entry)
           ;; For directories, increment the version number by one.
           (let ((next-version (1+ (hyperdrive-entry-version entry))))
-            (if (eq next-version latest-version)
-                (open-at-version nil)
-              (open-at-version next-version)))
+            (open-at-version (if (eq next-version latest-version)
+                                 ;; Remove version number upon reaching the 
end of the history.
+                                 nil
+                               next-version)))
         (pcase-let* ((`(,_range-start . ,(map (:range-end range-end))) 
(hyperdrive-entry-version-range entry))
                      (next-range-start (1+ range-end))
                      ((map (:existsp next-range-existsp) (:range-end 
next-range-end))