cgit.sxemacs.org Git - packages/blob - xemacs-packages/eudc/eudcb-ldap.el

   1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@xemacs.org>
   6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
   7 ;; Created: Feb 1998
   8 ;; Version: $Revision: 1.2 $
   9 ;; Keywords: help
  10
  11 ;; This file is part of XEmacs
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29 ;;    This library provides specific LDAP protocol support for the
  30 ;;    Emacs Unified Directory Client package
  31
  32 ;;; Installation:
  33 ;;    Install EUDC first. See EUDC documentation.
  34
  35 ;;; Code:
  36
  37 (require 'eudc)
  38 (require 'ldap)
  39
  40
  41 ;;{{{      Internal cooking
  42
  43 (eval-and-compile
  44   (if (fboundp 'ldap-get-host-parameter)
  45       (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter)
  46     (defun eudc-ldap-get-host-parameter (host parameter)
  47       "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
  48       (plist-get (cdr (assoc host ldap-host-parameters-alist))
  49                  parameter))))
  50
  51 (defvar eudc-ldap-attributes-translation-alist
  52   '((name . sn)
  53     (firstname . givenname)
  54     (email . mail)
  55     (phone . telephonenumber))
  56   "Alist mapping EUDC attribute names to LDAP names.")
  57
  58 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal
  59                    'ldap)
  60 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list
  61                    'ldap)
  62 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist
  63                    'eudc-ldap-attributes-translation-alist 'ldap)
  64 (eudc-protocol-set 'eudc-bbdb-conversion-alist
  65                    'eudc-ldap-bbdb-conversion-alist
  66                    'ldap)
  67 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)
  68 (eudc-protocol-set 'eudc-attribute-display-method-alist
  69                    '(("jpegphoto" . eudc-display-jpeg-inline)
  70                      ("labeledurl" . eudc-display-url)
  71                      ("audio" . eudc-display-sound)
  72                      ("labeledurl" . eudc-display-url)
  73                      ("url" . eudc-display-url))
  74                    'ldap)
  75 (eudc-protocol-set 'eudc-switch-to-server-hook
  76                    '(eudc-ldap-check-base)
  77                    'ldap)
  78
  79 (defun eudc-ldap-cleanup-record-simple (record)
  80   "Do some cleanup in a RECORD to make it suitable for EUDC."
  81   (mapcar
  82    (function
  83     (lambda (field)
  84       (cons (intern (car field))
  85             (if (cdr (cdr field))
  86                 (cdr field)
  87               (car (cdr field))))))
  88    record))
  89
  90 (defun eudc-filter-$ (string)
  91   (mapconcat 'identity (split-string string "\\$") "\n"))
  92
  93 ;; Cleanup a LDAP record to make it suitable for EUDC:
  94 ;;   Make the record a cons-cell instead of a list if the it's single-valued
  95 ;;   Filter the $ character in addresses into \n if not done by the LDAP lib
  96 (defun eudc-ldap-cleanup-record-filtering-addresses (record)
  97   (mapcar
  98    (function
  99     (lambda (field)
 100       (let ((name (intern (car field)))
 101             (value (cdr field)))
 102         (if (memq name '(postaladdress registeredaddress))
 103             (setq value (mapcar 'eudc-filter-$ value)))
 104         (cons name
 105               (if (cdr value)
 106                   value
 107                 (car value))))))
 108    record))
 109
 110 (defun eudc-ldap-simple-query-internal (query &optional return-attrs)
 111   "Query the LDAP server with QUERY.
 112 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
 113 LDAP attribute names.
 114 RETURN-ATTRS is a list of attributes to return, defaulting to
 115 `eudc-default-return-attributes'."
 116   (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
 117                              eudc-server
 118                              (if (listp return-attrs)
 119                                  (mapcar 'symbol-name return-attrs))))
 120         final-result)
 121     (if (or (not (boundp 'ldap-ignore-attribute-codings))
 122             ldap-ignore-attribute-codings)
 123         (setq result
 124               (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
 125       (setq result (mapcar 'eudc-ldap-cleanup-record-simple result)))
 126
 127     (if (and eudc-strict-return-matches
 128              return-attrs
 129              (not (eq 'all return-attrs)))
 130         (setq result (eudc-filter-partial-records result return-attrs)))
 131     ;; Apply eudc-duplicate-attribute-handling-method
 132     (if (not (eq 'list eudc-duplicate-attribute-handling-method))
 133         (mapcar
 134          (function (lambda (record)
 135                      (setq final-result
 136                            (append (eudc-filter-duplicate-attributes record)
 137                                    final-result))))
 138          result))
 139     final-result))
 140
 141 (defun eudc-ldap-get-field-list (dummy &optional objectclass)
 142   "Return a list of valid attribute names for the current server.
 143 OBJECTCLASS is the LDAP object class for which the valid
 144 attribute names are returned. Default to `person'"
 145   (interactive)
 146   (or eudc-server
 147       (call-interactively 'eudc-set-server))
 148   (let ((ldap-host-parameters-alist
 149          (list (cons eudc-server
 150                      '(scope subtree sizelimit 1)))))
 151     (mapcar 'eudc-ldap-cleanup-record
 152             (ldap-search
 153              (eudc-ldap-format-query-as-rfc1558
 154               (list (cons "objectclass"
 155                           (or objectclass
 156                               "person"))))
 157              eudc-server nil t))))
 158
 159 (defun eudc-ldap-escape-query-special-chars (string)
 160   "Value is STRING with characters forbidden in LDAP queries escaped."
 161 ;; Note that * should also be escaped but in most situations I suppose
 162 ;; the user doesn't want this
 163   (eudc-replace-in-string
 164    (eudc-replace-in-string
 165     (eudc-replace-in-string
 166       (eudc-replace-in-string
 167        string
 168        "\\\\" "\\5c")
 169       "(" "\\28")
 170      ")" "\\29")
 171    (char-to-string ?\0) "\\00"))
 172
 173 (defun eudc-ldap-format-query-as-rfc1558 (query)
 174   "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
 175   (format "(&%s)"
 176           (apply 'concat
 177                  (mapcar '(lambda (item)
 178                             (format "(%s=%s)"
 179                                     (car item)
 180                                     (eudc-ldap-escape-query-special-chars (cdr item))))
 181                          query))))
 182
 183
 184 ;;}}}
 185
 186 ;;{{{      High-level interfaces (interactive functions)
 187
 188 (defun eudc-ldap-customize ()
 189   "Customize the EUDC LDAP support."
 190   (interactive)
 191   (customize-group 'eudc-ldap))
 192
 193 (defun eudc-ldap-check-base ()
 194   "Check if the current LDAP server has a configured search base."
 195   (unless (or (eudc-ldap-get-host-parameter eudc-server 'base)
 196               ldap-default-base
 197               (null (y-or-n-p "No search base defined. Configure it now ?")))
 198     ;; If the server is not in ldap-host-parameters-alist we add it for the
 199     ;; user
 200     (if (null (assoc eudc-server ldap-host-parameters-alist))
 201         (setq ldap-host-parameters-alist
 202               (cons (list eudc-server) ldap-host-parameters-alist)))
 203     (customize-variable 'ldap-host-parameters-alist)))
 204
 205 ;;;}}}
 206
 207
 208 (eudc-register-protocol 'ldap)
 209
 210 (provide 'eudcb-ldap)
 211
 212 ;;; eudcb-ldap.el ends here