Sync
authoryamaoka <yamaoka>
Sun, 28 May 2000 22:34:47 +0000 (22:34 +0000)
committeryamaoka <yamaoka>
Sun, 28 May 2000 22:34:47 +0000 (22:34 +0000)
with `t-gnus-6_14' and Gnus.

ChangeLog
contrib/rfc2015.el [new file with mode: 0644]
lisp/nnshimbun.el

index f88d85f..d4f5c32 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2000-05-28  TSUCHIYA Masatoshi  <tsuchiya@pine.kuee.kyoto-u.ac.jp>
+
+       * nnshimbun.el (nnshimbun-request-article-1): Fix to insert x-face
+       unless SERVER.
+       (nnshimbun-asahi-get-headers): Fix for subjects which contain ^M.
+
 2000-05-26  TSUCHIYA Masatoshi  <tsuchiya@pine.kuee.kyoto-u.ac.jp>
 
        * lisp/nnshimbun.el (nnshimbun-write-nov): New function.
diff --git a/contrib/rfc2015.el b/contrib/rfc2015.el
new file mode 100644 (file)
index 0000000..065d07d
--- /dev/null
@@ -0,0 +1,183 @@
+;;; rfc2015.el --- MIME Security with Pretty Good Privacy (PGP)
+;; Copyright (c) 2000 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: PGP MIME
+
+;; This file is a part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation; either version 2, or (at your
+;; option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Usage:
+;;    (rfc2015-setup)
+;; 
+;; Insert an attribute, postprocess=pgp-sign (or pgp-encrypt), into
+;; the mml tag to be signed (or encrypted).
+
+;;; Code:
+
+(defvar rfc2015-decrypt-function 'mailcrypt-decrypt)
+(defvar rfc2015-verify-function 'mailcrypt-verify)
+
+(defun rfc2015-decrypt (handle)
+  (let (child)
+    (cond 
+     ((setq child (mm-find-part-by-type (cdr handle) 
+                                       "application/octet-stream"))
+      (let (handles result)
+       (with-temp-buffer
+         (mm-insert-part child)
+         (setq result (funcall rfc2015-decrypt-function))
+         (unless (car result)
+           (error "Decrypting error."))
+         (setq handles (mm-dissect-buffer t)))
+       (setq gnus-article-mime-handles
+             (append (if (listp (car gnus-article-mime-handles))
+                         gnus-article-mime-handles
+                       (list gnus-article-mime-handles))
+                     (if (listp (car handles))
+                         handles
+                       (list handles))))
+       (gnus-mime-display-part handles)))
+     (t
+      (if (y-or-n-p "Corrupted pgp-encrypted part. Abort?" )
+         (error "Corrupted pgp-encrypted part.")
+       (gnus-mime-display-mixed (cdr handle)))))))
+
+;; FIXME: mm-dissect-buffer loses information of micalg and the
+;; original header of signed part.
+
+(defun rfc2015-verify (handle)
+  (if (y-or-n-p "Verify signed part?" )
+      (let (child result hash)
+       (with-temp-buffer
+         (unless (setq child (mm-find-part-by-type 
+                              (cdr handle) "application/pgp-signature" t))
+           (error "Corrupted pgp-signature part."))
+         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
+         (insert (format "Hash: %s\n\n" (read-string "Hash: " "SHA1")))
+         (mm-insert-part child)
+         (goto-char (point-max))
+         (unless (bolp)
+           (insert "\n"))
+         (unless (setq child (mm-find-part-by-type 
+                              (cdr handle) "application/pgp-signature"))
+           (error "Corrupted pgp-signature part."))
+         (mm-insert-part child)
+         (setq result (funcall rfc2015-verify-function))
+         (unless result
+           (error "Verify error.")))))
+  (gnus-mime-display-part 
+   (mm-find-part-by-type 
+    (cdr handle) "application/pgp-signature" t)))
+
+(defvar rfc2015-mailcrypt-prefix 0)
+
+(defun rfc2015-mailcrypt-sign (cont)
+  (mailcrypt-sign rfc2015-mailcrypt-prefix)
+  (let ((boundary 
+        (funcall mml-boundary-function (incf mml-multipart-number)))
+       (scheme-alist (funcall (or mc-default-scheme 
+                                  (cdr (car mc-schemes)))))
+       hash)
+    (goto-char (point-min))
+    (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
+      (error "Cannot find signed begin line." ))
+    (goto-char (match-beginning 0))
+    (forward-line 1)
+    (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
+      (error "Cannot not find PGP hash." ))
+    (setq hash (match-string 1))
+    (unless (re-search-forward "^$" nil t)
+      (error "Cannot not find PGP message." ))
+    (forward-line 1)
+    (delete-region (point-min) (point))
+    (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+                   boundary))
+    (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
+                   hash))
+    (insert "\n")
+    (insert (format "--%s\n" boundary))
+    (unless (re-search-forward (cdr (assq 'signed-end-line scheme-alist)))
+      (error "Cannot find signature part." ))
+    (goto-char (match-beginning 0))
+    (unless (re-search-backward "^-+BEGIN" nil t)
+      (error "Cannot find signature part." ))
+    (goto-char (match-beginning 0))
+    (insert (format "--%s\n" boundary))
+    (insert "Content-Type: application/pgp-signature\n\n")
+    (goto-char (point-max))
+    (insert (format "--%s--\n" boundary))
+    (goto-char (point-max))))
+
+(defun rfc2015-mailcrypt-encrypt (cont)
+  ;; FIXME:
+  ;; You have to input the receiptant.
+  (mailcrypt-encrypt rfc2015-mailcrypt-prefix)
+  (let ((boundary 
+        (funcall mml-boundary-function (incf mml-multipart-number))))
+    (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")
+    (goto-char (point-max))
+    (insert (format "--%s--\n" boundary))
+    (goto-char (point-max))))
+
+;; The following code might be moved into mml.el or gnus-art.el.
+
+(defvar mml-postprocess-alist
+  '(("pgp-sign" . rfc2015-mailcrypt-sign)
+    ("pgp-encrypt" . rfc2015-mailcrypt-encrypt))
+  "Alist of postprocess functions.")
+
+(defun mml-postprocess (cont)
+  (let ((pp (cdr (or (assq 'postprocess cont)
+                    (assq 'pp cont))))
+       item)
+    (if (and pp (setq item (assoc pp mml-postprocess-alist)))
+       (funcall (cdr item) cont))))
+
+(defun rfc2015-setup ()
+  (setq mml-generate-mime-postprocess-function 'mml-postprocess)
+;  (push '("multipart/signed" . rfc2015-verify)
+;      gnus-mime-multipart-functions)
+  (push '("multipart/encrypted" . rfc2015-decrypt)
+       gnus-mime-multipart-functions))
+
+;; The following code might be moved into mm-decode.el.
+
+(defun mm-find-part-by-type (handles type &optional notp) 
+  (let (handle)
+    (while handles
+      (if (if notp
+             (not (equal (mm-handle-media-type (car handles)) type))
+           (equal (mm-handle-media-type (car handles)) type))
+         (setq handle (car handles)
+               handles nil))
+      (setq handles (cdr handles)))
+    handle))
+
+(provide 'rfc2015)
+
+;;; rfc2015.el ends here
index ed60a93..71a9e8d 100644 (file)
                           (and (nnheader-find-nov-line article)
                                (nnheader-parse-nov))))
        (let* ((xref (substring (mail-header-xref header) 6))
-              (x-faces (cdr (or (assoc server nnshimbun-x-face-alist)
+              (x-faces (cdr (or (assoc (or server
+                                           (nnoo-current-server 'nnshimbun))
+                                       nnshimbun-x-face-alist)
                                 (assoc "default" nnshimbun-x-face-alist))))
               (x-face (cdr (or (assoc group x-faces)
                                (assoc "default" x-faces)))))
@@ -785,7 +787,7 @@ is enclosed by at least one regexp grouping construct."
                                (buffer-substring
                                 (match-end 0)
                                 (progn (search-forward "<br>" nil t) (point)))
-                               "<[^>]+>")
+                               "\\(<[^>]+>\\|\r\\)")
                               ""))
                   nnshimbun-from-address
                   "" id "" 0 0 (concat nnshimbun-url url))