Lots of work

cl-xdg-trash.asd

@@ -5,13 +5,14 @@
   :maintainer "Alexander Rosenberg <zanderpkg@pm.me>"
   :homepage "https://git.zander.im/Zander671/cl-xdg-trash"
   :license "GPL3"
-  :depends-on (#:local-time #:uiop #:trivial-features #:yason #:cffi)
+  :depends-on (#:local-time #:uiop #:trivial-features :osicat)
   :serial t
   :components
   ((:file "package")
    (:file "url-encode")
    (:file "mountpoints")
    (:file "trashinfo")
+   (:file "directorysizes")
    (:file "trash"))
   :long-description
   #.(uiop:read-file-string

directorysizes.lisp

@@ -0,0 +1,155 @@
+(in-package :cl-xdg-trash/directorysizes)
+
+(declaim (ftype (function ((or string pathname)) integer) regular-file-size))
+(defun regular-file-size (path)
+  "Return the size (in bytes) of the non-directory file PATH."
+  (let ((res (osicat-posix:stat (uiop:native-namestring
+                                 (ensure-nonwild-pathname path)))))
+    (when (osicat-posix:s-isdir (osicat-posix:stat-mode res))
+      (error 'file-error :pathname path))
+    (osicat-posix:stat-size res)))
+
+(declaim (ftype (function ((or string pathname)) integer) file-size))
+(defun file-size (path)
+  "Return the size of the file (inode) named by PATH."
+  (loop for queue = (list (ensure-nonwild-pathname path)) then queue
+        while queue
+        for cur = (first queue)
+        for res = (osicat-posix:stat cur)
+        do (pop queue)
+        when (osicat-posix:s-isdir (osicat-posix:stat-mode res))
+          do (setq queue (nconc (uiop:directory*
+                                 (merge-pathnames
+                                  uiop:*wild-file-for-directory* cur))
+                                queue))
+        else
+          summing (regular-file-size cur)))
+
+(declaim (ftype (function (string character &optional (or null integer)) list)
+                split-string))
+(defun split-string (string seperator &optional max)
+  "Split STRING on SEPERATOR, a character. If MAX is an integer, return a list
+of at most MAX elements, with the last element being the remaining, un-split
+part of STRING."
+  (loop with start = 0
+        with count = 0
+        for i below (length string)
+        while (or (not (integerp max)) (< count (1- max)))
+        for char = (aref string i)
+        when (eql char seperator)
+          collect (subseq string start i) into out
+          and do (setq start (1+ i)
+                       count (1+ count))
+        finally (return (progn
+                          (nconc out (list (subseq string start)))))))
+
+(defstruct directorysizes-entry
+  "Single entry in a directorysizes file."
+  size mtime name)
+
+(declaim (ftype (function (stream) hash-table) parse-directorysizes))
+(defun parse-directorysizes (stream)
+  "Parse the directorysizes file read from STREAM."
+  (loop with out = (make-hash-table :test #'equal)
+        for line = (read-line stream nil)
+        while line
+        for (size mtime encoded-name) = (split-string line #\Space 3)
+        for name = (url-decode encoded-name)
+        do (setf (gethash name out)
+                 (make-directorysizes-entry
+                  :size (parse-integer size)
+                  :mtime (parse-integer mtime)
+                  :name name))
+        finally (return out)))
+
+(declaim (ftype (function ((or string pathname)) hash-table)
+                read-directorysizes-file))
+(defun read-directorysizes-file (path)
+  "Read the directorysizes file PATH."
+  (with-open-file (stream (ensure-nonwild-pathname path))
+    (parse-directorysizes stream)))
+
+(declaim (ftype (function ((or string pathname)) pathname)
+                calculate-direcotrysizes-path))
+(defun calculate-direcotrysizes-path (trash-directory)
+  "Return the directorysizes file for TRASH-DIRECTORY."
+  (merge-pathnames #P"directorysizes"
+                   (ensure-nonwild-pathname trash-directory
+                                            :ensure-directory t)))
+
+(declaim (ftype (function ((or boolean stream) hash-table) t)
+                format-directorysizes))
+(defun format-directorysizes (stream directorysizes)
+  "Write DIRECTORYSIZES to STREAM."
+  (loop for name being the hash-keys of directorysizes
+          using (hash-value entry)
+        do (with-slots (size mtime) entry
+             (format stream "~A ~A ~A~%" size mtime (url-encode name)))))
+
+(defmacro with-atomic-write ((stream path) &body body)
+  "Evaluate BODY with STREAM bound to a stream that will write to a temporary
+file. If execution is successful, rename this temporary file to PATH, replacing
+it."
+  (let ((tmp-path (gensym "TMP-PATH-"))
+        (target-path (gensym "TARGET-PATH-"))
+        (dir (gensym "DIR")))
+    `(let* ((,target-path (ensure-nonwild-pathname ,path))
+            (,dir (uiop:pathname-parent-directory-pathname ,target-path)))
+       (uiop:call-with-temporary-file
+        #'(lambda (,stream ,tmp-path)
+            ,@body
+            (osicat-posix:rename
+             (uiop:native-namestring ,tmp-path)
+             (uiop:native-namestring ,target-path)))
+        :keep t :directory ,dir :type nil))))
+
+
+(declaim (ftype (function ((or string pathname) string))
+                update-directorysizes-entry))
+(defun trashed-file-size (trash-directory name)
+  "Return the size of the trashed file NAME in TRASH-DIRECTORY. If NAME is a
+directory and the file size cache is out of date, update it."
+  (let* ((directorysizes-path (calculate-direcotrysizes-path trash-directory))
+         (directorysizes (handler-case
+                             (read-directorysizes-file directorysizes-path)
+                           (file-error ()
+                             (make-hash-table :test #'equal))))
+         (cur-entry (gethash name directorysizes))
+         (path (merge-pathnames (make-pathname :name name
+                                               :directory '(:relative "files"))
+                                (ensure-nonwild-pathname trash-directory
+                                                         :ensure-directory t)))
+         (stat (handler-case
+                   (osicat-posix:stat (uiop:native-namestring path))
+                 (t nil nil)))
+         (trashinfo-mtime
+           (handler-case (osicat-posix:stat-mtime
+                          (osicat-posix:stat (uiop:native-namestring
+                                              (compute-trashinfo-source-file
+                                               trash-directory name))))
+             (t nil nil)))
+         did-change ret-size)
+    (cond
+      ((not stat)
+       (setf did-change (remhash name directorysizes)))
+      ((not (osicat-posix:s-isdir (osicat-posix:stat-mode stat)))
+       (setf did-change (remhash name directorysizes)
+             ret-size (osicat-posix:stat-size stat)))
+      ((and (directorysizes-entry-p cur-entry)
+            (eql (directorysizes-entry-mtime cur-entry)
+                 trashinfo-mtime))
+       (setq ret-size (directorysizes-entry-size cur-entry)))
+      (t
+       (let ((orig-size (gethash name directorysizes))
+             (size (file-size path)))
+         (setf (gethash name directorysizes)
+               (make-directorysizes-entry
+                :mtime trashinfo-mtime
+                :size size
+                :name name)
+               did-change (not (eql size orig-size))
+               ret-size size))))
+    (when did-change
+      (with-atomic-write (stream directorysizes-path)
+        (format-directorysizes stream directorysizes)))
+    ret-size))

mountpoints.lisp

@@ -60,11 +60,17 @@ return file-systems that were mounted read-write."
 (defun device-id-for-path (path)
   "Return the device id for the device on which PATH resides, or nil if it can't
 be determined."
-  #+sbcl (handler-case
+  (handler-case
-             (sb-posix:stat-dev (sb-posix:stat path))
+      (osicat-posix:stat-dev (osicat-posix:stat path))
-           (sb-posix:syscall-error ()
+    (osicat-posix:posix-error ()
-             nil))
+      nil)))
-  #-(or sbcl) nil)
+
+(declaim (ftype (function (string string) string) remove-suffix))
+(defun remove-suffix (string suffix)
+  "Return STRING without SIFFIX."
+  (if (uiop:string-suffix-p string suffix)
+      (subseq string 0 (- (length string) (length suffix)))
+      string))
 
 (declaim (ftype (function ((or pathname string) &key (:ensure-directory t))
                           pathname)
@@ -85,8 +91,8 @@ be determined."
   "Return the name of the last component of PATH, be it a file or directory."
   (if (uiop:pathname-equal path "/")
       "/"
-      (first (last (pathname-directory
+      (let ((unix-path (remove-suffix (uiop:unix-namestring path) "/")))
-                    (ensure-nonwild-pathname path :ensure-directory t))))))
+        (first (last (uiop:split-string unix-path :max 2 :separator '(#\/)))))))
 
 (declaim (ftype (function ((or string pathname)) (or pathname null))
                 deepest-existing-path))

package.lisp

@@ -14,6 +14,7 @@
   (:export #:list-mountpoints
            #:find-filesystem-root
            #:ensure-nonwild-pathname
+           #:remove-suffix
            #:file-or-dir-namestring))
 
 (defpackage :cl-xdg-trash/trashinfo
@@ -25,7 +26,8 @@
                 #:url-decode)
   (:import-from #:cl-xdg-trash/mountpoints
                 #:file-or-dir-namestring
-                #:ensure-nonwild-pathname)
+                #:ensure-nonwild-pathname
+                #:remove-suffix)
   (:export #:trashinfo-format-error
            #:trashinfo-format-error-message
            #:trashinfo-format-error-line-numer
@@ -34,17 +36,34 @@
            #:trashinfo
            #:trashinfo-trash-directory
            #:trashinfo-name
-           #:trashinfo-path
+           #:trashinfo-original-path
            #:trashinfo-deletion-date
+           #:trashinfo-info-file
            #:trashinfo-trashed-file
+           #:compute-trashinfo-source-file
            #:parse-trashinfo-from-stream
            #:parse-trashinfo-file
            #:format-trashinfo
            #:make-trashinfo-for))
 
+(defpackage :cl-xdg-trash/directorysizes
+  (:documentation
+   "Parser and utility functions for dealing with the directorysizes file.")
+  (:use #:cl)
+  (:import-from #:cl-xdg-trash/mountpoints
+                #:ensure-nonwild-pathname)
+  (:import-from #:cl-xdg-trash/url-encode
+                #:url-encode
+                #:url-decode)
+  (:import-from #:cl-xdg-trash/trashinfo
+                #:compute-trashinfo-source-file)
+  (:export #:read-directorysizes-file
+           #:prase-directorysizes
+           #:trashed-file-size))
+
 (defpackage :cl-xdg-trash
   (:documentation
    "Common Lisp interface to the XDG trash specification.")
   (:use #:cl #:cl-xdg-trash/trashinfo #:cl-xdg-trash/url-encode
-        #:cl-xdg-trash/mountpoints)
+        #:cl-xdg-trash/mountpoints #:cl-xdg-trash/directorysizes)
   (:export))

trash.lisp

@@ -1,10 +1,9 @@
 (in-package :cl-xdg-trash)
 
-(declaim (ftype (function () (or integer null)) getuid))
+(declaim (ftype (function () integer) getuid))
 (defun getuid ()
-  "Return the current user's UID, or nil if it cannot be determined."
+  "Return the current user's UID."
-  #+sbcl (sb-posix:getuid)
+  (osicat-posix:getuid))
-  #-(or sbcl) nil)
 
 (declaim (ftype (function (&key (:homedir (or pathname string null))) pathname)
                 xdg-data-home))
@@ -77,16 +76,73 @@ directory)."
              (car (find-trash-dirs-for-toplevel root)))
         (user-home-trash-directory))))
 
-(declaim (ftype (function ((or pathname string)) t) trash-file))
+(declaim (ftype (function ((or pathname string) &optional t) t) trash-file))
-(defun trash-file (path)
+(defun trash-file (path &optional (update-size-cache t))
   "Move PATH to the trash. Specifically, move it to the proper trash as
-specified by the XDG standard."
+specified by the XDG standard. If UPDATE-SIZE-CACHE is non-nil (the default)
+also update the directory size cache."
   (let* ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd)))
          (trash-directory (trash-directory-for-file path))
          (trashinfo (make-trashinfo-for trash-directory path))
          (files-dir (ensure-directories-exist (merge-pathnames
                                                #P"files/" trash-directory)
                                               :verbose nil)))
-    (rename-file path (merge-pathnames
+    (osicat-posix:rename (uiop:native-namestring path)
+                         (uiop:native-namestring
+                          (merge-pathnames
                            (make-pathname :name (trashinfo-name trashinfo))
-                       files-dir))))
+                           files-dir)))
+    (when update-size-cache
+      (trashed-file-size trash-directory (trashinfo-name trashinfo)))))
+
+(declaim (ftype (function ((or pathname string list)) list)
+                normalize-trash-directories)
+         (inline normalize-trash-directories))
+(defun normalize-trash-directories (trash-directories)
+  "Normalize TRASH-DIRECTORIES to a non-wild list of pathnames."
+  (if (or (stringp trash-directories) (pathnamep trash-directories))
+      (list (ensure-nonwild-pathname trash-directories :ensure-directory t))
+      (mapcar #'(lambda (elt)
+                  (ensure-nonwild-pathname elt :ensure-directory t))
+              trash-directories)))
+
+(declaim (ftype (function (pathname) list) list-trashed-files-for-directory))
+(defun list-trasheds-file-for-directory (trash-directory)
+  "Return a list of trashinfo objects for every trashed file in
+TRASH-DIRECTORY."
+  (let ((info-dir (merge-pathnames #P"info/" trash-directory)))
+    (mapcan #'(lambda (path)
+                (let ((name (file-or-dir-namestring path)))
+                  (when (uiop:string-suffix-p name ".trashinfo")
+                    (list (parse-trashinfo-file
+                           trash-directory
+                           (subseq name 0 (- (length name)
+                                             (length ".trashinfo"))))))))
+            (uiop:directory-files info-dir))))
+
+(declaim (ftype (function (&optional (or pathname string list)) list)
+                normalize-trash-directories))
+(defun list-trashed-files (&optional (trash-directories (list-trash-directories)))
+  "Return a list of trashinfo objects for each trashed file in
+TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path."
+  (mapcan #'list-trashed-file-for-directory
+          (normalize-trash-directories trash-directories)))
+
+(declaim (ftype (function (trashinfo &optional t) t) restore-file))
+(defun restore-file (trashinfo &optional (update-size-cache t))
+  "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil
+(the default), also update the directory size cache."
+  (osicat-posix:rename
+   (uiop:native-namestring (trashinfo-trashed-file trashinfo))
+   (uiop:native-namestring (trashinfo-original-path trashinfo)))
+  (handler-bind
+      ;; attempt to re-trash the file in case of error
+      ((t #'(lambda (e)
+              (osicat-posix:rename
+               (uiop:native-namestring (trashinfo-original-path trashinfo))
+               (uiop:native-namestring (trashinfo-trashed-file trashinfo)))
+              (signal e))))
+    (delete-file (trashinfo-info-file trashinfo))
+    (when update-size-cache
+      (trashed-file-size (trashinfo-trash-directory trashinfo)
+                         (trashinfo-name trashinfo)))))

trashinfo.lisp

@@ -33,8 +33,8 @@ trashinfo file belongs to.")
          :initarg :name
          :type string
          :documentation "The name of this trashinfo file without the extension.")
-   (path :reader trashinfo-path
+   (original-path :reader trashinfo-original-path
-         :initarg :path
+                  :initarg :original-path
                   :type pathname
                   :documentation "Path to the original location of the file.")
    (deletion-date :reader trashinfo-deletion-date
@@ -44,6 +44,16 @@ trashinfo file belongs to.")
 trashed."))
   (:documentation "Represents a .trashinfo file."))
 
+(defmethod print-object ((obj trashinfo) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (princ (trashinfo-name obj) stream)))
+
+(defmethod trashinfo-info-file ((trashinfo trashinfo))
+  (with-slots (name trash-directory) trashinfo
+    (merge-pathnames (make-pathname :name (format nil "~A.trashinfo" name)
+                                    :directory '(:relative "info"))
+                     trash-directory)))
+
 (defmethod trashinfo-trashed-file ((trashinfo trashinfo))
   (with-slots (name trash-directory) trashinfo
     (merge-pathnames (make-pathname :name name :directory '(:relative "files"))
@@ -81,13 +91,14 @@ trashed."))
       (setq second (next-int 2))
       (local-time:encode-timestamp 0 second minute hour day month year))))
 
-(declaim (ftype (function (pathname string) pathname) compute-trashinfo-source-file))
+(declaim (ftype (function ((or pathname string) string) pathname)
+                compute-trashinfo-source-file))
 (defun compute-trashinfo-source-file (trash-directory name)
   "Return the pathname object for the actual trashinfo file corresponding to the
 trashed file NAME in TRASH-DIRECTORY."
-  (merge-pathnames (make-pathname :name name :type "trashinfo"
+  (merge-pathnames (make-pathname :name (format nil "~A.trashinfo" name)
                                   :directory '(:relative "info"))
-                   trash-directory))
+                   (ensure-nonwild-pathname trash-directory :ensure-directory t)))
 
 (declaim (ftype (function (pathname string stream &key (:source-file pathname))
                           trashinfo)
@@ -137,7 +148,7 @@ trashed file NAME in TRASH-DIRECTORY."
                       "End-of-file without both \"Path\" and \"DeletionDate\"")
                (return (make-instance 'trashinfo
                                       :deletion-date deletion-date
-                                      :path path :name name
+                                      :original-path path :name name
                                       :trash-directory trash-directory)))))
 
 (declaim (ftype (function ((or pathname string) string) trashinfo)))
@@ -169,9 +180,9 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
                 format-trashinfo))
 (defun format-trashinfo (trashinfo &optional stream)
   "Write the trashinfo file out to STREAM."
-  (with-slots (path deletion-date) trashinfo
+  (with-slots (original-path deletion-date) trashinfo
     (format stream "[Trash Info]~%Path=~A~%DeletionDate=~A~%"
-            (url-encode path :safe-chars '(#\/))
+            (url-encode original-path :safe-chars '(#\/))
             (format-trashinfo-timestamp deletion-date))))
 
 (declaim (ftype (function (pathname (or string pathname)) stream)
@@ -187,9 +198,8 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
                          :verbose nil)
         for info-file = (merge-pathnames
                          (make-pathname
-                          :name (format nil "~A-~D"
+                          :name (format nil "~A-~D.trashinfo"
-                                        name (random most-positive-fixnum))
+                                        name (random most-positive-fixnum)))
-                          :type "trashinfo")
                          info-dir)
         for stream = (open info-file :direction :output
                                      :if-exists nil
@@ -197,13 +207,6 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
         until stream
         finally (return stream)))
 
-(declaim (ftype (function (string string) string) remove-suffix))
-(defun remove-suffix (string suffix)
-  "Return STRING without SIFFIX."
-  (if (uiop:string-suffix-p string suffix)
-      (subseq string 0 (- (length string) (length suffix)))
-      string))
-
 (declaim (ftype (function (pathname (or pathname string)
                                     &optional local-time:timestamp)
                           trashinfo)
@@ -221,8 +224,9 @@ TRASH-DIRECTORY. Return a trashinfo object pointing to this file."
                     (signal e))))
           (let ((trashinfo
                   (make-instance 'trashinfo
-                                 :path (uiop:native-namestring
+                                 :original-path (uiop:native-namestring
-                                        (merge-pathnames path (uiop:getcwd)))
+                                                 (merge-pathnames path
+                                                                  (uiop:getcwd)))
                                  :name (remove-suffix
                                         (file-or-dir-namestring
                                          (pathname stream))