From 321eede79c0b1b5007dd936a29709fe65c7cf8dc Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 5 Feb 2022 14:18:24 +0100 Subject: [PATCH] - [kami] optimized deletion of file system trees. --- src/chats-list-window.lisp | 6 +-- src/filesystem-tree-window.lisp | 91 +++++++++++++++++++++++---------- src/filesystem-utils.lisp | 52 +++++++++++-------- src/kami/client.lisp | 34 +++++++----- src/package.lisp | 1 + src/ui-goodies.lisp | 32 +++++++----- 6 files changed, 141 insertions(+), 75 deletions(-) diff --git a/src/chats-list-window.lisp b/src/chats-list-window.lisp index 36fcf97..434aef9 100644 --- a/src/chats-list-window.lisp +++ b/src/chats-list-window.lisp @@ -18,9 +18,9 @@ (in-package :chats-list-window) (defclass chats-list-window (focus-marked-window - simple-line-navigation-window - title-window - border-window) + simple-line-navigation-window + title-window + border-window) ()) (defmethod refresh-config :after ((object chats-list-window)) diff --git a/src/filesystem-tree-window.lisp b/src/filesystem-tree-window.lisp index d4b9656..ed8f259 100644 --- a/src/filesystem-tree-window.lisp +++ b/src/filesystem-tree-window.lisp @@ -93,6 +93,17 @@ :documentation "function with two parameter the path and a feature to query Valid feature values are :size. Returns nil if Returns nil if the path does not point to an actual file.") + (filesystem-list-all-file-paths-function + :initform #'fs:collect-tree + :accessor filesystem-list-all-file-paths-function + :type function + :documentation "function with a single parameter, the + path. Returns a list of path to all the reachable files from the + argument as root directory e.g + (funcall filesystem-list-all-file-paths-function \"foo/\") + ; => (foo/bar/baz + foo/a/b + ...)") (filesystem-close-connection-function :initform (constantly t) :accessor filesystem-close-connection-function @@ -105,22 +116,24 @@ &key (handlers-plist nil) &allow-other-keys) (when handlers-plist (setf (filesystem-expand-function object) - (getf handlers-plist :filesystem-expand-function) - (filesystem-expand-function object) - (getf handlers-plist :filesystem-expand-function) - (filesystem-rename-function object) - (getf handlers-plist :filesystem-rename-function) - (filesystem-delete-function object) - (getf handlers-plist :filesystem-delete-function) - (filesystem-create-function object) - (getf handlers-plist :filesystem-create-function) - (filesystem-download-function object) - (getf handlers-plist :filesystem-download-function) - (filesystem-upload-function object) - (getf handlers-plist :filesystem-upload-function) - (filesystem-query-path-function object) - (getf handlers-plist :filesystem-query-path-function) - (filesystem-close-connection-function object) + (getf handlers-plist :filesystem-expand-function)) + (setf (filesystem-expand-function object) + (getf handlers-plist :filesystem-expand-function)) + (setf (filesystem-rename-function object) + (getf handlers-plist :filesystem-rename-function)) + (setf (filesystem-delete-function object) + (getf handlers-plist :filesystem-delete-function)) + (setf (filesystem-create-function object) + (getf handlers-plist :filesystem-create-function)) + (setf (filesystem-download-function object) + (getf handlers-plist :filesystem-download-function)) + (setf (filesystem-upload-function object) + (getf handlers-plist :filesystem-upload-function)) + (setf (filesystem-query-path-function object) + (getf handlers-plist :filesystem-query-path-function)) + (setf (filesystem-list-all-file-paths-function object) + (getf handlers-plist :filesystem-list-all-file-paths-function)) + (setf (filesystem-close-connection-function object) (getf handlers-plist :filesystem-close-connection-function))) object) @@ -435,23 +448,49 @@ (win-clear window :redraw nil) (resync-rows-db window :redraw t :selected-path remote-path))))) -(defun recursive-delete-node (window path) +(defun recursive-delete-node (window path + &key + (progress-function (lambda (filename file-count all-files-number) + (declare (ignore filename file-count all-files-number))))) (with-accessors ((root-node filesystem-root) - (filesystem-expand-function filesystem-expand-function)) window + (filesystem-expand-function filesystem-expand-function) + (list-all-file-function filesystem-list-all-file-paths-function)) + window (let* ((matching-node (find-node root-node path)) (filep (not (tree-dir-p (data matching-node))))) (if filep (delete-treenode window path) (when (not (or (fs:loopback-reference-dir-p path) (fs:backreference-dir-p path))) - (%expand-treenode root-node - (tree-path (data matching-node)) - filesystem-expand-function) - (setf matching-node (find-node root-node path)) - (do-children (child matching-node) - (let ((path-to-recurse (tree-path (data child)))) - (recursive-delete-node window path-to-recurse))) - (delete-treenode window path)))))) + (multiple-value-bind (all-files-to-delete all-dirs-to-delete) + (funcall list-all-file-function path) + (let ((items-count 0) + (items-total-number (+ (length all-files-to-delete) + (length all-dirs-to-delete)))) + (flet ((delete-items (items) + (loop for item in items + for count from 0 + when (not (or (fs:backreference-dir-p item) + (fs:loopback-reference-dir-p item))) + do + (let ((node (mtree:make-node (make-node-data item nil)))) + (incf items-count) + (funcall (filesystem-delete-function window) + node) + (funcall progress-function + item + items-count + items-total-number))))) + (delete-items all-files-to-delete) + (delete-items all-dirs-to-delete) + (delete-items (list path)) + (when-let* ((parent-node (find-node root-node + (fs:parent-dir-path path))) + (parent-path (tree-path (data parent-node)))) + (remove-all-children parent-node) + (expand-treenode window parent-path) + (win-clear window :redraw nil) + (resync-rows-db window :redraw t :selected-path parent-path)))))))))) (defun filesystem-query-treenode (window path what) (assert (member what '(:size :size-string :permissions :permissions-string :type))) diff --git a/src/filesystem-utils.lisp b/src/filesystem-utils.lisp index 49e8150..73dc5f5 100644 --- a/src/filesystem-utils.lisp +++ b/src/filesystem-utils.lisp @@ -120,10 +120,14 @@ (text-utils:strcat file "." extension)) (defun cat-parent-dir (parent direntry) - (if (or (backreference-dir-p direntry) - (loopback-reference-dir-p direntry)) - (format nil "~a~a" parent direntry) - (format nil "~a~a~a" parent *directory-sep* direntry))) + (cond + ((or (backreference-dir-p direntry) + (loopback-reference-dir-p direntry)) + (format nil "~a~a" parent direntry)) + ((string= (string (alexandria:last-elt parent)) *directory-sep*) + (format nil "~a~a" parent direntry)) + (t + (format nil "~a~a~a" parent *directory-sep* direntry)))) (defmacro do-directory ((var) root &body body) (with-gensyms (dir) @@ -149,23 +153,29 @@ (setf all-paths (sort all-paths #'string<)) all-paths)) -(defun collect-tree (unvisited-dirs &optional (accum '())) - (declare (optimize (debug 0) (speed 3))) - (cond - ((null unvisited-dirs) - accum) - (t - (let* ((children (collect-children (first unvisited-dirs))) - (files (mapcar #'normalize-path - (remove-if #'directory-exists-p children))) - (directories (mapcar (lambda (a) (text-utils:strcat a "/")) - (remove-if (lambda (a) - (or (file-exists-p a) - (backreference-dir-p a) - (loopback-reference-dir-p a))) - children)))) - (collect-tree (append (rest unvisited-dirs) directories) - (append files accum)))))) +(defun collect-tree (root) + (labels ((%collect-tree (unvisited-dirs + &optional + (accum-files '()) + (accum-dirs '())) + (declare (optimize (debug 0) (speed 3))) + (cond + ((null unvisited-dirs) + (values accum-files accum-dirs)) + (t + (let* ((children (collect-children (first unvisited-dirs))) + (files (mapcar #'normalize-path + (remove-if #'directory-exists-p children))) + (directories (mapcar (lambda (a) (text-utils:strcat a "/")) + (remove-if (lambda (a) + (or (file-exists-p a) + (backreference-dir-p a) + (loopback-reference-dir-p a))) + children)))) + (%collect-tree (append (rest unvisited-dirs) directories) + (append files accum-files) + (append directories accum-dirs))))))) + (%collect-tree (list root)))) (defun backreference-dir-p (path) (string= (path-last-element path) "..")) diff --git a/src/kami/client.lisp b/src/kami/client.lisp index 2892b8f..09acf91 100644 --- a/src/kami/client.lisp +++ b/src/kami/client.lisp @@ -158,25 +158,33 @@ (9p:permissions-group-string mode) (9p:permissions-others-string mode)))))))))) +(defun collect-tree (stream root-fid) + (lambda (path) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (with-cloned-root-fid (*stream* root-fid) + (9p:collect-tree *stream* root-fid path))))) + (defun generate-filesystem-window-handlers (path host port query fragment client-certificate client-key) (with-open-ssl-stream (stream socket host port client-certificate client-key) (let* ((*stream* stream) (*root-fid* (9p:mount *stream* "/"))) - (list :query query - :fragment fragment - :socket socket - :path path - :filesystem-expand-function (expand-node *stream* *root-fid*) - :filesystem-rename-function (rename-node *stream* *root-fid*) - :filesystem-delete-function (delete-node *stream* *root-fid*) - :filesystem-create-function (create-node *stream* *root-fid*) - :filesystem-download-function (download-node *stream* *root-fid*) - :filesystem-upload-function (upload-node *stream* *root-fid*) - :filesystem-query-path-function (query-path *stream* *root-fid*) - :filesystem-close-connection-function (lambda () - (9p:close-client socket)))))) + (list :query query + :fragment fragment + :socket socket + :path path + :filesystem-expand-function (expand-node *stream* *root-fid*) + :filesystem-rename-function (rename-node *stream* *root-fid*) + :filesystem-delete-function (delete-node *stream* *root-fid*) + :filesystem-create-function (create-node *stream* *root-fid*) + :filesystem-download-function (download-node *stream* *root-fid*) + :filesystem-upload-function (upload-node *stream* *root-fid*) + :filesystem-query-path-function (query-path *stream* *root-fid*) + :filesystem-list-all-file-paths-function (collect-tree *stream* *root-fid*) + :filesystem-close-connection-function (lambda () + (9p:close-client socket)))))) (defun iri->filesystem-window-handlers (kami-iri) (a:when-let ((parsed-iri (iri:iri-parse kami-iri :null-on-error t))) diff --git a/src/package.lisp b/src/package.lisp index c3e5424..f3dba7d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -287,6 +287,7 @@ :add-extension :do-directory :collect-children + :collect-tree :backreference-dir-p :loopback-reference-dir-p :path-referencing-dir-p diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 9e399ca..2ba6fe2 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -2670,18 +2670,26 @@ printed, on the main window." (when-let* ((win *filesystem-explorer-window*) (fields (line-oriented-window:selected-row-fields win)) (path (fstree:tree-path fields))) - (flet ((on-input-complete (maybe-accepted) - (with-valid-yes-at-prompt (maybe-accepted y-pressed-p) - (when y-pressed-p - (info-message (format nil (_"deleting ~a") path)) - (with-enqueued-process () - (fstree:recursive-delete-node win path) - (fstree:resync-rows-db win - :selected-path (fs:parent-dir-path path) - :redraw nil) - (windows:win-clear win) - (windows:draw win) - (info-message (format nil (_"Completed") path))))))) + (labels ((progress-print (file count item-number) + (info-message (format nil + (_ "deleting ~a (~a of ~a)") + file + count + item-number))) + (on-input-complete (maybe-accepted) + (with-valid-yes-at-prompt (maybe-accepted y-pressed-p) + (when y-pressed-p + (info-message (format nil (_"Preparing to delete ~a") path)) + (with-enqueued-process () + (fstree:recursive-delete-node win + path + :progress-function #'progress-print) + (fstree:resync-rows-db win + :selected-path (fs:parent-dir-path path) + :redraw nil) + (windows:win-clear win) + (windows:draw win) + (info-message (format nil (_"Completed") path))))))) (ask-string-input #'on-input-complete :prompt (format nil (_ "Delete ~a? ") path)))))