lisp/net/eudcb-ldap.el

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