lisp/net/eudcb-ldap.el

   1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 1998-2015 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
  74 (defun eudc-ldap-cleanup-record-simple (record)
  75   "Do some cleanup in a RECORD to make it suitable for EUDC."
  76   (mapcar
  77    (function
  78     (lambda (field)
  79       ;; Some servers return case-sensitive names (e.g. givenName
  80       ;; instead of givenname); downcase the field's name so that it
  81       ;; can be matched against
  82       ;; eudc-ldap-attributes-translation-alist.
  83       (cons (intern (downcase (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 (downcase (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         (mapc
 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   (let ((formatter (lambda (item &optional wildcard)
 175                      (format "(%s=%s)"
 176                              (car item)
 177                              (concat
 178                               (eudc-ldap-escape-query-special-chars
 179                                (cdr item)) (if wildcard "*" ""))))))
 180     (format "(&%s)"
 181             (concat
 182              (mapconcat formatter (butlast query) "")
 183              (funcall formatter (car (last query)) t)))))
 184
 185 ;;}}}
 186
 187 ;;{{{      High-level interfaces (interactive functions)
 188
 189 (defun eudc-ldap-customize ()
 190   "Customize the EUDC LDAP support."
 191   (interactive)
 192   (customize-group 'eudc-ldap))
 193
 194 (defun eudc-ldap-check-base ()
 195   "Check if the current LDAP server has a configured search base."
 196   (unless (or (eudc-ldap-get-host-parameter eudc-server 'base)
 197               ldap-default-base
 198               (null (y-or-n-p "No search base defined. Configure it now? ")))
 199     ;; If the server is not in ldap-host-parameters-alist we add it for the
 200     ;; user
 201     (if (null (assoc eudc-server ldap-host-parameters-alist))
 202         (setq ldap-host-parameters-alist
 203               (cons (list eudc-server) ldap-host-parameters-alist)))
 204     (customize-variable 'ldap-host-parameters-alist)))
 205
 206 ;;}}}
 207
 208
 209 (eudc-register-protocol 'ldap)
 210
 211 (provide 'eudcb-ldap)
 212
 213 ;;; eudcb-ldap.el ends here