1;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code 2 3;; Copyright (C) 1998, 1999, 2004, 2005, 2006, 2007 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 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., 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. 119The return value is a buffer displaying the search results in HTML. 120URL 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 245