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 2, 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. 112QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid 113LDAP attribute names. 114RETURN-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 (mapcar 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. 143OBJECTCLASS is the LDAP object class for which the valid 144attribute 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 214