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-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-find-usable-key (keys usage)
 355   (catch 'found
 356     (while keys
 357       (let ((pointer (epg-key-sub-key-list (car keys))))
 358         (while pointer
 359           (if (and (memq usage (epg-sub-key-capability (car pointer)))
 360                    (not (memq (epg-sub-key-validity (car pointer))
 361                               '(revoked expired))))
 362               (throw 'found (car keys)))
 363           (setq pointer (cdr pointer))))
 364       (setq keys (cdr keys)))))
 365
 366 (defun mml-smime-epg-sign (cont)
 367   (let* ((inhibit-redisplay t)
 368          (context (epg-make-context 'CMS))
 369          (boundary (mml-compute-boundary cont))
 370          signer-key
 371          (signers
 372           (or (message-options-get 'mml-smime-epg-signers)
 373               (message-options-set
 374               'mml-smime-epg-signers
 375               (if mml-smime-verbose
 376                   (epa-select-keys context "\
 377 Select keys for signing.
 378 If no one is selected, default secret key is used.  "
 379                                    mml-smime-signers t)
 380                 (if mml-smime-signers
 381                     (mapcar
 382                      (lambda (signer)
 383                        (setq signer-key (mml-smime-epg-find-usable-key
 384                                          (epg-list-keys context signer t)
 385                                          'sign))
 386                        (unless (or signer-key
 387                                    (y-or-n-p
 388                                     (format "No secret key for %s; skip it? "
 389                                             signer)))
 390                          (error "No secret key for %s" signer))
 391                        signer-key)
 392                      mml-smime-signers))))))
 393          signature micalg)
 394     (epg-context-set-signers context signers)
 395     (if mml-smime-cache-passphrase
 396         (epg-context-set-passphrase-callback
 397          context
 398          #'mml-smime-epg-passphrase-callback))
 399     (condition-case error
 400         (setq signature (epg-sign-string context (buffer-string) t)
 401               mml-smime-epg-secret-key-id-list nil)
 402       (error
 403        (while mml-smime-epg-secret-key-id-list
 404          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 405          (setq mml-smime-epg-secret-key-id-list
 406                (cdr mml-smime-epg-secret-key-id-list)))
 407        (signal (car error) (cdr error))))
 408     (if (epg-context-result-for context 'sign)
 409         (setq micalg (epg-new-signature-digest-algorithm
 410                       (car (epg-context-result-for context 'sign)))))
 411     (goto-char (point-min))
 412     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 413                     boundary))
 414     (if micalg
 415         (insert (format "\tmicalg=%s; "
 416                         (downcase
 417                          (cdr (assq micalg
 418                                     epg-digest-algorithm-alist))))))
 419     (insert "protocol=\"application/pkcs7-signature\"\n")
 420     (insert (format "\n--%s\n" boundary))
 421     (goto-char (point-max))
 422     (insert (format "\n--%s\n" boundary))
 423     (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
 424 Content-Transfer-Encoding: base64
 425 Content-Disposition: attachment; filename=smime.p7s
 426
 427 ")
 428     (insert (base64-encode-string signature) "\n")
 429     (goto-char (point-max))
 430     (insert (format "--%s--\n" boundary))
 431     (goto-char (point-max))))
 432
 433 (defun mml-smime-epg-encrypt (cont)
 434   (let ((inhibit-redisplay t)
 435         (context (epg-make-context 'CMS))
 436         (config (epg-configuration))
 437         (recipients (message-options-get 'mml-smime-epg-recipients))
 438         cipher signers
 439         (boundary (mml-compute-boundary cont))
 440         recipient-key)
 441     (unless recipients
 442       (setq recipients
 443             (apply #'nconc
 444                    (mapcar
 445                     (lambda (recipient)
 446                       (or (epg-expand-group config recipient)
 447                           (list recipient)))
 448                     (split-string
 449                      (or (message-options-get 'message-recipients)
 450                          (message-options-set 'message-recipients
 451                                               (read-string "Recipients: ")))
 452                      "[ \f\t\n\r\v,]+"))))
 453       (if mml-smime-verbose
 454           (setq recipients
 455                 (epa-select-keys context "\
 456 Select recipients for encryption.
 457 If no one is selected, symmetric encryption will be performed.  "
 458                                  recipients))
 459         (setq recipients
 460               (mapcar
 461                (lambda (recipient)
 462                  (setq recipient-key (mml-smime-epg-find-usable-key
 463                                       (epg-list-keys context recipient)
 464                                       'encrypt))
 465                  (unless (or recipient-key
 466                              (y-or-n-p
 467                               (format "No public key for %s; skip it? "
 468                                       recipient)))
 469                    (error "No public key for %s" recipient))
 470                  recipient-key)
 471                recipients))
 472         (unless recipients
 473           (error "No recipient specified")))
 474       (message-options-set 'mml-smime-epg-recipients recipients))
 475     (if mml-smime-cache-passphrase
 476         (epg-context-set-passphrase-callback
 477          context
 478          #'mml-smime-epg-passphrase-callback))
 479     (condition-case error
 480         (setq cipher
 481               (epg-encrypt-string context (buffer-string) recipients)
 482               mml-smime-epg-secret-key-id-list nil)
 483       (error
 484        (while mml-smime-epg-secret-key-id-list
 485          (password-cache-remove (car mml-smime-epg-secret-key-id-list))
 486          (setq mml-smime-epg-secret-key-id-list
 487                (cdr mml-smime-epg-secret-key-id-list)))
 488        (signal (car error) (cdr error))))
 489     (delete-region (point-min) (point-max))
 490     (goto-char (point-min))
 491     (insert "\
 492 Content-Type: application/pkcs7-mime;
 493  smime-type=enveloped-data;
 494  name=smime.p7m
 495 Content-Transfer-Encoding: base64
 496 Content-Disposition: attachment; filename=smime.p7m
 497
 498 ")
 499     (insert (base64-encode-string cipher))
 500     (goto-char (point-max))))
 501
 502 (defun mml-smime-epg-verify (handle ctl)
 503   (catch 'error
 504     (let ((inhibit-redisplay t)
 505           context plain signature-file part signature)
 506       (when (or (null (setq part (mm-find-raw-part-by-type
 507                                   ctl (or (mm-handle-multipart-ctl-parameter
 508                                            ctl 'protocol)
 509                                           "application/pkcs7-signature")
 510                                   t)))
 511                 (null (setq signature (mm-find-part-by-type
 512                                        (cdr handle)
 513                                        "application/pkcs7-signature"
 514                                        nil t))))
 515         (mm-set-handle-multipart-parameter
 516          mm-security-handle 'gnus-info "Corrupted")
 517         (throw 'error handle))
 518       (setq 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