view lisp/url/url-ldap.el @ 105829:328150f0cf76

* url-util.el (url-insert-entities-in-string): * url-nfs.el (url-nfs-unescape): * url-ldap.el (url-ldap): * url-imap.el (url-imap): * url-cid.el (url-cid-gnus, url-cid): Use with-current-buffer. * erc.el (erc-display-line-1, erc-process-away): * erc-truncate.el (erc-truncate-buffer-to-size): Use with-current-buffer. * term/ns-win.el (ns-scroll-bar-move, ns-face-at-pos): * play/mpuz.el (mpuz-create-buffer): * play/landmark.el (lm-prompt-for-move, lm-print-wts, lm-print-smell) (lm-print-y,s,noise, lm-print-w0, lm-init): * play/gomoku.el (gomoku-prompt-for-move): * play/fortune.el (fortune-in-buffer): * play/dissociate.el (dissociated-press): * play/decipher.el (decipher-adjacency-list, decipher-display-regexp) (decipher-analyze-buffer, decipher-stats-buffer,decipher-stats-buffer): * mail/supercite.el (sc-eref-show): * mail/smtpmail.el (smtpmail-send-it): * mail/rmailsum.el (rmail-summary-next-labeled-message) (rmail-summary-previous-labeled-message, rmail-summary-wipe) (rmail-summary-undelete-many, rmail-summary-rmail-update) (rmail-summary-goto-msg, rmail-summary-expunge) (rmail-summary-get-new-mail, rmail-summary-search-backward) (rmail-summary-add-label, rmail-summary-output-menu) (rmail-summary-output-body): * mail/rfc822.el (rfc822-addresses): * mail/reporter.el (reporter-dump-variable, reporter-dump-state): * mail/mailpost.el (post-mail-send-it): * mail/hashcash.el (hashcash-generate-payment): * mail/feedmail.el (feedmail-run-the-queue) (feedmail-queue-send-edit-prompt-help-first) (feedmail-send-it-immediately, feedmail-give-it-to-buffer-eater) (feedmail-deduce-address-list): * eshell/esh-ext.el (eshell-remote-command): * eshell/em-unix.el (eshell-occur-mode-mouse-goto): * emulation/viper-util.el (viper-glob-unix-files, viper-save-setting) (viper-wildcard-to-regexp, viper-glob-mswindows-files) (viper-save-string-in-file, viper-valid-marker): * emulation/viper-keym.el (viper-toggle-key): * emulation/viper-ex.el (ex-expand-filsyms, viper-get-ex-file) (ex-edit, ex-global, ex-mark, ex-next-related-buffer, ex-quit) (ex-get-inline-cmd-args, ex-tag, ex-command, ex-compile): * emulation/viper-cmd.el (viper-exec-form-in-vi) (viper-exec-form-in-emacs, viper-brac-function): * emulation/viper.el (viper-delocalize-var): * emulation/vip.el (vip-mode, vip-get-ex-token, vip-ex, vip-get-ex-pat) (vip-get-ex-command, vip-get-ex-opt-gc, vip-get-ex-buffer) (vip-get-ex-count, vip-get-ex-file, ex-edit, ex-global, ex-mark) (ex-map, ex-unmap, ex-quit, ex-read, ex-tag, ex-command): * emulation/vi.el (vi-switch-mode, vi-ex-cmd): * emulation/edt.el (edt-electric-helpify): * emulation/cua-rect.el (cua--rectangle-aux-replace): * emulation/cua-gmrk.el (cua--insert-at-global-mark) (cua--delete-at-global-mark, cua--copy-rectangle-to-global-mark) (cua-indent-to-global-mark-column): * calendar/diary-lib.el (calendar-mark-1): * calendar/cal-hebrew.el (calendar-hebrew-mark-date-pattern): Use with-current-buffer. * emulation/viper.el (viper-delocalize-var): Use dolist.

;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code

;; Copyright (C) 1998, 1999, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'url-vars)
(require 'url-parse)
(require 'url-util)
(require 'ldap)
(autoload 'tls-certificate-information "tls")

;; 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)
		(tls-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))))

;;;###autoload
(defun url-ldap (url)
  "Perform an LDAP search specified by URL.
The return value is a buffer displaying the search results in HTML.
URL can be a URL string, or a URL vector of the type returned by
`url-generic-parse-url'."
  (if (stringp url)
      (setq url (url-generic-parse-url (url-unhex-string url)))
    (if (not (vectorp url))
        (error "Argument is not a valid URL")))
  (with-current-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)
	     (results nil))

	;; 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 sub)))
	    (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 results (cdr (ldap-search-internal
		       (list 'host (concat host ":" (number-to-string port))
			     'base base-object
			     'attributes attributes
			     'scope scope
			     'filter filter
			     'binddn binddn))))

	(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")
		(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")))
                      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