assboard/pgp.lisp

(in-package :cl-user)
(defpackage #:assboard.pgp
  (:use :cl :assboard.utils)
  (:export #:list-fingerprints
           #:recv-key
           #:delete-key
           #:verify))
(in-package #:assboard.pgp)

(defvar *gpg-program* "/usr/bin/gpg" "gpg command")
(defvar *gpg-homedir* (make-pathname :name ".gnupg"
                                     :defaults +project-path+)
  "gpg homedir (key storage)")
(defvar *gpg-keyserver* "pgpkeys.mit.edu" "Keyserver to use")


(defmacro loop-lines (s &body body)
  `(with-input-from-string (stream ,s)
     (loop for line = (read-line stream nil :eof nil)
        until (eq line :eof)
          ,@body)))

(defun extract-fingerprint (line)
  (let* ((last (1- (length line)))
         (first (1+ (position #\: line :from-end t :end last))))
    (subseq line first last)))

(defun run-gpg (args &key input)
  (with-output-to-string (s)
    (sb-ext:run-program *gpg-program*
                        (append
                         (list "--homedir" (namestring *gpg-homedir*)
                               "--status-fd" "1"
                               "--logger-fd" "2"
                               "--no-tty")
                         args)
                        :input input
                        :output s
                        :error nil)))

(defun list-fingerprints ()
  (loop-lines (run-gpg '("--with-colons"
                         "--with-fingerprint"
                         "--list-keys"))
     if (starts-with "fpr:" line)
     collect (extract-fingerprint line)))

(defun recv-key (fingerprint)
  (loop-lines (run-gpg (list "--keyserver" *gpg-keyserver*
                             "--recv-keys" fingerprint))
     if (starts-with "[GNUPG:] IMPORT_OK" line)
     do (return t)))

(defun delete-key (fingerprint)
  (not (loop-lines (run-gpg (list "--batch"
                                  "--delete-keys" fingerprint))
          if (starts-with "[GNUPG:] DELETE_PROBLEM" line)
          do (return t))))

(defun verify (clearsigned)
  (with-input-from-string (input clearsigned)
    (loop-lines (run-gpg '("--verify") :input input)
       if (starts-with "[GNUPG:] VALIDSIG" line)
       do (return (values (subseq line (1+ (position #\Space line :from-end t)))
                          (parse-integer line
                                         :start 70
                                         :end (position #\Space line :start 70)))))))