From 5d716cefa0f961677cb318a47bc5466969ead3f2 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Thu, 3 Jun 2021 12:41:19 +0200 Subject: [PATCH] ambrevar: Complete storage.lisp with all features from homesync. --- .../common-lisp/source/ambrevar/storage.lisp | 144 ++++++++++++++++++ 1 file changed, 144 insertions(+) diff --git a/.local/share/common-lisp/source/ambrevar/storage.lisp b/.local/share/common-lisp/source/ambrevar/storage.lisp index 2718664b..cc30d36e 100644 --- a/.local/share/common-lisp/source/ambrevar/storage.lisp +++ b/.local/share/common-lisp/source/ambrevar/storage.lisp @@ -2,7 +2,9 @@ (: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) @@ -26,6 +28,9 @@ (defun personal (&rest subdirs) (apply #'subpath (uiop:getenv "PERSONAL") subdirs)) +(defun home (&rest subdirs) + (apply #'subpath (uiop:getenv "HOME") subdirs)) + (defun basename (pathname) (first (last (pathname-directory (uiop:ensure-directory-pathname pathname))))) @@ -102,3 +107,142 @@ If DESTINATION ends with '.gpg', it gets GPG-encrypted." ("big-games" (write-simple-index entry)))))) (mapc #'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 'stowed-saves) +(defun stowed-saves () + (dolist (entry (fof:list-directory (personal "games" "stowed-saves"))) + (format t "~a~&" (fof:path (fof:basename entry))) + (uiop:run-program + `("stow" + "-t" ,(home) + "-d" ,(fof:path (fof:parent entry)) + ,(fof:path (fof:basename entry))) + :output t + :error-output t))) + +(defun git-repository? (dir) + (find ".git" (uiop:subdirectories (if (stringp dir) + (uiop:parse-native-namestring dir) + dir)) + :test #'string= + :key #'basename)) + +(defun parent (path) + "Return the parent directory of PATH." + (if (uiop:directory-pathname-p path) + (uiop:pathname-parent-directory-pathname path) + (uiop:pathname-directory-pathname path))) + +(defun depth (file parent) + (if (uiop:pathname-equal file parent) + 0 + (unless (uiop:pathname-equal (parent file) file) + (or (when (uiop:pathname-equal (parent file) parent) + 1) + (alex:when-let ((level (depth (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))) + 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))))))) + +(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." + (let ((mapper-name "gpg_backup")) + (cmd:cmd "sudo cryptsetup open" device mapper-name) + (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+))) + ;; TODO: Uncomment this once tested. + ;; (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 () + (dolist (op '(write-roots-index + notmuch-tags + stowed-saves + project-status)) + (log:info "~a" op) + (funcall op)))