cgit.sxemacs.org Git - gnus/blob - lisp/mml-smime.el

   1 ;;; mml-smime.el --- S/MIME support for MML
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 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 2, 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 (eval-and-compile
 302   (autoload 'epg-make-context "epg"))
 303
 304 (eval-when-compile
 305   (defvar epg-user-id-alist)
 306   (defvar epg-digest-algorithm-alist)
 307   (defvar inhibit-redisplay)
 308   (autoload 'epg-context-set-armor "epg")
 309   (autoload 'epg-context-set-textmode "epg")
 310   (autoload 'epg-context-set-signers "epg")
 311   (autoload 'epg-context-result-for "epg")
 312   (autoload 'epg-new-signature-digest-algorithm "epg")
 313   (autoload 'epg-verify-result-to-string "epg")
 314   (autoload 'epg-list-keys "epg")
 315   (autoload 'epg-decrypt-string "epg")
 316   (autoload 'epg-verify-string "epg")
 317   (autoload 'epg-sign-string "epg")
 318   (autoload 'epg-encrypt-string "epg")
 319   (autoload 'epg-passphrase-callback-function "epg")
 320   (autoload 'epg-context-set-passphrase-callback "epg")
 321   (autoload 'epg-configuration "epg-config")
 322   (autoload 'epg-expand-group "epg-config")
 323   (autoload 'epa-select-keys "epa"))
 324
 325 (eval-when-compile
 326   (defvar password-cache-expiry)
 327   (autoload 'password-read "password")
 328   (autoload 'password-cache-add "password")
 329   (autoload 'password-cache-remove "password"))
 330
 331 (defvar mml-smime-epg-secret-key-id-list nil)
 332
 333 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
 334   (if (eq key-id 'SYM)
 335       (epg-passphrase-callback-function context key-id nil)
 336     (let* (entry
 337            (passphrase
 338             (password-read
 339              (if (eq key-id 'PIN)
 340                  "Passphrase for PIN: "
 341                (if (setq entry (assoc key-id epg-user-id-alist))
 342                    (format "Passphrase for %s %s: " key-id (cdr entry))
 343                  (format "Passphrase for %s: " key-id)))
 344              (if (eq key-id 'PIN)
 345                  "PIN"
 346                key-id))))
 347       (when passphrase
 348         (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
 349           (password-cache-add key-id passphrase))
 350         (setq mml-smime-epg-secret-key-id-list
 351               (cons key-id mml-smime-epg-secret-key-id-list))
 352         (copy-sequence passphrase)))))
 353
 354 (defun mml-smime-epg-sign (cont)
 355   (let* ((inhibit-redisplay t)
 356          (context (epg-make-context 'CMS))
 357          (boundary (mml-compute-boundary cont))
 358          (signers
 359           (or (message-options-get 'mml-smime-epg-signers)
 360               (message-options-set
 361               'mml-smime-epg-signers
 362               (if mml-smime-verbose
 363                   (epa-select-keys context "\
 364 Select keys for signing.
 365 If no one is selected, default secret key is used.  "
 366                                    mml-smime-signers t)
 367                 (if mml-smime-signers
 368                     (mapcar (lambda (name)
 369                               (car (epg-list-keys context name t)))
 370                             mml-smime-signers))))))
 371         signature micalg)
 372     (epg-context-set-signers context signers)
 373     (if mml-smime-cache-passphrase
 374         (epg-context-set-passphrase-callback
 375          context
 376          #'mml-smime-epg-passphrase-callback))
 377     (condition-case error
 378         (setq signature (epg-sign-string context (buffer-string) t)
 379               mml-smime-epg-secret-key-id-list nil)
 380       (error
 381        (while mml-smime-epg-secret-key-id-list
 382          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 383          (setq mml-smime-epg-secret-key-id-list
 384                (cdr mml-smime-epg-secret-key-id-list)))
 385        (signal (car error) (cdr error))))
 386     (if (epg-context-result-for context 'sign)
 387         (setq micalg (epg-new-signature-digest-algorithm
 388                       (car (epg-context-result-for context 'sign)))))
 389     (goto-char (point-min))
 390     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 391                     boundary))
 392     (if micalg
 393         (insert (format "\tmicalg=%s; "
 394                         (downcase
 395                          (cdr (assq micalg
 396                                     epg-digest-algorithm-alist))))))
 397     (insert "protocol=\"application/pkcs7-signature\"\n")
 398     (insert (format "\n--%s\n" boundary))
 399     (goto-char (point-max))
 400     (insert (format "\n--%s\n" boundary))
 401     (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
 402 Content-Transfer-Encoding: base64
 403 Content-Disposition: attachment; filename=smime.p7s
 404
 405 ")
 406     (insert (base64-encode-string signature) "\n")
 407     (goto-char (point-max))
 408     (insert (format "--%s--\n" boundary))
 409     (goto-char (point-max))))
 410
 411 (defun mml-smime-epg-encrypt (cont)
 412   (let ((inhibit-redisplay t)
 413         (context (epg-make-context 'CMS))
 414         (config (epg-configuration))
 415         (recipients (message-options-get 'mml-smime-epg-recipients))
 416         cipher signers
 417         (boundary (mml-compute-boundary cont)))
 418     (unless recipients
 419       (setq recipients
 420             (apply #'nconc
 421                    (mapcar
 422                     (lambda (recipient)
 423                       (or (epg-expand-group config recipient)
 424                           (list recipient)))
 425                     (split-string
 426                      (or (message-options-get 'message-recipients)
 427                          (message-options-set 'message-recipients
 428                                               (read-string "Recipients: ")))
 429                      "[ \f\t\n\r\v,]+"))))
 430       (if mml-smime-verbose
 431           (setq recipients
 432                 (epa-select-keys context "\
 433 Select recipients for encryption.
 434 If no one is selected, symmetric encryption will be performed.  "
 435                                  recipients))
 436         (setq recipients
 437               (delq nil (mapcar (lambda (name)
 438                                   (car (epg-list-keys context name)))
 439                                 recipients))))
 440       (message-options-set 'mml-smime-epg-recipients recipients))
 441     (if mml-smime-cache-passphrase
 442         (epg-context-set-passphrase-callback
 443          context
 444          #'mml-smime-epg-passphrase-callback))
 445     (condition-case error
 446         (setq cipher
 447               (epg-encrypt-string context (buffer-string) recipients)
 448               mml-smime-epg-secret-key-id-list nil)
 449       (error
 450        (while mml-smime-epg-secret-key-id-list
 451          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 452          (setq mml-smime-epg-secret-key-id-list
 453                (cdr mml-smime-epg-secret-key-id-list)))
 454        (signal (car error) (cdr error))))
 455     (delete-region (point-min) (point-max))
 456     (goto-char (point-min))
 457     (insert "\
 458 Content-Type: application/pkcs7-mime;
 459  smime-type=enveloped-data;
 460  name=smime.p7m
 461 Content-Transfer-Encoding: base64
 462 Content-Disposition: attachment; filename=smime.p7m
 463
 464 ")
 465     (insert (base64-encode-string cipher))
 466     (goto-char (point-max))))
 467
 468 (defun mml-smime-epg-verify (handle ctl)
 469   (catch 'error
 470     (let ((inhibit-redisplay t)
 471           context plain signature-file part signature)
 472       (when (or (null (setq part (mm-find-raw-part-by-type
 473                                   ctl (or (mm-handle-multipart-ctl-parameter
 474                                            ctl 'protocol)
 475                                           "application/pkcs7-signature")
 476                                   t)))
 477                 (null (setq signature (mm-find-part-by-type
 478                                        (cdr handle)
 479                                        "application/pkcs7-signature"
 480                                        nil t))))
 481         (mm-set-handle-multipart-parameter
 482          mm-security-handle 'gnus-info "Corrupted")
 483         (throw 'error handle))
 484       (setq context (epg-make-context 'CMS))
 485       (condition-case error
 486           (setq plain (epg-verify-string context (mm-get-part signature) part))
 487         (error
 488          (mm-set-handle-multipart-parameter
 489           mm-security-handle 'gnus-info "Failed")
 490          (if (eq (car error) 'quit)
 491              (mm-set-handle-multipart-parameter
 492               mm-security-handle 'gnus-details "Quit.")
 493            (mm-set-handle-multipart-parameter
 494             mm-security-handle 'gnus-details (format "%S" error)))
 495          (throw 'error handle)))
 496       (mm-set-handle-multipart-parameter
 497        mm-security-handle 'gnus-info
 498        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
 499       handle)))
 500
 501 (defun mml-smime-epg-verify-test (handle ctl)
 502   t)
 503
 504 (provide 'mml-smime)
 505
 506 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
 507 ;;; mml-smime.el ends here