Mercurial > emacs
comparison lisp/url/url-ldap.el @ 54695:3fb37923e567
Initial revision
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Sun, 04 Apr 2004 01:21:46 +0000 |
parents | |
children | 7784ae10206d |
comparison
equal
deleted
inserted
replaced
54694:253149f265f2 | 54695:3fb37923e567 |
---|---|
1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code | |
2 ;; Author: $Author: wmperry $ | |
3 ;; Created: $Date: 1999/11/26 12:11:50 $ | |
4 ;; Version: $Revision: 1.1.1.1 $ | |
5 ;; Keywords: comm, data, processes | |
6 | |
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
8 ;;; Copyright (c) 1998 - 1999 Free Software Foundation, Inc. | |
9 ;;; | |
10 ;;; This file is part of GNU Emacs. | |
11 ;;; | |
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;;; it under the terms of the GNU General Public License as published by | |
14 ;;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;;; any later version. | |
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 | |
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to the | |
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 ;;; Boston, MA 02111-1307, USA. | |
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
27 | |
28 (require 'url-vars) | |
29 (require 'url-parse) | |
30 (require 'url-util) | |
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 | |
41 ;; Communicator v4.5 under linux. | |
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")) | |
67 "*An assoc list mapping LDAP attribute names to pretty descriptions of them.") | |
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)) | |
79 "*An assoc list mapping LDAP attribute names to pretty formatters for them.") | |
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)) | |
98 (let ((vals (and (fboundp 'ssl-certificate-information) | |
99 (ssl-certificate-information data)))) | |
100 (if (not vals) | |
101 "<b>Unable to parse certificate</b>" | |
102 (concat "<table border=0>\n" | |
103 (mapconcat | |
104 (lambda (ava) | |
105 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava))) | |
106 vals "\n") | |
107 "</table>\n")))) | |
108 | |
109 (defun url-ldap-image-formatter (data) | |
110 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>" | |
111 (url-hexify-string (base64-encode-string data)))) | |
112 | |
113 ;;;###autoload | |
114 (defun url-ldap (url) | |
115 (save-excursion | |
116 (set-buffer (generate-new-buffer " *url-ldap*")) | |
117 (setq url-current-object url) | |
118 (insert "Content-type: text/html\r\n\r\n") | |
119 (if (not (fboundp 'ldap-search-internal)) | |
120 (insert "<html>\n" | |
121 " <head>\n" | |
122 " <title>LDAP Not Supported</title>\n" | |
123 " <base href='" (url-recreate-url url) "'>\n" | |
124 " </head>\n" | |
125 " <body>\n" | |
126 " <h1>LDAP Not Supported</h1>\n" | |
127 " <p>\n" | |
128 " This version of Emacs does not support LDAP.\n" | |
129 " </p>\n" | |
130 " </body>\n" | |
131 "</html>\n") | |
132 (let* ((binddn nil) | |
133 (data (url-filename url)) | |
134 (host (url-host url)) | |
135 (port (url-port url)) | |
136 (base-object nil) | |
137 (attributes nil) | |
138 (scope nil) | |
139 (filter nil) | |
140 (extensions nil) | |
141 (connection nil) | |
142 (results nil) | |
143 (extract-dn (and (fboundp 'function-max-args) | |
144 (= (function-max-args 'ldap-search-internal) 7)))) | |
145 | |
146 ;; Get rid of leading / | |
147 (if (string-match "^/" data) | |
148 (setq data (substring data 1))) | |
149 | |
150 (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?")) | |
151 base-object (nth 0 data) | |
152 attributes (nth 1 data) | |
153 scope (nth 2 data) | |
154 filter (nth 3 data) | |
155 extensions (nth 4 data)) | |
156 | |
157 ;; fill in the defaults | |
158 (setq base-object (url-unhex-string (or base-object "")) | |
159 scope (intern (url-unhex-string (or scope "base"))) | |
160 filter (url-unhex-string (or filter "(objectClass=*)"))) | |
161 | |
162 (if (not (memq scope '(base one tree))) | |
163 (error "Malformed LDAP URL: Unknown scope: %S" scope)) | |
164 | |
165 ;; Convert to the internal LDAP support scoping names. | |
166 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree))))) | |
167 | |
168 (if attributes | |
169 (setq attributes (mapcar 'url-unhex-string (split-string attributes ",")))) | |
170 | |
171 ;; Parse out the exentions | |
172 (if extensions | |
173 (setq extensions (mapcar (lambda (ext) | |
174 (if (string-match "\\([^=]*\\)=\\(.*\\)" ext) | |
175 (cons (match-string 1 ext) (match-string 2 ext)) | |
176 (cons ext ext))) | |
177 (split-string extensions ",")) | |
178 extensions (mapcar (lambda (ext) | |
179 (cons (url-unhex-string (car ext)) | |
180 (url-unhex-string (cdr ext)))) | |
181 extensions))) | |
182 | |
183 (setq binddn (cdr-safe (or (assoc "bindname" extensions) | |
184 (assoc "!bindname" extensions)))) | |
185 | |
186 ;; Now, let's actually do something with it. | |
187 (setq connection (ldap-open host (if binddn (list 'binddn binddn))) | |
188 results (if extract-dn | |
189 (ldap-search-internal connection filter base-object scope attributes nil t) | |
190 (ldap-search-internal connection filter base-object scope attributes nil))) | |
191 | |
192 (ldap-close connection) | |
193 (insert "<html>\n" | |
194 " <head>\n" | |
195 " <title>LDAP Search Results</title>\n" | |
196 " <base href='" (url-recreate-url url) "'>\n" | |
197 " </head>\n" | |
198 " <body>\n" | |
199 " <h1>" (int-to-string (length results)) " matches</h1>\n") | |
200 | |
201 (mapc (lambda (obj) | |
202 (insert " <hr>\n" | |
203 " <table border=1>\n") | |
204 (if extract-dn | |
205 (insert " <tr><th colspan=2>" (car obj) "</th></tr>\n")) | |
206 (mapc (lambda (attr) | |
207 (if (= (length (cdr attr)) 1) | |
208 ;; single match, easy | |
209 (insert " <tr><td>" | |
210 (url-ldap-attribute-pretty-name (car attr)) | |
211 "</td><td>" | |
212 (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr))) | |
213 "</td></tr>\n") | |
214 ;; Multiple matches, slightly uglier | |
215 (insert " <tr>\n" | |
216 (format " <td valign=top>" (length (cdr attr))) | |
217 (url-ldap-attribute-pretty-name (car attr)) "</td><td>" | |
218 (mapconcat (lambda (x) | |
219 (url-ldap-attribute-pretty-desc (car attr) x)) | |
220 (cdr attr) | |
221 "<br>\n") | |
222 "</td>" | |
223 " </tr>\n"))) | |
224 (if extract-dn (cdr obj) obj)) | |
225 (insert " </table>\n")) | |
226 results) | |
227 | |
228 (insert " <hr>\n" | |
229 " </body>\n" | |
230 "</html>\n"))) | |
231 (current-buffer))) | |
232 | |
233 (provide 'url-ldap) |