ambrevar: Complete storage.lisp with all features from homesync.

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