24 |
;; Boston, MA 02111-1307, USA. |
;; Boston, MA 02111-1307, USA. |
25 |
|
|
26 |
;;; Commentary: |
;;; Commentary: |
27 |
;; This library provides specific LDAP protocol support for the |
;; This library provides specific LDAP protocol support for the |
28 |
;; Emacs Unified Directory Client package |
;; Emacs Unified Directory Client package |
29 |
|
|
30 |
;;; Installation: |
;;; Installation: |
53 |
(phone . telephonenumber)) |
(phone . telephonenumber)) |
54 |
"Alist mapping EUDC attribute names to LDAP names.") |
"Alist mapping EUDC attribute names to LDAP names.") |
55 |
|
|
56 |
(eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
(eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
57 |
'ldap) |
'ldap) |
58 |
(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list |
(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list |
59 |
'ldap) |
'ldap) |
60 |
(eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
(eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
61 |
'eudc-ldap-attributes-translation-alist 'ldap) |
'eudc-ldap-attributes-translation-alist 'ldap) |
62 |
(eudc-protocol-set 'eudc-bbdb-conversion-alist |
(eudc-protocol-set 'eudc-bbdb-conversion-alist |
63 |
'eudc-ldap-bbdb-conversion-alist |
'eudc-ldap-bbdb-conversion-alist |
64 |
'ldap) |
'ldap) |
65 |
(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) |
(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) |
66 |
(eudc-protocol-set 'eudc-attribute-display-method-alist |
(eudc-protocol-set 'eudc-attribute-display-method-alist |
67 |
'(("jpegphoto" . eudc-display-jpeg-inline) |
'(("jpegphoto" . eudc-display-jpeg-inline) |
68 |
("labeledurl" . eudc-display-url) |
("labeledurl" . eudc-display-url) |
69 |
("audio" . eudc-display-sound) |
("audio" . eudc-display-sound) |
70 |
("labeleduri" . eudc-display-url) |
("labeleduri" . eudc-display-url) |
71 |
("url" . eudc-display-url)) |
("url" . eudc-display-url)) |
72 |
'ldap) |
'ldap) |
73 |
(eudc-protocol-set 'eudc-switch-to-server-hook |
(eudc-protocol-set 'eudc-switch-to-server-hook |
74 |
'(eudc-ldap-check-base) |
'(eudc-ldap-check-base) |
75 |
'ldap) |
'ldap) |
76 |
|
|
77 |
(defun eudc-ldap-cleanup-record-simple (record) |
(defun eudc-ldap-cleanup-record-simple (record) |
78 |
"Do some cleanup in a RECORD to make it suitable for EUDC." |
"Do some cleanup in a RECORD to make it suitable for EUDC." |
79 |
(mapcar |
(mapcar |
80 |
(function |
(function |
81 |
(lambda (field) |
(lambda (field) |
82 |
(cons (intern (car field)) |
(cons (intern (car field)) |
83 |
(if (cdr (cdr field)) |
(if (cdr (cdr field)) |
92 |
;; Make the record a cons-cell instead of a list if the it's single-valued |
;; Make the record a cons-cell instead of a list if the it's single-valued |
93 |
;; Filter the $ character in addresses into \n if not done by the LDAP lib |
;; Filter the $ character in addresses into \n if not done by the LDAP lib |
94 |
(defun eudc-ldap-cleanup-record-filtering-addresses (record) |
(defun eudc-ldap-cleanup-record-filtering-addresses (record) |
95 |
(mapcar |
(mapcar |
96 |
(function |
(function |
97 |
(lambda (field) |
(lambda (field) |
98 |
(let ((name (intern (car field))) |
(let ((name (intern (car field))) |
99 |
(value (cdr field))) |
(value (cdr field))) |
107 |
|
|
108 |
(defun eudc-ldap-simple-query-internal (query &optional return-attrs) |
(defun eudc-ldap-simple-query-internal (query &optional return-attrs) |
109 |
"Query the LDAP server with QUERY. |
"Query the LDAP server with QUERY. |
110 |
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
111 |
LDAP attribute names. |
LDAP attribute names. |
112 |
RETURN-ATTRS is a list of attributes to return, defaulting to |
RETURN-ATTRS is a list of attributes to return, defaulting to |
113 |
`eudc-default-return-attributes'." |
`eudc-default-return-attributes'." |
114 |
(let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) |
(let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) |
115 |
eudc-server |
eudc-server |
118 |
final-result) |
final-result) |
119 |
(if (or (not (boundp 'ldap-ignore-attribute-codings)) |
(if (or (not (boundp 'ldap-ignore-attribute-codings)) |
120 |
ldap-ignore-attribute-codings) |
ldap-ignore-attribute-codings) |
121 |
(setq result |
(setq result |
122 |
(mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) |
(mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) |
123 |
(setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) |
(setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) |
124 |
|
|
128 |
(setq result (eudc-filter-partial-records result return-attrs))) |
(setq result (eudc-filter-partial-records result return-attrs))) |
129 |
;; Apply eudc-duplicate-attribute-handling-method |
;; Apply eudc-duplicate-attribute-handling-method |
130 |
(if (not (eq 'list eudc-duplicate-attribute-handling-method)) |
(if (not (eq 'list eudc-duplicate-attribute-handling-method)) |
131 |
(mapcar |
(mapcar |
132 |
(function (lambda (record) |
(function (lambda (record) |
133 |
(setq final-result |
(setq final-result |
134 |
(append (eudc-filter-duplicate-attributes record) |
(append (eudc-filter-duplicate-attributes record) |
135 |
final-result)))) |
final-result)))) |
136 |
result)) |
result)) |
143 |
(interactive) |
(interactive) |
144 |
(or eudc-server |
(or eudc-server |
145 |
(call-interactively 'eudc-set-server)) |
(call-interactively 'eudc-set-server)) |
146 |
(let ((ldap-host-parameters-alist |
(let ((ldap-host-parameters-alist |
147 |
(list (cons eudc-server |
(list (cons eudc-server |
148 |
'(scope subtree sizelimit 1))))) |
'(scope subtree sizelimit 1))))) |
149 |
(mapcar 'eudc-ldap-cleanup-record |
(mapcar 'eudc-ldap-cleanup-record |
150 |
(ldap-search |
(ldap-search |
151 |
(eudc-ldap-format-query-as-rfc1558 |
(eudc-ldap-format-query-as-rfc1558 |
152 |
(list (cons "objectclass" |
(list (cons "objectclass" |
153 |
(or objectclass |
(or objectclass |
154 |
"person")))) |
"person")))) |
156 |
|
|
157 |
(defun eudc-ldap-escape-query-special-chars (string) |
(defun eudc-ldap-escape-query-special-chars (string) |
158 |
"Value is STRING with characters forbidden in LDAP queries escaped." |
"Value is STRING with characters forbidden in LDAP queries escaped." |
159 |
;; Note that * should also be escaped but in most situations I suppose |
;; Note that * should also be escaped but in most situations I suppose |
160 |
;; the user doesn't want this |
;; the user doesn't want this |
161 |
(eudc-replace-in-string |
(eudc-replace-in-string |
162 |
(eudc-replace-in-string |
(eudc-replace-in-string |
163 |
(eudc-replace-in-string |
(eudc-replace-in-string |
164 |
(eudc-replace-in-string |
(eudc-replace-in-string |
165 |
string |
string |
166 |
"\\\\" "\\5c") |
"\\\\" "\\5c") |
167 |
"(" "\\28") |
"(" "\\28") |
168 |
")" "\\29") |
")" "\\29") |
170 |
|
|
171 |
(defun eudc-ldap-format-query-as-rfc1558 (query) |
(defun eudc-ldap-format-query-as-rfc1558 (query) |
172 |
"Format the EUDC QUERY list as a RFC1558 LDAP search filter." |
"Format the EUDC QUERY list as a RFC1558 LDAP search filter." |
173 |
(format "(&%s)" |
(format "(&%s)" |
174 |
(apply 'concat |
(apply 'concat |
175 |
(mapcar '(lambda (item) |
(mapcar '(lambda (item) |
176 |
(format "(%s=%s)" |
(format "(%s=%s)" |
177 |
(car item) |
(car item) |
178 |
(eudc-ldap-escape-query-special-chars (cdr item)))) |
(eudc-ldap-escape-query-special-chars (cdr item)))) |
179 |
query)))) |
query)))) |
180 |
|
|
181 |
|
|
182 |
;;}}} |
;;}}} |
183 |
|
|
184 |
;;{{{ High-level interfaces (interactive functions) |
;;{{{ High-level interfaces (interactive functions) |
185 |
|
|
196 |
;; If the server is not in ldap-host-parameters-alist we add it for the |
;; If the server is not in ldap-host-parameters-alist we add it for the |
197 |
;; user |
;; user |
198 |
(if (null (assoc eudc-server ldap-host-parameters-alist)) |
(if (null (assoc eudc-server ldap-host-parameters-alist)) |
199 |
(setq ldap-host-parameters-alist |
(setq ldap-host-parameters-alist |
200 |
(cons (list eudc-server) ldap-host-parameters-alist))) |
(cons (list eudc-server) ldap-host-parameters-alist))) |
201 |
(customize-variable 'ldap-host-parameters-alist))) |
(customize-variable 'ldap-host-parameters-alist))) |
202 |
|
|
203 |
;;;}}} |
;;}}} |
204 |
|
|
205 |
|
|
206 |
(eudc-register-protocol 'ldap) |
(eudc-register-protocol 'ldap) |