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 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-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
 324 (eval-when-compile
 325   (defvar password-cache-expiry)
 326   (autoload 'password-read "password")
 327   (autoload 'password-cache-add "password")
 328   (autoload 'password-cache-remove "password"))
 329
 330 (defvar mml-smime-epg-secret-key-id-list nil)
 331
 332 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
 333   (if (eq key-id 'SYM)
 334       (epg-passphrase-callback-function context key-id nil)
 335     (let* (entry
 336            (passphrase
 337             (password-read
 338              (if (eq key-id 'PIN)
 339                  "Passphrase for PIN: "
 340                (if (setq entry (assoc key-id epg-user-id-alist))
 341                    (format "Passphrase for %s %s: " key-id (cdr entry))
 342                  (format "Passphrase for %s: " key-id)))
 343              (if (eq key-id 'PIN)
 344                  "PIN"
 345                key-id))))
 346       (when passphrase
 347         (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
 348           (password-cache-add key-id passphrase))
 349         (setq mml-smime-epg-secret-key-id-list
 350               (cons key-id mml-smime-epg-secret-key-id-list))
 351         (copy-sequence passphrase)))))
 352
 353 (defun mml-smime-epg-find-usable-key (keys usage)
 354   (catch 'found
 355     (while keys
 356       (let ((pointer (epg-key-sub-key-list (car keys))))
 357         (while pointer
 358           (if (and (memq usage (epg-sub-key-capability (car pointer)))
 359                    (not (memq (epg-sub-key-validity (car pointer))
 360                               '(revoked expired))))
 361               (throw 'found (car keys)))
 362           (setq pointer (cdr pointer))))
 363       (setq keys (cdr keys)))))
 364
 365 (defun mml-smime-epg-sign (cont)
 366   (let* ((inhibit-redisplay t)
 367          (context (epg-make-context 'CMS))
 368          (boundary (mml-compute-boundary cont))
 369          signer-key
 370          (signers
 371           (or (message-options-get 'mml-smime-epg-signers)
 372               (message-options-set
 373               'mml-smime-epg-signers
 374               (if mml-smime-verbose
 375                   (epa-select-keys context "\
 376 Select keys for signing.
 377 If no one is selected, default secret key is used.  "
 378                                    mml-smime-signers t)
 379                 (if mml-smime-signers
 380                     (mapcar
 381                      (lambda (signer)
 382                        (setq signer-key (mml-smime-epg-find-usable-key
 383                                          (epg-list-keys context signer t)
 384                                          'sign))
 385                        (unless (or signer-key
 386                                    (y-or-n-p
 387                                     (format "No secret key for %s; skip it? "
 388                                             signer)))
 389                          (error "No secret key for %s" signer))
 390                        signer-key)
 391                      mml-smime-signers))))))
 392          signature micalg)
 393     (epg-context-set-signers context signers)
 394     (if mml-smime-cache-passphrase
 395         (epg-context-set-passphrase-callback
 396          context
 397          #'mml-smime-epg-passphrase-callback))
 398     (condition-case error
 399         (setq signature (epg-sign-string context
 400                                          (mm-replace-in-string (buffer-string)
 401                                                                "\n" "\r\n")
 402                                          t)
 403               mml-smime-epg-secret-key-id-list nil)
 404       (error
 405        (while mml-smime-epg-secret-key-id-list
 406          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 407          (setq mml-smime-epg-secret-key-id-list
 408                (cdr mml-smime-epg-secret-key-id-list)))
 409        (signal (car error) (cdr error))))
 410     (if (epg-context-result-for context 'sign)
 411         (setq micalg (epg-new-signature-digest-algorithm
 412                       (car (epg-context-result-for context 'sign)))))
 413     (goto-char (point-min))
 414     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 415                     boundary))
 416     (if micalg
 417         (insert (format "\tmicalg=%s; "
 418                         (downcase
 419                          (cdr (assq micalg
 420                                     epg-digest-algorithm-alist))))))
 421     (insert "protocol=\"application/pkcs7-signature\"\n")
 422     (insert (format "\n--%s\n" boundary))
 423     (goto-char (point-max))
 424     (insert (format "\n--%s\n" boundary))
 425     (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
 426 Content-Transfer-Encoding: base64
 427 Content-Disposition: attachment; filename=smime.p7s
 428
 429 ")
 430     (insert (base64-encode-string signature) "\n")
 431     (goto-char (point-max))
 432     (insert (format "--%s--\n" boundary))
 433     (goto-char (point-max))))
 434
 435 (defun mml-smime-epg-encrypt (cont)
 436   (let ((inhibit-redisplay t)
 437         (context (epg-make-context 'CMS))
 438         (config (epg-configuration))
 439         (recipients (message-options-get 'mml-smime-epg-recipients))
 440         cipher signers
 441         (boundary (mml-compute-boundary cont))
 442         recipient-key)
 443     (unless recipients
 444       (setq recipients
 445             (apply #'nconc
 446                    (mapcar
 447                     (lambda (recipient)
 448                       (or (epg-expand-group config recipient)
 449                           (list recipient)))
 450                     (split-string
 451                      (or (message-options-get 'message-recipients)
 452                          (message-options-set 'message-recipients
 453                                               (read-string "Recipients: ")))
 454                      "[ \f\t\n\r\v,]+"))))
 455       (if mml-smime-verbose
 456           (setq recipients
 457                 (epa-select-keys context "\
 458 Select recipients for encryption.
 459 If no one is selected, symmetric encryption will be performed.  "
 460                                  recipients))
 461         (setq recipients
 462               (mapcar
 463                (lambda (recipient)
 464                  (setq recipient-key (mml-smime-epg-find-usable-key
 465                                       (epg-list-keys context recipient)
 466                                       'encrypt))
 467                  (unless (or recipient-key
 468                              (y-or-n-p
 469                               (format "No public key for %s; skip it? "
 470                                       recipient)))
 471                    (error "No public key for %s" recipient))
 472                  recipient-key)
 473                recipients))
 474         (unless recipients
 475           (error "No recipient specified")))
 476       (message-options-set 'mml-smime-epg-recipients recipients))
 477     (if mml-smime-cache-passphrase
 478         (epg-context-set-passphrase-callback
 479          context
 480          #'mml-smime-epg-passphrase-callback))
 481     (condition-case error
 482         (setq cipher
 483               (epg-encrypt-string context (buffer-string) recipients)
 484               mml-smime-epg-secret-key-id-list nil)
 485       (error
 486        (while mml-smime-epg-secret-key-id-list
 487          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 488          (setq mml-smime-epg-secret-key-id-list
 489                (cdr mml-smime-epg-secret-key-id-list)))
 490        (signal (car error) (cdr error))))
 491     (delete-region (point-min) (point-max))
 492     (goto-char (point-min))
 493     (insert "\
 494 Content-Type: application/pkcs7-mime;
 495  smime-type=enveloped-data;
 496  name=smime.p7m
 497 Content-Transfer-Encoding: base64
 498 Content-Disposition: attachment; filename=smime.p7m
 499
 500 ")
 501     (insert (base64-encode-string cipher))
 502     (goto-char (point-max))))
 503
 504 (defun mml-smime-epg-verify (handle ctl)
 505   (catch 'error
 506     (let ((inhibit-redisplay t)
 507           context plain signature-file part signature)
 508       (when (or (null (setq part (mm-find-raw-part-by-type
 509                                   ctl (or (mm-handle-multipart-ctl-parameter
 510                                            ctl 'protocol)
 511                                           "application/pkcs7-signature")
 512                                   t)))
 513                 (null (setq signature (mm-find-part-by-type
 514                                        (cdr handle)
 515                                        "application/pkcs7-signature"
 516                                        nil t))))
 517         (mm-set-handle-multipart-parameter
 518          mm-security-handle 'gnus-info "Corrupted")
 519         (throw 'error handle))
 520       (setq part (mm-replace-in-string part "\n" "\r\n" t)
 521             context (epg-make-context 'CMS))
 522       (condition-case error
 523           (setq plain (epg-verify-string context (mm-get-part signature) part))
 524         (error
 525          (mm-set-handle-multipart-parameter
 526           mm-security-handle 'gnus-info "Failed")
 527          (if (eq (car error) 'quit)
 528              (mm-set-handle-multipart-parameter
 529               mm-security-handle 'gnus-details "Quit.")
 530            (mm-set-handle-multipart-parameter
 531             mm-security-handle 'gnus-details (format "%S" error)))
 532          (throw 'error handle)))
 533       (mm-set-handle-multipart-parameter
 534        mm-security-handle 'gnus-info
 535        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
 536       handle)))
 537
 538 (defun mml-smime-epg-verify-test (handle ctl)
 539   t)
 540
 541 (provide 'mml-smime)
 542
 543 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
 544 ;;; mml-smime.el ends here