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