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 'epg)
  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       (epg-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)
  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 context
  80                                   (buffer-substring start end)
  81                                   (mapcar
  82                                    (lambda (recipient)
  83                                      (car (epg-list-keys context recipient)))
  84                                    (if pgg-encrypt-for-me
  85                                        (cons pgg-default-user-id recipients)
  86                                      recipients))
  87                                   sign t)
  88               pgg-epg-secret-key-id-list nil)
  89       (error
  90        (while pgg-epg-secret-key-id-list
  91          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
  92          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
  93        (signal (car error) (cdr error))))
  94     (save-excursion
  95       (set-buffer (get-buffer-create pgg-output-buffer))
  96       (insert cipher))
  97     t))
  98
  99 (defun pgg-epg-encrypt-symmetric-region (start end &optional passphrase)
 100   "This function is for internal use only.
 101
 102 Encrypt the current region between START and END with symmetric cipher.
 103
 104 If optional PASSPHRASE is not specified, it will be obtained from the
 105 passphrase cache or user."
 106   (pgg-epg-encrypt-region start end nil))
 107
 108 (defun pgg-epg-decrypt-region (start end &optional passphrase)
 109   "This function is for internal use only.
 110
 111 Decrypt the current region between START and END.
 112
 113 If optional PASSPHRASE is not specified, it will be obtained from the
 114 passphrase cache or user."
 115   (let ((context (epg-make-context))
 116         (inhibit-redisplay t)           ;Gnus users don't like flickering
 117         plain)
 118     (epg-context-set-armor context t)
 119     (epg-context-set-textmode context pgg-text-mode)
 120     (epg-context-set-passphrase-callback context #'pgg-epg-passphrase-callback)
 121     (save-excursion
 122       (set-buffer (get-buffer-create pgg-output-buffer))
 123       (erase-buffer)
 124       (set-buffer (get-buffer-create pgg-errors-buffer))
 125       (erase-buffer))
 126     (condition-case error
 127         (setq plain
 128               (epg-decrypt-string context (buffer-substring start end))
 129               pgg-epg-secret-key-id-list nil)
 130       (error
 131        (while pgg-epg-secret-key-id-list
 132          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
 133          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
 134        (signal (car error) (cdr error))))
 135     (if pgg-text-mode
 136         (setq plain (decode-coding-string plain 'raw-text)))
 137     (save-excursion
 138       (set-buffer (get-buffer-create pgg-output-buffer))
 139       (insert plain))
 140     t))
 141
 142 (defun pgg-epg-sign-region (start end &optional cleartext passphrase)
 143   "This function is for internal use only.
 144
 145 Make detached signature from text between START and END.
 146
 147 If optional PASSPHRASE is not specified, it will be obtained from the
 148 passphrase cache or user."
 149   (let ((context (epg-make-context))
 150         (inhibit-redisplay t)           ;Gnus users don't like flickering
 151         signature)
 152     (epg-context-set-armor context t)
 153     (epg-context-set-textmode context pgg-text-mode)
 154     (epg-context-set-passphrase-callback context #'pgg-epg-passphrase-callback)
 155     (epg-context-set-signers
 156      context
 157      (list (car (epg-list-keys context pgg-default-user-id t))))
 158     (save-excursion
 159       (set-buffer (get-buffer-create pgg-output-buffer))
 160       (erase-buffer)
 161       (set-buffer (get-buffer-create pgg-errors-buffer))
 162       (erase-buffer))
 163     (condition-case error
 164         (setq signature
 165               (epg-sign-string context
 166                                (buffer-substring start end)
 167                                (if cleartext
 168                                    'clear
 169                                  'detached))
 170               pgg-epg-secret-key-id-list nil)
 171       (error
 172        (while pgg-epg-secret-key-id-list
 173          (pgg-remove-passphrase-from-cache (car pgg-epg-secret-key-id-list))
 174          (setq pgg-epg-secret-key-id-list (cdr pgg-epg-secret-key-id-list)))
 175        (signal (car error) (cdr error))))
 176     (save-excursion
 177       (set-buffer (get-buffer-create pgg-output-buffer))
 178       (insert signature))
 179     t))
 180
 181 (defvar pgg-epg-signatures nil)
 182
 183 (defun pgg-epg-verify-region (start end &optional signature)
 184   "This function is for internal use only.
 185
 186 Verify region between START and END as the detached signature SIGNATURE."
 187   (let ((context (epg-make-context))
 188         (inhibit-redisplay t))          ;Gnus users don't like flickering
 189     (epg-context-set-armor context t)
 190     (epg-context-set-textmode context pgg-text-mode)
 191     (save-excursion
 192       (set-buffer (get-buffer-create pgg-output-buffer))
 193       (erase-buffer)
 194       (set-buffer (get-buffer-create pgg-errors-buffer))
 195       (erase-buffer))
 196     (if signature
 197         (epg-verify-string context
 198                            (with-temp-buffer
 199                              (insert-file-contents signature)
 200                              (buffer-string))
 201                            (buffer-substring start end))
 202       (epg-verify-string context (buffer-substring start end)))
 203     (save-excursion
 204       (set-buffer (get-buffer-create pgg-errors-buffer))
 205       (make-local-variable 'pgg-epg-signatures)
 206       (setq pgg-epg-signatures (epg-context-result-for context 'verify))
 207       (insert (epg-verify-result-to-string pgg-epg-signatures)))
 208     t))
 209
 210 (defun pgg-epg-insert-key ()
 211   "This function is for internal use only.
 212
 213 Insert public key at point."
 214   (let ((context (epg-make-context))
 215         (inhibit-redisplay t)           ;Gnus users don't like flickering
 216         )
 217     (epg-context-set-armor context t)
 218     (epg-context-set-textmode context pgg-text-mode)
 219     (save-excursion
 220       (set-buffer (get-buffer-create pgg-output-buffer))
 221       (erase-buffer)
 222       (set-buffer (get-buffer-create pgg-errors-buffer))
 223       (erase-buffer))
 224     (insert (epg-export-keys-to-string context pgg-default-user-id))))
 225
 226 (defun pgg-epg-snarf-keys-region (start end)
 227   "This function is for internal use only.
 228
 229 Add all public keys in region between START and END to the keyring."
 230   (let ((context (epg-make-context))
 231         (inhibit-redisplay t)           ;Gnus users don't like flickering
 232         )
 233     (epg-context-set-armor context t)
 234     (epg-context-set-textmode context pgg-text-mode)
 235     (save-excursion
 236       (set-buffer (get-buffer-create pgg-output-buffer))
 237       (erase-buffer)
 238       (set-buffer (get-buffer-create pgg-errors-buffer))
 239       (erase-buffer))
 240     (epg-import-keys-from-string context (buffer-substring start end))))
 241
 242 (eval-when-compile
 243   (autoload 'mml2015-gpg-pretty-print-fpr "mml2015"))
 244 (defun mml2015-gpg-extract-signature-details ()
 245   (if pgg-epg-signatures
 246       (let* ((expired (eq (epg-signature-status (car pgg-epg-signatures))
 247                           'key-expired))
 248              (signer (cons (epg-signature-key-id (car pgg-epg-signatures))
 249                            (cdr (assoc (epg-signature-key-id
 250                                         (car pgg-epg-signatures))
 251                                        epg-user-id-alist))))
 252              (fprint (epg-signature-fingerprint (car pgg-epg-signatures)))
 253              (trust-good-enough-p
 254               (memq (epg-signature-validity (car pgg-epg-signatures))
 255                     '(marginal fully ultimate))))
 256         (cond ((and signer fprint)
 257                (concat (cdr signer)
 258                        (unless trust-good-enough-p
 259                          (concat "\nUntrusted, Fingerprint: "
 260                                  (mml2015-gpg-pretty-print-fpr fprint)))
 261                        (when expired
 262                          (format "\nWARNING: Signature from expired key (%s)"
 263                                  (car signer)))))
 264               (t
 265                "From unknown user")))
 266     "From unknown user"))
 267
 268 (defun pgg-epg-lookup-key (string &optional type)
 269   "Search keys associated with STRING."
 270   (mapcar (lambda (key)
 271             (epg-sub-key-id (car (epg-key-sub-key-list key))))
 272           (epg-list-keys (epg-make-context) string (not (null type)))))
 273
 274 (provide 'pgg-epg)
 275
 276 ;;; pgg-epg.el ends here