;;; mml-smime.el --- S/MIME support for MML
-;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+;; Copyright (c) 2000, 2001, 2003, 2005 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: Gnus, MIME, S/MIME, MML
(quit))
result))
+(defun mml-smime-get-dns-ldap ()
+ ;; todo: deal with comma separated multiple recipients
+ (let (result who bad cert)
+ (condition-case ()
+ (while (not result)
+ (setq who (read-from-minibuffer
+ (format "%sLookup certificate for: " (or bad ""))
+ (cadr (funcall gnus-extract-address-components
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "to")))
+ "")))))
+ (if (setq cert (smime-cert-by-ldap who))
+ (setq result (list 'certfile (buffer-name cert)))
+ (setq bad (format "`%s' not found. " who))))
+ (quit))
+ result))
+
(defun mml-smime-encrypt-query ()
;; todo: add ldap support (xemacs ldap api?)
;; todo: try dns/ldap automatically first, before prompting user
(while (not done)
(ecase (read (gnus-completing-read-with-default
"dns" "Fetch certificate from"
- '(("dns") ("file")) nil t))
+ '(("dns") ("ldap") ("file")) nil t))
(dns (setq certs (append certs
(mml-smime-get-dns-cert))))
+ (ldap (setq certs (append certs
+ (mml-smime-get-dns-ldap))))
(file (setq certs (append certs
(mml-smime-get-file-cert)))))
(setq done (not (y-or-n-p "Add more recipients? "))))
--- /dev/null
+;;; smime-ldap.el --- client interface to LDAP for Emacs
+
+;; Copyright (C) 1998, 1999, 2000, 2005 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
+;; Maintainer: Arne J\e,Ax\e(Brgensen <arne@arnested.dk>
+;; Created: February 2005
+;; Keywords: comm
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file has a slightly changed implementation of Emacs 21.3's
+;; ldap-search and ldap-search-internal from ldap.el. The changes are
+;; made to achieve compatibility with OpenLDAP v2 and to make it
+;; possible to retrieve LDAP attributes that are tagged ie ";binary".
+
+;; When Gnus drops support for Emacs 21.x this file can be removed and
+;; smime.el changed to
+
+;; - (require 'smime-ldap) => (require 'ldap)
+;; - (smime-ldap-search ...) => (ldap-search ...)
+
+;; If we are running in Emacs 22 or newer it just uses the build-in
+;; version of ldap-search.
+
+;;; Code:
+
+(load-library "net/ldap")
+
+(defun smime-ldap-search (filter &optional host attributes attrsonly withdn)
+ "Perform an LDAP search.
+FILTER is the search filter in RFC1558 syntax.
+HOST is the LDAP host on which to perform the search.
+ATTRIBUTES are the specific attributes to retrieve, nil means
+retrieve all.
+ATTRSONLY, if non-nil, retrieves the attributes only, without
+the associated values.
+If WITHDN is non-nil, each entry in the result will be prepended with
+its distinguished name WITHDN.
+Additional search parameters can be specified through
+`ldap-host-parameters-alist', which see."
+ (interactive "sFilter:")
+ (if (>= emacs-major-version 22)
+ (ldap-search filter host attributes attrsonly)
+ (or host
+ (setq host ldap-default-host)
+ (error "No LDAP host specified"))
+ (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
+ result)
+ (setq result (smime-ldap-search-internal (append host-plist
+ (list 'host host
+ 'filter filter
+ 'attributes attributes
+ 'attrsonly attrsonly
+ 'withdn withdn))))
+ (if ldap-ignore-attribute-codings
+ result
+ (mapcar (function
+ (lambda (record)
+ (mapcar 'ldap-decode-attribute record)))
+ result)))))
+
+(defun smime-ldap-search-internal (search-plist)
+ "Perform a search on a LDAP server.
+SEARCH-PLIST is a property list describing the search request.
+Valid keys in that list are:
+ `host' is a string naming one or more (blank-separated) LDAP servers to
+to try to connect to. Each host name may optionally be of the form HOST:PORT.
+ `filter' is a filter string for the search as described in RFC 1558.
+ `attributes' is a list of strings indicating which attributes to retrieve
+for each matching entry. If nil, return all available attributes.
+ `attrsonly', if non-nil, indicates that only attributes are retrieved,
+not their associated values.
+ `base' is the base for the search as described in RFC 1779.
+ `scope' is one of the three symbols `sub', `base' or `one'.
+ `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax).
+ `passwd' is the password to use for simple authentication.
+ `deref' is one of the symbols `never', `always', `search' or `find'.
+ `timelimit' is the timeout limit for the connection in seconds.
+ `sizelimit' is the maximum number of matches to return.
+ `withdn' if non-nil each entry in the result will be prepended with
+its distinguished name DN.
+The function returns a list of matching entries. Each entry is itself
+an alist of attribute/value pairs."
+ (let ((buf (get-buffer-create " *ldap-search*"))
+ (bufval (get-buffer-create " *ldap-value*"))
+ (host (or (plist-get search-plist 'host)
+ ldap-default-host))
+ (filter (plist-get search-plist 'filter))
+ (attributes (plist-get search-plist 'attributes))
+ (attrsonly (plist-get search-plist 'attrsonly))
+ (base (or (plist-get search-plist 'base)
+ ldap-default-base))
+ (scope (plist-get search-plist 'scope))
+ (binddn (plist-get search-plist 'binddn))
+ (passwd (plist-get search-plist 'passwd))
+ (deref (plist-get search-plist 'deref))
+ (timelimit (plist-get search-plist 'timelimit))
+ (sizelimit (plist-get search-plist 'sizelimit))
+ (withdn (plist-get search-plist 'withdn))
+ (numres 0)
+ arglist dn name value record result)
+ (if (or (null filter)
+ (equal "" filter))
+ (error "No search filter"))
+ (setq filter (cons filter attributes))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (if (and host
+ (not (equal "" host)))
+ (setq arglist (nconc arglist (list (format "-h%s" host)))))
+ (if (and attrsonly
+ (not (equal "" attrsonly)))
+ (setq arglist (nconc arglist (list "-A"))))
+ (if (and base
+ (not (equal "" base)))
+ (setq arglist (nconc arglist (list (format "-b%s" base)))))
+ (if (and scope
+ (not (equal "" scope)))
+ (setq arglist (nconc arglist (list (format "-s%s" scope)))))
+ (if (and binddn
+ (not (equal "" binddn)))
+ (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
+ (if (and passwd
+ (not (equal "" passwd)))
+ (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
+ (if (and deref
+ (not (equal "" deref)))
+ (setq arglist (nconc arglist (list (format "-a%s" deref)))))
+ (if (and timelimit
+ (not (equal "" timelimit)))
+ (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
+ (if (and sizelimit
+ (not (equal "" sizelimit)))
+ (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
+ (eval `(call-process ldap-ldapsearch-prog
+ nil
+ buf
+ nil
+ ,@arglist
+ "-tt" ; Write values to temp files
+ "-x"
+ "-LL"
+ ; ,@ldap-ldapsearch-args
+ ,@filter))
+ (insert "\n")
+ (goto-char (point-min))
+
+ (while (re-search-forward "[\t\n\f]+ " nil t)
+ (replace-match "" nil nil))
+ (goto-char (point-min))
+
+ (if (looking-at "usage")
+ (error "Incorrect ldapsearch invocation")
+ (message "Parsing results... ")
+ (while (progn
+ (skip-chars-forward " \t\n")
+ (not (eobp)))
+ (setq dn (buffer-substring (point) (save-excursion
+ (end-of-line)
+ (point))))
+ (forward-line 1)
+ (while (looking-at "^\\(\\w*\\)\\(;\\w*\\)?[=:\t ]+\\(<[\t ]*file://\\)?\\(.*\\)$")
+ (setq name (match-string 1)
+ value (match-string 4))
+ (save-excursion
+ (set-buffer bufval)
+ (erase-buffer)
+ (insert-file-contents-literally value)
+ (delete-file value)
+ (setq value (buffer-substring (point-min) (point-max))))
+ (setq record (cons (list name value)
+ record))
+ (forward-line 1))
+ (setq result (cons (if withdn
+ (cons dn (nreverse record))
+ (nreverse record)) result))
+ (setq record nil)
+ (skip-chars-forward " \t\n")
+ (message "Parsing results... %d" numres)
+ (1+ numres))
+ (message "Parsing results... done")
+ (nreverse result)))))
+
+(provide 'smime-ldap)
+
+;;; smime-ldap.el ends here
;;; smime.el --- S/MIME support library
-;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+;; Copyright (c) 2000, 2001, 2003, 2005 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: SMIME X.509 PEM OpenSSL
;; This library perform S/MIME operations from within Emacs.
;;
;; Functions for fetching certificates from public repositories are
-;; provided, currently only from DNS. LDAP support (via EUDC) is planned.
+;; provided, currently from DNS and LDAP.
;;
;; It uses OpenSSL (tested with version 0.9.5a and 0.9.6) for signing,
;; encryption and decryption.
;; 2000-06-05 initial version, committed to Gnus CVS contrib/
;; 2000-10-28 retrieve certificates via DNS CERT RRs
;; 2001-10-14 posted to gnu.emacs.sources
+;; 2005-02-13 retrieve certificates via LDAP
;;; Code:
(require 'dig)
+(require 'smime-ldap)
(eval-when-compile (require 'cl))
(defgroup smime nil
string)
:group 'smime)
+(defcustom smime-ldap-host-list nil
+ "A list of LDAP hosts with S/MIME user certificates."
+ :type '(repeat (string :tag "Host name"))
+ :group 'smime)
+
(defvar smime-details-buffer "*OpenSSL output*")
;; Use mm-util?
(kill-buffer digbuf)
retbuf))
+(defun smime-cert-by-ldap-1 (mail host)
+ "Get cetificate for MAIL from the ldap server at HOST."
+ (let ((ldapresult (smime-ldap-search (concat "mail=" mail) host '("userCertificate") nil))
+ (retbuf (generate-new-buffer (format "*certificate for %s*" mail))))
+ (if (> (length ldapresult) 1)
+ (with-current-buffer retbuf
+ (set-buffer-multibyte nil)
+ (insert (nth 1 (car (nth 1 ldapresult))))
+ (goto-char (point-min))
+ (if (smime-call-openssl-region (point-min) (point-max) t "x509" "-inform" "DER" "-outform" "PEM")
+ (progn
+ (delete-region (point) (point-max))
+ retbuf)
+ (kill-buffer retbuf)
+ nil))
+ (kill-buffer retbuf)
+ nil)))
+
+(defun smime-cert-by-ldap (mail)
+ "Find certificate for MAIL."
+ (if smime-ldap-host-list
+ (catch 'certbuf
+ (dolist (host smime-ldap-host-list)
+ (let ((retbuf (smime-cert-by-ldap-1 mail host)))
+ (when retbuf
+ (throw 'certbuf retbuf)))))))
+
;; User interface.
(defvar smime-buffer "*SMIME*")