code.delx.au - gnu-emacs/blob - lisp/net/eudcb-ldap.el

   1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
   2
   3 ;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   6 ;;         Pavel Janík <Pavel@Janik.cz>
   7 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
   8 ;; Keywords: comm
   9 ;; Package: eudc
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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
  75 (defun eudc-ldap-cleanup-record-simple (record)
  76   "Do some cleanup in a RECORD to make it suitable for EUDC."
  77   (declare (obsolete eudc-ldap-cleanup-record-filtering-addresses "25.1"))
  78   (mapcar
  79    (function
  80     (lambda (field)
  81       (cons (intern (downcase (car field)))
  82             (if (cdr (cdr field))
  83                 (cdr field)
  84               (car (cdr field))))))
  85    record))
  86
  87 (defun eudc-filter-$ (string)
  88   (mapconcat 'identity (split-string string "\\$") "\n"))
  89
  90 (defun eudc-ldap-cleanup-record-filtering-addresses (record)
  91   "Clean up RECORD to make it suitable for EUDC.
  92 Make the record a cons-cell instead of a list if it is
  93 single-valued.  Change the `$' character in postal addresses to a
  94 newline.  Combine separate mail fields into one mail field with
  95 multiple addresses."
  96   (let ((clean-up-addresses (or (not (boundp 'ldap-ignore-attribute-codings))
  97                                 (not ldap-ignore-attribute-codings)))
  98         result mail-addresses)
  99     (dolist (field record)
 100       ;; Some servers return case-sensitive names (e.g. givenName
 101       ;; instead of givenname); downcase the field's name so that it
 102       ;; can be matched against
 103       ;; eudc-ldap-attributes-translation-alist.
 104       (let ((name (intern (downcase (car field))))
 105             (value (cdr field)))
 106         (when (and clean-up-addresses
 107                    (memq name '(postaladdress registeredaddress)))
 108           (setq value (mapcar 'eudc-filter-$ value)))
 109         (if (eq name 'mail)
 110             (setq mail-addresses (append mail-addresses value))
 111           (push (cons name (if (cdr value)
 112                                value
 113                              (car value)))
 114                 result))))
 115     (push (cons 'mail (if (cdr mail-addresses)
 116                           mail-addresses
 117                         (car mail-addresses)))
 118           result)
 119     (nreverse result)))
 120
 121 (defun eudc-ldap-simple-query-internal (query &optional return-attrs)
 122   "Query the LDAP server with QUERY.
 123 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
 124 LDAP attribute names.
 125 RETURN-ATTRS is a list of attributes to return, defaulting to
 126 `eudc-default-return-attributes'."
 127   (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
 128                              eudc-server
 129                              (if (listp return-attrs)
 130                                  (mapcar 'symbol-name return-attrs))))
 131         final-result)
 132     (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
 133
 134     (if (and eudc-strict-return-matches
 135              return-attrs
 136              (not (eq 'all return-attrs)))
 137         (setq result (eudc-filter-partial-records result return-attrs)))
 138     ;; Apply eudc-duplicate-attribute-handling-method
 139     (if (not (eq 'list eudc-duplicate-attribute-handling-method))
 140         (mapc
 141          (function (lambda (record)
 142                      (setq final-result
 143                            (append (eudc-filter-duplicate-attributes record)
 144                                    final-result))))
 145          result))
 146     final-result))
 147
 148 (defun eudc-ldap-get-field-list (_dummy &optional objectclass)
 149   "Return a list of valid attribute names for the current server.
 150 OBJECTCLASS is the LDAP object class for which the valid
 151 attribute names are returned. Default to `person'"
 152   (interactive)
 153   (or eudc-server
 154       (call-interactively 'eudc-set-server))
 155   (let ((ldap-host-parameters-alist
 156          (list (cons eudc-server
 157                      '(scope subtree sizelimit 1)))))
 158     (mapcar 'eudc-ldap-cleanup-record-filtering-addresses
 159             (ldap-search
 160              (eudc-ldap-format-query-as-rfc1558
 161               (list (cons "objectclass"
 162                           (or objectclass
 163                               "person"))))
 164              eudc-server nil t))))
 165
 166 (defun eudc-ldap-escape-query-special-chars (string)
 167   "Value is STRING with characters forbidden in LDAP queries escaped."
 168 ;; Note that * should also be escaped but in most situations I suppose
 169 ;; the user doesn't want this
 170   (eudc-replace-in-string
 171    (eudc-replace-in-string
 172     (eudc-replace-in-string
 173       (eudc-replace-in-string
 174        string
 175        "\\\\" "\\5c")
 176       "(" "\\28")
 177      ")" "\\29")
 178    (char-to-string ?\0) "\\00"))
 179
 180 (defun eudc-ldap-format-query-as-rfc1558 (query)
 181   "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
 182   (let ((formatter (lambda (item &optional wildcard)
 183                      (format "(%s=%s)"
 184                              (car item)
 185                              (concat
 186                               (eudc-ldap-escape-query-special-chars
 187                                (cdr item)) (if wildcard "*" ""))))))
 188     (format "(&%s)"
 189             (concat
 190              (mapconcat formatter (butlast query) "")
 191              (funcall formatter (car (last query)) t)))))
 192
 193 ;;}}}
 194
 195 ;;{{{      High-level interfaces (interactive functions)
 196
 197 (defun eudc-ldap-customize ()
 198   "Customize the EUDC LDAP support."
 199   (interactive)
 200   (customize-group 'eudc-ldap))
 201
 202 (defun eudc-ldap-check-base ()
 203   "Check if the current LDAP server has a configured search base."
 204   (unless (or (eudc-ldap-get-host-parameter eudc-server 'base)
 205               ldap-default-base
 206               (null (y-or-n-p "No search base defined. Configure it now? ")))
 207     ;; If the server is not in ldap-host-parameters-alist we add it for the
 208     ;; user
 209     (if (null (assoc eudc-server ldap-host-parameters-alist))
 210         (setq ldap-host-parameters-alist
 211               (cons (list eudc-server) ldap-host-parameters-alist)))
 212     (customize-variable 'ldap-host-parameters-alist)))
 213
 214 ;;}}}
 215
 216
 217 (eudc-register-protocol 'ldap)
 218
 219 (provide 'eudcb-ldap)
 220
 221 ;;; eudcb-ldap.el ends here