[bpt/emacs.git] / lisp / url / url-ldap.el

;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
;; Copyright (c) 1998 - 1999, 2004 Free Software Foundation, Inc.

;; Keywords: comm, data, processes

;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(require 'url-vars)
(require 'url-parse)
(require 'url-util)
(require 'ldap)

;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997)
;;
;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions
;;
;; Test URLs:
;; ldap://ldap.itd.umich.edu/cn%3Dumbflabmanager%2C%20ou%3DUser%20Groups%2C%20ou%3DGroups%2C%20o%3DUniversity%20of%20Michigan%2C%20c%3DUS
;; ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US
;;
;; For simple queries, I have verified compatibility with Netscape
;; Communicator v4.5 under GNU/Linux.
;;
;; For anything _useful_ though, like specifying the attributes,
;; scope, filter, or extensions, netscape claims the URL format is
;; unrecognized.  So I don't think it supports anything other than the
;; defaults (scope=base,attributes=*,filter=(objectClass=*)

(defconst url-ldap-default-port 389 "Default LDAP port.")
(defalias 'url-ldap-expand-file-name 'url-default-expander)

(defvar url-ldap-pretty-names
  '(("l"           . "City")
    ("objectclass" . "Object Class")
    ("o"           . "Organization")
    ("ou"          . "Organizational Unit")
    ("cn"          . "Name")
    ("sn"          . "Last Name")
    ("givenname"   . "First Name")
    ("mail"        . "Email")
    ("title"       . "Title")
    ("c"           . "Country")
    ("postalcode"  . "ZIP Code")
    ("telephonenumber"          . "Phone Number")
    ("facsimiletelephonenumber" . "Fax")
    ("postaladdress"            . "Mailing Address")
    ("description"              . "Notes"))
  "*An assoc list mapping LDAP attribute names to pretty descriptions of them.")

(defvar url-ldap-attribute-formatters
  '(("mail"       . (lambda (x) (format "<a href='mailto:%s'>%s</a>" x x)))
    ("owner"      . url-ldap-dn-formatter)
    ("creatorsname" . url-ldap-dn-formatter)
    ("jpegphoto"     . url-ldap-image-formatter)
    ("usercertificate" . url-ldap-certificate-formatter)
    ("modifiersname" . url-ldap-dn-formatter)
    ("namingcontexts" . url-ldap-dn-formatter)
    ("defaultnamingcontext" . url-ldap-dn-formatter)
    ("member"     . url-ldap-dn-formatter))
  "*An assoc list mapping LDAP attribute names to pretty formatters for them.")

(defsubst url-ldap-attribute-pretty-name (n)
  (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n))

(defsubst url-ldap-attribute-pretty-desc (n v)
  (if (string-match "^\\([^;]+\\);" n)
      (setq n (match-string 1 n)))
  (funcall (or (cdr-safe (assoc (downcase n) url-ldap-attribute-formatters)) 'identity) v))

(defun url-ldap-dn-formatter (dn)
  (concat "<a href='/"
	  (url-hexify-string dn)
	  "'>" dn "</a>"))

(defun url-ldap-certificate-formatter (data)
  (condition-case ()
      (require 'ssl)
    (error nil))
  (let ((vals (if (fboundp 'ssl-certificate-information)
		  (ssl-certificate-information data))))
    (if (not vals)
	"<b>Unable to parse certificate</b>"
      (concat "<table border=0>\n"
	      (mapconcat
	       (lambda (ava)
		 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava)))
	       vals "\n")
	      "</table>\n"))))

(defun url-ldap-image-formatter (data)
  (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
	  (url-hexify-string (base64-encode-string data))))

;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
;; calls of ldap-open, ldap-close, ldap-search-internal
;;;###autoload
(defun url-ldap (url)
  (save-excursion
    (set-buffer (generate-new-buffer " *url-ldap*"))
    (setq url-current-object url)
    (insert "Content-type: text/html\r\n\r\n")
    (if (not (fboundp 'ldap-search-internal))
	(insert "<html>\n"
		" <head>\n"
		"  <title>LDAP Not Supported</title>\n"
		"  <base href='" (url-recreate-url url) "'>\n"
		" </head>\n"
		" <body>\n"
		"  <h1>LDAP Not Supported</h1>\n"
		"  <p>\n"
		"    This version of Emacs does not support LDAP.\n"
		"  </p>\n"
		" </body>\n"
		"</html>\n")
      (let* ((binddn nil)
	     (data (url-filename url))
	     (host (url-host url))
	     (port (url-port url))
	     (base-object nil)
	     (attributes nil)
	     (scope nil)
	     (filter nil)
	     (extensions nil)
	     (connection nil)
	     (results nil)
	     (extract-dn (and (fboundp 'function-max-args)
			      (= (function-max-args 'ldap-search-internal) 7))))

	;; Get rid of leading /
	(if (string-match "^/" data)
	    (setq data (substring data 1)))

	(setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
	      base-object (nth 0 data)
	      attributes (nth 1 data)
	      scope (nth 2 data)
	      filter (nth 3 data)
	      extensions (nth 4 data))

	;; fill in the defaults
	(setq base-object (url-unhex-string (or base-object ""))
	      scope (intern (url-unhex-string (or scope "base")))
	      filter (url-unhex-string (or filter "(objectClass=*)")))

	(if (not (memq scope '(base one tree)))
	    (error "Malformed LDAP URL: Unknown scope: %S" scope))

	;; Convert to the internal LDAP support scoping names.
	(setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))

	(if attributes
	    (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))

	;; Parse out the exentions
	(if extensions
	    (setq extensions (mapcar (lambda (ext)
				       (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
					   (cons (match-string 1 ext) (match-string 2 ext))
					 (cons ext ext)))
				     (split-string extensions ","))
		  extensions (mapcar (lambda (ext)
				       (cons (url-unhex-string (car ext))
					     (url-unhex-string (cdr ext))))
				     extensions)))

	(setq binddn (cdr-safe (or (assoc "bindname" extensions)
				   (assoc "!bindname" extensions))))
    
	;; Now, let's actually do something with it.
	(setq connection (ldap-open host (if binddn (list 'binddn binddn)))
	      results (if extract-dn
			  (ldap-search-internal connection filter base-object scope attributes nil t)
			(ldap-search-internal connection filter base-object scope attributes nil)))
		      
	(ldap-close connection)
	(insert "<html>\n"
		" <head>\n"
		"  <title>LDAP Search Results</title>\n"
		"  <base href='" (url-recreate-url url) "'>\n"
		" </head>\n"
		" <body>\n"
		"  <h1>" (int-to-string (length results)) " matches</h1>\n")

	(mapc (lambda (obj)
		(insert "  <hr>\n"
			"  <table border=1>\n")
		(if extract-dn
		    (insert "   <tr><th colspan=2>" (car obj) "</th></tr>\n"))
		(mapc (lambda (attr)
			(if (= (length (cdr attr)) 1)
			    ;; single match, easy
			    (insert "   <tr><td>"
				    (url-ldap-attribute-pretty-name (car attr))
				    "</td><td>"
				    (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
				    "</td></tr>\n")
			  ;; Multiple matches, slightly uglier
			  (insert "   <tr>\n"
				  (format "    <td valign=top>")
				  (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
				  (mapconcat (lambda (x)
					       (url-ldap-attribute-pretty-desc (car attr) x))
					     (cdr attr)
					     "<br>\n")
				  "</td>"
				  "   </tr>\n")))
		      (if extract-dn (cdr obj) obj))
		(insert "  </table>\n"))
	      results)

	(insert "  <hr>\n"
		" </body>\n"
		"</html>\n")))
    (current-buffer)))

(provide 'url-ldap)

;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
;;; url-ldap.el ends here
Commit	Line	Data
8c8b8430	1	;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
bebcf940 SM	2	;; Copyright (c) 1998 - 1999, 2004 Free Software Foundation, Inc.
bebcf940 SM	3
8c8b8430 SM	4	;; Keywords: comm, data, processes
8c8b8430 SM	5
bebcf940 SM	6	;; This file is part of GNU Emacs.
	7	;;
	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)
	11	;; any later version.
	12	;;
	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.
	17	;;
	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.
	22
	23	;;; Commentary:
	24
	25	;;; Code:
8c8b8430 SM	26
	27	(require 'url-vars)
	28	(require 'url-parse)
	29	(require 'url-util)
bebcf940	30	(require 'ldap)
8c8b8430 SM	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
bebcf940	41	;; Communicator v4.5 under GNU/Linux.
8c8b8430 SM	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))
bebcf940 SM	98	(let ((vals (if (fboundp 'ssl-certificate-information)
bebcf940 SM	99	(ssl-certificate-information data))))
8c8b8430 SM	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)
bebcf940	110	(format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
8c8b8430 SM	111	(url-hexify-string (base64-encode-string data))))
8c8b8430 SM	112
bebcf940 SM	113	;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
bebcf940 SM	114	;; calls of ldap-open, ldap-close, ldap-search-internal
8c8b8430 SM	115	;;;###autoload
	116	(defun url-ldap (url)
	117	(save-excursion
	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))
	122	(insert "<html>\n"
	123	" <head>\n"
	124	" <title>LDAP Not Supported</title>\n"
	125	" <base href='" (url-recreate-url url) "'>\n"
	126	" </head>\n"
	127	" <body>\n"
	128	" <h1>LDAP Not Supported</h1>\n"
	129	" <p>\n"
	130	" This version of Emacs does not support LDAP.\n"
	131	" </p>\n"
	132	" </body>\n"
	133	"</html>\n")
	134	(let* ((binddn nil)
	135	(data (url-filename url))
	136	(host (url-host url))
	137	(port (url-port url))
	138	(base-object nil)
	139	(attributes nil)
	140	(scope nil)
	141	(filter nil)
	142	(extensions nil)
	143	(connection nil)
	144	(results nil)
	145	(extract-dn (and (fboundp 'function-max-args)
	146	(= (function-max-args 'ldap-search-internal) 7))))
	147
	148	;; Get rid of leading /
	149	(if (string-match "^/" data)
	150	(setq data (substring data 1)))
	151
	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)
	155	scope (nth 2 data)
	156	filter (nth 3 data)
	157	extensions (nth 4 data))
	158
	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=*)")))
	163
	164	(if (not (memq scope '(base one tree)))
	165	(error "Malformed LDAP URL: Unknown scope: %S" scope))
	166
	167	;; Convert to the internal LDAP support scoping names.
	168	(setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
	169
	170	(if attributes
	171	(setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
	172
	173	;; Parse out the exentions
	174	(if extensions
	175	(setq extensions (mapcar (lambda (ext)
	176	(if (string-match "\\([^=]\\)=\\(.\\)" ext)
	177	(cons (match-string 1 ext) (match-string 2 ext))
	178	(cons ext ext)))
179	(split-string extensions ","))
180	extensions (mapcar (lambda (ext)
181	(cons (url-unhex-string (car ext))
182	(url-unhex-string (cdr ext))))
183	extensions)))
184
185	(setq binddn (cdr-safe (or (assoc "bindname" extensions)
186	(assoc "!bindname" extensions))))
187
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)))
193
194	(ldap-close connection)
195	(insert "<html>\n"
196	" <head>\n"
197	" <title>LDAP Search Results</title>\n"
198	" <base href='" (url-recreate-url url) "'>\n"
199	" </head>\n"
200	" <body>\n"
201	" <h1>" (int-to-string (length results)) " matches</h1>\n")
202
203	(mapc (lambda (obj)
204	(insert " <hr>\n"
205	" <table border=1>\n")
206	(if extract-dn
207	(insert " <tr><th colspan=2>" (car obj) "</th></tr>\n"))
208	(mapc (lambda (attr)
209	(if (= (length (cdr attr)) 1)
210	;; single match, easy
211	(insert " <tr><td>"
212	(url-ldap-attribute-pretty-name (car attr))
213	"</td><td>"
214	(url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
215	"</td></tr>\n")
216	;; Multiple matches, slightly uglier
217	(insert " <tr>\n"
bebcf940	218	(format " <td valign=top>")
8c8b8430 SM	219	(url-ldap-attribute-pretty-name (car attr)) "</td><td>"
	220	(mapconcat (lambda (x)
	221	(url-ldap-attribute-pretty-desc (car attr) x))
	222	(cdr attr)
	223	"<br>\n")
	224	"</td>"
	225	" </tr>\n")))
	226	(if extract-dn (cdr obj) obj))
	227	(insert " </table>\n"))
	228	results)
	229
	230	(insert " <hr>\n"
	231	" </body>\n"
	232	"</html>\n")))
	233	(current-buffer)))
	234
	235	(provide 'url-ldap)
e5566bd5	236
bebcf940 SM	237	;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
bebcf940 SM	238	;;; url-ldap.el ends here