pgg-epg.el

   1 ;;; pgg-epg.el --- Gnus' PGG backend of EasyPG.
   2 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
   3 ;;   2005, 2006 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2006 Daiki Ueno
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Keywords: PGP, GnuPG, Gnus
   8
   9 ;; This file is part of EasyPG.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; To use, add (setq pgg-scheme 'epg) to your ~/.gnus.
  29
  30 ;;; Code:
  31
  32 (require 'epa)
  33 (eval-when-compile (require 'pgg))
  34
  35 (defvar pgg-epg-secret-key-id-list nil)
  36
  37 (defun pgg-epg-passphrase-callback (context key-id ignore)
  38   (if (eq key-id 'SYM)
  39       (epa-passphrase-callback-function context key-id nil)
  40     (let* ((entry (assoc key-id epg-user-id-alist))
  41            (passphrase
  42             (pgg-read-passphrase
  43              (format "GnuPG passphrase for %s: "
  44                      (if entry
  45                          (cdr entry)
  46                        key-id))
  47              (if (eq key-id 'PIN)
  48                  "PIN"
  49                key-id))))
  50       (when passphrase
  51         (pgg-add-passphrase-to-cache key-id passphrase)
  52         (setq pgg-epg-secret-key-id-list
  53               (cons key-id pgg-epg-secret-key-id-list))
  54         (copy-sequence passphrase)))))
  55
  56 (defvar inhibit-redisplay)
  57 (defun pgg-epg-encrypt-region (start end recipients &optional sign passphrase)
  58   "This function is for internal use only.
  59
  60 Encrypt the current region between START and END.
  61
  62 If optional argument SIGN is non-nil, do a combined sign and encrypt.
  63
  64 If optional PASSPHRASE is not specified, it will be obtained from the
  65 passphrase cache or user."
  66   (let ((context (epg-make-context))
  67         (inhibit-redisplay t)           ;Gnus users don't like flickering
  68         cipher recipient-keys)
  69     (epg-context-set-armor context t)
  70     (epg-context-set-textmode context pgg-text-mode)
  71     (epg-context-set-passphrase-callback context #'pgg-epg-passphrase-callback)
  72     (save-excursion
  73       (set-buffer (get-buffer-create pgg-output-buffer))
  74       (erase-buffer)
  75       (set-buffer (get-buffer-create pgg-errors-buffer))
  76       (erase-buffer))
  77     (condition-case error
  78         (setq cipher
  79               (epg-encrypt-string
  80                context
  81                (buffer-substring start end)
  82                (apply #'nconc
  83                       (mapcar
  84                        (lambda (recipient)
  85                          (setq recipient-keys
  86                                (epg-list-keys context recipient))
  87                          (unless (or recipient-keys
  88                                      (y-or-n-p
  89                                       (format "No public key for %s; skip it? "
  90                                               recipient)))
  91                            (error "No public key for %s" recipient))
  92                          recipient-keys)
  93                        (if pgg-encrypt-for-me
  94                            (cons pgg-default-user-id recipients)
  95                          recipients)))
  96                sign t)
  97               pgg-epg-secret-key-id-list nil)
  98       (error
  99        (while pgg-epg-secret-key-id-list
 100          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
 101          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
 102        (signal (car error) (cdr error))))
 103     (save-excursion
 104       (set-buffer (get-buffer-create pgg-output-buffer))
 105       (insert cipher))
 106     t))
 107
 108 (defun pgg-epg-encrypt-symmetric-region (start end &optional passphrase)
 109   "This function is for internal use only.
 110
 111 Encrypt the current region between START and END with symmetric cipher.
 112
 113 If optional PASSPHRASE is not specified, it will be obtained from the
 114 passphrase cache or user."
 115   (pgg-epg-encrypt-region start end nil))
 116
 117 (defun pgg-epg-decrypt-region (start end &optional passphrase)
 118   "This function is for internal use only.
 119
 120 Decrypt the current region between START and END.
 121
 122 If optional PASSPHRASE is not specified, it will be obtained from the
 123 passphrase cache or user."
 124   (let ((context (epg-make-context))
 125         (inhibit-redisplay t)           ;Gnus users don't like flickering
 126         plain)
 127     (epg-context-set-armor context t)
 128     (epg-context-set-textmode context pgg-text-mode)
 129     (epg-context-set-passphrase-callback context #'pgg-epg-passphrase-callback)
 130     (save-excursion
 131       (set-buffer (get-buffer-create pgg-output-buffer))
 132       (erase-buffer)
 133       (set-buffer (get-buffer-create pgg-errors-buffer))
 134       (erase-buffer))
 135     (condition-case error
 136         (setq plain
 137               (epg-decrypt-string context (buffer-substring start end))
 138               pgg-epg-secret-key-id-list nil)
 139       (error
 140        (while pgg-epg-secret-key-id-list
 141          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
 142          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
 143        (signal (car error) (cdr error))))
 144     (if (and pgg-text-mode
 145              (fboundp 'decode-coding-string))
 146         (setq plain (decode-coding-string plain 'raw-text)))
 147     (save-excursion
 148       (set-buffer (get-buffer-create pgg-output-buffer))
 149       (insert plain))
 150     t))
 151
 152 (defun pgg-epg-sign-region (start end &optional cleartext passphrase)
 153   "This function is for internal use only.
 154
 155 Make detached signature from text between START and END.
 156
 157 If optional PASSPHRASE is not specified, it will be obtained from the
 158 passphrase cache or user."
 159   (let ((context (epg-make-context))
 160         (inhibit-redisplay t)           ;Gnus users don't like flickering
 161         signature)
 162     (epg-context-set-armor context t)
 163     (epg-context-set-textmode context pgg-text-mode)
 164     (epg-context-set-passphrase-callback context #'pgg-epg-passphrase-callback)
 165     (epg-context-set-signers
 166      context
 167      (list (car (epg-list-keys context pgg-default-user-id t))))
 168     (save-excursion
 169       (set-buffer (get-buffer-create pgg-output-buffer))
 170       (erase-buffer)
 171       (set-buffer (get-buffer-create pgg-errors-buffer))
 172       (erase-buffer))
 173     (condition-case error
 174         (setq signature
 175               (epg-sign-string context
 176                                (buffer-substring start end)
 177                                (if cleartext
 178                                    'clear
 179                                  'detached))
 180               pgg-epg-secret-key-id-list nil)
 181       (error
 182        (while pgg-epg-secret-key-id-list
 183          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
 184          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
 185        (signal (car error) (cdr error))))
 186     (save-excursion
 187       (set-buffer (get-buffer-create pgg-output-buffer))
 188       (insert signature))
 189     t))
 190
 191 (defvar pgg-epg-signatures nil)
 192
 193 (defun pgg-epg-verify-region (start end &optional signature)
 194   "This function is for internal use only.
 195
 196 Verify region between START and END as the detached signature SIGNATURE."
 197   (let ((context (epg-make-context))
 198         (inhibit-redisplay t))          ;Gnus users don't like flickering
 199     (epg-context-set-armor context t)
 200     (epg-context-set-textmode context pgg-text-mode)
 201     (save-excursion
 202       (set-buffer (get-buffer-create pgg-output-buffer))
 203       (erase-buffer)
 204       (set-buffer (get-buffer-create pgg-errors-buffer))
 205       (erase-buffer))
 206     (if signature
 207         (epg-verify-string context
 208                            (with-temp-buffer
 209                              (insert-file-contents signature)
 210                              (buffer-string))
 211                            (buffer-substring start end))
 212       (epg-verify-string context (buffer-substring start end)))
 213     (save-excursion
 214       (set-buffer (get-buffer-create pgg-errors-buffer))
 215       (make-local-variable 'pgg-epg-signatures)
 216       (setq pgg-epg-signatures (epg-context-result-for context 'verify))
 217       (insert (epg-verify-result-to-string pgg-epg-signatures)))
 218     t))
 219
 220 (defun pgg-epg-insert-key ()
 221   "This function is for internal use only.
 222
 223 Insert public key at point."
 224   (let ((context (epg-make-context))
 225         (inhibit-redisplay t)           ;Gnus users don't like flickering
 226         )
 227     (epg-context-set-armor context t)
 228     (epg-context-set-textmode context pgg-text-mode)
 229     (save-excursion
 230       (set-buffer (get-buffer-create pgg-output-buffer))
 231       (erase-buffer)
 232       (set-buffer (get-buffer-create pgg-errors-buffer))
 233       (erase-buffer))
 234     (insert (epg-export-keys-to-string context pgg-default-user-id))))
 235
 236 (defun pgg-epg-snarf-keys-region (start end)
 237   "This function is for internal use only.
 238
 239 Add all public keys in region between START and END to the keyring."
 240   (let ((context (epg-make-context))
 241         (inhibit-redisplay t)           ;Gnus users don't like flickering
 242         )
 243     (epg-context-set-armor context t)
 244     (epg-context-set-textmode context pgg-text-mode)
 245     (save-excursion
 246       (set-buffer (get-buffer-create pgg-output-buffer))
 247       (erase-buffer)
 248       (set-buffer (get-buffer-create pgg-errors-buffer))
 249       (erase-buffer))
 250     (epg-import-keys-from-string context (buffer-substring start end))))
 251
 252 (eval-when-compile
 253   (autoload 'mml2015-gpg-pretty-print-fpr "mml2015"))
 254 (defun mml2015-gpg-extract-signature-details ()
 255   (if pgg-epg-signatures
 256       (let* ((expired (eq (epg-signature-status (car pgg-epg-signatures))
 257                           'key-expired))
 258              (signer (cons (epg-signature-key-id (car pgg-epg-signatures))
 259                            (cdr (assoc (epg-signature-key-id
 260                                         (car pgg-epg-signatures))
 261                                        epg-user-id-alist))))
 262              (fprint (epg-signature-fingerprint (car pgg-epg-signatures)))
 263              (trust-good-enough-p
 264               (memq (epg-signature-validity (car pgg-epg-signatures))
 265                     '(marginal full ultimate))))
 266         (cond ((and signer fprint)
 267                (concat (cdr signer)
 268                        (unless trust-good-enough-p
 269                          (concat "\nUntrusted, Fingerprint: "
 270                                  (mml2015-gpg-pretty-print-fpr fprint)))
 271                        (when expired
 272                          (format "\nWARNING: Signature from expired key (%s)"
 273                                  (car signer)))))
 274               (t
 275                "From unknown user")))
 276     "From unknown user"))
 277
 278 (defun pgg-epg-lookup-key (string &optional type)
 279   "Search keys associated with STRING."
 280   (mapcar (lambda (key)
 281             (epg-sub-key-id (car (epg-key-sub-key-list key))))
 282           (epg-list-keys (epg-make-context) string (not (null type)))))
 283
 284 (provide 'pgg-epg)
 285
 286 ;;; pgg-epg.el ends here