ambrevar: Add storage.lisp.

2021-06-02 16:21:16 +02:00 · 2021-06-02 16:21:16 +02:00 · f41795cce9
parent fa1a233ffc
commit f41795cce9
1 changed files with 103 additions and 0 deletions
--- a/.local/share/common-lisp/source/ambrevar/storage.lisp
+++ b/.local/share/common-lisp/source/ambrevar/storage.lisp
@ -0,0 +1,103 @@
+(uiop:define-package ambrevar/storage
+  (:documentation "Snapshots, backup, file listing and sync.")
+  (:use #:common-lisp)
+  (:use #:trivia)
+  (:import-from #:fof)
+  (: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))
+
+;; TODO: Use ppath to simplify code?
+
+(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 subpath (root &rest subdirs)
+  (str:join (fof:separator)
+            (cons root subdirs)))
+
+(defun personal (&rest subdirs)
+  (apply #'subpath (uiop:getenv "PERSONAL") 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 index of DIRECTORY to DESTINATION.
+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))))
+    (values
+     nil
+     sorted-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 (apply #'subpath destination
+                                        (append
+                                         destination-subdir
+                                         (list
+                                          (str:concat (fof:basename target) ".index"))))))
+           (index1 (root)
+             (ambrevar/shell:make-directory destination)
+             (dolist (entry (fof:list-directory root))
+               (str:string-case (fof:basename entry)
+                 ("public"
+                  (dolist (subentry (fof:list-directory entry))
+                    (match (fof:basename subentry)
+                      ((or "gaming" "videos")
+                       (ambrevar/shell:make-directory (subpath destination (fof:basename subentry)))
+                       (dolist (entry (fof:list-directory subentry))
+                         (write-simple-index entry (fof:basename subentry))))
+                      (otherwise
+                       (write-simple-index subentry)))))
+                 ("private"
+                  (dolist (subentry (fof:list-directory entry))
+                    (write-index subentry (subpath destination "private"
+                                                   (str:concat (fof:basename subentry) ".index.gpg")))))
+                 ("big-games"
+                  (write-simple-index entry))))))
+    (mapc #'index1 (roots))))