From: Daiki Ueno <ueno@unixuser.org>
Subject: Re: EasyPG support for mml2015.el
Date: Mon, 10 Jul 2006 18:04:45 +0900 [thread overview]
Message-ID: <717683f1-48a8-4e2f-8ad4-0b4127172417@well-done.deisui.org> (raw)
In-Reply-To: <0a485279-4c9d-4249-bb88-c2fbf73c6171@well-done.deisui.org> (Daiki Ueno's message of "Mon, 10 Jul 2006 12:54:57 +0900")
[-- Attachment #1: Type: text/plain, Size: 326 bytes --]
>>>>> In <0a485279-4c9d-4249-bb88-c2fbf73c6171@well-done.deisui.org>
>>>>> Daiki Ueno <ueno@unixuser.org> wrote:
> 2 weeks ago, we had CodeFest Akihabara 2006 (a 24-hour hacking marathon
> in Japan). There I wrote a patch which allows to use EasyPG directly
> from Gnus.
I just wrote a patch to mml1991.el attached below.
[-- Attachment #2: mml-epg.el.diff --]
[-- Type: application/octet-stream, Size: 18380 bytes --]
Index: lisp/mml1991.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/mml1991.el,v
retrieving revision 7.10
diff -u -r7.10 mml1991.el
--- lisp/mml1991.el 27 Apr 2006 07:00:49 -0000 7.10
+++ lisp/mml1991.el 10 Jul 2006 09:00:59 -0000
@@ -46,9 +46,22 @@
(gpg mml1991-gpg-sign
mml1991-gpg-encrypt)
(pgg mml1991-pgg-sign
- mml1991-pgg-encrypt))
+ mml1991-pgg-encrypt)
+ (epg mml1991-epg-sign
+ mml1991-epg-encrypt))
"Alist of PGP functions.")
+(defvar mml1991-verbose nil
+ "If non-nil, ask the user about the current operation more verbosely.")
+
+(defvar mml1991-cache-passphrase t
+ "If t, cache passphrase.")
+
+(defvar mml1991-passphrase-cache-expiry 16
+ "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`mml1991-cache-passphrase'.")
+
;;; mailcrypt wrapper
(eval-and-compile
@@ -288,6 +301,146 @@
(delete-region (point-min) (point-max))
(insert "\n")
(insert-buffer-substring pgg-output-buffer)
+ t)
+
+;; epg wrapper
+
+(eval-and-compile
+ (autoload 'epg-make-context "epg"))
+
+(eval-when-compile
+ (defvar epg-user-id-alist)
+ (autoload 'epg-passphrase-callback-function "epg")
+ (autoload 'epa-select-keys "epa")
+ (autoload 'epg-list-keys "epg")
+
+ (autoload 'epg-context-set-armor "epg")
+ (autoload 'epg-context-set-textmode "epg")
+
+ (autoload 'epg-context-set-signers "epg")
+ (autoload 'epg-context-set-passphrase-callback "epg")
+
+ (autoload 'epg-sign-string "epg")
+ (autoload 'epg-encrypt-string "epg"))
+
+(defvar mml1991-epg-secret-key-id-list nil)
+
+(defun mml1991-epg-passphrase-callback (context key-id ignore)
+ (if (eq key-id 'SYM)
+ (epg-passphrase-callback-function context key-id nil)
+ (let* ((entry (assoc key-id epg-user-id-alist))
+ (passphrase
+ (password-read
+ (format "GnuPG passphrase for %s: "
+ (if entry
+ (cdr entry)
+ key-id))
+ (if (eq key-id 'PIN)
+ "PIN"
+ key-id))))
+ (when passphrase
+ (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
+ (password-cache-add key-id passphrase))
+ (setq mml1991-epg-secret-key-id-list
+ (cons key-id mml1991-epg-secret-key-id-list))
+ (copy-sequence passphrase)))))
+
+(defun mml1991-epg-sign (cont)
+ (let ((context (epg-make-context))
+ headers cte signers signature)
+ (if mml1991-verbose
+ (setq signers (epa-select-keys context "Select keys for signing.
+If no one is selected, default secret key is used. "
+ nil t))
+ (setq signers (list (car (epg-list-keys
+ context
+ (message-options-get 'mml-sender) t)))))
+ (epg-context-set-armor context t)
+ (epg-context-set-textmode context t)
+ (epg-context-set-signers context signers)
+ (epg-context-set-passphrase-callback
+ context
+ #'mml1991-epg-passphrase-callback)
+ ;; Don't sign headers.
+ (goto-char (point-min))
+ (when (re-search-forward "^$" nil t)
+ (setq headers (buffer-substring (point-min) (point)))
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (setq cte (mail-fetch-field "content-transfer-encoding")))
+ (forward-line 1)
+ (delete-region (point-min) (point))
+ (when cte
+ (setq cte (intern (downcase cte)))
+ (mm-decode-content-transfer-encoding cte)))
+ (condition-case error
+ (setq signature (epg-sign-string context (buffer-string) 'clear)
+ mml1991-epg-secret-key-id-list nil)
+ (error
+ (while mml1991-epg-secret-key-id-list
+ (password-cache-remove (car mml1991-epg-secret-key-id-list))
+ (setq mml1991-epg-secret-key-id-list
+ (cdr mml1991-epg-secret-key-id-list)))
+ (signal (car error) (cdr error))))
+ (delete-region (point-min) (point-max))
+ (mm-with-unibyte-current-buffer
+ (insert signature)
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (when cte
+ (mm-encode-content-transfer-encoding cte))
+ (goto-char (point-min))
+ (when headers
+ (insert headers))
+ (insert "\n"))
+ t))
+
+(defun mml1991-epg-encrypt (cont &optional sign)
+ (goto-char (point-min))
+ (when (re-search-forward "^$" nil t)
+ (let ((cte (save-restriction
+ (narrow-to-region (point-min) (point))
+ (mail-fetch-field "content-transfer-encoding"))))
+ ;; Strip MIME headers since it will be ASCII armoured.
+ (forward-line 1)
+ (delete-region (point-min) (point))
+ (when cte
+ (mm-decode-content-transfer-encoding (intern (downcase cte))))))
+ (let ((context (epg-make-context))
+ recipients cipher)
+ (if (or mml1991-verbose
+ (null (message-options-get 'message-recipients)))
+ (setq recipients
+ (epa-select-keys context "Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed. "
+ (if (message-options-get 'message-recipients)
+ (split-string
+ (message-options-get 'message-recipients)
+ "[ \f\t\n\r\v,]+"))))
+ (setq recipients
+ (mapcar (lambda (name)
+ (car (epg-list-keys context name)))
+ (split-string
+ (message-options-get 'message-recipients)
+ "[ \f\t\n\r\v,]+"))))
+ (epg-context-set-armor context t)
+ (epg-context-set-textmode context t)
+ (epg-context-set-passphrase-callback
+ context
+ #'mml1991-epg-passphrase-callback)
+ (condition-case error
+ (setq cipher
+ (epg-encrypt-string context (buffer-string) recipients sign)
+ mml1991-epg-secret-key-id-list nil)
+ (error
+ (while mml1991-epg-secret-key-id-list
+ (password-cache-remove (car mml1991-epg-secret-key-id-list))
+ (setq mml1991-epg-secret-key-id-list
+ (cdr mml1991-epg-secret-key-id-list)))
+ (signal (car error) (cdr error))))
+ (delete-region (point-min) (point-max))
+ (insert "\n" cipher))
t)
;;;###autoload
Index: lisp/mml2015.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/mml2015.el,v
retrieving revision 7.15
diff -u -r7.15 mml2015.el
--- lisp/mml2015.el 28 Apr 2006 05:17:40 -0000 7.15
+++ lisp/mml2015.el 10 Jul 2006 09:01:00 -0000
@@ -34,6 +34,7 @@
(require 'mm-decode)
(require 'mm-util)
(require 'mml)
+(require 'password)
(defvar mc-pgp-always-sign)
@@ -79,7 +80,13 @@
mml2015-pgg-verify
mml2015-pgg-decrypt
mml2015-pgg-clear-verify
- mml2015-pgg-clear-decrypt))
+ mml2015-pgg-clear-decrypt)
+ (epg mml2015-epg-sign
+ mml2015-epg-encrypt
+ mml2015-epg-verify
+ mml2015-epg-decrypt
+ mml2015-epg-clear-verify
+ mml2015-epg-clear-decrypt))
"Alist of PGP/MIME functions.")
(defvar mml2015-result-buffer nil)
@@ -96,6 +103,23 @@
:type '(repeat (cons (regexp :tag "GnuPG output regexp")
(boolean :tag "Trust key"))))
+(defcustom mml2015-verbose nil
+ "If non-nil, ask the user about the current operation more verbosely."
+ :group 'mime-security
+ :type 'boolean)
+
+(defcustom mml2015-cache-passphrase t
+ "If t, cache passphrase."
+ :group 'mime-security
+ :type 'boolean)
+
+(defcustom mml2015-passphrase-cache-expiry 16
+ "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`mml2015-cache-passphrase'."
+ :group 'mime-security
+ :type 'integer)
+
;;; mailcrypt wrapper
(eval-and-compile
@@ -871,6 +895,296 @@
(insert (format "--%s\n" boundary))
(insert "Content-Type: application/octet-stream\n\n")
(insert-buffer-substring pgg-output-buffer)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+;;; epg wrapper
+
+(eval-and-compile
+ (autoload 'epg-make-context "epg"))
+
+(eval-when-compile
+ (defvar epg-user-id-alist)
+ (defvar epg-digest-algorithm-alist)
+ (defvar inhibit-redisplay)
+ (autoload 'epg-context-set-armor "epg")
+ (autoload 'epg-context-set-textmode "epg")
+ (autoload 'epg-context-set-signers "epg")
+ (autoload 'epg-context-result-for "epg")
+ (autoload 'epg-new-signature-digest-algorithm "epg")
+ (autoload 'epg-verify-result-to-string "epg")
+ (autoload 'epg-list-keys "epg")
+ (autoload 'epg-decrypt-string "epg")
+ (autoload 'epg-verify-string "epg")
+ (autoload 'epg-sign-string "epg")
+ (autoload 'epg-encrypt-string "epg")
+ (autoload 'epg-passphrase-callback-function "epg")
+ (autoload 'epg-context-set-passphrase-callback "epg")
+ (autoload 'epa-select-keys "epa"))
+
+(defvar mml2015-epg-secret-key-id-list nil)
+
+(defun mml2015-epg-passphrase-callback (context key-id ignore)
+ (if (eq key-id 'SYM)
+ (epg-passphrase-callback-function context key-id nil)
+ (let* ((entry (assoc key-id epg-user-id-alist))
+ (passphrase
+ (password-read
+ (format "GnuPG passphrase for %s: "
+ (if entry
+ (cdr entry)
+ key-id))
+ (if (eq key-id 'PIN)
+ "PIN"
+ key-id))))
+ (when passphrase
+ (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
+ (password-cache-add key-id passphrase))
+ (setq mml2015-epg-secret-key-id-list
+ (cons key-id mml2015-epg-secret-key-id-list))
+ (copy-sequence passphrase)))))
+
+(defun mml2015-epg-decrypt (handle ctl)
+ (catch 'error
+ (let ((inhibit-redisplay t)
+ context plain child handles result decrypt-status)
+ (unless (setq child (mm-find-part-by-type
+ (cdr handle)
+ "application/octet-stream" nil t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (setq context (epg-make-context))
+ (epg-context-set-passphrase-callback
+ context
+ #'mml2015-epg-passphrase-callback)
+ (condition-case error
+ (setq plain (epg-decrypt-string context (mm-get-part child))
+ mml2015-epg-secret-key-id-list nil)
+ (error
+ (while mml2015-epg-secret-key-id-list
+ (password-cache-remove (car mml2015-epg-secret-key-id-list))
+ (setq mml2015-epg-secret-key-id-list
+ (cdr mml2015-epg-secret-key-id-list)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (if (eq (car error) 'quit)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error error)))
+ (throw 'error handle)))
+ (with-temp-buffer
+ (insert plain)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (setq handles (mm-dissect-buffer t))
+ (mm-destroy-parts handle)
+ (if (epg-context-result-for context 'verify)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (concat "OK\n"
+ (epg-verify-result-to-string
+ (epg-context-result-for context 'verify))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK"))
+ (if (stringp (car handles))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
+ (if (listp (car handles))
+ handles
+ (list handles)))))
+
+(defun mml2015-epg-clear-decrypt ()
+ (let ((inhibit-redisplay t)
+ (context (epg-make-context))
+ plain)
+ (epg-context-set-passphrase-callback
+ context
+ #'mml2015-epg-passphrase-callback)
+ (condition-case error
+ (setq plain (epg-decrypt-string context (buffer-string))
+ mml2015-epg-secret-key-id-list nil)
+ (error
+ (while mml2015-epg-secret-key-id-list
+ (password-cache-remove (car mml2015-epg-secret-key-id-list))
+ (setq mml2015-epg-secret-key-id-list
+ (cdr mml2015-epg-secret-key-id-list)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (if (eq (car error) 'quit)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error error)))))
+ (when plain
+ (erase-buffer)
+ ;; Treat data which epg returns as a unibyte string.
+ (mm-disable-multibyte)
+ (insert plain)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (if (epg-context-result-for context 'verify)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (concat "OK\n"
+ (epg-verify-result-to-string
+ (epg-context-result-for context 'verify))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")))))
+
+(defun mml2015-epg-verify (handle ctl)
+ (catch 'error
+ (let ((inhibit-redisplay t)
+ context plain signature-file part signature)
+ (when (or (null (setq part (mm-find-raw-part-by-type
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
+ "application/pgp-signature")
+ t)))
+ (null (setq signature (mm-find-part-by-type
+ (cdr handle) "application/pgp-signature"
+ nil t))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (setq context (epg-make-context))
+ (condition-case error
+ (setq plain (epg-verify-string context (mm-get-part signature) part))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (if (eq (car error) 'quit)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error error)))
+ (throw 'error handle)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (epg-verify-result-to-string (epg-context-result-for context 'verify)))
+ handle)))
+
+(defun mml2015-epg-clear-verify ()
+ (let ((inhibit-redisplay t)
+ (context (epg-make-context))
+ (signature (encode-coding-string (buffer-string)
+ buffer-file-coding-system))
+ plain)
+ (condition-case error
+ (setq plain (epg-verify-string context signature))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (if (eq (car error) 'quit)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error error)))))
+ (if plain
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (epg-verify-result-to-string
+ (epg-context-result-for context 'verify))))))
+
+(defun mml2015-epg-sign (cont)
+ (let ((inhibit-redisplay t)
+ (context (epg-make-context))
+ (boundary (mml-compute-boundary cont))
+ signers signature micalg)
+ (if mml2015-verbose
+ (setq signers (epa-select-keys context "Select keys for signing.
+If no one is selected, default secret key is used. "
+ nil t))
+ (setq signers (list (car (epg-list-keys
+ context
+ (message-options-get 'mml-sender) t)))))
+ (epg-context-set-armor context t)
+ (epg-context-set-textmode context t)
+ (epg-context-set-signers context signers)
+ (epg-context-set-passphrase-callback
+ context
+ #'mml2015-epg-passphrase-callback)
+ (condition-case error
+ (setq signature (epg-sign-string context (buffer-string) t)
+ mml2015-epg-secret-key-id-list nil)
+ (error
+ (while mml2015-epg-secret-key-id-list
+ (password-cache-remove (car mml2015-epg-secret-key-id-list))
+ (setq mml2015-epg-secret-key-id-list
+ (cdr mml2015-epg-secret-key-id-list)))
+ (signal (car error) (cdr error))))
+ (if (epg-context-result-for context 'sign)
+ (setq micalg (epg-new-signature-digest-algorithm
+ (car (epg-context-result-for context 'sign)))))
+ (goto-char (point-min))
+ (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+ boundary))
+ (if micalg
+ (insert (format "\tmicalg=%s; "
+ (downcase
+ (cdr (assq micalg
+ epg-digest-algorithm-alist))))))
+ (insert "protocol=\"application/pgp-signature\"\n")
+ (insert (format "\n--%s\n" boundary))
+ (goto-char (point-max))
+ (insert (format "\n--%s\n" boundary))
+ (insert "Content-Type: application/pgp-signature\n\n")
+ (insert signature)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+(defun mml2015-epg-encrypt (cont &optional sign)
+ (let ((inhibit-redisplay t)
+ (context (epg-make-context))
+ recipients cipher
+ (boundary (mml-compute-boundary cont)))
+ (if (or mml2015-verbose
+ (null (message-options-get 'message-recipients)))
+ (setq recipients
+ (epa-select-keys context "Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed. "
+ (if (message-options-get 'message-recipients)
+ (split-string
+ (message-options-get 'message-recipients)
+ "[ \f\t\n\r\v,]+"))))
+ (setq recipients
+ (mapcar (lambda (name)
+ (car (epg-list-keys context name)))
+ (split-string
+ (message-options-get 'message-recipients)
+ "[ \f\t\n\r\v,]+"))))
+ (epg-context-set-armor context t)
+ (epg-context-set-textmode context t)
+ (epg-context-set-passphrase-callback
+ context
+ #'mml2015-epg-passphrase-callback)
+ (condition-case error
+ (setq cipher
+ (epg-encrypt-string context (buffer-string) recipients sign)
+ mml2015-epg-secret-key-id-list nil)
+ (error
+ (while mml2015-epg-secret-key-id-list
+ (password-cache-remove (car mml2015-epg-secret-key-id-list))
+ (setq mml2015-epg-secret-key-id-list
+ (cdr mml2015-epg-secret-key-id-list)))
+ (signal (car error) (cdr error))))
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
+ boundary))
+ (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/pgp-encrypted\n\n")
+ (insert "Version: 1\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/octet-stream\n\n")
+ (insert cipher)
(goto-char (point-max))
(insert (format "--%s--\n" boundary))
(goto-char (point-max))))
[-- Attachment #3: Type: text/plain, Size: 25 bytes --]
Regards,
--
Daiki Ueno
next prev parent reply other threads:[~2006-07-10 9:04 UTC|newest]
Thread overview: 12+ messages / expand[flat|nested] mbox.gz Atom feed top
2006-07-10 3:54 Daiki Ueno
2006-07-10 9:04 ` Daiki Ueno [this message]
2006-07-10 10:08 ` Simon Josefsson
2006-07-10 10:36 ` Daiki Ueno
2006-07-10 10:53 ` Simon Josefsson
2006-07-11 8:28 ` Daiki Ueno
2006-07-25 5:23 ` Daiki Ueno
2006-07-10 10:03 ` Simon Josefsson
2006-07-12 7:38 ` EasyPG hangs Max Froumentin
2006-07-12 8:16 ` Daiki Ueno
2006-07-12 9:16 ` Max Froumentin
2006-07-13 4:02 ` Daiki Ueno
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=717683f1-48a8-4e2f-8ad4-0b4127172417@well-done.deisui.org \
--to=ueno@unixuser.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for NNTP newsgroup(s).