cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/url-ldap.el

   1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
   2
   3 ;; Copyright (C) 1998-1999, 2004-2012 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 3 of the License, or
  12 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'url-vars)
  27 (require 'url-parse)
  28 (require 'url-util)
  29 (require 'ldap)
  30 (autoload 'tls-certificate-information "tls")
  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
  41 ;; Communicator v4.5 under GNU/Linux.
  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))
  98   (let ((vals (if (fboundp 'ssl-certificate-information)
  99                   (ssl-certificate-information data)
 100                 (tls-certificate-information data))))
 101     (if (not vals)
 102         "<b>Unable to parse certificate</b>"
 103       (concat "<table border=0>\n"
 104               (mapconcat
 105                (lambda (ava)
 106                  (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava)))
 107                vals "\n")
 108               "</table>\n"))))
 109
 110 (defun url-ldap-image-formatter (data)
 111   (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
 112           (url-hexify-string (base64-encode-string data))))
 113
 114 ;;;###autoload
 115 (defun url-ldap (url)
 116   "Perform an LDAP search specified by URL.
 117 The return value is a buffer displaying the search results in HTML.
 118 URL can be a URL string, or a URL vector of the type returned by
 119 `url-generic-parse-url'."
 120   (if (stringp url)
 121       (setq url (url-generic-parse-url (url-unhex-string url)))
 122     (if (not (vectorp url))
 123         (error "Argument is not a valid URL")))
 124   (with-current-buffer (generate-new-buffer " *url-ldap*")
 125     (setq url-current-object url)
 126     (insert "Content-type: text/html\r\n\r\n")
 127     (if (not (fboundp 'ldap-search-internal))
 128         (insert "<html>\n"
 129                 " <head>\n"
 130                 "  <title>LDAP Not Supported</title>\n"
 131                 "  <base href='" (url-recreate-url url) "'>\n"
 132                 " </head>\n"
 133                 " <body>\n"
 134                 "  <h1>LDAP Not Supported</h1>\n"
 135                 "  <p>\n"
 136                 "    This version of Emacs does not support LDAP.\n"
 137                 "  </p>\n"
 138                 " </body>\n"
 139                 "</html>\n")
 140       (let* ((binddn nil)
 141              (data (url-filename url))
 142              (host (url-host url))
 143              (port (url-port url))
 144              (base-object nil)
 145              (attributes nil)
 146              (scope nil)
 147              (filter nil)
 148              (extensions nil)
 149              (results nil))
 150
 151         ;; Get rid of leading /
 152         (if (string-match "^/" data)
 153             (setq data (substring data 1)))
 154
 155         (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
 156               base-object (nth 0 data)
 157               attributes (nth 1 data)
 158               scope (nth 2 data)
 159               filter (nth 3 data)
 160               extensions (nth 4 data))
 161
 162         ;; fill in the defaults
 163         (setq base-object (url-unhex-string (or base-object ""))
 164               scope (intern (url-unhex-string (or scope "base")))
 165               filter (url-unhex-string (or filter "(objectClass=*)")))
 166
 167         (if (not (memq scope '(base one sub)))
 168             (error "Malformed LDAP URL: Unknown scope: %S" scope))
 169
 170         ;; Convert to the internal LDAP support scoping names.
 171         (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
 172
 173         (if attributes
 174             (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
 175
 176         ;; Parse out the extensions.
 177         (if extensions
 178             (setq extensions (mapcar (lambda (ext)
 179                                        (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
 180                                            (cons (match-string 1 ext) (match-string 2 ext))
 181                                          (cons ext ext)))
 182                                      (split-string extensions ","))
 183                   extensions (mapcar (lambda (ext)
 184                                        (cons (url-unhex-string (car ext))
 185                                              (url-unhex-string (cdr ext))))
 186                                      extensions)))
 187
 188         (setq binddn (cdr-safe (or (assoc "bindname" extensions)
 189                                    (assoc "!bindname" extensions))))
 190
 191         ;; Now, let's actually do something with it.
 192         (setq results (cdr (ldap-search-internal
 193                        (list 'host (concat host ":" (number-to-string port))
 194                              'base base-object
 195                              'attributes attributes
 196                              'scope scope
 197                              'filter filter
 198                              'binddn binddn))))
 199
 200         (insert "<html>\n"
 201                 " <head>\n"
 202                 "  <title>LDAP Search Results</title>\n"
 203                 "  <base href='" (url-recreate-url url) "'>\n"
 204                 " </head>\n"
 205                 " <body>\n"
 206                 "  <h1>" (int-to-string (length results)) " matches</h1>\n")
 207
 208         (mapc (lambda (obj)
 209                 (insert "  <hr>\n"
 210                         "  <table border=1>\n")
 211                 (mapc (lambda (attr)
 212                         (if (= (length (cdr attr)) 1)
 213                             ;; single match, easy
 214                             (insert "   <tr><td>"
 215                                     (url-ldap-attribute-pretty-name (car attr))
 216                                     "</td><td>"
 217                                     (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
 218                                     "</td></tr>\n")
 219                           ;; Multiple matches, slightly uglier
 220                           (insert "   <tr>\n"
 221                                   (format "    <td valign=top>")
 222                                   (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
 223                                   (mapconcat (lambda (x)
 224                                                (url-ldap-attribute-pretty-desc (car attr) x))
 225                                              (cdr attr)
 226                                              "<br>\n")
 227                                   "</td>"
 228                                   "   </tr>\n")))
 229                       obj)
 230                 (insert "  </table>\n"))
 231               results)
 232
 233         (insert "  <hr>\n"
 234                 " </body>\n"
 235                 "</html>\n")))
 236     (current-buffer)))
 237
 238 (provide 'url-ldap)
 239
 240 ;;; url-ldap.el ends here