lisp/url/url-ldap.el

   1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
   2 ;; Copyright (c) 1998 - 1999, 2004 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., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, 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 ;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
 116 ;; calls of ldap-open, ldap-close, ldap-search-internal
 117 ;;;###autoload
 118 (defun url-ldap (url)
 119   (save-excursion
 120     (set-buffer (generate-new-buffer " *url-ldap*"))
 121     (setq url-current-object url)
 122     (insert "Content-type: text/html\r\n\r\n")
 123     (if (not (fboundp 'ldap-search-internal))
 124         (insert "<html>\n"
 125                 " <head>\n"
 126                 "  <title>LDAP Not Supported</title>\n"
 127                 "  <base href='" (url-recreate-url url) "'>\n"
 128                 " </head>\n"
 129                 " <body>\n"
 130                 "  <h1>LDAP Not Supported</h1>\n"
 131                 "  <p>\n"
 132                 "    This version of Emacs does not support LDAP.\n"
 133                 "  </p>\n"
 134                 " </body>\n"
 135                 "</html>\n")
 136       (let* ((binddn nil)
 137              (data (url-filename url))
 138              (host (url-host url))
 139              (port (url-port url))
 140              (base-object nil)
 141              (attributes nil)
 142              (scope nil)
 143              (filter nil)
 144              (extensions nil)
 145              (connection nil)
 146              (results nil)
 147              (extract-dn (and (fboundp 'function-max-args)
 148                               (= (function-max-args 'ldap-search-internal) 7))))
 149
 150         ;; Get rid of leading /
 151         (if (string-match "^/" data)
 152             (setq data (substring data 1)))
 153
 154         (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
 155               base-object (nth 0 data)
 156               attributes (nth 1 data)
 157               scope (nth 2 data)
 158               filter (nth 3 data)
 159               extensions (nth 4 data))
 160
 161         ;; fill in the defaults
 162         (setq base-object (url-unhex-string (or base-object ""))
 163               scope (intern (url-unhex-string (or scope "base")))
 164               filter (url-unhex-string (or filter "(objectClass=*)")))
 165
 166         (if (not (memq scope '(base one tree)))
 167             (error "Malformed LDAP URL: Unknown scope: %S" scope))
 168
 169         ;; Convert to the internal LDAP support scoping names.
 170         (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
 171
 172         (if attributes
 173             (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
 174
 175         ;; Parse out the exentions
 176         (if extensions
 177             (setq extensions (mapcar (lambda (ext)
 178                                        (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
 179                                            (cons (match-string 1 ext) (match-string 2 ext))
 180                                          (cons ext ext)))
 181                                      (split-string extensions ","))
 182                   extensions (mapcar (lambda (ext)
 183                                        (cons (url-unhex-string (car ext))
 184                                              (url-unhex-string (cdr ext))))
 185                                      extensions)))
 186
 187         (setq binddn (cdr-safe (or (assoc "bindname" extensions)
 188                                    (assoc "!bindname" extensions))))
 189
 190         ;; Now, let's actually do something with it.
 191         (setq connection (ldap-open host (if binddn (list 'binddn binddn)))
 192               results (if extract-dn
 193                           (ldap-search-internal connection filter base-object scope attributes nil t)
 194                         (ldap-search-internal connection filter base-object scope attributes nil)))
 195
 196         (ldap-close connection)
 197         (insert "<html>\n"
 198                 " <head>\n"
 199                 "  <title>LDAP Search Results</title>\n"
 200                 "  <base href='" (url-recreate-url url) "'>\n"
 201                 " </head>\n"
 202                 " <body>\n"
 203                 "  <h1>" (int-to-string (length results)) " matches</h1>\n")
 204
 205         (mapc (lambda (obj)
 206                 (insert "  <hr>\n"
 207                         "  <table border=1>\n")
 208                 (if extract-dn
 209                     (insert "   <tr><th colspan=2>" (car obj) "</th></tr>\n"))
 210                 (mapc (lambda (attr)
 211                         (if (= (length (cdr attr)) 1)
 212                             ;; single match, easy
 213                             (insert "   <tr><td>"
 214                                     (url-ldap-attribute-pretty-name (car attr))
 215                                     "</td><td>"
 216                                     (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
 217                                     "</td></tr>\n")
 218                           ;; Multiple matches, slightly uglier
 219                           (insert "   <tr>\n"
 220                                   (format "    <td valign=top>")
 221                                   (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
 222                                   (mapconcat (lambda (x)
 223                                                (url-ldap-attribute-pretty-desc (car attr) x))
 224                                              (cdr attr)
 225                                              "<br>\n")
 226                                   "</td>"
 227                                   "   </tr>\n")))
 228                       (if extract-dn (cdr obj) obj))
 229                 (insert "  </table>\n"))
 230               results)
 231
 232         (insert "  <hr>\n"
 233                 " </body>\n"
 234                 "</html>\n")))
 235     (current-buffer)))
 236
 237 (provide 'url-ldap)
 238
 239 ;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
 240 ;;; url-ldap.el ends here