From mboxrd@z Thu Jan 1 00:00:00 1970 X-Msuck: nntp://news.gmane.io/gmane.emacs.gnus.general/63456 Path: news.gmane.org!not-for-mail From: Daiki Ueno Newsgroups: gmane.emacs.gnus.general Subject: Re: EasyPG support for mml2015.el Date: Mon, 10 Jul 2006 18:04:45 +0900 Message-ID: <717683f1-48a8-4e2f-8ad4-0b4127172417@well-done.deisui.org> References: <0a485279-4c9d-4249-bb88-c2fbf73c6171@well-done.deisui.org> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="Multipart_Mon_Jul_10_18:04:45_2006-1" X-Trace: sea.gmane.org 1152522598 7471 80.91.229.2 (10 Jul 2006 09:09:58 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Mon, 10 Jul 2006 09:09:58 +0000 (UTC) Original-X-From: ding-owner+m11983@lists.math.uh.edu Mon Jul 10 11:09:57 2006 Return-path: Envelope-to: ding-account@gmane.org Original-Received: from malifon.math.uh.edu ([129.7.128.13]) by ciao.gmane.org with esmtp (Exim 4.43) id 1Fzrlu-0000Qt-Gu for ding-account@gmane.org; Mon, 10 Jul 2006 11:09:44 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.math.uh.edu ident=lists) by malifon.math.uh.edu with smtp (Exim 3.20 #1) id 1Fzrle-0003Xd-00; Mon, 10 Jul 2006 04:09:26 -0500 Original-Received: from nas01.math.uh.edu ([129.7.128.39]) by malifon.math.uh.edu with esmtp (Exim 3.20 #1) id 1FzrhN-0003XY-00 for ding@lists.math.uh.edu; Mon, 10 Jul 2006 04:05:01 -0500 Original-Received: from quimby.gnus.org ([80.91.224.244]) by nas01.math.uh.edu with esmtp (Exim 4.52) id 1FzrhL-0001zx-JK for ding@lists.math.uh.edu; Mon, 10 Jul 2006 04:05:01 -0500 Original-Received: from g96069.scn-net.ne.jp ([210.231.96.69] helo=well-done.deisui.org) by quimby.gnus.org with esmtp (Exim 3.35 #1 (Debian)) id 1FzrhF-0005t6-00 for ; Mon, 10 Jul 2006 11:04:53 +0200 Original-Received: from [150.82.173.221] (helo=well-done.deisui.org) by well-done.deisui.org with esmtps (TLS-1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.62) (envelope-from ) id 1Fzrf7-0001rV-84 for ding@gnus.org; Mon, 10 Jul 2006 18:02:42 +0900 Original-To: ding@gnus.org X-Attribution: DU 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") User-Agent: T-gnus/6.17.2 (based on No Gnus v0.2) EMIKO/1.14.1 (Choanoflagellata) FLIM/1.14.7 (=?ISO-8859-4?Q?Sanj=F2?=) APEL/10.6 EasyPG/0.0.3 MULE XEmacs/21.4 (patch 17) (Jumbo Shrimp) (i686-pc-linux) X-Spam-Score: -2.0 (--) Precedence: bulk Original-Sender: ding-owner@lists.math.uh.edu Xref: news.gmane.org gmane.emacs.gnus.general:63456 Archived-At: --Multipart_Mon_Jul_10_18:04:45_2006-1 Content-Type: text/plain; charset=US-ASCII >>>>> In <0a485279-4c9d-4249-bb88-c2fbf73c6171@well-done.deisui.org> >>>>> Daiki Ueno 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. --Multipart_Mon_Jul_10_18:04:45_2006-1 Content-Type: application/octet-stream; type=patch Content-Disposition: attachment; filename="mml-epg.el.diff" Content-Transfer-Encoding: 7bit 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)))) --Multipart_Mon_Jul_10_18:04:45_2006-1 Content-Type: text/plain; charset=US-ASCII Regards, -- Daiki Ueno --Multipart_Mon_Jul_10_18:04:45_2006-1--