code.delx.au - gnu-emacs/blob - lisp/url/url-ldap.el

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