Mercurial > emacs
annotate lisp/net/eudcb-ldap.el @ 94980:51e9d65c90fc
Merge from gnus--devo--0
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1161
author | Miles Bader <miles@gnu.org> |
---|---|
date | Thu, 15 May 2008 00:26:27 +0000 |
parents | 91e5880a36c1 |
children | a9dc0e7c3f2b |
rev | line source |
---|---|
27313 | 1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend |
2 | |
74509 | 3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
79714 | 4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
27313 | 5 |
42779
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
6 ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz> |
42574 | 8 ;; Keywords: comm |
27313 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
12 ;; GNU Emacs is free software: you can redistribute it and/or modify |
27313 | 13 ;; it under the terms of the GNU General Public License as published by |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
14 ;; the Free Software Foundation, either version 3 of the License, or |
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
15 ;; (at your option) any later version. |
27313 | 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 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
27313 | 24 |
25 ;;; Commentary: | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
26 ;; This library provides specific LDAP protocol support for the |
27313 | 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 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
55 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
27313 | 56 'ldap) |
57 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | |
58 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
59 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
27313 | 60 'eudc-ldap-attributes-translation-alist 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
61 (eudc-protocol-set 'eudc-bbdb-conversion-alist |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
62 'eudc-ldap-bbdb-conversion-alist |
27313 | 63 'ldap) |
64 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
65 (eudc-protocol-set 'eudc-attribute-display-method-alist |
27313 | 66 '(("jpegphoto" . eudc-display-jpeg-inline) |
67 ("labeledurl" . eudc-display-url) | |
68 ("audio" . eudc-display-sound) | |
42565
ede718edd19b
(eudc-attribute-display-method-alist): Use proper attribute name labeledUri
Pavel Janík <Pavel@Janik.cz>
parents:
27313
diff
changeset
|
69 ("labeleduri" . eudc-display-url) |
42779
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
70 ("mail" . eudc-display-mail) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
71 ("url" . eudc-display-url)) |
27313 | 72 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
73 (eudc-protocol-set 'eudc-switch-to-server-hook |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
74 '(eudc-ldap-check-base) |
27313 | 75 'ldap) |
76 | |
77 (defun eudc-ldap-cleanup-record-simple (record) | |
78 "Do some cleanup in a RECORD to make it suitable for EUDC." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
79 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
80 (function |
27313 | 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: | |
42578
281571076b02
(eudc-ldap-get-field-list): Do not try to call non-existent function.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
92 ;; Make the record a cons-cell instead of a list if it is single-valued |
27313 | 93 ;; Filter the $ character in addresses into \n if not done by the LDAP lib |
94 (defun eudc-ldap-cleanup-record-filtering-addresses (record) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
95 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
96 (function |
27313 | 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. | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
110 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
111 LDAP attribute names. |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
112 RETURN-ATTRS is a list of attributes to return, defaulting to |
27313 | 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) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
121 (setq result |
27313 | 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)) | |
85227
d1f4134ad896
(eudc-ldap-simple-query-internal): Use mapc rather than mapcar.
Glenn Morris <rgm@gnu.org>
parents:
78230
diff
changeset
|
131 (mapc |
27313 | 132 (function (lambda (record) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
133 (setq final-result |
27313 | 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)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
146 (let ((ldap-host-parameters-alist |
27313 | 147 (list (cons eudc-server |
148 '(scope subtree sizelimit 1))))) | |
42578
281571076b02
(eudc-ldap-get-field-list): Do not try to call non-existent function.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
149 (mapcar 'eudc-ldap-cleanup-record-simple |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
150 (ldap-search |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
151 (eudc-ldap-format-query-as-rfc1558 |
27313 | 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." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
159 ;; Note that * should also be escaped but in most situations I suppose |
27313 | 160 ;; the user doesn't want this |
161 (eudc-replace-in-string | |
162 (eudc-replace-in-string | |
163 (eudc-replace-in-string | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
164 (eudc-replace-in-string |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
165 string |
27313 | 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." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
173 (format "(&%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
174 (apply 'concat |
27313 | 175 (mapcar '(lambda (item) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
176 (format "(%s=%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
177 (car item) |
27313 | 178 (eudc-ldap-escape-query-special-chars (cdr item)))) |
179 query)))) | |
180 | |
181 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
182 ;;}}} |
27313 | 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 | |
65689
96187e7edd1b
2005-09-25 Romain Francoise <romain@orebokech.com>
Romain Francoise <romain@orebokech.com>
parents:
64701
diff
changeset
|
195 (null (y-or-n-p "No search base defined. Configure it now? "))) |
27313 | 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)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
199 (setq ldap-host-parameters-alist |
27313 | 200 (cons (list eudc-server) ldap-host-parameters-alist))) |
201 (customize-variable 'ldap-host-parameters-alist))) | |
202 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
203 ;;}}} |
27313 | 204 |
205 | |
206 (eudc-register-protocol 'ldap) | |
207 | |
208 (provide 'eudcb-ldap) | |
209 | |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87649
diff
changeset
|
210 ;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b |
27313 | 211 ;;; eudcb-ldap.el ends here |