1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
3 ;; Copyright (C) 1998, 1999, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5 ;; Keywords: comm, data, processes
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
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.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 (autoload 'tls-certificate-information "tls")
32 ;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997)
34 ;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions
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
40 ;; For simple queries, I have verified compatibility with Netscape
41 ;; Communicator v4.5 under GNU/Linux.
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=*)
48 (defconst url-ldap-default-port 389 "Default LDAP port.")
49 (defalias 'url-ldap-expand-file-name 'url-default-expander)
51 (defvar url-ldap-pretty-names
53 ("objectclass" . "Object Class")
54 ("o" . "Organization")
55 ("ou" . "Organizational Unit")
58 ("givenname" . "First Name")
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.")
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.")
81 (defsubst url-ldap-attribute-pretty-name (n)
82 (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n))
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))
89 (defun url-ldap-dn-formatter (dn)
91 (url-hexify-string dn)
94 (defun url-ldap-certificate-formatter (data)
98 (let ((vals (if (fboundp 'ssl-certificate-information)
99 (ssl-certificate-information data)
100 (tls-certificate-information data))))
102 "<b>Unable to parse certificate</b>"
103 (concat "<table border=0>\n"
106 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava)))
110 (defun url-ldap-image-formatter (data)
111 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
112 (url-hexify-string (base64-encode-string data))))
115 (defun url-ldap (url)
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'."
121 (setq url (url-generic-parse-url (url-unhex-string url)))
122 (if (not (vectorp url))
123 (error "Argument is not a valid URL")))
125 (set-buffer (generate-new-buffer " *url-ldap*"))
126 (setq url-current-object url)
127 (insert "Content-type: text/html\r\n\r\n")
128 (if (not (fboundp 'ldap-search-internal))
131 " <title>LDAP Not Supported</title>\n"
132 " <base href='" (url-recreate-url url) "'>\n"
135 " <h1>LDAP Not Supported</h1>\n"
137 " This version of Emacs does not support LDAP.\n"
142 (data (url-filename url))
143 (host (url-host url))
144 (port (url-port url))
152 ;; Get rid of leading /
153 (if (string-match "^/" data)
154 (setq data (substring data 1)))
156 (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
157 base-object (nth 0 data)
158 attributes (nth 1 data)
161 extensions (nth 4 data))
163 ;; fill in the defaults
164 (setq base-object (url-unhex-string (or base-object ""))
165 scope (intern (url-unhex-string (or scope "base")))
166 filter (url-unhex-string (or filter "(objectClass=*)")))
168 (if (not (memq scope '(base one sub)))
169 (error "Malformed LDAP URL: Unknown scope: %S" scope))
171 ;; Convert to the internal LDAP support scoping names.
172 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
175 (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
177 ;; Parse out the exentions
179 (setq extensions (mapcar (lambda (ext)
180 (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
181 (cons (match-string 1 ext) (match-string 2 ext))
183 (split-string extensions ","))
184 extensions (mapcar (lambda (ext)
185 (cons (url-unhex-string (car ext))
186 (url-unhex-string (cdr ext))))
189 (setq binddn (cdr-safe (or (assoc "bindname" extensions)
190 (assoc "!bindname" extensions))))
192 ;; Now, let's actually do something with it.
193 (setq results (cdr (ldap-search-internal
194 (list 'host (concat host ":" (number-to-string port))
196 'attributes attributes
203 " <title>LDAP Search Results</title>\n"
204 " <base href='" (url-recreate-url url) "'>\n"
207 " <h1>" (int-to-string (length results)) " matches</h1>\n")
211 " <table border=1>\n")
213 (if (= (length (cdr attr)) 1)
214 ;; single match, easy
216 (url-ldap-attribute-pretty-name (car attr))
218 (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
220 ;; Multiple matches, slightly uglier
222 (format " <td valign=top>")
223 (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
224 (mapconcat (lambda (x)
225 (url-ldap-attribute-pretty-desc (car attr) x))
231 (insert " </table>\n"))
241 ;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
242 ;;; url-ldap.el ends here