* pgg-epg.el (pgg-epg-lookup-key): New function.
[elisp/epg.git] / 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