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