1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
2 ;; Copyright (c) 1998 - 1999, 2004 Free Software Foundation, Inc.
4 ;; Keywords: comm, data, processes
6 ;; This file is part of GNU Emacs.
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
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
))))
101 "<b>Unable to parse certificate</b>"
102 (concat "<table border=0>\n"
105 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava
) (cdr ava
)))
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
))))
113 ;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
114 ;; calls of ldap-open, ldap-close, ldap-search-internal
116 (defun url-ldap (url)
118 (set-buffer (generate-new-buffer " *url-ldap*"))
119 (setq url-current-object url
)
120 (insert "Content-type: text/html\r\n\r\n")
121 (if (not (fboundp 'ldap-search-internal
))
124 " <title>LDAP Not Supported</title>\n"
125 " <base href='" (url-recreate-url url
) "'>\n"
128 " <h1>LDAP Not Supported</h1>\n"
130 " This version of Emacs does not support LDAP.\n"
135 (data (url-filename url
))
136 (host (url-host url
))
137 (port (url-port url
))
145 (extract-dn (and (fboundp 'function-max-args
)
146 (= (function-max-args 'ldap-search-internal
) 7))))
148 ;; Get rid of leading /
149 (if (string-match "^/" data
)
150 (setq data
(substring data
1)))
152 (setq data
(mapcar (lambda (x) (if (/= (length x
) 0) x nil
)) (split-string data
"\\?"))
153 base-object
(nth 0 data
)
154 attributes
(nth 1 data
)
157 extensions
(nth 4 data
))
159 ;; fill in the defaults
160 (setq base-object
(url-unhex-string (or base-object
""))
161 scope
(intern (url-unhex-string (or scope
"base")))
162 filter
(url-unhex-string (or filter
"(objectClass=*)")))
164 (if (not (memq scope
'(base one tree
)))
165 (error "Malformed LDAP URL: Unknown scope: %S" scope
))
167 ;; Convert to the internal LDAP support scoping names.
168 (setq scope
(cdr (assq scope
'((base . base
) (one . onelevel
) (sub . subtree
)))))
171 (setq attributes
(mapcar 'url-unhex-string
(split-string attributes
","))))
173 ;; Parse out the exentions
175 (setq extensions
(mapcar (lambda (ext)
176 (if (string-match "\\([^=]*\\)=\\(.*\\)" ext
)
177 (cons (match-string 1 ext
) (match-string 2 ext
))
179 (split-string extensions
","))
180 extensions
(mapcar (lambda (ext)
181 (cons (url-unhex-string (car ext
))
182 (url-unhex-string (cdr ext
))))
185 (setq binddn
(cdr-safe (or (assoc "bindname" extensions
)
186 (assoc "!bindname" extensions
))))
188 ;; Now, let's actually do something with it.
189 (setq connection
(ldap-open host
(if binddn
(list 'binddn binddn
)))
190 results
(if extract-dn
191 (ldap-search-internal connection filter base-object scope attributes nil t
)
192 (ldap-search-internal connection filter base-object scope attributes nil
)))
194 (ldap-close connection
)
197 " <title>LDAP Search Results</title>\n"
198 " <base href='" (url-recreate-url url
) "'>\n"
201 " <h1>" (int-to-string (length results
)) " matches</h1>\n")
205 " <table border=1>\n")
207 (insert " <tr><th colspan=2>" (car obj
) "</th></tr>\n"))
209 (if (= (length (cdr attr
)) 1)
210 ;; single match, easy
212 (url-ldap-attribute-pretty-name (car attr
))
214 (url-ldap-attribute-pretty-desc (car attr
) (car (cdr attr
)))
216 ;; Multiple matches, slightly uglier
218 (format " <td valign=top>")
219 (url-ldap-attribute-pretty-name (car attr
)) "</td><td>"
220 (mapconcat (lambda (x)
221 (url-ldap-attribute-pretty-desc (car attr
) x
))
226 (if extract-dn
(cdr obj
) obj
))
227 (insert " </table>\n"))
237 ;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
238 ;;; url-ldap.el ends here