;;; ldap.el --- LDAP support for Emacs

;; Copyright (C) 1997 Free Software Foundation, Inc.

;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Created: Jan 1998
;; Version: $Revision: 1.7.2.6 $
;; Keywords: help comm

;; This file is part of XEmacs

;; XEmacs 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.

;; XEmacs 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 XEmacs; 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 provides mid-level and user-level functions to access directory
;;    servers using the LDAP protocol (RFC 1777). 

;;; Installation:
;;    LDAP support must have been built into XEmacs.


;;; Code:

(defgroup ldap nil
  "Lightweight Directory Access Protocol"
  :group 'comm)

(defcustom ldap-default-host nil
  "*Default LDAP server hostname.
A TCP port number can be appended to that name using a colon as 
a separator."
  :type '(choice (string :tag "Host name")
		 (const :tag "Use library default" nil))
  :group 'ldap)

(defcustom ldap-default-port nil
  "*Default TCP port for LDAP connections.
Initialized from the LDAP library at build time. Default value is 389."
  :type '(choice (const :tag "Use library default" nil)
		 (integer :tag "Port number"))
  :group 'ldap)

(defcustom ldap-default-base nil
  "*Default base for LDAP searches.
This is a string using the syntax of RFC 1779.
For instance, \"o=ACME, c=US\" limits the search to the
Acme organization in the United States."
  :type '(choice (const :tag "Use library default" nil)
		 (string :tag "Search base"))
  :group 'ldap)


(defcustom ldap-host-parameters-alist nil
  "*Alist of host-specific options for LDAP transactions.
The format of each list element is:
\(HOST PROP1 VAL1 PROP2 VAL2 ...)
HOST is the hostname of an LDAP server (with an optional TCP port number
appended to it  using a colon as a separator). 
PROPn and VALn are property/value pairs describing parameters for the server.
Valid properties include:
  `binddn' is the distinguished name of the user to bind as 
    (in RFC 1779 syntax).
  `passwd' is the password to use for simple authentication.
  `auth' is the authentication method to use. 
    Possible values are: `simple', `krbv41' and `krbv42'.
  `base' is the base for the search as described in RFC 1779.
  `scope' is one of the three symbols `subtree', `base' or `onelevel'.
  `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."
  :type '(repeat :menu-tag "Host parameters"
		 :tag "Host parameters"
		 (list :menu-tag "Host parameters"
		       :tag "Host parameters"
		       :value nil
		       (string :tag "Host name")
		       (checklist :inline t
				  :greedy t
				  (list
				   :tag "Search Base" 
				   :inline t
				   (const :tag "Search Base" base)
				   string)
				  (list
				   :tag "Binding DN"
				   :inline t
				   (const :tag "Binding DN" binddn)
				   string)
				  (list
				   :tag "Password"
				   :inline t
				   (const :tag "Password" passwd)
				   string)
				  (list
				   :tag "Authentication Method"
				   :inline t
				   (const :tag "Authentication Method" auth)
				   (choice
				    (const :menu-tag "None" :tag "None" nil)
				    (const :menu-tag "Simple" :tag "Simple" simple)
				    (const :menu-tag "Kerberos 4.1" :tag "Kerberos 4.1" krbv41)
				    (const :menu-tag "Kerberos 4.2" :tag "Kerberos 4.2" krbv42)))
				  (list
				   :tag "Search Scope" 
				   :inline t
				   (const :tag "Search Scope" scope)
				   (choice
				    (const :menu-tag "Default" :tag "Default" nil)
				    (const :menu-tag "Subtree" :tag "Subtree" subtree)
				    (const :menu-tag "Base" :tag "Base" base)
				    (const :menu-tag "One Level" :tag "One Level" onelevel)))
				  (list
				   :tag "Dereferencing"
				   :inline t
				   (const :tag "Dereferencing" deref)
				   (choice
				    (const :menu-tag "Default" :tag "Default" nil)
				    (const :menu-tag "Never" :tag "Never" never)
				    (const :menu-tag "Always" :tag "Always" always)
				    (const :menu-tag "When searching" :tag "When searching" search)
				    (const :menu-tag "When locating base" :tag "When locating base" find)))
				  (list
				   :tag "Time Limit"
				   :inline t
				   (const :tag "Time Limit" timelimit)
				   (integer :tag "(in seconds)"))
				  (list
				   :tag "Size Limit"
				   :inline t
				   (const :tag "Size Limit" sizelimit)
				   (integer :tag "(number of records)")))))
:group 'ldap)

(defcustom ldap-ignore-attribute-codings nil
  "*If non-nil, do not perform any encoding/decoding on LDAP attribute values."
  :type 'boolean
  :group 'ldap)

(defcustom ldap-default-attribute-decoder nil
  "*Decoder function to use for attributes whose syntax is unknown."
  :type 'symbol
  :group 'ldap)

(defcustom ldap-coding-system nil
  "*Coding system of LDAP string values.
LDAP v3 specifies the coding system of strings to be UTF-8.  
Mule support is needed for this."
  :type 'symbol
  :group 'ldap)

(defvar ldap-attribute-syntax-encoders
  [nil					; 1  ACI Item                        N  
   nil					; 2  Access Point                    Y  
   nil					; 3  Attribute Type Description      Y  
   nil					; 4  Audio                           N  
   nil					; 5  Binary                          N  
   nil					; 6  Bit String                      Y  
   ldap-encode-boolean			; 7  Boolean                         Y  
   nil					; 8  Certificate                     N  
   nil					; 9  Certificate List                N  
   nil					; 10 Certificate Pair                N  
   ldap-encode-country-string		; 11 Country String                  Y  
   ldap-encode-string			; 12 DN                              Y  
   nil					; 13 Data Quality Syntax             Y  
   nil					; 14 Delivery Method                 Y  
   ldap-encode-string			; 15 Directory String                Y  
   nil					; 16 DIT Content Rule Description    Y  
   nil					; 17 DIT Structure Rule Description  Y  
   nil					; 18 DL Submit Permission            Y  
   nil					; 19 DSA Quality Syntax              Y  
   nil					; 20 DSE Type                        Y  
   nil					; 21 Enhanced Guide                  Y  
   nil					; 22 Facsimile Telephone Number      Y  
   nil					; 23 Fax                             N  
   nil					; 24 Generalized Time                Y  
   nil					; 25 Guide                           Y  
   nil					; 26 IA5 String                      Y  
   number-to-string			; 27 INTEGER                         Y  
   nil					; 28 JPEG                            N  
   nil					; 29 Master And Shadow Access Points Y  
   nil					; 30 Matching Rule Description       Y  
   nil					; 31 Matching Rule Use Description   Y  
   nil					; 32 Mail Preference                 Y  
   nil					; 33 MHS OR Address                  Y  
   nil					; 34 Name And Optional UID           Y  
   nil					; 35 Name Form Description           Y  
   nil					; 36 Numeric String                  Y  
   nil					; 37 Object Class Description        Y  
   nil					; 38 OID                             Y  
   nil					; 39 Other Mailbox                   Y  
   nil					; 40 Octet String                    Y  
   ldap-encode-address			; 41 Postal Address                  Y  
   nil					; 42 Protocol Information            Y  
   nil					; 43 Presentation Address            Y  
   ldap-encode-string			; 44 Printable String                Y  
   nil					; 45 Subtree Specification           Y  
   nil					; 46 Supplier Information            Y  
   nil					; 47 Supplier Or Consumer            Y  
   nil					; 48 Supplier And Consumer           Y  
   nil					; 49 Supported Algorithm             N  
   nil					; 50 Telephone Number                Y  
   nil					; 51 Teletex Terminal Identifier     Y  
   nil					; 52 Telex Number                    Y  
   nil					; 53 UTC Time                        Y  
   nil					; 54 LDAP Syntax Description         Y  
   nil					; 55 Modify Rights                   Y  
   nil					; 56 LDAP Schema Definition          Y  
   nil					; 57 LDAP Schema Description         Y  
   nil					; 58 Substring Assertion             Y  
   ]  
  "A vector of functions used to encode LDAP attribute values.
The sequence of functions corresponds to the sequence of LDAP attribute syntax
object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in 
RFC2252 section 4.3.2")

(defvar ldap-attribute-syntax-decoders
  [nil					; 1  ACI Item                        N  
   nil					; 2  Access Point                    Y  
   nil					; 3  Attribute Type Description      Y  
   nil					; 4  Audio                           N  
   nil					; 5  Binary                          N  
   nil					; 6  Bit String                      Y  
   ldap-decode-boolean			; 7  Boolean                         Y  
   nil					; 8  Certificate                     N  
   nil					; 9  Certificate List                N  
   nil					; 10 Certificate Pair                N  
   ldap-decode-string			; 11 Country String                  Y  
   ldap-decode-string			; 12 DN                              Y  
   nil					; 13 Data Quality Syntax             Y  
   nil					; 14 Delivery Method                 Y  
   ldap-decode-string			; 15 Directory String                Y  
   nil					; 16 DIT Content Rule Description    Y  
   nil					; 17 DIT Structure Rule Description  Y  
   nil					; 18 DL Submit Permission            Y  
   nil					; 19 DSA Quality Syntax              Y  
   nil					; 20 DSE Type                        Y  
   nil					; 21 Enhanced Guide                  Y  
   nil					; 22 Facsimile Telephone Number      Y  
   nil					; 23 Fax                             N  
   nil					; 24 Generalized Time                Y  
   nil					; 25 Guide                           Y  
   nil					; 26 IA5 String                      Y  
   string-to-number			; 27 INTEGER                         Y  
   nil					; 28 JPEG                            N  
   nil					; 29 Master And Shadow Access Points Y  
   nil					; 30 Matching Rule Description       Y  
   nil					; 31 Matching Rule Use Description   Y  
   nil					; 32 Mail Preference                 Y  
   nil					; 33 MHS OR Address                  Y  
   nil					; 34 Name And Optional UID           Y  
   nil					; 35 Name Form Description           Y  
   nil					; 36 Numeric String                  Y  
   nil					; 37 Object Class Description        Y  
   nil					; 38 OID                             Y  
   nil					; 39 Other Mailbox                   Y  
   nil					; 40 Octet String                    Y  
   ldap-decode-address			; 41 Postal Address                  Y  
   nil					; 42 Protocol Information            Y  
   nil					; 43 Presentation Address            Y  
   ldap-decode-string			; 44 Printable String                Y  
   nil					; 45 Subtree Specification           Y  
   nil					; 46 Supplier Information            Y  
   nil					; 47 Supplier Or Consumer            Y  
   nil					; 48 Supplier And Consumer           Y  
   nil					; 49 Supported Algorithm             N  
   nil					; 50 Telephone Number                Y  
   nil					; 51 Teletex Terminal Identifier     Y  
   nil					; 52 Telex Number                    Y  
   nil					; 53 UTC Time                        Y  
   nil					; 54 LDAP Syntax Description         Y  
   nil					; 55 Modify Rights                   Y  
   nil					; 56 LDAP Schema Definition          Y  
   nil					; 57 LDAP Schema Description         Y  
   nil					; 58 Substring Assertion             Y  
   ]  
  "A vector of functions used to decode LDAP attribute values.
The sequence of functions corresponds to the sequence of LDAP attribute syntax
object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in 
RFC2252 section 4.3.2")


(defvar ldap-attribute-syntaxes-alist
  '((createtimestamp . 24)
    (modifytimestamp . 24)
    (creatorsname . 12)
    (modifiersname . 12)
    (subschemasubentry . 12)
    (attributetypes . 3)
    (objectclasses . 37)
    (matchingrules . 30)
    (matchingruleuse . 31)
    (namingcontexts . 12)
    (altserver . 26)
    (supportedextension . 38)
    (supportedcontrol . 38)
    (supportedsaslmechanisms . 15)
    (supportedldapversion . 27)
    (ldapsyntaxes . 16)
    (ditstructurerules . 17)
    (nameforms . 35)
    (ditcontentrules . 16)
    (objectclass . 38)
    (aliasedobjectname . 12)
    (cn . 15)
    (sn . 15)
    (serialnumber . 44)
    (c . 15)
    (l . 15)
    (st . 15)
    (street . 15)
    (o . 15)
    (ou . 15)
    (title . 15)
    (description . 15)
    (searchguide . 25)
    (businesscategory . 15)
    (postaladdress . 41)
    (postalcode . 15)
    (postofficebox . 15)
    (physicaldeliveryofficename . 15)
    (telephonenumber . 50)
    (telexnumber . 52)
    (telexterminalidentifier . 51)
    (facsimiletelephonenumber . 22)
    (x121address . 36)
    (internationalisdnnumber . 36)
    (registeredaddress . 41)
    (destinationindicator . 44)
    (preferreddeliverymethod . 14)
    (presentationaddress . 43)
    (supportedapplicationcontext . 38)
    (member . 12)
    (owner . 12)
    (roleoccupant . 12)
    (seealso . 12)
    (userpassword . 40)
    (usercertificate . 8)
    (cacertificate . 8)
    (authorityrevocationlist . 9)
    (certificaterevocationlist . 9)
    (crosscertificatepair . 10)
    (name . 15)
    (givenname . 15)
    (initials . 15)
    (generationqualifier . 15)
    (x500uniqueidentifier . 6)
    (dnqualifier . 44)
    (enhancedsearchguide . 21)
    (protocolinformation . 42)
    (distinguishedname . 12)
    (uniquemember . 34)
    (houseidentifier . 15)
    (supportedalgorithms . 49)
    (deltarevocationlist . 9)
    (dmdname . 15))
  "A map of LDAP attribute names to their type object id minor number.
This table is built from RFC2252 Section 5 and RFC2256 Section 5")


;; Coding/decoding functions

(defun ldap-encode-boolean (bool)
  (if bool
      "TRUE"
    "FALSE"))

(defun ldap-decode-boolean (str)
  (cond
   ((string-equal str "TRUE")
    t)
   ((string-equal str "FALSE")
    nil)
   (t
    (error "Wrong LDAP boolean string: %s" str))))
    
(defun ldap-encode-country-string (str)
  ;; We should do something useful here...
  (if (not (= 2 (length str)))
      (error "Invalid country string: %s" str)))

(defun ldap-decode-string (str)
  (if (fboundp 'decode-coding-string)
      (decode-coding-string str ldap-coding-system)))

(defun ldap-encode-string (str)
   (if (fboundp 'encode-coding-string)
       (encode-coding-string str ldap-coding-system)))

(defun ldap-decode-address (str)
  (mapconcat 'ldap-decode-string
	     (split-string str "\\$")
	     "\n"))

(defun ldap-encode-address (str)
  (mapconcat 'ldap-encode-string
	     (split-string str "\n")
	     "$"))


;; LDAP protocol functions
    
(defun ldap-get-host-parameter (host parameter)
  "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
  (plist-get (cdr (assoc host ldap-host-parameters-alist))
	     parameter))
	
(defun ldap-decode-attribute (attr)
  "Decode the attribute/value pair ATTR according to LDAP rules.
The attribute name is looked up in `ldap-attribute-syntaxes-alist' 
and the corresponding decoder is then retrieved from 
`ldap-attribute-syntax-decoders' and applied on the value(s)."
  (let* ((name (car attr))
	 (values (cdr attr))
	 (syntax-id (cdr (assq (intern (downcase name))
			       ldap-attribute-syntaxes-alist)))
	 decoder)
    (if syntax-id
	(setq decoder (aref ldap-attribute-syntax-decoders
			    (1- syntax-id)))
      (setq decoder ldap-default-attribute-decoder))
    (if decoder
	(cons name (mapcar decoder values))
      attr)))
    

(defun ldap-search (filter &optional host attributes attrsonly withdn)
  "Perform an LDAP search.
FILTER is the search filter in RFC1558 syntax, i.e., something that
looks like \"(cn=John Smith)\".
HOST is the LDAP host on which to perform the search.
ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
If ATTRSONLY is non nil, the attributes will be retrieved without
the associated values.
If WITHDN is non-nil each entry in the result will be prepennded with
its distinguished name DN.
Additional search parameters can be specified through 
`ldap-host-parameters-alist' which see.
The function returns a list of matching entries.  Each entry is itself
an alist of attribute/value pairs optionally preceded by the DN of the
entry according to the value of WITHDN."
  (interactive "sFilter:")
  (or host
      (setq host ldap-default-host)
      (error "No LDAP host specified"))
  (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
	ldap
	result)
    (message "Opening LDAP connection to %s..." host)
    (setq ldap (ldap-open host host-plist))
    (message "Searching with LDAP on %s..." host)
    (setq result (ldap-search-internal ldap filter 
				       (plist-get host-plist 'base)
				       (plist-get host-plist 'scope)
				       attributes attrsonly withdn))
    (ldap-close ldap)
    (if ldap-ignore-attribute-codings
	result
      (mapcar (function 
	       (lambda (record)
		 (mapcar 'ldap-decode-attribute record)))
	      result))))

(provide 'ldap)
		
;;; ldap.el ends here