267 lines
11 KiB
Common Lisp
267 lines
11 KiB
Common Lisp
(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))
|