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