Importing EasyPG.
[elisp/epg.git] / epg.el
1 (defgroup epg ()
2   "EasyPG, yet another GnuPG interface.")
3
4 (defcustom epg-gpg-program "gpg"
5   "The `gpg' executable."
6   :group 'epg
7   :type 'string)
8
9 (defvar epg-user-id nil
10   "GnuPG ID of your default identity.")
11
12 (defvar epg-user-id-alist nil
13   "An alist mapping from key ID to user ID.")
14
15 (defvar epg-read-point nil)
16 (defvar epg-pending-status-list nil)
17 (defvar epg-key-id nil)
18 (defvar epg-context nil)
19 (defvar epg-debug nil)
20
21 (defvar epg-colons-pub-spec
22   '((trust "[^:]")
23     (length "[0-9]+" 0 string-to-number)
24     (algorithm "[0-9]+" 0 string-to-number)
25     (key-id "[^:]+")
26     (creation-date "[0-9]+")
27     (expiration-date "[0-9]+")
28     nil
29     (ownertrust "[^:]")
30     nil
31     nil
32     (capability "[escaESCA]*"))
33   "The schema of keylisting output whose type is \"pub\".
34 This is used by `epg-list-keys'.")
35
36 (defvar epg-colons-sec-spec
37   '((trust "[^:]")
38     (length "[0-9]+" 0 string-to-number)
39     (algorithm "[0-9]+" 0 string-to-number)
40     (key-id "[^:]+")
41     (creation-date "[0-9]+")
42     (expiration-date "[0-9]+")
43     nil
44     (ownertrust "[^:]"))
45 "The schema of keylisting output whose type is \"sec\".
46 This is used by `epg-list-keys'.")
47
48 (defvar epg-colons-uid-spec
49   '((trust "[^:]")
50     nil
51     nil
52     nil
53     (creation-date "[0-9]+")
54     (expiration-date "[0-9]+")
55     (hash "[^:]+")
56     nil
57     (user-id "[^:]+"))
58   "The schema of keylisting output whose type is \"uid\".
59 This is used by `epg-list-keys'.")
60     
61 (defun epg-make-context (&optional protocol armor textmode include-certs
62                                    process output-file result)
63   "Return a context object."
64   (vector protocol armor textmode include-certs
65           (list #'epg-passphrase-callback)
66           (list #'epg-progress-callback)
67           nil process output-file result))
68
69 (defun epg-context-protocol (context)
70   "Return the protocol used within the context."
71   (aref context 0))
72
73 (defun epg-context-armor (context)
74   "Return t if the output shouled be ASCII armored in the CONTEXT context."
75   (aref context 1))
76
77 (defun epg-context-textmode (context)
78   "Return t if canonical text mode should be used in the CONTEXT context."
79   (aref context 2))
80
81 (defun epg-context-include-certs (context)
82   "Return how many certificates should be included in an S/MIME signed
83 message."
84   (aref context 3))
85
86 (defun epg-context-passphrase-callback (context)
87   "Return the function used to query passphrase."
88   (aref context 4))
89
90 (defun epg-context-progress-callback (context)
91   "Return the function which handles progress update."
92   (aref context 5))
93
94 (defun epg-context-signers (context)
95   "Return the list of key-id for singning."
96   (aref context 6))
97
98 (defun epg-context-process (context)
99   "Return the process object of `epg-gpg-program'.
100 This function is for internal use only."
101   (aref context 7))
102
103 (defun epg-context-output-file (context)
104   "Return the output file of `epg-gpg-program'.
105 This function is for internal use only."
106   (aref context 8))
107
108 (defun epg-context-result (context name)
109   "Return the result of the previous cryptographic operation."
110   (cdr (assq name (aref context 9))))
111
112 (defun epg-context-set-protocol (context protocol)
113   "Set the protocol used within the context."
114   (aset context 0 protocol))
115
116 (defun epg-context-set-armor (context armor)
117   "Specify if the output shouled be ASCII armored in the CONTEXT context."
118   (aset context 1 armor))
119
120 (defun epg-context-set-textmode (context textmode)
121   "Specify if canonical text mode should be used in the CONTEXT context."
122   (aset context 2 textmode))
123
124 (defun epg-context-set-include-certs (context include-certs)
125  "Set how many certificates should be included in an S/MIME signed message."
126   (aset context 3 include-certs))
127
128 (defun epg-context-set-passphrase-callback (context passphrase-callback
129                                                     &optional handback)
130   "Set the function used to query passphrase."
131   (aset context 4 (cons passphrase-callback handback)))
132
133 (defun epg-context-set-progress-callback (context progress-callback
134                                                   &optional handback)
135   "Set the function which handles progress update."
136   (aset context 5 (cons progress-callback handback)))
137
138 (defun epg-context-set-signers (context signers)
139  "Set the list of key-id for singning."
140   (aset context 6 signers))
141
142 (defun epg-context-set-process (context process)
143   "Set the process object of `epg-gpg-program'.
144 This function is for internal use only."
145   (aset context 7 process))
146
147 (defun epg-context-set-output-file (context output-file)
148   "Set the output file of `epg-gpg-program'.
149 This function is for internal use only."
150   (aset context 8 output-file))
151
152 (defun epg-context-set-result (context name result)
153   "Set the result of the previous cryptographic operation."
154   (let ((entry (assq name (aref context 9))))
155     (if entry
156         (setcdr entry result)
157       (aset context 9 (cons (cons name result) (aref context 9))))))
158
159 (defun epg-make-signature (status key-id user-id)
160   "Return a signature object."
161   (vector status key-id user-id nil))
162
163 (defun epg-signature-status (signature)
164   "Return the status code of SIGNATURE."
165   (aref signature 0))
166
167 (defun epg-signature-key-id (signature)
168   "Return the key-id of SIGNATURE."
169   (aref signature 1))
170
171 (defun epg-signature-user-id (signature)
172   "Return the user-id of SIGNATURE."
173   (aref signature 2))
174   
175 (defun epg-signature-validity (signature)
176   "Return the validity of SIGNATURE."
177   (aref signature 3))
178
179 (defun epg-signature-set-status (signature status)
180  "Set the status code of SIGNATURE."
181   (aset signature 0 status))
182
183 (defun epg-signature-set-key-id (signature key-id)
184  "Set the key-id of SIGNATURE."
185   (aset signature 1 key-id))
186
187 (defun epg-signature-set-user-id (signature user-id)
188  "Set the user-id of SIGNATURE."
189   (aset signature 2 user-id))
190   
191 (defun epg-signature-set-validity (signature validity)
192  "Set the validity of SIGNATURE."
193   (aset signature 3 validity))
194
195 (defun epg-start (context args)
196   "Start `epg-gpg-program' in a subprocess with given ARGS."
197   (let* ((args (append (list "--no-tty"
198                              "--status-fd" "1"
199                              "--command-fd" "0"
200                              "--yes") ; overwrite
201                        (if (epg-context-armor context) '("--armor"))
202                        (if (epg-context-textmode context) '("--textmode"))
203                        (if (epg-context-output-file context)
204                            (list "--output" (epg-context-output-file context)))
205                        args))
206          (coding-system-for-write 'binary)
207          process-connection-type
208          (orig-mode (default-file-modes))
209          (buffer (generate-new-buffer " *epg*"))
210          process)
211     (with-current-buffer buffer
212       (make-local-variable 'epg-read-point)
213       (setq epg-read-point (point-min))
214       (make-local-variable 'epg-pending-status-list)
215       (setq epg-pending-status-list nil)
216       (make-local-variable 'epg-key-id)
217       (setq epg-key-id nil)
218       (make-local-variable 'epg-context)
219       (setq epg-context context))
220     (unwind-protect
221         (progn
222           (set-default-file-modes 448)
223           (setq process
224                 (apply #'start-process "epg" buffer epg-gpg-program args)))
225       (set-default-file-modes orig-mode))
226     (set-process-filter process #'epg-process-filter)
227     (epg-context-set-process context process)))
228
229 (defun epg-process-filter (process input)
230   (if epg-debug
231       (save-excursion
232         (set-buffer (get-buffer-create  " *epg-debug*"))
233         (goto-char (point-max))
234         (insert input)))
235   (if (buffer-live-p (process-buffer process))
236       (save-excursion
237         (set-buffer (process-buffer process))
238         (goto-char (point-max))
239         (insert input)
240         (goto-char epg-read-point)
241         (beginning-of-line)
242         (while (looking-at ".*\n")      ;the input line is finished
243           (save-excursion
244             (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
245                 (let* ((status (match-string 1))
246                        (string (match-string 2))
247                        (symbol (intern-soft (concat "epg-status-" status))))
248                   (if (member status epg-pending-status-list)
249                       (setq epg-pending-status-list nil))
250                   (if (and symbol
251                            (fboundp symbol))
252                       (funcall symbol process string)))))
253           (forward-line))
254         (setq epg-read-point (point)))))
255
256 (defun epg-read-output (context)
257   (with-temp-buffer
258     (set-buffer-multibyte nil)
259     (if (file-exists-p (epg-context-output-file context))
260         (let ((coding-system-for-read (if (epg-context-output-file context)
261                                           'raw-text
262                                       'binary)))
263           (insert-file-contents (epg-context-output-file context))
264           (buffer-string)))))
265
266 (defun epg-wait-for-status (context status-list)
267   (with-current-buffer (process-buffer (epg-context-process context))
268     (setq epg-pending-status-list status-list)
269     (while (and (eq (process-status (epg-context-process context)) 'run)
270                 epg-pending-status-list)
271       (accept-process-output (epg-context-process context) 1))))
272
273 (defun epg-wait-for-completion (context)
274   (process-send-eof (epg-context-process context))
275   (while (eq (process-status (epg-context-process context)) 'run)
276     ;; We can't use accept-process-output instead of sit-for here
277     ;; because it may cause an interrupt during the sentinel execution.
278     (sit-for 0.1)))
279
280 (defun epg-reset (context)
281   (if (and (epg-context-process context)
282            (buffer-live-p (process-buffer (epg-context-process context))))
283       (kill-buffer (process-buffer (epg-context-process context))))
284   (epg-context-set-process context nil)
285   (if (file-exists-p (epg-context-output-file context))
286       (delete-file (epg-context-output-file context)))
287   (aset context 9 nil))
288
289 (defun epg-status-USERID_HINT (process string)
290   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
291       (let* ((key-id (match-string 1 string))
292              (user-id (match-string 2 string))
293              (entry (assoc key-id epg-user-id-alist)))
294         (if entry
295             (setcdr entry user-id)
296           (setq epg-user-id-alist (cons (cons key-id user-id)
297                                         epg-user-id-alist))))))
298
299 (defun epg-status-NEED_PASSPHRASE (process string)
300   (if (string-match "\\`\\([^ ]+\\)" string)
301       (setq epg-key-id (match-string 1 string))))
302
303 (defun epg-status-NEED_PASSPHRASE_SYM (process string)
304   (setq epg-key-id 'SYM))
305
306 (defun epg-status-NEED_PASSPHRASE_PIN (process string)
307   (setq epg-key-id 'PIN))
308
309 (defun epg-status-GET_HIDDEN (process string)
310   (let ((passphrase (funcall
311                      (car (epg-context-passphrase-callback epg-context))
312                      epg-key-id
313                      (cdr (epg-context-passphrase-callback epg-context)))))
314     (unwind-protect
315         (if passphrase
316             (process-send-string process (concat passphrase "\n")))
317       (fillarray passphrase 0))))
318
319 (defun epg-status-GOODSIG (process string)
320   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
321       (epg-context-set-result
322        epg-context
323        'verify
324        (cons (epg-make-signature 'good
325                                  (match-string 1 string)
326                                  (match-string 2 string))
327              (epg-context-result epg-context 'verify)))))
328
329 (defun epg-status-EXPSIG (process string)
330   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
331       (epg-context-set-result
332        epg-context
333        'verify
334        (cons (epg-make-signature 'expired
335                                  (match-string 1 string)
336                                  (match-string 2 string))
337              (epg-context-result epg-context 'verify)))))
338
339 (defun epg-status-EXPKEYSIG (process string)
340   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
341       (epg-context-set-result
342        epg-context
343        'verify
344        (cons (epg-make-signature 'expired-key
345                                  (match-string 1 string)
346                                  (match-string 2 string))
347              (epg-context-result epg-context 'verify)))))
348
349 (defun epg-status-REVKEYSIG (process string)
350   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
351       (epg-context-set-result
352        epg-context
353        'verify
354        (cons (epg-make-signature 'revoked-key
355                                  (match-string 1 string)
356                                  (match-string 2 string))
357              (epg-context-result epg-context 'verify)))))
358
359 (defun epg-status-BADSIG (process string)
360   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
361       (epg-context-set-result
362        epg-context
363        'verify
364        (cons (epg-make-signature 'bad
365                                  (match-string 1 string)
366                                  (match-string 2 string))
367              (epg-context-result epg-context 'verify)))))
368
369 (defun epg-status-TRUST_UNDEFINED (process string)
370   (let ((signature (car (epg-context-result epg-context 'verify))))
371     (if (and signature
372              (eq (epg-signature-status signature) 'good))
373         (epg-signature-set-validity signature 'unknown))))
374
375 (defun epg-status-TRUST_NEVER (process string)
376   (let ((signature (car (epg-context-result epg-context 'verify))))
377     (if (and signature
378              (eq (epg-signature-status signature) 'good))
379         (epg-signature-set-validity signature 'never))))
380
381 (defun epg-status-TRUST_MARGINAL (process string)
382   (let ((signature (car (epg-context-result epg-context 'verify))))
383     (if (and signature
384              (eq (epg-signature-status signature) 'marginal))
385         (epg-signature-set-validity signature 'marginal))))
386
387 (defun epg-status-TRUST_FULLY (process string)
388   (let ((signature (car (epg-context-result epg-context 'verify))))
389     (if (and signature
390              (eq (epg-signature-status signature) 'good))
391         (epg-signature-set-validity signature 'full))))
392
393 (defun epg-status-TRUST_ULTIMATE (process string)
394   (let ((signature (car (epg-context-result epg-context 'verify))))
395     (if (and signature
396              (eq (epg-signature-status signature) 'good))
397         (epg-signature-set-validity signature 'full))))
398
399 (defun epg-status-DECRYPTION_FAILED (process string)
400   (epg-context-set-result epg-context 'decrypt 'failed))
401
402 (defun epg-status-PROGRESS (process string)
403   (if (string-match "\\`\\([^ ]+\\) \\([^ ]\\) \\([0-9]+\\) \\([0-9]+\\)"
404                     string)
405       (funcall (car (epg-context-progress-callback epg-context))
406                (match-string 1 string)
407                (match-string 2 string)
408                (string-to-number (match-string 3 string))
409                (string-to-number (match-string 4 string)))))
410
411 (defun epg-passphrase-callback (key-id handback)
412   (read-passwd
413    (if (eq key-id 'SYM)
414        "GnuPG passphrase for symmetric encryption: "
415      (if (eq key-id 'PIN)
416          "GnuPG passphrase for PIN: "
417        (format "GnuPG passphrase for %s: "
418                (let ((entry (assoc key-id epg-user-id-alist)))
419                  (if entry
420                      (cdr entry)
421                    key-id)))))))
422
423 (defun epg-progress-callback (what char current total handback)
424   (message "%s: %d%%/%d%%" what current total))
425
426 (defun epg-list-keys (name &optional secret)
427   "List keys associated with STRING."
428   (let ((args (list "--with-colons" "--no-greeting" "--batch"
429                     "--fixed-list-mode"
430                     (if secret "--list-secret-keys" "--list-keys")
431                     name))
432         keys type symbol pointer)
433     (with-temp-buffer
434       (apply #'call-process epg-gpg-program nil (list t nil) nil args)
435       (goto-char (point-min))
436       (while (looking-at "\\([a-z][a-z][a-z]\\):\\(.*\\)")
437         (setq type (match-string 1)
438               symbol (intern-soft (format "epg-colons-%s-spec" type)))
439         (if (member type '("pub" "sec"))
440             (setq keys (cons nil keys)))
441         (if (and symbol
442                  (boundp symbol))
443             (setcar keys (cons (cons (intern type)
444                                      (epg-parse-colons
445                                       (symbol-value symbol)
446                                       (match-string 2)))
447                                (car keys))))
448         (forward-line)))
449     (setq pointer keys)
450     (while pointer
451       (setcar pointer (nreverse (car pointer)))
452       (setq pointer (cdr pointer)))
453     (nreverse keys)))
454
455 (defun epg-parse-colons (alist string)
456   (let ((index 0)
457         result)
458     (while (and alist
459                 (or (null (car alist))
460                     (eq index
461                         (string-match
462                          (concat "\\(" (nth 1 (car alist)) "\\)?:")
463                          string index))))
464       (if (car alist)
465           (progn
466             (setq index (match-end 0))
467             (if (match-beginning 1)
468                 (setq result
469                       (cons (cons (car (car alist))
470                                   (funcall (or (nth 3 (car alist)) #'identity)
471                                            (match-string
472                                             (1+ (or (nth 2 (car alist)) 0))
473                                             string)))
474                             result))))
475         (setq index (1+ index)))
476       (setq alist (cdr alist)))
477     (nreverse result)))
478
479 ;;;###autoload
480 (defun epg-decrypt-start (context input-file)
481   "Initiate a decrypt operation."
482   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
483   (epg-start context
484              (list "--decrypt" input-file))
485   (epg-wait-for-status context '("BEGIN_DECRYPTION")))
486
487 ;;;###autoload
488 (defun epg-decrypt-string (context string)
489   "Decrypt STRING."
490   (let ((input-file (epg-make-temp-file "epg-input"))
491         (coding-system-for-write 'binary))
492     (unwind-protect
493         (progn
494           (write-region string nil input-file)
495           (epg-decrypt-start context input-file)
496           (epg-wait-for-completion context)
497           (unless (epg-context-result context 'decrypt)
498             (epg-read-output context)))
499       (epg-reset context)
500       (if (file-exists-p input-file)
501           (delete-file input-file)))))
502
503 ;;;###autoload
504 (defun epg-verify-start (context signature &optional string)
505   "Initiate a verify operation."
506   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
507   (if string
508       ;; Detached signature.
509       (progn
510         (epg-start context
511                    (append (list "--verify")
512                            (list signature "-")))
513         (if (eq (process-status (epg-context-process context)) 'run)
514             (process-send-string (epg-context-process context) string)))
515     ;; Normal (or cleartext) signature.
516     (epg-start context
517                (list "--verify"))
518     (if (eq (process-status (epg-context-process context)) 'run)
519         (process-send-string (epg-context-process context) signature))))
520
521 ;;;###autoload
522 (defun epg-verify-string (context signature &optional string)
523   "Verify SIGNATURE."
524   (let ((input-file (epg-make-temp-file "epg-input"))
525         (coding-system-for-write 'binary))
526     (unwind-protect
527         (progn
528           (if string
529               (write-region signature nil input-file))
530           (epg-verify-start context input-file string)
531           (epg-wait-for-completion context)
532           (epg-context-result context 'verify))
533       (epg-reset context)
534       (if (file-exists-p input-file)
535           (delete-file input-file)))))
536
537 ;;;###autoload
538 (defun epg-sign-start (context string &optional mode)
539   "Initiate a sign operation."
540   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
541   (epg-start context
542              (append (list (if (null mode)
543                                "--sign"
544                              (if (or (eq mode t) (eq mode 'detached))
545                                  "--detach-sign"
546                                "--clearsign")))
547                      (apply #'nconc
548                             (mapcar (lambda (signer)
549                                       (list "-u" signer))
550                                     (epg-context-signers context)))))
551   (epg-wait-for-status context '("BEGIN_SIGNING"))
552   (if (eq (process-status (epg-context-process context)) 'run)
553       (process-send-string (epg-context-process context) string)))
554
555 ;;;###autoload
556 (defun epg-sign-string (context string &optional mode)
557   "Sign STRING."
558   (unwind-protect
559       (progn
560         (epg-sign-start context string mode)
561         (epg-wait-for-completion context)
562         (epg-read-output context))
563     (epg-reset context)))
564
565 ;;;###autoload
566 (defun epg-encrypt-start (context string recipients
567                                   &optional always-trust sign)
568   "Initiate a encrypt operation."
569   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
570   (epg-start context
571              (append (if always-trust '("--always-trust"))
572                      (if recipients '("--encrypt") '("--symmetric"))
573                      (if sign
574                          (cons "--sign"
575                                (apply #'nconc
576                                       (mapcar (lambda (signer)
577                                                 (list "-u" signer))
578                                               (epg-context-signers context)))))
579                      (apply #'nconc
580                             (mapcar (lambda (recipient)
581                                       (list "-r" recipient))
582                                     recipients))))
583   (if sign
584       (epg-wait-for-status context '("BEGIN_SIGNING")))
585   (if (eq (process-status (epg-context-process context)) 'run)
586       (process-send-string (epg-context-process context) string)))
587
588 ;;;###autoload
589 (defun epg-encrypt-string (context string recipients
590                                    &optional always-trust sign)
591   "Encrypt STRING."
592   (unwind-protect
593       (progn
594         (epg-encrypt-start context string recipients always-trust sign)
595         (epg-wait-for-completion context)
596         (epg-read-output context))
597     (epg-reset context)))
598
599 (provide 'epg)
600
601 ;;; epg.el ends here