From fa1a233ffc7f16344c7226131bf6655853f5783b Mon Sep 17 00:00:00 2001
From: Pierre Neidhardt <mail@ambrevar.xyz>
Date: Wed, 2 Jun 2021 13:13:20 +0200
Subject: [PATCH] ambrevar: Add gpg.lisp.

---
 .../common-lisp/source/ambrevar/gpg.lisp      | 103 ++++++++++++++++++
 1 file changed, 103 insertions(+)
 create mode 100644 .local/share/common-lisp/source/ambrevar/gpg.lisp

diff --git a/.local/share/common-lisp/source/ambrevar/gpg.lisp b/.local/share/common-lisp/source/ambrevar/gpg.lisp
new file mode 100644
index 00000000..780f5cbd
--- /dev/null
+++ b/.local/share/common-lisp/source/ambrevar/gpg.lisp
@@ -0,0 +1,103 @@
+(uiop:define-package ambrevar/gpg
+  (:documentation "GPG utilities like writing .gpg files.")
+  (:use #:common-lisp)
+  (:use #:trivia)
+  (:import-from #:log4cl)
+  (:import-from #:serapeum #:export-always))
+(in-package ambrevar/gpg)
+(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))
+
+;; Borrowed from Nyxt.
+;; TODO: Extract to public library?
+
+(defvar *gpg-program* "gpg")
+
+(export-always '*gpg-default-recipient*)
+(defvar *gpg-default-recipient* "mail@ambrevar.xyz")
+
+(defun gpg-recipient (file)             ; TODO: Find a proper way to do this.
+  "Return the key of FILE's recipient if any, `*gpg-recipient*' otherwise.
+As second value the email.
+As third value the name."
+  (if (uiop:file-exists-p file)
+      (let* ((output (sera:lines (with-output-to-string (s)
+                                   (uiop:run-program (list *gpg-program* "--decrypt" file)
+                                                     :output nil :error-output s))))
+             (first-line-tokens (str:split " " (first output)))
+             (key (let ((key-string (second (member "ID" first-line-tokens :test #'string=))))
+                    (if (str:ends-with? "," key-string)
+                        (subseq key-string 0 (1- (length key-string)))
+                        key-string)))
+             (second-line (str:trim (second output)))
+             (mail-start (position #\space second-line :from-end t))
+             (mail (str:trim (reduce (lambda (target rep) (str:replace-all rep "" target))
+                                     '(">" "<" "\"") :initial-value (subseq second-line mail-start))))
+             (name (str:replace-all "\"" "" (subseq second-line 0 mail-start))))
+        (values key mail name))
+      *gpg-default-recipient*))
+
+(defun gpg-write (stream gpg-file recipient)
+  "Write STREAM to GPG-FILE using RECIPIENT key."
+  (if recipient
+      ;; TODO: Handle GPG errors.
+      (uiop:run-program
+       (list *gpg-program* "--output" gpg-file "--recipient" recipient
+             "--batch" "--yes" "--encrypt")
+       :input stream)
+      (log:warn "Set `*gpg-default-recipient*' to save ~s." gpg-file)))
+
+(export-always 'with-gpg-file)
+(defmacro with-gpg-file ((stream gpg-file &rest options) &body body)
+  "Like `with-open-file' but use
+OPTIONS are as for `open''s `:direction'.
+Other options are not supported.  File is overwritten if it exists, while
+nothing is done if file is missing."
+  ;; TODO: Support all of `open' options.
+  (alex:with-gensyms (in clear-data result recipient)
+    (if (member (getf options :direction) '(:io :input nil))
+        `(when (uiop:file-exists-p ,gpg-file)
+           (let ((,clear-data (with-output-to-string (out)
+                                (uiop:run-program
+                                 (list *gpg-program* "--decrypt" ,gpg-file)
+                                 :output out))))
+             (with-input-from-string (,stream ,clear-data)
+               (prog1             ; TODO: Shouldn't we `unwind-protect' instead?
+                   (progn
+                     ,@body)
+                 ,(when (eq (getf options :direction) :io)
+                    ;; TODO: Need to handle error when gpg-file key is not available.
+                    `(gpg-write ,stream ,gpg-file (gpg-recipient ,gpg-file)))))))
+        `(let ((,result nil)
+               (,recipient (gpg-recipient ,gpg-file)))
+           (if ,recipient
+               (with-input-from-string (,in (with-output-to-string (,stream)
+                                              (setf ,result (progn ,@body))))
+                 (gpg-write ,in ,gpg-file ,recipient))
+               (error "No recipient."))
+           ,result))))
+
+(defun ensure-parent-exists (path)
+  "Create parent directories of PATH if they don't exist and return PATH."
+  (ensure-directories-exist (directory-namestring path))
+  path)
+
+(export-always 'with-maybe-gpg-file)
+(defmacro with-maybe-gpg-file ((stream filespec &rest options) &body body)
+  "Evaluate BODY with STREAM bound to DATA-PATH.
+DATA-PATH can be a GPG-encrypted file if it ends with a .gpg extension.
+If DATA-PATH expands to NIL or the empty string, do nothing.
+OPTIONS are as for `open'.
+Parent directories are created if necessary."
+  `(if (str:ends-with? ".gpg" ,filespec :ignore-case t)
+       (with-gpg-file (,stream ,filespec ,@options)
+         ,@body)
+       (progn
+         ,(when (and (member (getf options :direction) '(:io :output))
+                     (let ((l (nth-value 2 (get-properties options '(:if-does-not-exist)))))
+                       (or (null l)
+                           (eq (getf l :if-does-not-exist) :create))))
+            `(ensure-parent-exists ,filespec))
+         (with-open-file (,stream ,filespec ,@options)
+           ,@body))))