lisp/gnus/mml-smime.el

   1 ;;; mml-smime.el --- S/MIME support for MML
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <simon@josefsson.org>
   7 ;; Keywords: Gnus, MIME, S/MIME, MML
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published
  13 ;; by the Free Software Foundation; either version 3, or (at your
  14 ;; option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31
  32 (require 'smime)
  33 (require 'mm-decode)
  34 (require 'mml-sec)
  35 (autoload 'message-narrow-to-headers "message")
  36 (autoload 'message-fetch-field "message")
  37
  38 (defvar mml-smime-use 'openssl)
  39
  40 (defvar mml-smime-function-alist
  41   '((openssl mml-smime-openssl-sign
  42              mml-smime-openssl-encrypt
  43              mml-smime-openssl-sign-query
  44              mml-smime-openssl-encrypt-query
  45              mml-smime-openssl-verify
  46              mml-smime-openssl-verify-test)
  47     (epg mml-smime-epg-sign
  48          mml-smime-epg-encrypt
  49          nil
  50          nil
  51          mml-smime-epg-verify
  52          mml-smime-epg-verify-test)))
  53
  54 (defcustom mml-smime-verbose mml-secure-verbose
  55   "If non-nil, ask the user about the current operation more verbosely."
  56   :group 'mime-security
  57   :type 'boolean)
  58
  59 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
  60   "If t, cache passphrase."
  61   :group 'mime-security
  62   :type 'boolean)
  63
  64 (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
  65   "How many seconds the passphrase is cached.
  66 Whether the passphrase is cached at all is controlled by
  67 `mml-smime-cache-passphrase'."
  68   :group 'mime-security
  69   :type 'integer)
  70
  71 (defcustom mml-smime-signers nil
  72   "A list of your own key ID which will be used to sign a message."
  73   :group 'mime-security
  74   :type '(repeat (string :tag "Key ID")))
  75
  76 (defun mml-smime-sign (cont)
  77   (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
  78     (if func
  79         (funcall func cont)
  80       (error "Cannot find sign function"))))
  81
  82 (defun mml-smime-encrypt (cont)
  83   (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
  84     (if func
  85         (funcall func cont)
  86       (error "Cannot find encrypt function"))))
  87
  88 (defun mml-smime-sign-query ()
  89   (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
  90     (if func
  91         (funcall func))))
  92
  93 (defun mml-smime-encrypt-query ()
  94   (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
  95     (if func
  96         (funcall func))))
  97
  98 (defun mml-smime-verify (handle ctl)
  99   (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
 100     (if func
 101         (funcall func handle ctl)
 102       handle)))
 103
 104 (defun mml-smime-verify-test (handle ctl)
 105   (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
 106     (if func
 107         (funcall func handle ctl))))
 108
 109 (defun mml-smime-openssl-sign (cont)
 110   (when (null smime-keys)
 111     (customize-variable 'smime-keys)
 112     (error "No S/MIME keys configured, use customize to add your key"))
 113   (smime-sign-buffer (cdr (assq 'keyfile cont)))
 114   (goto-char (point-min))
 115   (while (search-forward "\r\n" nil t)
 116     (replace-match "\n" t t))
 117   (goto-char (point-max)))
 118
 119 (defun mml-smime-openssl-encrypt (cont)
 120   (let (certnames certfiles tmp file tmpfiles)
 121     ;; xxx tmp files are always an security issue
 122     (while (setq tmp (pop cont))
 123       (if (and (consp tmp) (eq (car tmp) 'certfile))
 124           (push (cdr tmp) certnames)))
 125     (while (setq tmp (pop certnames))
 126       (if (not (and (not (file-exists-p tmp))
 127                     (get-buffer tmp)))
 128           (push tmp certfiles)
 129         (setq file (mm-make-temp-file (expand-file-name "mml."
 130                                                         mm-tmp-directory)))
 131         (with-current-buffer tmp
 132           (write-region (point-min) (point-max) file))
 133         (push file certfiles)
 134         (push file tmpfiles)))
 135     (if (smime-encrypt-buffer certfiles)
 136         (progn
 137           (while (setq tmp (pop tmpfiles))
 138             (delete-file tmp))
 139           t)
 140       (while (setq tmp (pop tmpfiles))
 141         (delete-file tmp))
 142       nil))
 143   (goto-char (point-max)))
 144
 145 (defun mml-smime-openssl-sign-query ()
 146   ;; query information (what certificate) from user when MML tag is
 147   ;; added, for use later by the signing process
 148   (when (null smime-keys)
 149     (customize-variable 'smime-keys)
 150     (error "No S/MIME keys configured, use customize to add your key"))
 151   (list 'keyfile
 152         (if (= (length smime-keys) 1)
 153             (cadar smime-keys)
 154           (or (let ((from (cadr (funcall (if (boundp
 155                                               'gnus-extract-address-components)
 156                                              gnus-extract-address-components
 157                                            'mail-extract-address-components)
 158                                          (or (save-excursion
 159                                                (save-restriction
 160                                                  (message-narrow-to-headers)
 161                                                  (message-fetch-field "from")))
 162                                              "")))))
 163                 (and from (smime-get-key-by-email from)))
 164               (smime-get-key-by-email
 165                (completing-read "Sign this part with what signature? "
 166                                 smime-keys nil nil
 167                                 (and (listp (car-safe smime-keys))
 168                                      (caar smime-keys))))))))
 169
 170 (defun mml-smime-get-file-cert ()
 171   (ignore-errors
 172     (list 'certfile (read-file-name
 173                      "File with recipient's S/MIME certificate: "
 174                      smime-certificate-directory nil t ""))))
 175
 176 (defun mml-smime-get-dns-cert ()
 177   ;; todo: deal with comma separated multiple recipients
 178   (let (result who bad cert)
 179     (condition-case ()
 180         (while (not result)
 181           (setq who (read-from-minibuffer
 182                      (format "%sLookup certificate for: " (or bad ""))
 183                      (cadr (funcall (if (boundp
 184                                          'gnus-extract-address-components)
 185                                         gnus-extract-address-components
 186                                       'mail-extract-address-components)
 187                                     (or (save-excursion
 188                                           (save-restriction
 189                                             (message-narrow-to-headers)
 190                                             (message-fetch-field "to")))
 191                                         "")))))
 192           (if (setq cert (smime-cert-by-dns who))
 193               (setq result (list 'certfile (buffer-name cert)))
 194             (setq bad (format "`%s' not found. " who))))
 195       (quit))
 196     result))
 197
 198 (defun mml-smime-get-ldap-cert ()
 199   ;; todo: deal with comma separated multiple recipients
 200   (let (result who bad cert)
 201     (condition-case ()
 202         (while (not result)
 203           (setq who (read-from-minibuffer
 204                      (format "%sLookup certificate for: " (or bad ""))
 205                      (cadr (funcall gnus-extract-address-components
 206                                     (or (save-excursion
 207                                           (save-restriction
 208                                             (message-narrow-to-headers)
 209                                             (message-fetch-field "to")))
 210                                         "")))))
 211           (if (setq cert (smime-cert-by-ldap who))
 212               (setq result (list 'certfile (buffer-name cert)))
 213             (setq bad (format "`%s' not found. " who))))
 214       (quit))
 215     result))
 216
 217 (defun mml-smime-openssl-encrypt-query ()
 218   ;; todo: try dns/ldap automatically first, before prompting user
 219   (let (certs done)
 220     (while (not done)
 221       (ecase (read (gnus-completing-read-with-default
 222                     "ldap" "Fetch certificate from"
 223                     '(("dns") ("ldap") ("file")) nil t))
 224         (dns (setq certs (append certs
 225                                  (mml-smime-get-dns-cert))))
 226         (ldap (setq certs (append certs
 227                                   (mml-smime-get-ldap-cert))))
 228         (file (setq certs (append certs
 229                                   (mml-smime-get-file-cert)))))
 230       (setq done (not (y-or-n-p "Add more recipients? "))))
 231     certs))
 232
 233 (defun mml-smime-openssl-verify (handle ctl)
 234   (with-temp-buffer
 235     (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
 236     (goto-char (point-min))
 237     (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
 238     (insert (format "protocol=\"%s\"; "
 239                     (mm-handle-multipart-ctl-parameter ctl 'protocol)))
 240     (insert (format "micalg=\"%s\"; "
 241                     (mm-handle-multipart-ctl-parameter ctl 'micalg)))
 242     (insert (format "boundary=\"%s\"\n\n"
 243                     (mm-handle-multipart-ctl-parameter ctl 'boundary)))
 244     (when (get-buffer smime-details-buffer)
 245       (kill-buffer smime-details-buffer))
 246     (let ((buf (current-buffer))
 247           (good-signature (smime-noverify-buffer))
 248           (good-certificate (and (or smime-CA-file smime-CA-directory)
 249                                  (smime-verify-buffer)))
 250           addresses openssl-output)
 251       (setq openssl-output (with-current-buffer smime-details-buffer
 252                              (buffer-string)))
 253       (if (not good-signature)
 254           (progn
 255             ;; we couldn't verify message, fail with openssl output as message
 256             (mm-set-handle-multipart-parameter
 257              mm-security-handle 'gnus-info "Failed")
 258             (mm-set-handle-multipart-parameter
 259              mm-security-handle 'gnus-details
 260              (concat "OpenSSL failed to verify message integrity:\n"
 261                      "-------------------------------------------\n"
 262                      openssl-output)))
 263         ;; verify mail addresses in mail against those in certificate
 264         (when (and (smime-pkcs7-region (point-min) (point-max))
 265                    (smime-pkcs7-certificates-region (point-min) (point-max)))
 266           (with-temp-buffer
 267             (insert-buffer-substring buf)
 268             (goto-char (point-min))
 269             (while (re-search-forward "-----END CERTIFICATE-----" nil t)
 270               (when (smime-pkcs7-email-region (point-min) (point))
 271                 (setq addresses (append (smime-buffer-as-string-region
 272                                          (point-min) (point)) addresses)))
 273               (delete-region (point-min) (point)))
 274             (setq addresses (mapcar 'downcase addresses))))
 275         (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
 276             (mm-set-handle-multipart-parameter
 277              mm-security-handle 'gnus-info "Sender address forged")
 278           (if good-certificate
 279               (mm-set-handle-multipart-parameter
 280                mm-security-handle 'gnus-info "Ok (sender authenticated)")
 281             (mm-set-handle-multipart-parameter
 282              mm-security-handle 'gnus-info "Ok (sender not trusted)")))
 283         (mm-set-handle-multipart-parameter
 284          mm-security-handle 'gnus-details
 285          (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
 286                  (if addresses
 287                      (concat "Addresses in certificate: "
 288                              (mapconcat 'identity addresses ", "))
 289                    "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
 290                  "\n" "\n"
 291                  "OpenSSL output:\n"
 292                  "---------------\n" openssl-output "\n"
 293                  "Certificate(s) inside S/MIME signature:\n"
 294                  "---------------------------------------\n"
 295                  (buffer-string) "\n")))))
 296   handle)
 297
 298 (defun mml-smime-openssl-verify-test (handle ctl)
 299   smime-openssl-program)
 300
 301 (defvar epg-user-id-alist)
 302 (defvar epg-digest-algorithm-alist)
 303 (defvar inhibit-redisplay)
 304 (defvar password-cache-expiry)
 305
 306 (eval-when-compile
 307   (autoload 'epg-make-context "epg")
 308   (autoload 'epg-context-set-armor "epg")
 309   (autoload 'epg-context-set-signers "epg")
 310   (autoload 'epg-context-result-for "epg")
 311   (autoload 'epg-new-signature-digest-algorithm "epg")
 312   (autoload 'epg-verify-result-to-string "epg")
 313   (autoload 'epg-list-keys "epg")
 314   (autoload 'epg-decrypt-string "epg")
 315   (autoload 'epg-verify-string "epg")
 316   (autoload 'epg-sign-string "epg")
 317   (autoload 'epg-encrypt-string "epg")
 318   (autoload 'epg-passphrase-callback-function "epg")
 319   (autoload 'epg-context-set-passphrase-callback "epg")
 320   (autoload 'epg-configuration "epg-config")
 321   (autoload 'epg-expand-group "epg-config")
 322   (autoload 'epa-select-keys "epa")
 323   (autoload 'password-read "password")
 324   (autoload 'password-cache-add "password")
 325   (autoload 'password-cache-remove "password"))
 326
 327 (defvar mml-smime-epg-secret-key-id-list nil)
 328
 329 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
 330   (if (eq key-id 'SYM)
 331       (epg-passphrase-callback-function context key-id nil)
 332     (let* (entry
 333            (passphrase
 334             (password-read
 335              (if (eq key-id 'PIN)
 336                  "Passphrase for PIN: "
 337                (if (setq entry (assoc key-id epg-user-id-alist))
 338                    (format "Passphrase for %s %s: " key-id (cdr entry))
 339                  (format "Passphrase for %s: " key-id)))
 340              (if (eq key-id 'PIN)
 341                  "PIN"
 342                key-id))))
 343       (when passphrase
 344         (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
 345           (password-cache-add key-id passphrase))
 346         (setq mml-smime-epg-secret-key-id-list
 347               (cons key-id mml-smime-epg-secret-key-id-list))
 348         (copy-sequence passphrase)))))
 349
 350 (defun mml-smime-epg-find-usable-key (keys usage)
 351   (catch 'found
 352     (while keys
 353       (let ((pointer (epg-key-sub-key-list (car keys))))
 354         (while pointer
 355           (if (and (memq usage (epg-sub-key-capability (car pointer)))
 356                    (not (memq (epg-sub-key-validity (car pointer))
 357                               '(revoked expired))))
 358               (throw 'found (car keys)))
 359           (setq pointer (cdr pointer))))
 360       (setq keys (cdr keys)))))
 361
 362 (defun mml-smime-epg-sign (cont)
 363   (let* ((inhibit-redisplay t)
 364          (context (epg-make-context 'CMS))
 365          (boundary (mml-compute-boundary cont))
 366          signer-key
 367          (signers
 368           (or (message-options-get 'mml-smime-epg-signers)
 369               (message-options-set
 370               'mml-smime-epg-signers
 371               (if mml-smime-verbose
 372                   (epa-select-keys context "\
 373 Select keys for signing.
 374 If no one is selected, default secret key is used.  "
 375                                    mml-smime-signers t)
 376                 (if mml-smime-signers
 377                     (mapcar
 378                      (lambda (signer)
 379                        (setq signer-key (mml-smime-epg-find-usable-key
 380                                          (epg-list-keys context signer t)
 381                                          'sign))
 382                        (unless (or signer-key
 383                                    (y-or-n-p
 384                                     (format "No secret key for %s; skip it? "
 385                                             signer)))
 386                          (error "No secret key for %s" signer))
 387                        signer-key)
 388                      mml-smime-signers))))))
 389          signature micalg)
 390     (epg-context-set-signers context signers)
 391     (if mml-smime-cache-passphrase
 392         (epg-context-set-passphrase-callback
 393          context
 394          #'mml-smime-epg-passphrase-callback))
 395     (condition-case error
 396         (setq signature (epg-sign-string context
 397                                          (mm-replace-in-string (buffer-string)
 398                                                                "\n" "\r\n")
 399                                          t)
 400               mml-smime-epg-secret-key-id-list nil)
 401       (error
 402        (while mml-smime-epg-secret-key-id-list
 403          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 404          (setq mml-smime-epg-secret-key-id-list
 405                (cdr mml-smime-epg-secret-key-id-list)))
 406        (signal (car error) (cdr error))))
 407     (if (epg-context-result-for context 'sign)
 408         (setq micalg (epg-new-signature-digest-algorithm
 409                       (car (epg-context-result-for context 'sign)))))
 410     (goto-char (point-min))
 411     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 412                     boundary))
 413     (if micalg
 414         (insert (format "\tmicalg=%s; "
 415                         (downcase
 416                          (cdr (assq micalg
 417                                     epg-digest-algorithm-alist))))))
 418     (insert "protocol=\"application/pkcs7-signature\"\n")
 419     (insert (format "\n--%s\n" boundary))
 420     (goto-char (point-max))
 421     (insert (format "\n--%s\n" boundary))
 422     (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
 423 Content-Transfer-Encoding: base64
 424 Content-Disposition: attachment; filename=smime.p7s
 425
 426 ")
 427     (insert (base64-encode-string signature) "\n")
 428     (goto-char (point-max))
 429     (insert (format "--%s--\n" boundary))
 430     (goto-char (point-max))))
 431
 432 (defun mml-smime-epg-encrypt (cont)
 433   (let ((inhibit-redisplay t)
 434         (context (epg-make-context 'CMS))
 435         (config (epg-configuration))
 436         (recipients (message-options-get 'mml-smime-epg-recipients))
 437         cipher signers
 438         (boundary (mml-compute-boundary cont))
 439         recipient-key)
 440     (unless recipients
 441       (setq recipients
 442             (apply #'nconc
 443                    (mapcar
 444                     (lambda (recipient)
 445                       (or (epg-expand-group config recipient)
 446                           (list recipient)))
 447                     (split-string
 448                      (or (message-options-get 'message-recipients)
 449                          (message-options-set 'message-recipients
 450                                               (read-string "Recipients: ")))
 451                      "[ \f\t\n\r\v,]+"))))
 452       (if mml-smime-verbose
 453           (setq recipients
 454                 (epa-select-keys context "\
 455 Select recipients for encryption.
 456 If no one is selected, symmetric encryption will be performed.  "
 457                                  recipients))
 458         (setq recipients
 459               (mapcar
 460                (lambda (recipient)
 461                  (setq recipient-key (mml-smime-epg-find-usable-key
 462                                       (epg-list-keys context recipient)
 463                                       'encrypt))
 464                  (unless (or recipient-key
 465                              (y-or-n-p
 466                               (format "No public key for %s; skip it? "
 467                                       recipient)))
 468                    (error "No public key for %s" recipient))
 469                  recipient-key)
 470                recipients))
 471         (unless recipients
 472           (error "No recipient specified")))
 473       (message-options-set 'mml-smime-epg-recipients recipients))
 474     (if mml-smime-cache-passphrase
 475         (epg-context-set-passphrase-callback
 476          context
 477          #'mml-smime-epg-passphrase-callback))
 478     (condition-case error
 479         (setq cipher
 480               (epg-encrypt-string context (buffer-string) recipients)
 481               mml-smime-epg-secret-key-id-list nil)
 482       (error
 483        (while mml-smime-epg-secret-key-id-list
 484          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 485          (setq mml-smime-epg-secret-key-id-list
 486                (cdr mml-smime-epg-secret-key-id-list)))
 487        (signal (car error) (cdr error))))
 488     (delete-region (point-min) (point-max))
 489     (goto-char (point-min))
 490     (insert "\
 491 Content-Type: application/pkcs7-mime;
 492  smime-type=enveloped-data;
 493  name=smime.p7m
 494 Content-Transfer-Encoding: base64
 495 Content-Disposition: attachment; filename=smime.p7m
 496
 497 ")
 498     (insert (base64-encode-string cipher))
 499     (goto-char (point-max))))
 500
 501 (defun mml-smime-epg-verify (handle ctl)
 502   (catch 'error
 503     (let ((inhibit-redisplay t)
 504           context plain signature-file part signature)
 505       (when (or (null (setq part (mm-find-raw-part-by-type
 506                                   ctl (or (mm-handle-multipart-ctl-parameter
 507                                            ctl 'protocol)
 508                                           "application/pkcs7-signature")
 509                                   t)))
 510                 (null (setq signature (mm-find-part-by-type
 511                                        (cdr handle)
 512                                        "application/pkcs7-signature"
 513                                        nil t))))
 514         (mm-set-handle-multipart-parameter
 515          mm-security-handle 'gnus-info "Corrupted")
 516         (throw 'error handle))
 517       (setq part (mm-replace-in-string part "\n" "\r\n" t)
 518             context (epg-make-context 'CMS))
 519       (condition-case error
 520           (setq plain (epg-verify-string context (mm-get-part signature) part))
 521         (error
 522          (mm-set-handle-multipart-parameter
 523           mm-security-handle 'gnus-info "Failed")
 524          (if (eq (car error) 'quit)
 525              (mm-set-handle-multipart-parameter
 526               mm-security-handle 'gnus-details "Quit.")
 527            (mm-set-handle-multipart-parameter
 528             mm-security-handle 'gnus-details (format "%S" error)))
 529          (throw 'error handle)))
 530       (mm-set-handle-multipart-parameter
 531        mm-security-handle 'gnus-info
 532        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
 533       handle)))
 534
 535 (defun mml-smime-epg-verify-test (handle ctl)
 536   t)
 537
 538 (provide 'mml-smime)
 539
 540 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
 541 ;;; mml-smime.el ends here