local/bin/recompress: Init.

.local/bin/recompress

@@ -0,0 +1,86 @@
+#!/home/ambrevar/.local/bin/sbclscript --script
+;;; -*- mode: common-lisp; -*-
+
+(defun list-files-recursively (directory &key extensions)
+  "List files in directory with extension in EXTENSIONS.
+If EXTENSIONS is empty, list all files."
+  (let ((result '()))
+    (uiop:collect-sub*directories
+     (uiop:ensure-directory-pathname directory)
+     (constantly t) (constantly t)
+     (lambda (subdirectory)
+       (setf result (nconc result
+                           (let ((subfiles (uiop:directory-files subdirectory)))
+                             (if extensions
+                                 (delete-if (lambda (p)
+                                              (let ((normalized-p (string-downcase (namestring p))))
+                                                (notany (lambda (ext)
+                                                          (str:ends-with? ext normalized-p))
+                                                        extensions)))
+                                            subfiles)
+                                 subfiles))))))
+    result))
+
+(defun list-files ()
+  (list-files-recursively
+   (first (uiop:command-line-arguments))
+   :extensions '("zip")))
+
+(defun file-size-pairs ()
+  (sort
+   (mapcar (lambda (f)
+             (list f (trivial-file-size:file-size-in-octets f)))
+           (list-files))
+   #'> :key #'second))
+
+(defun file-size-sum ()
+  (reduce #'+
+          (mapcar #'trivial-file-size:file-size-in-octets
+                  (list-files-recursively
+                   (first (uiop:command-line-arguments))
+                   :extensions '("zip")))))
+
+(defvar *archive-mount-point*
+  (namestring
+   (uiop:resolve-absolute-location ; TODO: Can we generate a temp dir in Common Lisp?
+    (list (uiop:temporary-directory) "recompress-mount/"))))
+
+(defun make-directory (path)
+  (uiop:ensure-all-directories-exist (list (uiop:ensure-directory-pathname path)))
+  path)
+
+(defun run (&rest arguments)
+  ;; TODO: Hide stacktrace with `handler-case??
+  (uiop:run-program arguments
+                    :output t
+                    :error-output :output))
+
+(defmacro with-mounted-archive (path &body body)
+  `(progn
+     (make-directory *archive-mount-point*)
+     (unwind-protect
+          (progn
+            (run "archivemount" ,path *archive-mount-point*)
+            ,@body)
+       (run "fusermount" "-u" *archive-mount-point*))))
+
+(defun compress (source destination)
+  (let ((absolute-destination (namestring (uiop:truenamize destination))))
+    (with-mounted-archive source
+      (uiop:with-current-directory (*archive-mount-point*)
+        (apply #'run "apack" absolute-destination
+               (mapcar #'namestring (osicat:list-directory (uiop:getcwd) :bare-pathnames t)))))))
+
+(defun assert-program (program &rest more-programs)
+  (dolist (p (cons program more-programs))
+    (or (sera:resolve-executable p)
+        (warn "~s not found" p)
+        (uiop:quit 1))))
+
+(assert-program "apack" "archivemount")
+
+(unless (= 2 (length (uiop:command-line-arguments)))
+  (error "Requires 2 arguments"))
+
+(compress (first (uiop:command-line-arguments))
+          (second (uiop:command-line-arguments)))