mime-pgp.el

   1 ;;; mime-pgp.el --- mime-view internal methods for PGP.
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;;         Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
   7 ;; Created: 1995/12/7
   8 ;;      Renamed: 1997/2/27 from tm-pgp.el
   9 ;; Keywords: PGP, security, MIME, multimedia, mail, news
  10
  11 ;; This file is part of SEMI (Secure Emacs MIME Interface).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;;    This module is based on
  31
  32 ;;      [security-multipart] RFC 1847: "Security Multiparts for MIME:
  33 ;;          Multipart/Signed and Multipart/Encrypted" by
  34 ;;          Jim Galvin <galvin@tis.com>, Sandy Murphy <sandy@tis.com>,
  35 ;;          Steve Crocker <crocker@cybercash.com> and
  36 ;;          Ned Freed <ned@innosoft.com> (1995/10)
  37
  38 ;;      [PGP/MIME] RFC 2015: "MIME Security with Pretty Good Privacy
  39 ;;          (PGP)" by Michael Elkins <elkins@aero.org> (1996/6)
  40
  41 ;;      [PGP-kazu] draft-kazu-pgp-mime-00.txt: "PGP MIME Integration"
  42 ;;          by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp> (1995/10;
  43 ;;          expired)
  44
  45 ;;; Code:
  46
  47 (require 'mime-play)
  48 (require 'pgg-def)
  49 (require 'pgg-parse)
  50
  51
  52 ;;; @ Internal method for multipart/signed
  53 ;;;
  54 ;;; It is based on RFC 1847 (security-multipart).
  55
  56 (defun mime-verify-multipart/signed (entity situation)
  57   "Internal method to verify multipart/signed."
  58   (mime-play-entity
  59    (nth 1 (mime-entity-children entity)) ; entity-info of signature
  60    (list (assq 'mode situation)) ; play-mode
  61    ))
  62
  63
  64 ;;; @ internal method for application/pgp
  65 ;;;
  66 ;;; It is based on draft-kazu-pgp-mime-00.txt (PGP-kazu).
  67
  68 (defun mime-view-application/pgp (entity situation)
  69   (let* ((p-win (or (get-buffer-window (current-buffer))
  70                     (get-largest-window)))
  71          (new-name
  72           (format "%s-%s" (buffer-name) (mime-entity-number entity)))
  73          (mother (current-buffer))
  74          (preview-buffer (concat "*Preview-" (buffer-name) "*"))
  75          representation-type)
  76     (set-buffer (get-buffer-create new-name))
  77     (erase-buffer)
  78     (mime-insert-entity entity)
  79     (cond ((progn
  80              (goto-char (point-min))
  81              (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t))
  82            (funcall (pgp-function 'verify)
  83                     (point-min)(point-max))
  84            (goto-char (point-min))
  85            (delete-region
  86             (point-min)
  87             (and
  88              (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n")
  89              (match-end 0)))
  90            (delete-region
  91             (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+")
  92                  (match-beginning 0))
  93             (point-max))
  94            (goto-char (point-min))
  95            (while (re-search-forward "^- -" nil t)
  96              (replace-match "-")
  97              )
  98            (setq representation-type (if (mime-entity-cooked-p entity)
  99                                          'cooked))
 100            )
 101           ((progn
 102              (goto-char (point-min))
 103              (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t))
 104            (funcall (pgp-function 'decrypt)
 105                     (point-min)(point-max))
 106            (delete-region (point-min)(point-max))
 107            (insert-buffer pgg-output-buffer)
 108            (setq representation-type 'binary)
 109            ))
 110     (setq major-mode 'mime-show-message-mode)
 111     (save-window-excursion (mime-view-buffer nil preview-buffer mother
 112                                              nil representation-type))
 113     (set-window-buffer p-win preview-buffer)
 114     ))
 115
 116
 117 ;;; @ Internal method for application/pgp-signature
 118 ;;;
 119 ;;; It is based on RFC 2015 (PGP/MIME).
 120
 121 (defvar mime-pgp-command "pgp"
 122   "*Name of the PGP command.")
 123
 124 (defvar mime-pgp-default-language 'en
 125   "*Symbol of language for pgp.
 126 It should be ISO 639 2 letter language code such as en, ja, ...")
 127
 128 (defvar mime-pgp-good-signature-regexp-alist
 129   '((en . "Good signature from user.*$"))
 130   "Alist of language vs regexp to detect ``Good signature''.")
 131
 132 (defvar mime-pgp-key-expected-regexp-alist
 133   '((en . "Key matching expected Key ID \\(\\S +\\) not found"))
 134   "Alist of language vs regexp to detect ``Key expected''.")
 135
 136 (defun mime-pgp-check-signature (output-buffer sig-file orig-file)
 137   (save-excursion
 138     (set-buffer output-buffer)
 139     (erase-buffer))
 140   (let* ((lang (or mime-pgp-default-language 'en))
 141          (status (call-process-region (point-min)(point-max)
 142                                       mime-pgp-command
 143                                       nil output-buffer nil
 144                                       sig-file orig-file (format "+language=%s" lang)))
 145          (regexp (cdr (assq lang mime-pgp-good-signature-regexp-alist))))
 146     (if (= status 0)
 147         (save-excursion
 148           (set-buffer output-buffer)
 149           (goto-char (point-min))
 150           (message
 151            (cond ((not (stringp regexp))
 152                   "Please specify right regexp for specified language")
 153                  ((re-search-forward regexp nil t)
 154                   (buffer-substring (match-beginning 0) (match-end 0)))
 155                  (t "Bad signature")))
 156           ))))
 157
 158 (defun mime-verify-application/pgp-signature (entity situation)
 159   "Internal method to check PGP/MIME signature."
 160   (let* ((entity-node-id (mime-entity-node-id entity))
 161          (mother (mime-entity-parent entity))
 162          (knum (car entity-node-id))
 163          (onum (if (> knum 0)
 164                    (1- knum)
 165                  (1+ knum)))
 166          (orig-entity (nth onum (mime-entity-children mother)))
 167          (basename (expand-file-name "tm" temporary-file-directory))
 168          (sig-file (concat (make-temp-name basename) ".asc"))
 169          )
 170     (save-excursion (mime-show-echo-buffer))
 171     (mime-write-entity-content entity sig-file)
 172     (with-temp-buffer
 173       (mime-insert-entity orig-entity)
 174       (goto-char (point-min))
 175       (while (progn (end-of-line) (not (eobp)))
 176         (insert "\r")
 177         (forward-line 1))
 178       (let ((packet
 179              (cdr (assq 2 (pgg-parse-armor (mime-entity-content entity)))))
 180             (pgg-output-buffer mime-echo-buffer-name)
 181             key)
 182         (cond
 183          ((or (null (setq key (cdr (assq 'key-identifier packet))))
 184               (funcall (pgp-function 'lookup-key)
 185                        (setq key (concat "0x" (pgg-truncate-key-identifier key)))))
 186           (funcall (pgp-function 'verify)
 187                    (point-min)(point-max) sig-file)
 188           )
 189          ((y-or-n-p
 190            (format "Key %s not found; attempt to fetch? " key))
 191           (mime-pgp-fetch-key
 192            key (cdr (assq 'preferred-key-server packet)))
 193           ))))
 194     (delete-file sig-file)
 195     ))
 196
 197 (defun mime-display-application/pgp-signature (entity situation)
 198   (let ((packet
 199          (cdr (assq 2 (pgg-parse-armor (mime-entity-content entity)))))
 200         field)
 201     (insert
 202      "version: "
 203      (int-to-string (cdr (assq 'version packet)))
 204      "\n"
 205      "signature type: "
 206      (cdr (assq 'signature-type packet))
 207      "\n"
 208      (if (setq field (cdr (assq 'hash-algorithm packet)))
 209          (concat "hash algorithm: " (symbol-name field) "\n")
 210        "")
 211      (if (setq field (cdr (assq 'public-key-algorithm packet)))
 212          (concat "public key algorithm: " (symbol-name field) "\n")
 213        "")
 214      (if (setq field (cdr (assq 'key-identifier packet)))
 215          (concat "key identifier: " field "\n")
 216        "")
 217      (if (setq field (cdr (assq 'creation-time packet)))
 218          (concat "creation time: " (current-time-string field) "\n")
 219        "")
 220      (if (setq field (cdr (assq 'signature-expiry packet)))
 221          (concat "signature exipiration time: "
 222                  (current-time-string field) "\n")
 223        "")
 224      (if (setq field (cdr (assq 'key-expiry packet)))
 225          (concat "key exipiration time: " (current-time-string field) "\n")
 226        "")
 227      (if (setq field (cdr (assq 'trust-level packet)))
 228          (concat "trust level: " (int-to-string field) "\n")
 229        "")
 230      (if (setq field (cdr (assq 'preferred-symmetric-key-algorithm packet)))
 231          (concat "preferred symmetric algorithm: "
 232                  (symbol-name field) "\n")
 233        "")
 234      (if (setq field (cdr (assq 'preferred-hash-algorithm packet)))
 235          (concat "preferred hash algorithm: "
 236                  (symbol-name field) "\n")
 237        "")
 238      (if (setq field (cdr (assq 'exportability packet)))
 239          (concat "signature exportable: "
 240                  (if (< 0 field) "yes" "no") "\n")
 241        "")
 242      (if (setq field (cdr (assq 'revocability packet)))
 243          (concat "signature revocable: "
 244                  (if (< 0 field) "yes" "no") "\n")
 245        "")
 246      (if (setq field (cdr (assq 'policy-url packet)))
 247          (concat "policy URL: " field "\n")
 248        "")
 249      (if (setq field
 250                (delq nil (mapcar
 251                           (function (lambda (nn)
 252                                       (and (eq (car nn) 'notation) nn)))
 253                           packet)))
 254          (concat "notations:\n"
 255                  (mapconcat (lambda (nn)
 256                               (concat " " (cadr nn) ": " (cddr nn)))
 257                             field "\n")
 258                  "\n")
 259        ""))
 260     (mime-add-url-buttons)
 261     (run-hooks 'mime-display-application/pgp-signature-hook)
 262     ))
 263
 264
 265 ;;; @ Internal method for application/pgp-encrypted
 266 ;;;
 267 ;;; It is based on RFC 2015 (PGP/MIME).
 268
 269 (defun mime-decrypt-application/pgp-encrypted (entity situation)
 270   (let* ((entity-node-id (mime-entity-node-id entity))
 271          (mother (mime-entity-parent entity))
 272          (knum (car entity-node-id))
 273          (onum (if (> knum 0)
 274                    (1- knum)
 275                  (1+ knum)))
 276          (orig-entity (nth onum (mime-entity-children mother))))
 277     (mime-view-application/pgp orig-entity situation)
 278     ))
 279
 280 (defun mime-display-application/pgp-encrypted (entity situation)
 281   (let* ((entity-node-id (mime-entity-node-id entity))
 282          (mother (mime-entity-parent entity))
 283          (knum (car entity-node-id))
 284          (onum (if (> knum 0)
 285                    (1- knum)
 286                  (1+ knum)))
 287          (orig-entity (nth onum (mime-entity-children mother)))
 288          (packet (cdr (assq 1 (pgg-parse-armor
 289                                (mime-entity-content orig-entity))))))
 290     (insert
 291      "version: "
 292      (int-to-string (cdr (assq 'version packet)))
 293      "\n"
 294      "public key identifier: "
 295      (cdr (assq 'key-identifier packet))
 296      "\n"
 297      "public key algorithm: "
 298      (symbol-name (cdr (assq 'public-key-algorithm packet)))
 299      "\n\n")
 300     (run-hooks 'mime-display-application/pgp-encrypted-hook)
 301     ))
 302
 303 ;;; @ Internal method for application/pgp-keys
 304 ;;;
 305 ;;; It is based on RFC 2015 (PGP/MIME).
 306
 307 (defun mime-add-application/pgp-keys (entity situation)
 308   (let* ((start (mime-entity-header-start-point entity))
 309          (end (mime-entity-body-end-point entity))
 310          (entity-number (mime-entity-number entity))
 311          (new-name (format "%s-%s" (buffer-name) entity-number))
 312          (encoding (cdr (assq 'encoding situation)))
 313          str)
 314     (setq str (buffer-substring start end))
 315     (switch-to-buffer new-name)
 316     (setq buffer-read-only nil)
 317     (erase-buffer)
 318     (insert str)
 319     (goto-char (point-min))
 320     (if (re-search-forward "^\n" nil t)
 321         (delete-region (point-min) (match-end 0))
 322       )
 323     (mime-decode-region (point-min)(point-max) encoding)
 324     (funcall (pgp-function 'snarf-keys)
 325              (point-min)(point-max))
 326     (kill-buffer (current-buffer))
 327     ))
 328
 329 (defun mime-display-application/pgp-keys (entity situation)
 330   (let ((packet
 331          (cdr (assq 6 (pgg-parse-armor (mime-entity-content entity)))))
 332         field)
 333     (insert
 334      "version: "
 335      (int-to-string (cdr (assq 'version packet)))
 336      "\n"
 337      "creation time: "
 338      (current-time-string (cdr (assq 'creation-time packet)))
 339      "\n"
 340      "public key algorithm: "
 341      (symbol-name (cdr (assq 'public-key-algorithm packet)))
 342      "\n"
 343      (if (setq field (cdr (assq 'key-expiry packet)))
 344          (concat "key exipiration time: " (current-time-string field) "\n")
 345        ""))
 346     (run-hooks 'mime-display-application/pgp-keys-hook)
 347     ))
 348
 349
 350 ;;; @ Internal method for fetching a public key
 351 ;;;
 352
 353 (defcustom mime-pgp-keyserver-url-template "/pks/lookup?op=get&search=%s"
 354   "The URL to pass to the keyserver."
 355   :group 'mime-pgp
 356   :type 'string)
 357
 358 (defcustom mime-pgp-keyserver-protocol "http"
 359   "Protocol name of keyserver."
 360   :group 'mime-pgp
 361   :type 'string)
 362
 363 (defcustom mime-pgp-keyserver-address "pgp.nic.ad.jp"
 364   "Host name of keyserver."
 365   :group 'mime-pgp
 366   :type 'string)
 367
 368 (defcustom mime-pgp-keyserver-port 11371
 369   "Port on which the keyserver's HKP daemon lives."
 370   :group 'mime-pgp
 371   :type 'integer)
 372
 373 (defun mime-pgp-fetch-key (string &optional url)
 374   "Attempt to fetch a key for addition to PGP or GnuPG keyring.
 375 Interactively, prompt for string matching key to fetch.
 376
 377 Return t if we think we were successful; nil otherwise.  Note that nil
 378 is not necessarily an error, since we may have merely fired off an Email
 379 request for the key."
 380   (let ((url (or url
 381                  (concat mime-pgp-keyserver-protocol "://"
 382                          mime-pgp-keyserver-address ":"
 383                          mime-pgp-keyserver-port
 384                          (format mime-pgp-keyserver-url-template
 385                                  string)))))
 386     (pgg-fetch-key url)))
 387
 388
 389 ;;; @ end
 390 ;;;
 391
 392 (provide 'mime-pgp)
 393
 394 (run-hooks 'mime-pgp-load-hook)
 395
 396 ;;; mime-pgp.el ends here