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