Finish trashing files

cl-xdg-trash.asd

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

mountpoints.lisp

@@ -0,0 +1,127 @@
+(in-package :cl-xdg-trash/mountpoints)
+
+(declaim (ftype (function (string) string) unescape-linux-fstab-string))
+(defun unescape-linux-fstab-string (str)
+  "Return a copy of STR with Linux fstab escape sequences processed."
+  (coerce (loop with i = 0
+                while (< i (length str))
+                for char = (aref str i)
+                when (eql char #\\)
+                  collect (code-char (parse-integer str :start (1+ i)
+                                                        :end (+ i 4)
+                                                        :radix 8))
+                  and do (incf i 4)
+                else
+                  collect char
+                  and do (incf i))
+          'string))
+
+(declaim (ftype (function (string) list) parse-linux-fstab-options))
+(defun parse-linux-fstab-options (str)
+  "Parse STR, a comma separated list of mount options, to a list."
+  (mapcar #'unescape-linux-fstab-string (uiop:split-string str :separator '(#\,))))
+
+(declaim (ftype (function (string) list) parse-linux-fstab-line))
+(defun parse-linux-fstab-line (line)
+  (destructuring-bind (source target fstype options &rest rest)
+      (uiop:split-string line :separator '(#\ ))
+    (declare (ignore rest))
+    (list (unescape-linux-fstab-string source)
+          (unescape-linux-fstab-string target)
+          (unescape-linux-fstab-string fstype)
+          (parse-linux-fstab-options options))))
+
+(declaim (ftype (function (&key (:only-real t) (:only-writable t)) list)
+                list-linux-mountpoints))
+(defun list-linux-mountpoints (&key only-real only-writable)
+  "List all mount points on a Linux system. "
+  (with-open-file (in #P"/proc/mounts")
+    (loop for line = (read-line in nil)
+          while line
+          for (source target fstype options) = (parse-linux-fstab-line line)
+          when (and (or (not only-real) (uiop:string-prefix-p "/" source))
+                    (or (not only-writable) (member "rw" options
+                                                    :test #'equal)))
+            collect (if (uiop:string-suffix-p target "/")
+                        target
+                        (format nil "~A/" target)))))
+
+(declaim (ftype (function (&key (:only-real t) (:only-writable t)) list)
+                list-mountpoints))
+(defun list-mountpoints (&key only-real only-writable)
+  "List all mount points on the system. If ONLY-REAL is non-nil attempt to only
+return file systems like ext4, btrfs, zfs, etc. If ONLY-WRITABLE is non-nil, only
+return file-systems that were mounted read-write."
+  #+linux (list-linux-mountpoints :only-real only-real
+                                  :only-writable only-writable)
+  #-(or linux) nil)
+
+(declaim (ftype (function (string) (or integer null)) device-id-for-path))
+(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
+             (sb-posix:stat-dev (sb-posix:stat path))
+           (sb-posix:syscall-error ()
+             nil))
+  #-(or sbcl) nil)
+
+(declaim (ftype (function ((or pathname string) &key (:ensure-directory t))
+                          pathname)
+                ensure-nonwild-pathname))
+(defun ensure-nonwild-pathname (path &key ensure-directory)
+  "coerce path into a pathname. signal a file-error if it is wild."
+  (if (pathnamep path)
+      (progn
+        (when (wild-pathname-p path)
+          (error 'file-error :pathname path))
+        (if ensure-directory
+            (uiop:ensure-directory-pathname path)
+            path))
+      (uiop:parse-native-namestring path :ensure-directory ensure-directory)))
+
+(declaim (ftype (function ((or string pathname)) string) file-or-dir-namestring))
+(defun file-or-dir-namestring (path)
+  "Return the name of the last component of PATH, be it a file or directory."
+  (if (uiop:pathname-equal path "/")
+      "/"
+      (first (last (pathname-directory
+                    (ensure-nonwild-pathname path :ensure-directory t))))))
+
+(declaim (ftype (function ((or string pathname)) (or pathname null))
+                deepest-existing-path))
+(defun deepest-existing-path (path)
+  "Return the truename of the first parent of PATH that exists. If one of the
+leaning components of PATH exists, but is not a directory, return nil."
+  (let ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd))))
+    (handler-case
+        (and (truename path) path)
+      (file-error ()
+        (loop for cur = (uiop:pathname-parent-directory-pathname
+                         (uiop:ensure-directory-pathname path))
+                then (uiop:pathname-parent-directory-pathname cur)
+              until (probe-file cur)
+              finally (return (when (uiop:directory-exists-p cur)
+                                cur)))))))
+
+(declaim (ftype (function ((or string pathname)) (or pathname null))
+                find-filesystem-root))
+(defun find-filesystem-root (path)
+  "Find the root of the file-system on which PATH resides. If it cannot be
+determined, return nil."
+  (let ((bottom (deepest-existing-path path)))
+    (when bottom
+      (let ((bottom-dev (device-id-for-path (uiop:native-namestring bottom))))
+        (when bottom-dev
+          (loop ;; this will return two directories up for non-directory
+                ;; pathname, but that is OK as a non-directory file is going to
+                ;; be on the same device as its parent directory anyway
+                for prev = nil then cur
+                for cur = (uiop:pathname-parent-directory-pathname bottom)
+                  then (uiop:pathname-parent-directory-pathname cur)
+                for dev = (device-id-for-path (uiop:native-namestring cur))
+                while (and (eql dev bottom-dev))
+                when (uiop:pathname-equal cur prev)
+                  ;; we have reached the root
+                  do (return cur)
+                finally (return (or prev bottom))))))))

package.lisp

@@ -1,19 +1,31 @@
 (defpackage :cl-xdg-trash/url-encode
   (:documentation "URL encoding and decoding functions.")
-  (:use :cl)
+  (:use #:cl)
   (:export #:url-encode
            #:url-decode
            #:url-decode-error
            #:url-decode-error-string
            #:url-decode-error-index))
 
+(defpackage :cl-xdg-trash/mountpoints
+  (:documentation
+   "Utility function for discovering mount points.")
+  (:use #:cl)
+  (:export #:list-mountpoints
+           #:find-filesystem-root
+           #:ensure-nonwild-pathname
+           #:file-or-dir-namestring))
+
 (defpackage :cl-xdg-trash/trashinfo
   (:documentation
    "Parser and utility functions for dealing with .trashinfo files.")
-  (:use :cl)
+  (:use #:cl)
   (:import-from #:cl-xdg-trash/url-encode
                 #:url-encode
                 #:url-decode)
+  (:import-from #:cl-xdg-trash/mountpoints
+                #:file-or-dir-namestring
+                #:ensure-nonwild-pathname)
   (:export #:trashinfo-format-error
            #:trashinfo-format-error-message
            #:trashinfo-format-error-line-numer
@@ -27,4 +39,12 @@
            #:trashinfo-trashed-file
            #:parse-trashinfo-from-stream
            #:parse-trashinfo-file
-           #:format-trashinfo))
+           #:format-trashinfo
+           #:make-trashinfo-for))
+
+(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)
+  (:export))

trash.lisp

@@ -0,0 +1,92 @@
+(in-package :cl-xdg-trash)
+
+(declaim (ftype (function () (or integer null)) getuid))
+(defun getuid ()
+  "Return the current user's UID, or nil if it cannot be determined."
+  #+sbcl (sb-posix:getuid)
+  #-(or sbcl) nil)
+
+(declaim (ftype (function (&key (:homedir (or pathname string null))) pathname)
+                xdg-data-home))
+(defun xdg-data-home (&key homedir)
+  (let ((env (uiop:getenv "XDG_DATA_HOME")))
+    (cond
+      (env (uiop:parse-native-namestring
+            (pathname env) :ensure-directory t))
+      ((not homedir)
+       (merge-pathnames #P".local/share/"
+                        (user-homedir-pathname)))
+      ((pathnamep homedir)
+       (merge-pathnames #P".local/share/"
+                        (uiop:ensure-directory-pathname homedir)))
+      (t
+       (merge-pathnames #P".local/share/"
+                        (uiop:parse-native-namestring homedir
+                                                      :ensure-directory t))))))
+
+(declaim (ftype (function (&key (:homedir (or pathname string null))) pathname)
+                user-home-trash-directory))
+(defun user-home-trash-directory (&key homedir)
+  (merge-pathnames #P"Trash/" (xdg-data-home :homedir homedir)))
+
+(declaim (ftype (function ((or string pathname)) list) find-trash-dirs-for-toplevel))
+(defun find-trash-dirs-for-toplevel (toplevel)
+  "List the trash directories that exist under TOPLEVEL."
+  (let ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t))
+        found)
+    (let ((dir (merge-pathnames #P".Trash" top-path)))
+      (when (uiop:directory-exists-p dir)
+        (push dir found)))
+    (let ((uid (getuid)))
+      (when uid
+        (let ((dir (merge-pathnames (pathname (format nil ".Trash-~D" uid))
+                                    top-path)))
+          (when (uiop:directory-exists-p dir)
+            (push dir found)))))
+    found))
+
+(declaim (ftype (function () list) list-toplevel-trash-directories))
+(defun list-toplevel-trash-directories ()
+  "List all known trash directories other than the user's trash directory."
+  (mapcan 'find-trash-dirs-for-toplevel (list-mountpoints)))
+
+(declaim (ftype (function () list) list-trash-directories))
+(defun list-trash-directories ()
+  "List all known trash directories."
+  (cons (user-home-trash-directory) (list-toplevel-trash-directories)))
+
+(declaim (ftype (function ((or pathname string) &key (:include-self t)) t)
+                path-in-home-directory-p))
+(defun path-in-home-directory-p (path &key include-self)
+  "Return non-nil if PATH is in the user's home directory (or is the user's home
+directory)."
+  (let ((path (ensure-nonwild-pathname path :ensure-directory t))
+        (home (user-homedir-pathname)))
+    (or (and include-self (uiop:pathname-equal path home))
+        (uiop:subpathp path home))))
+
+(declaim (ftype (function ((or pathname string)) pathname)
+                trash-directory-for-file))
+(defun trash-directory-for-file (path)
+  "Return the trash directory into which PATH should be trashed."
+  (let* ((res-path (ensure-nonwild-pathname path))
+         (root (find-filesystem-root res-path)))
+    (or (and (path-in-home-directory-p res-path)
+             (uiop:pathname-equal (find-filesystem-root (user-homedir-pathname))
+                                  root)
+             (car (find-trash-dirs-for-toplevel root)))
+        (user-home-trash-directory))))
+
+(declaim (ftype (function ((or pathname string)) t) trash-file))
+(defun trash-file (path)
+  "Move PATH to the trash. Specifically, move it to the proper trash as
+specified by the XDG standard."
+  (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
+                       (make-pathname :name (trashinfo-name trashinfo))
+                       files-dir))))

trashinfo.lisp

@@ -174,6 +174,66 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
             (url-encode path :safe-chars '(#\/))
             (format-trashinfo-timestamp deletion-date))))
 
+(declaim (ftype (function (pathname (or string pathname)) stream)
+                open-trashinfo-for))
+(defun open-trashinfo-for (trash-directory path)
+  (loop with trash-directory = (ensure-nonwild-pathname trash-directory
+                                                        :ensure-directory t)
+        with name = (file-or-dir-namestring path)
+        with info-dir = (ensure-directories-exist
+                         (merge-pathnames #P"info/"
+                                          (uiop:ensure-directory-pathname
+                                           trash-directory))
+                         :verbose nil)
+        for info-file = (merge-pathnames
+                         (make-pathname
+                          :name (format nil "~A-~D"
+                                        name (random most-positive-fixnum))
+                          :type "trashinfo")
+                         info-dir)
+        for stream = (open info-file :direction :output
+                                     :if-exists nil
+                                     :if-does-not-exist :create)
+        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)
+                make-trashinfo-for))
+(defun make-trashinfo-for (trash-directory path &optional (deletion-date
+                                                           (local-time:now)))
+  "Generate a new name based off PATH and create a new trashinfo file under
+TRASH-DIRECTORY. Return a trashinfo object pointing to this file."
+  (let* ((path (ensure-nonwild-pathname path))
+         (stream (open-trashinfo-for trash-directory path)))
+    (prog1
+        (handler-bind
+            ((t #'(lambda (e)
+                    (close stream :abort t)
+                    (signal e))))
+          (let ((trashinfo
+                  (make-instance 'trashinfo
+                                 :path (uiop:native-namestring
+                                        (merge-pathnames path (uiop:getcwd)))
+                                 :name (remove-suffix
+                                        (file-or-dir-namestring
+                                         (pathname stream))
+                                        ".trashinfo")
+                                 :trash-directory trash-directory
+                                 :deletion-date deletion-date)))
+            (format-trashinfo trashinfo stream)
+            trashinfo))
+      ;; if we exited successfully
+      (close stream))))
+
 
 ;; Local Variables:
 ;; jinx-local-words: "trashinfo"