(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))))))))