lisp/net/eudcb-ldap.el

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