lisp/net/eudcb-ldap.el

   1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz>
   8 ;; Keywords: comm
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;    This library provides specific LDAP protocol support for the
  29 ;;    Emacs Unified Directory Client package
  30
  31 ;;; Installation:
  32 ;;    Install EUDC first. See EUDC documentation.
  33
  34 ;;; Code:
  35
  36 (require 'eudc)
  37 (require 'ldap)
  38
  39
  40 ;;{{{      Internal cooking
  41
  42 (eval-and-compile
  43   (if (fboundp 'ldap-get-host-parameter)
  44       (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter)
  45     (defun eudc-ldap-get-host-parameter (host parameter)
  46       "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
  47       (plist-get (cdr (assoc host ldap-host-parameters-alist))
  48                  parameter))))
  49
  50 (defvar eudc-ldap-attributes-translation-alist
  51   '((name . sn)
  52     (firstname . givenname)
  53     (email . mail)
  54     (phone . telephonenumber))
  55   "Alist mapping EUDC attribute names to LDAP names.")
  56
  57 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal
  58                    'ldap)
  59 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list
  60                    'ldap)
  61 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist
  62                    'eudc-ldap-attributes-translation-alist 'ldap)
  63 (eudc-protocol-set 'eudc-bbdb-conversion-alist
  64                    'eudc-ldap-bbdb-conversion-alist
  65                    'ldap)
  66 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)
  67 (eudc-protocol-set 'eudc-attribute-display-method-alist
  68                    '(("jpegphoto" . eudc-display-jpeg-inline)
  69                      ("labeledurl" . eudc-display-url)
  70                      ("audio" . eudc-display-sound)
  71                      ("labeleduri" . eudc-display-url)
  72                      ("mail" . eudc-display-mail)
  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 it is 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         (mapc
 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-simple
 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 ;;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b
 213 ;;; eudcb-ldap.el ends here