Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code |
71ddfde5 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1998-1999, 2004-2014 Free Software Foundation, Inc. |
bebcf940 | 4 | |
8c8b8430 SM |
5 | ;; Keywords: comm, data, processes |
6 | ||
bebcf940 SM |
7 | ;; This file is part of GNU Emacs. |
8 | ;; | |
4936186e | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
bebcf940 | 10 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
11 | ;; the Free Software Foundation, either version 3 of the License, or |
12 | ;; (at your option) any later version. | |
13 | ||
bebcf940 SM |
14 | ;; GNU Emacs is distributed in the hope that it will be useful, |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
4936186e | 18 | |
bebcf940 | 19 | ;; You should have received a copy of the GNU General Public License |
4936186e | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
bebcf940 SM |
21 | |
22 | ;;; Commentary: | |
23 | ||
24 | ;;; Code: | |
8c8b8430 SM |
25 | |
26 | (require 'url-vars) | |
27 | (require 'url-parse) | |
28 | (require 'url-util) | |
bebcf940 | 29 | (require 'ldap) |
5bbb0eb9 | 30 | (autoload 'tls-certificate-information "tls") |
8c8b8430 SM |
31 | |
32 | ;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997) | |
33 | ;; | |
34 | ;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions | |
35 | ;; | |
36 | ;; Test URLs: | |
37 | ;; ldap://ldap.itd.umich.edu/cn%3Dumbflabmanager%2C%20ou%3DUser%20Groups%2C%20ou%3DGroups%2C%20o%3DUniversity%20of%20Michigan%2C%20c%3DUS | |
38 | ;; ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US | |
39 | ;; | |
40 | ;; For simple queries, I have verified compatibility with Netscape | |
bebcf940 | 41 | ;; Communicator v4.5 under GNU/Linux. |
8c8b8430 SM |
42 | ;; |
43 | ;; For anything _useful_ though, like specifying the attributes, | |
44 | ;; scope, filter, or extensions, netscape claims the URL format is | |
45 | ;; unrecognized. So I don't think it supports anything other than the | |
46 | ;; defaults (scope=base,attributes=*,filter=(objectClass=*) | |
47 | ||
48 | (defconst url-ldap-default-port 389 "Default LDAP port.") | |
49 | (defalias 'url-ldap-expand-file-name 'url-default-expander) | |
50 | ||
51 | (defvar url-ldap-pretty-names | |
52 | '(("l" . "City") | |
53 | ("objectclass" . "Object Class") | |
54 | ("o" . "Organization") | |
55 | ("ou" . "Organizational Unit") | |
56 | ("cn" . "Name") | |
57 | ("sn" . "Last Name") | |
58 | ("givenname" . "First Name") | |
59 | ("mail" . "Email") | |
60 | ("title" . "Title") | |
61 | ("c" . "Country") | |
62 | ("postalcode" . "ZIP Code") | |
63 | ("telephonenumber" . "Phone Number") | |
64 | ("facsimiletelephonenumber" . "Fax") | |
65 | ("postaladdress" . "Mailing Address") | |
66 | ("description" . "Notes")) | |
fb7ada5f | 67 | "An assoc list mapping LDAP attribute names to pretty descriptions of them.") |
8c8b8430 SM |
68 | |
69 | (defvar url-ldap-attribute-formatters | |
70 | '(("mail" . (lambda (x) (format "<a href='mailto:%s'>%s</a>" x x))) | |
71 | ("owner" . url-ldap-dn-formatter) | |
72 | ("creatorsname" . url-ldap-dn-formatter) | |
73 | ("jpegphoto" . url-ldap-image-formatter) | |
74 | ("usercertificate" . url-ldap-certificate-formatter) | |
75 | ("modifiersname" . url-ldap-dn-formatter) | |
76 | ("namingcontexts" . url-ldap-dn-formatter) | |
77 | ("defaultnamingcontext" . url-ldap-dn-formatter) | |
78 | ("member" . url-ldap-dn-formatter)) | |
fb7ada5f | 79 | "An assoc list mapping LDAP attribute names to pretty formatters for them.") |
8c8b8430 SM |
80 | |
81 | (defsubst url-ldap-attribute-pretty-name (n) | |
82 | (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n)) | |
83 | ||
84 | (defsubst url-ldap-attribute-pretty-desc (n v) | |
85 | (if (string-match "^\\([^;]+\\);" n) | |
86 | (setq n (match-string 1 n))) | |
87 | (funcall (or (cdr-safe (assoc (downcase n) url-ldap-attribute-formatters)) 'identity) v)) | |
88 | ||
89 | (defun url-ldap-dn-formatter (dn) | |
90 | (concat "<a href='/" | |
91 | (url-hexify-string dn) | |
92 | "'>" dn "</a>")) | |
93 | ||
94 | (defun url-ldap-certificate-formatter (data) | |
95 | (condition-case () | |
96 | (require 'ssl) | |
97 | (error nil)) | |
bebcf940 | 98 | (let ((vals (if (fboundp 'ssl-certificate-information) |
5bbb0eb9 SJ |
99 | (ssl-certificate-information data) |
100 | (tls-certificate-information data)))) | |
8c8b8430 SM |
101 | (if (not vals) |
102 | "<b>Unable to parse certificate</b>" | |
103 | (concat "<table border=0>\n" | |
104 | (mapconcat | |
105 | (lambda (ava) | |
106 | (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava))) | |
107 | vals "\n") | |
108 | "</table>\n")))) | |
109 | ||
110 | (defun url-ldap-image-formatter (data) | |
bebcf940 | 111 | (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>" |
8c8b8430 SM |
112 | (url-hexify-string (base64-encode-string data)))) |
113 | ||
114 | ;;;###autoload | |
115 | (defun url-ldap (url) | |
d9cdf64b RS |
116 | "Perform an LDAP search specified by URL. |
117 | The return value is a buffer displaying the search results in HTML. | |
118 | URL can be a URL string, or a URL vector of the type returned by | |
119 | `url-generic-parse-url'." | |
120 | (if (stringp url) | |
121 | (setq url (url-generic-parse-url (url-unhex-string url))) | |
122 | (if (not (vectorp url)) | |
123 | (error "Argument is not a valid URL"))) | |
937e6a56 | 124 | (with-current-buffer (generate-new-buffer " *url-ldap*") |
8c8b8430 SM |
125 | (setq url-current-object url) |
126 | (insert "Content-type: text/html\r\n\r\n") | |
127 | (if (not (fboundp 'ldap-search-internal)) | |
128 | (insert "<html>\n" | |
129 | " <head>\n" | |
130 | " <title>LDAP Not Supported</title>\n" | |
131 | " <base href='" (url-recreate-url url) "'>\n" | |
132 | " </head>\n" | |
133 | " <body>\n" | |
134 | " <h1>LDAP Not Supported</h1>\n" | |
135 | " <p>\n" | |
136 | " This version of Emacs does not support LDAP.\n" | |
137 | " </p>\n" | |
138 | " </body>\n" | |
139 | "</html>\n") | |
140 | (let* ((binddn nil) | |
141 | (data (url-filename url)) | |
142 | (host (url-host url)) | |
143 | (port (url-port url)) | |
144 | (base-object nil) | |
145 | (attributes nil) | |
146 | (scope nil) | |
147 | (filter nil) | |
148 | (extensions nil) | |
d9cdf64b | 149 | (results nil)) |
8c8b8430 SM |
150 | |
151 | ;; Get rid of leading / | |
152 | (if (string-match "^/" data) | |
153 | (setq data (substring data 1))) | |
154 | ||
155 | (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?")) | |
156 | base-object (nth 0 data) | |
157 | attributes (nth 1 data) | |
158 | scope (nth 2 data) | |
159 | filter (nth 3 data) | |
160 | extensions (nth 4 data)) | |
161 | ||
162 | ;; fill in the defaults | |
163 | (setq base-object (url-unhex-string (or base-object "")) | |
164 | scope (intern (url-unhex-string (or scope "base"))) | |
165 | filter (url-unhex-string (or filter "(objectClass=*)"))) | |
166 | ||
d9cdf64b | 167 | (if (not (memq scope '(base one sub))) |
8c8b8430 SM |
168 | (error "Malformed LDAP URL: Unknown scope: %S" scope)) |
169 | ||
170 | ;; Convert to the internal LDAP support scoping names. | |
171 | (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree))))) | |
172 | ||
173 | (if attributes | |
174 | (setq attributes (mapcar 'url-unhex-string (split-string attributes ",")))) | |
175 | ||
4c36be58 | 176 | ;; Parse out the extensions. |
8c8b8430 SM |
177 | (if extensions |
178 | (setq extensions (mapcar (lambda (ext) | |
179 | (if (string-match "\\([^=]*\\)=\\(.*\\)" ext) | |
180 | (cons (match-string 1 ext) (match-string 2 ext)) | |
181 | (cons ext ext))) | |
182 | (split-string extensions ",")) | |
183 | extensions (mapcar (lambda (ext) | |
184 | (cons (url-unhex-string (car ext)) | |
185 | (url-unhex-string (cdr ext)))) | |
186 | extensions))) | |
187 | ||
188 | (setq binddn (cdr-safe (or (assoc "bindname" extensions) | |
189 | (assoc "!bindname" extensions)))) | |
71ddfde5 | 190 | |
8c8b8430 | 191 | ;; Now, let's actually do something with it. |
d9cdf64b RS |
192 | (setq results (cdr (ldap-search-internal |
193 | (list 'host (concat host ":" (number-to-string port)) | |
194 | 'base base-object | |
195 | 'attributes attributes | |
196 | 'scope scope | |
197 | 'filter filter | |
198 | 'binddn binddn)))) | |
199 | ||
8c8b8430 SM |
200 | (insert "<html>\n" |
201 | " <head>\n" | |
202 | " <title>LDAP Search Results</title>\n" | |
203 | " <base href='" (url-recreate-url url) "'>\n" | |
204 | " </head>\n" | |
205 | " <body>\n" | |
206 | " <h1>" (int-to-string (length results)) " matches</h1>\n") | |
207 | ||
208 | (mapc (lambda (obj) | |
209 | (insert " <hr>\n" | |
210 | " <table border=1>\n") | |
8c8b8430 SM |
211 | (mapc (lambda (attr) |
212 | (if (= (length (cdr attr)) 1) | |
213 | ;; single match, easy | |
214 | (insert " <tr><td>" | |
215 | (url-ldap-attribute-pretty-name (car attr)) | |
216 | "</td><td>" | |
217 | (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr))) | |
218 | "</td></tr>\n") | |
219 | ;; Multiple matches, slightly uglier | |
220 | (insert " <tr>\n" | |
bebcf940 | 221 | (format " <td valign=top>") |
8c8b8430 SM |
222 | (url-ldap-attribute-pretty-name (car attr)) "</td><td>" |
223 | (mapconcat (lambda (x) | |
224 | (url-ldap-attribute-pretty-desc (car attr) x)) | |
225 | (cdr attr) | |
226 | "<br>\n") | |
227 | "</td>" | |
228 | " </tr>\n"))) | |
d9cdf64b | 229 | obj) |
8c8b8430 SM |
230 | (insert " </table>\n")) |
231 | results) | |
232 | ||
233 | (insert " <hr>\n" | |
234 | " </body>\n" | |
235 | "</html>\n"))) | |
236 | (current-buffer))) | |
237 | ||
238 | (provide 'url-ldap) | |
e5566bd5 | 239 | |
bebcf940 | 240 | ;;; url-ldap.el ends here |