lisp/url/url-ldap.el

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