lisp/url/url-ldap.el

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