;;; eudc.el --- Emacs Unified Directory Client - LDAP Support

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

;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
;; Created: Feb 1998
;; Version: 1.8
;; Keywords: help

;; 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 library provides specific LDAP protocol support for the 
;;    Emacs Unified Directory Client library.

;;; Installation:
;;    Install EUDC first. See EUDC documentation.

;;    This library runs under XEmacs 20 and under Emacs 19.34 and above

;;; Usage:

;;; Code:

(require 'eudc)
(require 'ldap)


;;{{{      Package customization variables

(defgroup eudc-ldap nil 
  "Emacs Unified Directory Client - LDAP Support"
  :group 'comm)

(defcustom eudc-ldap-bbdb-conversion-alist
  '((name . cn)
    (net . mail)
    (address . (eudc-bbdbify-address postaladdress "Address"))
    (phone . ((eudc-bbdbify-phone telephonenumber "Phone"))))
  "*A mapping from BBDB to LDAP attributes.
This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
BBDB-FIELD is the name of a field that must be defined in your BBDB
environment (standard field names are `name', `company', `net', `phone',
`address' and `notes').  SPEC-OR-LIST is either a single SPEC or a list
of SPECs.  Lists of specs are valid only for the `phone' and `address'
BBDB fields.  SPECs are sexps which are evaluated:
  a string evaluates to itself,
  a symbol evaluates to the symbol value.  Symbols naming LDAP attributes
    present in the record evaluate to the value of the field in the record,
  a form is evaluated as a function.  The argument list may contain LDAP 
    field names which eval to the corresponding values in the
    record.  The form evaluation should return something appropriate for
    the particular BBDB-FIELD (see `bbdb-create-internal').
    `eudc-bbdbify-phone' and `eudc-bbdbify-address' are provided as convenience
    functions to parse phones and addresses."
  :tag "BBDB to LDAP Attribute Names Mapping"
  :type '(repeat (cons :tag "Field Name"
		       (symbol :tag "BBDB Field")
		       (sexp :tag "Conversion Spec")))
  :group 'eudc-ldap)
;;}}}

;;{{{      Internal cooking

;; Whether eudc-inline-query-format should be cleared on switching protocols
;; from LDAP
(defvar eudc-ldap-clear-inline-query-format-on-exit nil)

(defvar eudc-ldap-attributes-translation-alist
  '((name . sn)
    (firstname . givenname)
    (email . mail)
    (phone . telephonenumber))
  "Alist mapping EUDC attribute names to LDAP names.")

(defconst eudc-ldap-protocol-locals 
  '((eudc-query-function . eudc-ldap-simple-query-internal)
    (eudc-list-attributes-function . eudc-ldap-get-field-list)
    (eudc-protocol-attributes-translation-alist . eudc-ldap-attributes-translation-alist)
    (eudc-bbdb-conversion-alist . eudc-ldap-bbdb-conversion-alist)
    (eudc-protocol-switch-init-function . eudc-ldap-protocol-switch-init)
    (eudc-protocol-switch-exit-function . eudc-ldap-protocol-switch-exit))
  "LDAP protocol specific values of EUDC variables.
This should be an alist of the form (EUDC-VAR . LDAP-VAR) where
EUDC-VAR is the name of a EUDC variable and LDAP-VAR is 
the corresponding LDAP-specific variable.")

(defun eudc-filter-$ (string)
  (let ((res ""))
    (while (string-match " \\$ " string)
      (setq res (concat res 
			(substring string 0 (match-beginning 0))
			"\n"))
      (setq string (substring string (match-end 0))))
    (setq res (concat res string))))

(defun eudc-ldap-cleanup-record-field (field)
  "Do some cleanup in a record field to make it suitable for EUDC."
  ;; Make the field a cons-cell if it's single-valued
  (if (stringp (car (cdr field)))
      (cons (intern (car field)) 
	    (eudc-filter-$ (car (cdr field))))
    ;; Otherwise simply make the field name a symbol
    (cons (intern (car field)) (cdr field))))

(defun eudc-ldap-cleanup-record (record)
  (mapcar 'eudc-ldap-cleanup-record-field
	  record))

(defun eudc-ldap-simple-query-internal (query &optional return-attrs)
  "Query the LDAP server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid 
LDAP attribute names.  
RETURN-ATTRS is a list of attributes to return, defaulting to 
`eudc-default-return-attributes'."
  (mapcar 'eudc-ldap-cleanup-record
	  (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
		       eudc-server
		       (mapcar 'symbol-name return-attrs))))

(defun eudc-ldap-get-field-list (dummy &optional objectclass)
  "Return a list of valid attribute names for the current server.
OBJECTCLASS is the LDAP object class for which the valid
attribute names are returned. Default to `person'"
  (interactive)
  (or eudc-server
      (call-interactively 'eudc-set-server))
  (let ((ldap-host-parameters-plist 
	 (list (cons eudc-server
		     '(scope subtree sizelimit 1)))))
    (mapcar 'eudc-ldap-cleanup-record
	    (ldap-search 
	     (eudc-ldap-format-query-as-rfc1558 
	      (list (cons "objectclass"
			  (or objectclass
			      "person"))))
	     eudc-server nil t))))

(defun eudc-ldap-format-query-as-rfc1558 (query)
  "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
  (format "(&%s)" (apply 'concat (mapcar '(lambda (item)
					    (format "(%s=%s)" (car item) (cdr item)))
					 query))))

;; Set eudc-inline-query-format for LDAP since LDAP does not
;; have default query attributes and hence won't accept plain
;; string queries without an associated attribute name
(defun eudc-ldap-set-inline-query-format-maybe ()
  (when (null eudc-inline-query-format)
    (setq eudc-inline-query-format '(name))
    (setq eudc-ldap-clear-inline-query-format-on-exit t)))

(defun eudc-ldap-protocol-switch-init ()
  (eudc-ldap-set-inline-query-format-maybe))

(defun eudc-ldap-protocol-switch-exit ()
  (if eudc-ldap-clear-inline-query-format-on-exit
      (setq eudc-inline-query-format nil)))

;;}}}        

;;{{{      High-level interfaces (interactive functions)

(defun eudc-ldap-customize ()
  "Customize the EUDC LDAP support."
  (interactive)
  (customize-group 'eudc-ldap))

(defun eudc-ldap-set-server (server)
  "Set the LDAP server to SERVER."
  (interactive "sNew LDAP Server: ")
  (eudc-set-server server 'ldap)
  (message "Selected LDAP server is now %s" server))

;;;}}}


(eudc-register-protocol 'ldap eudc-ldap-protocol-locals)

(provide 'eudc-ldap)

;;; eudc-ldap.el ends here