[Emacs-diffs] Changes to emacs/lisp/url/url-ldap.el [emacs-unicode-2]

[Miles Bader]

Index: emacs/lisp/url/url-ldap.el
diff -c /dev/null emacs/lisp/url/url-ldap.el:1.4.2.1
*** /dev/null   Thu Oct 14 08:51:00 2004
--- emacs/lisp/url/url-ldap.el  Thu Oct 14 08:49:52 2004
***************
*** 0 ****
--- 1,240 ----
+ ;;; 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)
+ (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))))
+ 
+ ;; 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