(uiop:define-package ambrevar/storage
  (:documentation "Snapshots, backup, file listing and sync.")
  (:use #:common-lisp)
  (:use #:trivia)
  (:import-from #:cmd)
  (:import-from #:fof)
  (:import-from #:log4cl)
  (:import-from #:ambrevar/gpg)
  (:import-from #:serapeum #:export-always))
(in-package ambrevar/storage)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
  (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum)
  (trivial-package-local-nicknames:add-package-local-nickname :path :pathname-utils))

(defun roots (&optional (prefix "/media/"))
  (sera:filter (sera:op (str:starts-with? prefix _))
               (mapcar (alex:compose #'rest #'first)
                       (rest
                        (first (json:decode-json-from-string
                                (cmd:$cmd "findmnt -n --fstab --output TARGET --json")))))))

(defun absolute-pathname (path-designator)
  (uiop:ensure-pathname path-designator
                        :truenamize t))

(defun absolute-path (path-designator)
  (uiop:native-namestring
   (absolute-pathname path-designator)))

(defun subpath (root &rest subdirs)
  "Return merged paths as a string.
SUBDIRS can be either a single path or a list of paths."
  (str:join (fof:separator)
            (cons root (alex:flatten subdirs))))

(defun personal (&rest subdirs)
  (subpath (uiop:getenv "PERSONAL") subdirs))

(defun home (&rest subdirs)
  (subpath (uiop:getenv "HOME") subdirs))

(defun basename (pathname)
  (first (last (pathname-directory (uiop:ensure-directory-pathname pathname)))))

(defun index (&optional (directory (fof:current-directory)))
  "Return the list of files (not directories) in DIRECTORIES.
Without DIRECTORIES, work over the current directory.
EncFS encrypted directories are skipped.
.git folders are skipped."
  ;; We don't use `fof:finder*' because we it's too slow and we only need file names.
  (let ((result '())
        (recursep (alex:conjoin
                   (sera:op (not (str:starts-with? ".Trash" (basename _))))
                   (sera:op (string/= ".git" (basename _1)))
                   (complement
                    (lambda (dir)
                      (find-if (sera:op (let ((name (basename _)))
                                          (and (str:starts-with? ".encfs" name)
                                               (str:ends-with? ".xml" name))))
                               (uiop:directory-files dir)))))))
    (when (funcall recursep (fof:path directory))
      (uiop:collect-sub*directories
       (uiop:ensure-directory-pathname (fof:path directory))
       (constantly t)
       recursep
       (lambda (subdirectory)
         (setf result (nconc result (uiop:directory-files subdirectory))))))
    result))

(defun write-index (directory destination)
  "Write sorted index of DIRECTORY to DESTINATION.
Return a pair of (DESTINATION index).
See `index'.
If DESTINATION ends with '.gpg', it gets GPG-encrypted."
  (let* ((relative-index (mapcar (alex:rcurry #'fof:relative-path (fof:file directory))
                                 (index directory)))
         (sorted-index (sort relative-index #'string<)))
    (when sorted-index
      (format t "~a~&" destination)
      (ambrevar/gpg:with-maybe-gpg-file (f destination :if-does-not-exist :create
                                                       :direction :output
                                                       ;; TODO: Overwrite by default?  Customizable?
                                                       :if-exists :supersede)
        (dolist (entry sorted-index)
          (format f "~a~&" entry))))
    (list destination sorted-index)))

(export-always 'write-roots-index)
(defun write-roots-index (&optional (destination (personal "index")))
  "Write indexes of `roots' sub-directories to DESTINATION."
  (labels ((write-simple-index (target &rest destination-subdir)
             (write-index target (subpath destination
                                          (append
                                           destination-subdir
                                           (list
                                            (str:concat (fof:basename target) ".index"))))))
           (index1 (root)
             (ambrevar/shell:make-directory destination)
             (alex:mappend
              (lambda (entry)
                (str:string-case (fof:basename entry)
                  ("public"
                   (alex:mappend
                    (lambda (subentry)
                      (match (fof:basename subentry)
                        ((or "gaming" "videos")
                         (ambrevar/shell:make-directory (subpath destination (fof:basename subentry)))
                         (mapcar (lambda (entry)
                                   (write-simple-index entry (fof:basename subentry)))
                                 (fof:list-directory subentry)))
                        (otherwise
                         (list (write-simple-index subentry)))))
                    (fof:list-directory entry)))
                  ("private"
                   (mapcar (lambda (subentry)
                             (write-index subentry
                                          (subpath destination "private"
                                                   (str:concat (fof:basename subentry) ".index.gpg"))))
                           (fof:list-directory entry)))
                  ("big-games"
                   (list (write-simple-index entry)))))
              (fof:list-directory root))))
    (delete-if-not #'second (alex:mappend #'index1 (roots)))))

(export-always 'notmuch-tags)
(defun notmuch-tags ()
  (let ((dump (personal "mail" "notmuch.dump")))
    (format t "~a~&" dump)
    (cmd:cmd "notmuch restore --accumulate" (str:concat "--input=" dump))
    (cmd:cmd "emacs --quick --batch"
             (str:concat "--load=" (home ".emacs.d" "lisp" "init-notmuch-sync.el"))
             "-f notmuch-dump-important-tags")))

(export-always 'stow-saves)
(defun stow-saves ()
  (mapcar
   (lambda (gamesave)
     (uiop:run-program
      `("stow"
        "-t" ,(home)
        "-d" ,(fof:path (fof:parent gamesave))
        ,(fof:path (fof:basename gamesave)))
      :output t
      :error-output t)
     (fof:path (fof:basename gamesave)))
   (fof:list-directory (personal "games" "stowed-saves"))))

(defun git-repository? (dir)
  (find ".git" (uiop:subdirectories (if (stringp dir)
                                        (uiop:parse-native-namestring dir)
                                        dir))
        :test #'string=
        :key #'basename))

(defun depth (file parent)
  (if (uiop:pathname-equal file parent)
      0
      (unless (uiop:pathname-equal (path:parent file) file)
        (or (when (uiop:pathname-equal (path:parent file) parent)
              1)
            (alex:when-let ((level (depth (path:parent file) parent)))
              (1+ level))))))

(export-always 'list-projects)
(defun list-projects ()
  (let ((repository-directories
          (read-from-string
           (nth-value
            1
            (uiop:run-program
             `("emacs" "--batch"
                       "--quick"
                       ,(str:concat "--load=" (home ".emacs.d" "lisp" "init-magit.el"))
                       "--eval" "(message \"%S\" (mapcar (lambda (entry) (setcar entry (expand-file-name (car entry))) entry) magit-repository-directories)))")
             :output t
             :error-output :string)))))
    (alex:mappend
     (lambda (entry)
       (if (or (not (rest entry))
               (= 0 (rest entry)))
           (list (uiop:ensure-directory-pathname (first entry)))
           (let ((max-depth (rest entry))
                 (result '())
                 (root (uiop:ensure-directory-pathname (first entry))))
             (uiop:collect-sub*directories
              root
              (constantly t)
              (alex:conjoin
               (lambda (dir) (< (depth dir root) max-depth))
               (complement #'git-repository?))
              (lambda (subdirectory)
                (setf result (nconc result (sera:filter #'git-repository? (uiop:subdirectories subdirectory))))))
             result)))
     repository-directories)))

(export-always 'project-status)
(defun project-status (project)
  "PROJECT is a git directory."
  ;; TODO: Parsing Git's output is clunky.  Can `legit' do better?
  (let* ((repository (make-instance 'legit:repository :location project))
         (push-commit (ignore-errors (legit:git-value repository `(push)
                                       (legit:git-rev-parse "@{push}" :abbrev-ref t
                                                                      :symbolic-full-name t)))))
    `(("Project" ,project)
      ("Unpushed commits"
       ,(if (uiop:emptyp push-commit)
            :no-push-remote
            (let ((unmerged-commits (legit:git-value repository '(commits)
                                      (legit:git-log :pretty "oneline"
                                                     :revision-range (str:concat push-commit "..")))))
              (sera:lines unmerged-commits))))
      ("Unstaged files"
       ,(sera:lines (legit:git-value repository '(unstaged) (legit:git-diff :name-only t))))
      ("Staged files"
       ,(sera:lines (legit:git-value repository '(staged) (legit:git-diff :name-only t :cached t)))))))

;; TODO: Add option to push upstream?
(export-always 'project-statuses)
(defun project-statuses ()
  (delete-if (sera:op (and (null (second (second _1)))
                           (null (second (third _1)))
                           (null (second (fourth _1)))))
             (mapcar #'project-status (list-projects))))

(defparameter +fs-time-format+
  '((:year 4) #\- (:month 2) #\- (:day 2) #\_ (:hour 2) #\: (:min 2) #\: (:sec 2)))

(export-always 'sync-gpg-key)
(defun sync-gpg-key (device &key (mount-point "/mnt"))
  "Device (e.g. /dev/sda1) where to sync ~/.gnupg."
  (format t "Enter passphrase for ~a:~&" device)
  (let ((mapper-name "gpg_backup")
        (passphrase (uiop:run-program `(,(uiop:getenv "SUDO_ASKPASS")) :output '(:string :stripped t))))
    (with-input-from-string (input passphrase)
      (uiop:run-program
       `("sudo" "cryptsetup" "open" ,device ,mapper-name)
       :input input))
    (cmd:cmd "sudo mount -o compress=zstd"
             (str:concat "/dev/mapper/" mapper-name)
             mount-point)
    (cmd:cmd "gpg --import"
             (str:concat mount-point "/public/.gnupg/pubring.gpg"))
    (cmd:cmd "sudo btrfs subvolume snapshot -r"
             (str:concat mount-point "/public")
             (str:concat mount-point "/.snapshots/public."
                         (local-time:format-timestring t (local-time:now)
                                                       :format +fs-time-format+)))
    (uiop:delete-directory-tree
     (str:concat mount-point "/public/.gnupg/")
     :validate t)
    ;; TODO: How to copy directory trees in pure CL?
    (cmd:cmd "cp -av" (home ".gnupg") (str:concat mount-point "/public"))
    (cmd:cmd "sudo umount" mount-point)
    (cmd:cmd "sudo cryptsetup close" mapper-name)))

(export-always 'sync-all)
(defun sync-all ()                      ; REVIEW: Optionally call `sync-gpg-key'?
  (dolist (op '(write-roots-index
                notmuch-tags
                stow-saves))
    (log:info "~a" op)
    (funcall op))
  ;; Run last to get inspectable return value:
  (log:info "~a" 'project-statuses)
  (project-statuses))