Commit | Line | Data |
---|---|---|
c38e0c97 | 1 | ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- coding: utf-8 -*- |
7970b229 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1998-2014 Free Software Foundation, Inc. |
7970b229 | 4 | |
ee9a44ab | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
c38e0c97 | 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> |
ab651127 | 7 | ;; Keywords: comm |
bd78fa1d | 8 | ;; Package: eudc |
7970b229 GM |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
874a927a | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
7970b229 | 13 | ;; it under the terms of the GNU General Public License as published by |
874a927a GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
7970b229 GM |
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 | |
874a927a | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
7970b229 GM |
24 | |
25 | ;;; Commentary: | |
aed3fbc3 | 26 | ;; This library provides specific LDAP protocol support for the |
7970b229 GM |
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 | ||
aed3fbc3 | 55 | (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
7970b229 GM |
56 | 'ldap) |
57 | (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | |
58 | 'ldap) | |
aed3fbc3 | 59 | (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
7970b229 | 60 | 'eudc-ldap-attributes-translation-alist 'ldap) |
aed3fbc3 PJ |
61 | (eudc-protocol-set 'eudc-bbdb-conversion-alist |
62 | 'eudc-ldap-bbdb-conversion-alist | |
7970b229 GM |
63 | 'ldap) |
64 | (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) | |
aed3fbc3 | 65 | (eudc-protocol-set 'eudc-attribute-display-method-alist |
7970b229 GM |
66 | '(("jpegphoto" . eudc-display-jpeg-inline) |
67 | ("labeledurl" . eudc-display-url) | |
68 | ("audio" . eudc-display-sound) | |
bae297c2 | 69 | ("labeleduri" . eudc-display-url) |
ee9a44ab | 70 | ("mail" . eudc-display-mail) |
aed3fbc3 | 71 | ("url" . eudc-display-url)) |
7970b229 | 72 | 'ldap) |
aed3fbc3 PJ |
73 | (eudc-protocol-set 'eudc-switch-to-server-hook |
74 | '(eudc-ldap-check-base) | |
7970b229 GM |
75 | 'ldap) |
76 | ||
77 | (defun eudc-ldap-cleanup-record-simple (record) | |
78 | "Do some cleanup in a RECORD to make it suitable for EUDC." | |
aed3fbc3 PJ |
79 | (mapcar |
80 | (function | |
7970b229 GM |
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: | |
527813ef | 92 | ;; Make the record a cons-cell instead of a list if it is single-valued |
7970b229 GM |
93 | ;; Filter the $ character in addresses into \n if not done by the LDAP lib |
94 | (defun eudc-ldap-cleanup-record-filtering-addresses (record) | |
aed3fbc3 PJ |
95 | (mapcar |
96 | (function | |
7970b229 GM |
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. | |
aed3fbc3 PJ |
110 | QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
111 | LDAP attribute names. | |
112 | RETURN-ATTRS is a list of attributes to return, defaulting to | |
7970b229 GM |
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) | |
aed3fbc3 | 121 | (setq result |
7970b229 GM |
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)) | |
fdad1919 | 131 | (mapc |
7970b229 | 132 | (function (lambda (record) |
aed3fbc3 | 133 | (setq final-result |
7970b229 GM |
134 | (append (eudc-filter-duplicate-attributes record) |
135 | final-result)))) | |
136 | result)) | |
137 | final-result)) | |
138 | ||
6c42fc3e | 139 | (defun eudc-ldap-get-field-list (_dummy &optional objectclass) |
7970b229 GM |
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)) | |
aed3fbc3 | 146 | (let ((ldap-host-parameters-alist |
7970b229 GM |
147 | (list (cons eudc-server |
148 | '(scope subtree sizelimit 1))))) | |
527813ef | 149 | (mapcar 'eudc-ldap-cleanup-record-simple |
aed3fbc3 PJ |
150 | (ldap-search |
151 | (eudc-ldap-format-query-as-rfc1558 | |
7970b229 GM |
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." | |
aed3fbc3 | 159 | ;; Note that * should also be escaped but in most situations I suppose |
7970b229 GM |
160 | ;; the user doesn't want this |
161 | (eudc-replace-in-string | |
162 | (eudc-replace-in-string | |
163 | (eudc-replace-in-string | |
aed3fbc3 PJ |
164 | (eudc-replace-in-string |
165 | string | |
7970b229 GM |
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." | |
aed3fbc3 PJ |
173 | (format "(&%s)" |
174 | (apply 'concat | |
4f91a816 SM |
175 | (mapcar (lambda (item) |
176 | (format "(%s=%s)" | |
177 | (car item) | |
178 | (eudc-ldap-escape-query-special-chars (cdr item)))) | |
7970b229 GM |
179 | query)))) |
180 | ||
181 | ||
aed3fbc3 | 182 | ;;}}} |
7970b229 GM |
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 | |
ce5a3ac0 | 195 | (null (y-or-n-p "No search base defined. Configure it now? "))) |
7970b229 GM |
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)) | |
aed3fbc3 | 199 | (setq ldap-host-parameters-alist |
7970b229 GM |
200 | (cons (list eudc-server) ldap-host-parameters-alist))) |
201 | (customize-variable 'ldap-host-parameters-alist))) | |
202 | ||
aed3fbc3 | 203 | ;;}}} |
7970b229 GM |
204 | |
205 | ||
206 | (eudc-register-protocol 'ldap) | |
207 | ||
208 | (provide 'eudcb-ldap) | |
209 | ||
210 | ;;; eudcb-ldap.el ends here |