104 lines
4.8 KiB
Common Lisp
104 lines
4.8 KiB
Common Lisp
|
(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))))
|