add DATA.GPGPUBKEYS

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 82 insertions, 0 deletions

diff --git a/src/data/gpgpubkeys.lisp b/src/data/gpgpubkeys.lisp
new file mode 100644
index 0000000..a83f138
--- /dev/null
+++ b/src/data/gpgpubkeys.lisp
@@ -0,0 +1,82 @@
+;;; Consfigurator -- Lisp declarative configuration management system
+
+;;; Copyright (C) 2021  Sean Whitton <spwhitton@spwhitton.name>
+
+;;; This file is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3, or (at your option)
+;;; any later version.
+
+;;; This file is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :consfigurator.data.gpgpubkeys)
+(named-readtables:in-readtable :consfigurator)
+
+(defmethod register-data-source
+    ((type (eql :gpgpubkeys)) &key keyring try-recv-key)
+  "Obtain ASCII-armoured PGP public keys by querying local gpg keyring KEYRING.
+If TRY-RECV-KEY, try to add any missing keys to KEYRING by querying keyservers
+configured in dirmngr.conf."
+  (unless (file-exists-p keyring)
+    (missing-data-source "~A does not exist." keyring))
+  (let (cache lastmod)
+    (labels ((reset-cache (&optional (new-lastmod (file-write-date keyring)))
+               (setq cache (make-hash-table :test #'equal)
+                     lastmod new-lastmod))
+             (retrieve (iden1 fingerprint)
+               (declare (ignore iden1))
+               (let ((new-lastmod (file-write-date keyring)))
+                 (when (> new-lastmod lastmod)
+                   (reset-cache new-lastmod)))
+               (or (gethash fingerprint cache)
+                   (multiple-value-bind (key queriedp)
+                       (getkey keyring fingerprint try-recv-key)
+                     (when queriedp (reset-cache))
+                     (and key
+                          (setf (gethash fingerprint cache)
+                                (make-instance 'string-data
+                                               :string key
+                                               :mime "application/pgp-keys"
+                                               :iden1 "--pgp-pubkey"
+                                               :iden2 fingerprint
+                                               :version lastmod))))))
+             (check (iden1 iden2)
+               ;; We can't avoid running gpg(1) to find out whether a PGP key
+               ;; is available, so we might as well just do the extraction
+               ;; work when asked whether we can extract.
+               (and (string= iden1 "--pgp-pubkey")
+                    (let ((retrieved (retrieve nil iden2)))
+                      (and retrieved (data-version retrieved))))))
+      (reset-cache)
+      (cons #'check #'retrieve))))
+
+(defun local-getkey (keyring fingerprint)
+  (multiple-value-bind (output _ exit-code)
+      (run-program `("gpg" "--armor" "--no-default-keyring"
+                           "--keyring" ,(namestring keyring)
+                           "--export-options" "export-minimal"
+                           "--export" ,fingerprint)
+                   :output :string :ignore-error-status t)
+    (declare (ignore _))
+    (let ((key (stripln output)))
+      (and (zerop exit-code) (not (string-equal "" key)) key))))
+
+(defun getkey (keyring fingerprint try-recv-key)
+  (let ((local (local-getkey keyring fingerprint)))
+    (when (or local (not try-recv-key))
+      (return-from getkey (values local nil)))
+    (let ((exit-code
+            (nth-value
+             2 (run-program
+                `("gpg" "--no-default-keyring"
+                        "--keyring" ,(namestring keyring)
+                        "--recv-key" ,fingerprint)
+                :output :string :ignore-error-status t))))
+      (when (zerop exit-code)
+        (values (local-getkey keyring fingerprint) t)))))