Mercurial > emacs
annotate lisp/net/eudcb-ldap.el @ 42597:255b72a74a90
*** empty log message ***
author | Jaeyoun Chung <jay@kldp.org> |
---|---|
date | Mon, 07 Jan 2002 07:36:15 +0000 |
parents | 281571076b02 |
children | 897623591168 |
rev | line source |
---|---|
27313 | 1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend |
2 | |
3 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Oscar Figueiredo <oscar@xemacs.org> | |
6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org> | |
42574 | 7 ;; Keywords: comm |
27313 | 8 |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 ;; Boston, MA 02111-1307, USA. | |
25 | |
26 ;;; Commentary: | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
27 ;; This library provides specific LDAP protocol support for the |
27313 | 28 ;; Emacs Unified Directory Client package |
29 | |
30 ;;; Installation: | |
31 ;; Install EUDC first. See EUDC documentation. | |
32 | |
33 ;;; Code: | |
34 | |
35 (require 'eudc) | |
36 (require 'ldap) | |
37 | |
38 | |
39 ;;{{{ Internal cooking | |
40 | |
41 (eval-and-compile | |
42 (if (fboundp 'ldap-get-host-parameter) | |
43 (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) | |
44 (defun eudc-ldap-get-host-parameter (host parameter) | |
45 "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." | |
46 (plist-get (cdr (assoc host ldap-host-parameters-alist)) | |
47 parameter)))) | |
48 | |
49 (defvar eudc-ldap-attributes-translation-alist | |
50 '((name . sn) | |
51 (firstname . givenname) | |
52 (email . mail) | |
53 (phone . telephonenumber)) | |
54 "Alist mapping EUDC attribute names to LDAP names.") | |
55 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
56 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
27313 | 57 'ldap) |
58 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | |
59 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
60 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
27313 | 61 'eudc-ldap-attributes-translation-alist 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
62 (eudc-protocol-set 'eudc-bbdb-conversion-alist |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
63 'eudc-ldap-bbdb-conversion-alist |
27313 | 64 'ldap) |
65 (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
|
66 (eudc-protocol-set 'eudc-attribute-display-method-alist |
27313 | 67 '(("jpegphoto" . eudc-display-jpeg-inline) |
68 ("labeledurl" . eudc-display-url) | |
69 ("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
|
70 ("labeleduri" . eudc-display-url) |
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)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
131 (mapcar |
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 | |
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)) | |
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 | |
210 ;;; eudcb-ldap.el ends here |