| 1 | ;;; url-dav.el --- WebDAV support |
| 2 | |
| 3 | ;; Copyright (C) 2001, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Bill Perry <wmperry@gnu.org> |
| 6 | ;; Maintainer: Bill Perry <wmperry@gnu.org> |
| 7 | ;; Keywords: url, vc |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 3, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 24 | ;; Boston, MA 02110-1301, USA. |
| 25 | |
| 26 | ;; DAV is in RFC 2518. |
| 27 | |
| 28 | ;;; Commentary: |
| 29 | |
| 30 | ;;; Code: |
| 31 | |
| 32 | (eval-when-compile |
| 33 | (require 'cl)) |
| 34 | |
| 35 | (require 'xml) |
| 36 | (require 'url-util) |
| 37 | (require 'url-handlers) |
| 38 | |
| 39 | (defvar url-dav-supported-protocols '(1 2) |
| 40 | "List of supported DAV versions.") |
| 41 | |
| 42 | (defun url-intersection (l1 l2) |
| 43 | "Return a list of the elements occuring in both of the lists L1 and L2." |
| 44 | (if (null l2) |
| 45 | l2 |
| 46 | (let (result) |
| 47 | (while l1 |
| 48 | (if (member (car l1) l2) |
| 49 | (setq result (cons (pop l1) result)) |
| 50 | (pop l1))) |
| 51 | (nreverse result)))) |
| 52 | |
| 53 | ;;;###autoload |
| 54 | (defun url-dav-supported-p (url) |
| 55 | (and (featurep 'xml) |
| 56 | (fboundp 'xml-expand-namespace) |
| 57 | (url-intersection url-dav-supported-protocols |
| 58 | (plist-get (url-http-options url) 'dav)))) |
| 59 | |
| 60 | (defun url-dav-node-text (node) |
| 61 | "Return the text data from the XML node NODE." |
| 62 | (mapconcat (lambda (txt) |
| 63 | (if (stringp txt) |
| 64 | txt |
| 65 | "")) (xml-node-children node) " ")) |
| 66 | |
| 67 | \f |
| 68 | ;;; Parsing routines for the actual node contents. |
| 69 | ;; |
| 70 | ;; I am not incredibly happy with how this code looks/works right |
| 71 | ;; now, but it DOES work, and if we get the API right, our callers |
| 72 | ;; won't have to worry about the internal representation. |
| 73 | |
| 74 | (defconst url-dav-datatype-attribute |
| 75 | 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt) |
| 76 | |
| 77 | (defun url-dav-process-integer-property (node) |
| 78 | (truncate (string-to-number (url-dav-node-text node)))) |
| 79 | |
| 80 | (defun url-dav-process-number-property (node) |
| 81 | (string-to-number (url-dav-node-text node))) |
| 82 | |
| 83 | (defconst url-dav-iso8601-regexp |
| 84 | (let* ((dash "-?") |
| 85 | (colon ":?") |
| 86 | (4digit "\\([0-9][0-9][0-9][0-9]\\)") |
| 87 | (2digit "\\([0-9][0-9]\\)") |
| 88 | (date-fullyear 4digit) |
| 89 | (date-month 2digit) |
| 90 | (date-mday 2digit) |
| 91 | (time-hour 2digit) |
| 92 | (time-minute 2digit) |
| 93 | (time-second 2digit) |
| 94 | (time-secfrac "\\(\\.[0-9]+\\)?") |
| 95 | (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute)) |
| 96 | (time-offset (concat "Z" time-numoffset)) |
| 97 | (partial-time (concat time-hour colon time-minute colon time-second |
| 98 | time-secfrac)) |
| 99 | (full-date (concat date-fullyear dash date-month dash date-mday)) |
| 100 | (full-time (concat partial-time time-offset)) |
| 101 | (date-time (concat full-date "T" full-time))) |
| 102 | (list (concat "^" full-date) |
| 103 | (concat "T" partial-time) |
| 104 | (concat "Z" time-numoffset))) |
| 105 | "List of regular expressions matching iso8601 dates. |
| 106 | 1st regular expression matches the date. |
| 107 | 2nd regular expression matches the time. |
| 108 | 3rd regular expression matches the (optional) timezone specification.") |
| 109 | |
| 110 | (defun url-dav-process-date-property (node) |
| 111 | (require 'parse-time) |
| 112 | (let* ((date-re (nth 0 url-dav-iso8601-regexp)) |
| 113 | (time-re (nth 1 url-dav-iso8601-regexp)) |
| 114 | (tz-re (nth 2 url-dav-iso8601-regexp)) |
| 115 | (date-string (url-dav-node-text node)) |
| 116 | re-start |
| 117 | time seconds minute hour fractional-seconds |
| 118 | day month year day-of-week dst tz) |
| 119 | ;; We need to populate 'time' with |
| 120 | ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) |
| 121 | |
| 122 | ;; Nobody else handles iso8601 correctly, lets do it ourselves. |
| 123 | (when (string-match date-re date-string re-start) |
| 124 | (setq year (string-to-number (match-string 1 date-string)) |
| 125 | month (string-to-number (match-string 2 date-string)) |
| 126 | day (string-to-number (match-string 3 date-string)) |
| 127 | re-start (match-end 0)) |
| 128 | (when (string-match time-re date-string re-start) |
| 129 | (setq hour (string-to-number (match-string 1 date-string)) |
| 130 | minute (string-to-number (match-string 2 date-string)) |
| 131 | seconds (string-to-number (match-string 3 date-string)) |
| 132 | fractional-seconds (string-to-number (or |
| 133 | (match-string 4 date-string) |
| 134 | "0")) |
| 135 | re-start (match-end 0)) |
| 136 | (when (string-match tz-re date-string re-start) |
| 137 | (setq tz (match-string 1 date-string))) |
| 138 | (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" "")) |
| 139 | (setq time (list seconds minute hour day month year day-of-week dst tz)))) |
| 140 | |
| 141 | ;; Fall back to having Gnus do fancy things for us. |
| 142 | (when (not time) |
| 143 | (setq time (parse-time-string date-string))) |
| 144 | |
| 145 | (if time |
| 146 | (setq time (apply 'encode-time time)) |
| 147 | (url-debug 'dav "Unable to decode date (%S) (%s)" |
| 148 | (xml-node-name node) date-string)) |
| 149 | time)) |
| 150 | |
| 151 | (defun url-dav-process-boolean-property (node) |
| 152 | (/= 0 (string-to-number (url-dav-node-text node)))) |
| 153 | |
| 154 | (defun url-dav-process-uri-property (node) |
| 155 | ;; Returns a parsed representation of the URL... |
| 156 | (url-generic-parse-url (url-dav-node-text node))) |
| 157 | |
| 158 | (defun url-dav-find-parser (node) |
| 159 | "Find a function to parse the XML node NODE." |
| 160 | (or (get (xml-node-name node) 'dav-parser) |
| 161 | (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node))))) |
| 162 | (if (not (fboundp fn)) |
| 163 | (setq fn 'url-dav-node-text) |
| 164 | (put (xml-node-name node) 'dav-parser fn)) |
| 165 | fn))) |
| 166 | |
| 167 | (defmacro url-dav-dispatch-node (node) |
| 168 | `(funcall (url-dav-find-parser ,node) ,node)) |
| 169 | |
| 170 | (defun url-dav-process-DAV:prop (node) |
| 171 | ;; A prop node has content model of ANY |
| 172 | ;; |
| 173 | ;; Some predefined nodes have special meanings though. |
| 174 | ;; |
| 175 | ;; DAV:supportedlock - list of DAV:lockentry |
| 176 | ;; DAV:source |
| 177 | ;; DAV:iscollection - boolean |
| 178 | ;; DAV:getcontentlength - integer |
| 179 | ;; DAV:ishidden - boolean |
| 180 | ;; DAV:getcontenttype - string |
| 181 | ;; DAV:resourcetype - node who's name is the resource type |
| 182 | ;; DAV:getlastmodified - date |
| 183 | ;; DAV:creationdate - date |
| 184 | ;; DAV:displayname - string |
| 185 | ;; DAV:getetag - unknown |
| 186 | (let ((children (xml-node-children node)) |
| 187 | (node-type nil) |
| 188 | (props nil) |
| 189 | (value nil) |
| 190 | (handler-func nil)) |
| 191 | (when (not children) |
| 192 | (error "No child nodes in DAV:prop")) |
| 193 | |
| 194 | (while children |
| 195 | (setq node (car children) |
| 196 | node-type (intern |
| 197 | (or |
| 198 | (cdr-safe (assq url-dav-datatype-attribute |
| 199 | (xml-node-attributes node))) |
| 200 | "unknown")) |
| 201 | value nil) |
| 202 | |
| 203 | (case node-type |
| 204 | ((dateTime.iso8601tz |
| 205 | dateTime.iso8601 |
| 206 | dateTime.tz |
| 207 | dateTime.rfc1123 |
| 208 | dateTime |
| 209 | date) ; date is our 'special' one... |
| 210 | ;; Some type of date/time string. |
| 211 | (setq value (url-dav-process-date-property node))) |
| 212 | (int |
| 213 | ;; Integer type... |
| 214 | (setq value (url-dav-process-integer-property node))) |
| 215 | ((number float) |
| 216 | (setq value (url-dav-process-number-property node))) |
| 217 | (boolean |
| 218 | (setq value (url-dav-process-boolean-property node))) |
| 219 | (uri |
| 220 | (setq value (url-dav-process-uri-property node))) |
| 221 | (otherwise |
| 222 | (if (not (eq node-type 'unknown)) |
| 223 | (url-debug 'dav "Unknown data type in url-dav-process-prop: %s" |
| 224 | node-type)) |
| 225 | (setq value (url-dav-dispatch-node node)))) |
| 226 | |
| 227 | (setq props (plist-put props (xml-node-name node) value) |
| 228 | children (cdr children))) |
| 229 | props)) |
| 230 | |
| 231 | (defun url-dav-process-DAV:supportedlock (node) |
| 232 | ;; DAV:supportedlock is a list of DAV:lockentry items. |
| 233 | ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype. |
| 234 | ;; The DAV:lockscope must have a single node beneath it, ditto for |
| 235 | ;; DAV:locktype. |
| 236 | (let ((children (xml-node-children node)) |
| 237 | (results nil) |
| 238 | scope type) |
| 239 | (while children |
| 240 | (when (and (not (stringp (car children))) |
| 241 | (eq (xml-node-name (car children)) 'DAV:lockentry)) |
| 242 | (setq scope (assq 'DAV:lockscope (xml-node-children (car children))) |
| 243 | type (assq 'DAV:locktype (xml-node-children (car children)))) |
| 244 | (when (and scope type) |
| 245 | (setq scope (xml-node-name (car (xml-node-children scope))) |
| 246 | type (xml-node-name (car (xml-node-children type)))) |
| 247 | (push (cons type scope) results))) |
| 248 | (setq children (cdr children))) |
| 249 | results)) |
| 250 | |
| 251 | (defun url-dav-process-subnode-property (node) |
| 252 | ;; Returns a list of child node names. |
| 253 | (delq nil (mapcar 'car-safe (xml-node-children node)))) |
| 254 | |
| 255 | (defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property) |
| 256 | (defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property) |
| 257 | (defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property) |
| 258 | (defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property) |
| 259 | (defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property) |
| 260 | (defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property) |
| 261 | (defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property) |
| 262 | (defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property) |
| 263 | (defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property) |
| 264 | |
| 265 | (defun url-dav-process-DAV:locktoken (node) |
| 266 | ;; DAV:locktoken can have one or more DAV:href children. |
| 267 | (delq nil (mapcar (lambda (n) |
| 268 | (if (stringp n) |
| 269 | n |
| 270 | (url-dav-dispatch-node n))) |
| 271 | (xml-node-children node)))) |
| 272 | |
| 273 | (defun url-dav-process-DAV:owner (node) |
| 274 | ;; DAV:owner can contain anything. |
| 275 | (delq nil (mapcar (lambda (n) |
| 276 | (if (stringp n) |
| 277 | n |
| 278 | (url-dav-dispatch-node n))) |
| 279 | (xml-node-children node)))) |
| 280 | |
| 281 | (defun url-dav-process-DAV:activelock (node) |
| 282 | ;; DAV:activelock can contain: |
| 283 | ;; DAV:lockscope |
| 284 | ;; DAV:locktype |
| 285 | ;; DAV:depth |
| 286 | ;; DAV:owner (optional) |
| 287 | ;; DAV:timeout (optional) |
| 288 | ;; DAV:locktoken (optional) |
| 289 | (let ((children (xml-node-children node)) |
| 290 | (results nil)) |
| 291 | (while children |
| 292 | (if (listp (car children)) |
| 293 | (push (cons (xml-node-name (car children)) |
| 294 | (url-dav-dispatch-node (car children))) |
| 295 | results)) |
| 296 | (setq children (cdr children))) |
| 297 | results)) |
| 298 | |
| 299 | (defun url-dav-process-DAV:lockdiscovery (node) |
| 300 | ;; Can only contain a list of DAV:activelock objects. |
| 301 | (let ((children (xml-node-children node)) |
| 302 | (results nil)) |
| 303 | (while children |
| 304 | (cond |
| 305 | ((stringp (car children)) |
| 306 | ;; text node? why? |
| 307 | nil) |
| 308 | ((eq (xml-node-name (car children)) 'DAV:activelock) |
| 309 | (push (url-dav-dispatch-node (car children)) results)) |
| 310 | (t |
| 311 | ;; Ignore unknown nodes... |
| 312 | nil)) |
| 313 | (setq children (cdr children))) |
| 314 | results)) |
| 315 | |
| 316 | (defun url-dav-process-DAV:status (node) |
| 317 | ;; The node contains a standard HTTP/1.1 response line... we really |
| 318 | ;; only care about the numeric status code. |
| 319 | (let ((status (url-dav-node-text node))) |
| 320 | (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status) |
| 321 | (string-to-number (match-string 1 status)) |
| 322 | 500))) |
| 323 | |
| 324 | (defun url-dav-process-DAV:propstat (node) |
| 325 | ;; A propstate node can have the following children... |
| 326 | ;; |
| 327 | ;; DAV:prop - a list of properties and values |
| 328 | ;; DAV:status - An HTTP/1.1 status line |
| 329 | (let ((children (xml-node-children node)) |
| 330 | (props nil) |
| 331 | (status nil)) |
| 332 | (when (not children) |
| 333 | (error "No child nodes in DAV:propstat")) |
| 334 | |
| 335 | (setq props (url-dav-dispatch-node (assq 'DAV:prop children)) |
| 336 | status (url-dav-dispatch-node (assq 'DAV:status children))) |
| 337 | |
| 338 | ;; Need to parse out the HTTP status |
| 339 | (setq props (plist-put props 'DAV:status status)) |
| 340 | props)) |
| 341 | |
| 342 | (defun url-dav-process-DAV:response (node) |
| 343 | (let ((children (xml-node-children node)) |
| 344 | (propstat nil) |
| 345 | (href)) |
| 346 | (when (not children) |
| 347 | (error "No child nodes in DAV:response")) |
| 348 | |
| 349 | ;; A response node can have the following children... |
| 350 | ;; |
| 351 | ;; DAV:href - URL the response is for. |
| 352 | ;; DAV:propstat - see url-dav-process-propstat |
| 353 | ;; DAV:responsedescription - text description of the response |
| 354 | (setq propstat (assq 'DAV:propstat children) |
| 355 | href (assq 'DAV:href children)) |
| 356 | |
| 357 | (when (not href) |
| 358 | (error "No href in DAV:response")) |
| 359 | |
| 360 | (when (not propstat) |
| 361 | (error "No propstat in DAV:response")) |
| 362 | |
| 363 | (setq propstat (url-dav-dispatch-node propstat) |
| 364 | href (url-dav-dispatch-node href)) |
| 365 | (cons href propstat))) |
| 366 | |
| 367 | (defun url-dav-process-DAV:multistatus (node) |
| 368 | (let ((children (xml-node-children node)) |
| 369 | (results nil)) |
| 370 | (while children |
| 371 | (push (url-dav-dispatch-node (car children)) results) |
| 372 | (setq children (cdr children))) |
| 373 | results)) |
| 374 | |
| 375 | \f |
| 376 | ;;; DAV request/response generation/processing |
| 377 | (defun url-dav-process-response (buffer url) |
| 378 | "Parse a WebDAV response from BUFFER, interpreting it relative to URL. |
| 379 | |
| 380 | The buffer must have been retrieved by HTTP or HTTPS and contain an |
| 381 | XML document." |
| 382 | (declare (special url-http-content-type |
| 383 | url-http-response-status |
| 384 | url-http-end-of-headers)) |
| 385 | (let ((tree nil) |
| 386 | (overall-status nil)) |
| 387 | (when buffer |
| 388 | (unwind-protect |
| 389 | (with-current-buffer buffer |
| 390 | (goto-char url-http-end-of-headers) |
| 391 | (setq overall-status url-http-response-status) |
| 392 | |
| 393 | ;; XML documents can be transferred as either text/xml or |
| 394 | ;; application/xml, and we are required to accept both of |
| 395 | ;; them. |
| 396 | (if (and |
| 397 | url-http-content-type |
| 398 | (string-match "\\`\\(text\\|application\\)/xml" |
| 399 | url-http-content-type)) |
| 400 | (setq tree (xml-parse-region (point) (point-max))))) |
| 401 | ;; Clean up after ourselves. |
| 402 | (kill-buffer buffer))) |
| 403 | |
| 404 | ;; We should now be |
| 405 | (if (eq (xml-node-name (car tree)) 'DAV:multistatus) |
| 406 | (url-dav-dispatch-node (car tree)) |
| 407 | (url-debug 'dav "Got back singleton response for URL(%S)" url) |
| 408 | (let ((properties (url-dav-dispatch-node (car tree)))) |
| 409 | ;; We need to make sure we have a DAV:status node in there for |
| 410 | ;; higher-level code; |
| 411 | (setq properties (plist-put properties 'DAV:status overall-status)) |
| 412 | ;; Make this look like a DAV:multistatus parse tree so that |
| 413 | ;; nobody but us needs to know the difference. |
| 414 | (list (cons url properties)))))) |
| 415 | |
| 416 | (defun url-dav-request (url method tag body |
| 417 | &optional depth headers namespaces) |
| 418 | "Perform WebDAV operation METHOD on URL. Return the parsed responses. |
| 419 | Automatically creates an XML request body if TAG is non-nil. |
| 420 | BODY is the XML document fragment to be enclosed by <TAG></TAG>. |
| 421 | |
| 422 | DEPTH is how deep the request should propogate. Default is 0, meaning |
| 423 | it should apply only to URL. A negative number means to use |
| 424 | `Infinity' for the depth. Not all WebDAV servers support this depth |
| 425 | though. |
| 426 | |
| 427 | HEADERS is an assoc list of extra headers to send in the request. |
| 428 | |
| 429 | NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are |
| 430 | added to the <TAG> element. The DAV=DAV: namespace is automatically |
| 431 | added to this list, so most requests can just pass in nil." |
| 432 | ;; Take care of the default value for depth... |
| 433 | (setq depth (or depth 0)) |
| 434 | |
| 435 | ;; Now lets translate it into something webdav can understand. |
| 436 | (if (< depth 0) |
| 437 | (setq depth "Infinity") |
| 438 | (setq depth (int-to-string depth))) |
| 439 | (if (not (assoc "DAV" namespaces)) |
| 440 | (setq namespaces (cons '("DAV" . "DAV:") namespaces))) |
| 441 | |
| 442 | (let* ((url-request-extra-headers `(("Depth" . ,depth) |
| 443 | ("Content-type" . "text/xml") |
| 444 | ,@headers)) |
| 445 | (url-request-method method) |
| 446 | (url-request-data |
| 447 | (if tag |
| 448 | (concat |
| 449 | "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n" |
| 450 | "<" (symbol-name tag) " " |
| 451 | ;; add in the appropriate namespaces... |
| 452 | (mapconcat (lambda (ns) |
| 453 | (concat "xmlns:" (car ns) "='" (cdr ns) "'")) |
| 454 | namespaces "\n ") |
| 455 | ">\n" |
| 456 | body |
| 457 | "</" (symbol-name tag) ">\n")))) |
| 458 | (url-dav-process-response (url-retrieve-synchronously url) url))) |
| 459 | |
| 460 | (defun url-dav-get-properties (url &optional attributes depth namespaces) |
| 461 | "Return properties for URL, up to DEPTH levels deep. |
| 462 | |
| 463 | Returns an assoc list, where the key is the filename (possibly a full |
| 464 | URI), and the value is a standard property list of DAV property |
| 465 | names (ie: DAV:resourcetype)." |
| 466 | (url-dav-request url "PROPFIND" 'DAV:propfind |
| 467 | (if attributes |
| 468 | (mapconcat (lambda (attr) |
| 469 | (concat "<DAV:prop><" |
| 470 | (symbol-name attr) |
| 471 | "/></DAV:prop>")) |
| 472 | attributes "\n ") |
| 473 | " <DAV:allprop/>") |
| 474 | depth nil namespaces)) |
| 475 | |
| 476 | (defmacro url-dav-http-success-p (status) |
| 477 | "Return whether PROPERTIES was the result of a successful DAV request." |
| 478 | `(= (/ (or ,status 500) 100) 2)) |
| 479 | |
| 480 | \f |
| 481 | ;;; Locking support |
| 482 | (defvar url-dav-lock-identifier (concat "mailto:" user-mail-address) |
| 483 | "*URL used as contact information when creating locks in DAV. |
| 484 | This will be used as the contents of the DAV:owner/DAV:href tag to |
| 485 | identify the owner of a LOCK when requesting it. This will be shown |
| 486 | to other users when the DAV:lockdiscovery property is requested, so |
| 487 | make sure you are comfortable with it leaking to the outside world.") |
| 488 | |
| 489 | (defun url-dav-lock-resource (url exclusive &optional depth) |
| 490 | "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock. |
| 491 | Optional 3rd argument DEPTH says how deep the lock should go, default is 0 |
| 492 | \(lock only the resource and none of its children\). |
| 493 | |
| 494 | Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS). |
| 495 | SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken). |
| 496 | FAILURE-RESULTS is a list of (URL STATUS)." |
| 497 | (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>")) |
| 498 | (let* ((body |
| 499 | (concat |
| 500 | " <DAV:lockscope>" exclusive "</DAV:lockscope>\n" |
| 501 | " <DAV:locktype> <DAV:write/> </DAV:locktype>\n" |
| 502 | " <DAV:owner>\n" |
| 503 | " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n" |
| 504 | " </DAV:owner>\n")) |
| 505 | (response nil) ; Responses to the LOCK request |
| 506 | (result nil) ; For walking thru the response list |
| 507 | (child-url nil) |
| 508 | (child-status nil) |
| 509 | (failures nil) ; List of failure cases (URL . STATUS) |
| 510 | (successes nil)) ; List of success cases (URL . STATUS) |
| 511 | (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body |
| 512 | depth '(("Timeout" . "Infinite")))) |
| 513 | |
| 514 | ;; Get the parent URL ready for expand-file-name |
| 515 | (if (not (vectorp url)) |
| 516 | (setq url (url-generic-parse-url url))) |
| 517 | |
| 518 | ;; Walk thru the response list, fully expand the URL, and grab the |
| 519 | ;; status code. |
| 520 | (while response |
| 521 | (setq result (pop response) |
| 522 | child-url (url-expand-file-name (pop result) url) |
| 523 | child-status (or (plist-get result 'DAV:status) 500)) |
| 524 | (if (url-dav-http-success-p child-status) |
| 525 | (push (list url child-status "huh") successes) |
| 526 | (push (list url child-status) failures))) |
| 527 | (cons successes failures))) |
| 528 | |
| 529 | (defun url-dav-active-locks (url &optional depth) |
| 530 | "Return an assoc list of all active locks on URL." |
| 531 | (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth)) |
| 532 | (properties nil) |
| 533 | (child nil) |
| 534 | (child-url nil) |
| 535 | (child-results nil) |
| 536 | (results nil)) |
| 537 | (if (not (vectorp url)) |
| 538 | (setq url (url-generic-parse-url url))) |
| 539 | |
| 540 | (while response |
| 541 | (setq child (pop response) |
| 542 | child-url (pop child) |
| 543 | child-results nil) |
| 544 | (when (and (url-dav-http-success-p (plist-get child 'DAV:status)) |
| 545 | (setq child (plist-get child 'DAV:lockdiscovery))) |
| 546 | ;; After our parser has had its way with it, The |
| 547 | ;; DAV:lockdiscovery property is a list of DAV:activelock |
| 548 | ;; objects, which are comprised of DAV:activelocks, which |
| 549 | ;; assoc lists of properties and values. |
| 550 | (while child |
| 551 | (if (assq 'DAV:locktoken (car child)) |
| 552 | (let ((tokens (cdr (assq 'DAV:locktoken (car child)))) |
| 553 | (owners (cdr (assq 'DAV:owner (car child))))) |
| 554 | (dolist (token tokens) |
| 555 | (dolist (owner owners) |
| 556 | (push (cons token owner) child-results))))) |
| 557 | (pop child))) |
| 558 | (if child-results |
| 559 | (push (cons (url-expand-file-name child-url url) child-results) |
| 560 | results))) |
| 561 | results)) |
| 562 | |
| 563 | (defun url-dav-unlock-resource (url lock-token) |
| 564 | "Release the lock on URL represented by LOCK-TOKEN. |
| 565 | Returns t if the lock was successfully released." |
| 566 | (declare (special url-http-response-status)) |
| 567 | (let* ((url-request-extra-headers (list (cons "Lock-Token" |
| 568 | (concat "<" lock-token ">")))) |
| 569 | (url-request-method "UNLOCK") |
| 570 | (url-request-data nil) |
| 571 | (buffer (url-retrieve-synchronously url)) |
| 572 | (result nil)) |
| 573 | (when buffer |
| 574 | (unwind-protect |
| 575 | (with-current-buffer buffer |
| 576 | (setq result (url-dav-http-success-p url-http-response-status))) |
| 577 | (kill-buffer buffer))) |
| 578 | result)) |
| 579 | |
| 580 | \f |
| 581 | ;;; file-name-handler stuff |
| 582 | (defun url-dav-file-attributes-mode-string (properties) |
| 583 | (let ((modes (make-string 10 ?-)) |
| 584 | (supported-locks (plist-get properties 'DAV:supportedlock)) |
| 585 | (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable) |
| 586 | "T")) |
| 587 | (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype))) |
| 588 | (readable t) |
| 589 | (lock nil)) |
| 590 | ;; Assume we can read this, otherwise the PROPFIND would have |
| 591 | ;; failed. |
| 592 | (when readable |
| 593 | (aset modes 1 ?r) |
| 594 | (aset modes 4 ?r) |
| 595 | (aset modes 7 ?r)) |
| 596 | |
| 597 | (when directory-p |
| 598 | (aset modes 0 ?d)) |
| 599 | |
| 600 | (when executable-p |
| 601 | (aset modes 3 ?x) |
| 602 | (aset modes 6 ?x) |
| 603 | (aset modes 9 ?x)) |
| 604 | |
| 605 | (while supported-locks |
| 606 | (setq lock (car supported-locks) |
| 607 | supported-locks (cdr supported-locks)) |
| 608 | (case (car lock) |
| 609 | (DAV:write |
| 610 | (case (cdr lock) |
| 611 | (DAV:shared ; group permissions (possibly world) |
| 612 | (aset modes 5 ?w)) |
| 613 | (DAV:exclusive |
| 614 | (aset modes 2 ?w)) ; owner permissions? |
| 615 | (otherwise |
| 616 | (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) |
| 617 | (otherwise |
| 618 | (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock))))) |
| 619 | modes)) |
| 620 | |
| 621 | (autoload 'url-http-head-file-attributes "url-http") |
| 622 | |
| 623 | (defun url-dav-file-attributes (url &optional id-format) |
| 624 | (let ((properties (cdar (url-dav-get-properties url)))) |
| 625 | (if (and properties |
| 626 | (url-dav-http-success-p (plist-get properties 'DAV:status))) |
| 627 | ;; We got a good DAV response back.. |
| 628 | (list |
| 629 | ;; t for directory, string for symbolic link, or nil |
| 630 | ;; Need to support DAV Bindings to figure out the |
| 631 | ;; symbolic link issues. |
| 632 | (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil) |
| 633 | |
| 634 | ;; Number of links to file... Needs DAV Bindings. |
| 635 | 1 |
| 636 | |
| 637 | ;; File uid - no way to figure out? |
| 638 | 0 |
| 639 | |
| 640 | ;; File gid - no way to figure out? |
| 641 | 0 |
| 642 | |
| 643 | ;; Last access time - ??? |
| 644 | nil |
| 645 | |
| 646 | ;; Last modification time |
| 647 | (plist-get properties 'DAV:getlastmodified) |
| 648 | |
| 649 | ;; Last status change time... just reuse last-modified |
| 650 | ;; for now. |
| 651 | (plist-get properties 'DAV:getlastmodified) |
| 652 | |
| 653 | ;; size in bytes |
| 654 | (or (plist-get properties 'DAV:getcontentlength) 0) |
| 655 | |
| 656 | ;; file modes as a string like `ls -l' |
| 657 | ;; |
| 658 | ;; Should be able to build this up from the |
| 659 | ;; DAV:supportedlock attribute pretty easily. Getting |
| 660 | ;; the group info could be impossible though. |
| 661 | (url-dav-file-attributes-mode-string properties) |
| 662 | |
| 663 | ;; t if file's gid would change if it were deleted & |
| 664 | ;; recreated. No way for us to know that thru DAV. |
| 665 | nil |
| 666 | |
| 667 | ;; inode number - meaningless |
| 668 | nil |
| 669 | |
| 670 | ;; device number - meaningless |
| 671 | nil) |
| 672 | ;; Fall back to just the normal http way of doing things. |
| 673 | (url-http-head-file-attributes url id-format)))) |
| 674 | |
| 675 | (defun url-dav-save-resource (url obj &optional content-type lock-token) |
| 676 | "Save OBJ as URL using WebDAV. |
| 677 | URL must be a fully qualified URL. |
| 678 | OBJ may be a buffer or a string." |
| 679 | (declare (special url-http-response-status)) |
| 680 | (let ((buffer nil) |
| 681 | (result nil) |
| 682 | (url-request-extra-headers nil) |
| 683 | (url-request-method "PUT") |
| 684 | (url-request-data |
| 685 | (cond |
| 686 | ((bufferp obj) |
| 687 | (with-current-buffer obj |
| 688 | (buffer-string))) |
| 689 | ((stringp obj) |
| 690 | obj) |
| 691 | (t |
| 692 | (error "Invalid object to url-dav-save-resource"))))) |
| 693 | |
| 694 | (if lock-token |
| 695 | (push |
| 696 | (cons "If" (concat "(<" lock-token ">)")) |
| 697 | url-request-extra-headers)) |
| 698 | |
| 699 | ;; Everything must always have a content-type when we submit it. |
| 700 | (push |
| 701 | (cons "Content-type" (or content-type "application/octet-stream")) |
| 702 | url-request-extra-headers) |
| 703 | |
| 704 | ;; Do the save... |
| 705 | (setq buffer (url-retrieve-synchronously url)) |
| 706 | |
| 707 | ;; Sanity checking |
| 708 | (when buffer |
| 709 | (unwind-protect |
| 710 | (with-current-buffer buffer |
| 711 | (setq result (url-dav-http-success-p url-http-response-status))) |
| 712 | (kill-buffer buffer))) |
| 713 | result)) |
| 714 | |
| 715 | (eval-when-compile |
| 716 | (defmacro url-dav-delete-something (url lock-token &rest error-checking) |
| 717 | "Delete URL completely, with no sanity checking whatsoever. DO NOT USE. |
| 718 | This is defined as a macro that will not be visible from compiled files. |
| 719 | Use with care, and even then think three times. |
| 720 | " |
| 721 | `(progn |
| 722 | ,@error-checking |
| 723 | (url-dav-request ,url "DELETE" nil nil -1 |
| 724 | (if ,lock-token |
| 725 | (list |
| 726 | (cons "If" |
| 727 | (concat "(<" ,lock-token ">)")))))))) |
| 728 | |
| 729 | |
| 730 | (defun url-dav-delete-directory (url &optional recursive lock-token) |
| 731 | "Delete the WebDAV collection URL. |
| 732 | If optional second argument RECURSIVE is non-nil, then delete all |
| 733 | files in the collection as well." |
| 734 | (let ((status nil) |
| 735 | (props nil) |
| 736 | (props nil)) |
| 737 | (setq props (url-dav-delete-something |
| 738 | url lock-token |
| 739 | (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1)) |
| 740 | (if (and (not recursive) |
| 741 | (/= (length props) 1)) |
| 742 | (signal 'file-error (list "Removing directory" |
| 743 | "directory not empty" url))))) |
| 744 | |
| 745 | (mapc (lambda (result) |
| 746 | (setq status (plist-get (cdr result) 'DAV:status)) |
| 747 | (if (not (url-dav-http-success-p status)) |
| 748 | (signal 'file-error (list "Removing directory" |
| 749 | "Errror removing" |
| 750 | (car result) status)))) |
| 751 | props)) |
| 752 | nil) |
| 753 | |
| 754 | (defun url-dav-delete-file (url &optional lock-token) |
| 755 | "Delete file named URL." |
| 756 | (let ((props nil) |
| 757 | (status nil)) |
| 758 | (setq props (url-dav-delete-something |
| 759 | url lock-token |
| 760 | (setq props (url-dav-get-properties url)) |
| 761 | (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection) |
| 762 | (signal 'file-error (list "Removing old name" "is a collection" url))))) |
| 763 | |
| 764 | (mapc (lambda (result) |
| 765 | (setq status (plist-get (cdr result) 'DAV:status)) |
| 766 | (if (not (url-dav-http-success-p status)) |
| 767 | (signal 'file-error (list "Removing old name" |
| 768 | "Errror removing" |
| 769 | (car result) status)))) |
| 770 | props)) |
| 771 | nil) |
| 772 | |
| 773 | (defun url-dav-directory-files (url &optional full match nosort files-only) |
| 774 | "Return a list of names of files in DIRECTORY. |
| 775 | There are three optional arguments: |
| 776 | If FULL is non-nil, return absolute file names. Otherwise return names |
| 777 | that are relative to the specified directory. |
| 778 | If MATCH is non-nil, mention only file names that match the regexp MATCH. |
| 779 | If NOSORT is non-nil, the list is not sorted--its order is unpredictable. |
| 780 | NOSORT is useful if you plan to sort the result yourself." |
| 781 | (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1)) |
| 782 | (child-url nil) |
| 783 | (child-props nil) |
| 784 | (files nil) |
| 785 | (parsed-url (url-generic-parse-url url))) |
| 786 | |
| 787 | (if (= (length properties) 1) |
| 788 | (signal 'file-error (list "Opening directory" "not a directory" url))) |
| 789 | |
| 790 | (while properties |
| 791 | (setq child-props (pop properties) |
| 792 | child-url (pop child-props)) |
| 793 | (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection) |
| 794 | files-only) |
| 795 | ;; It is a directory, and we were told to return just files. |
| 796 | nil |
| 797 | |
| 798 | ;; Fully expand the URL and then rip off the beginning if we |
| 799 | ;; are not supposed to return fully-qualified names. |
| 800 | (setq child-url (url-expand-file-name child-url parsed-url)) |
| 801 | (if (not full) |
| 802 | (setq child-url (substring child-url (length url)))) |
| 803 | |
| 804 | ;; We don't want '/' as the last character in filenames... |
| 805 | (if (string-match "/$" child-url) |
| 806 | (setq child-url (substring child-url 0 -1))) |
| 807 | |
| 808 | ;; If we have a match criteria, then apply it. |
| 809 | (if (or (and match (not (string-match match child-url))) |
| 810 | (string= child-url "") |
| 811 | (string= child-url url)) |
| 812 | nil |
| 813 | (push child-url files)))) |
| 814 | |
| 815 | (if nosort |
| 816 | files |
| 817 | (sort files 'string-lessp)))) |
| 818 | |
| 819 | (defun url-dav-file-directory-p (url) |
| 820 | "Return t if URL names an existing DAV collection." |
| 821 | (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype))))) |
| 822 | (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection))) |
| 823 | |
| 824 | (defun url-dav-make-directory (url &optional parents) |
| 825 | "Create the directory DIR and any nonexistent parent dirs." |
| 826 | (declare (special url-http-response-status)) |
| 827 | (let* ((url-request-extra-headers nil) |
| 828 | (url-request-method "MKCOL") |
| 829 | (url-request-data nil) |
| 830 | (buffer (url-retrieve-synchronously url)) |
| 831 | (result nil)) |
| 832 | (when buffer |
| 833 | (unwind-protect |
| 834 | (with-current-buffer buffer |
| 835 | (case url-http-response-status |
| 836 | (201 ; Collection created in its entirety |
| 837 | (setq result t)) |
| 838 | (403 ; Forbidden |
| 839 | nil) |
| 840 | (405 ; Method not allowed |
| 841 | nil) |
| 842 | (409 ; Conflict |
| 843 | nil) |
| 844 | (415 ; Unsupported media type (WTF?) |
| 845 | nil) |
| 846 | (507 ; Insufficient storage |
| 847 | nil) |
| 848 | (otherwise |
| 849 | nil))) |
| 850 | (kill-buffer buffer))) |
| 851 | result)) |
| 852 | |
| 853 | (defun url-dav-rename-file (oldname newname &optional overwrite) |
| 854 | (if (not (and (string-match url-handler-regexp oldname) |
| 855 | (string-match url-handler-regexp newname))) |
| 856 | (signal 'file-error |
| 857 | (list "Cannot rename between different URL backends" |
| 858 | oldname newname))) |
| 859 | |
| 860 | (let* ((headers nil) |
| 861 | (props nil) |
| 862 | (status nil) |
| 863 | (directory-p (url-dav-file-directory-p oldname)) |
| 864 | (exists-p (url-http-file-exists-p newname))) |
| 865 | |
| 866 | (if (and exists-p |
| 867 | (or |
| 868 | (null overwrite) |
| 869 | (and (numberp overwrite) |
| 870 | (not (yes-or-no-p |
| 871 | (format "File %s already exists; rename to it anyway? " |
| 872 | newname)))))) |
| 873 | (signal 'file-already-exists (list "File already exists" newname))) |
| 874 | |
| 875 | ;; Honor the overwrite flag... |
| 876 | (if overwrite (push '("Overwrite" . "T") headers)) |
| 877 | |
| 878 | ;; Have to tell them where to copy it to! |
| 879 | (push (cons "Destination" newname) headers) |
| 880 | |
| 881 | ;; Always send a depth of -1 in case we are moving a collection. |
| 882 | (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0) |
| 883 | headers)) |
| 884 | |
| 885 | (mapc (lambda (result) |
| 886 | (setq status (plist-get (cdr result) 'DAV:status)) |
| 887 | |
| 888 | (if (not (url-dav-http-success-p status)) |
| 889 | (signal 'file-error (list "Renaming" oldname newname status)))) |
| 890 | props) |
| 891 | t)) |
| 892 | |
| 893 | (defun url-dav-file-name-all-completions (file url) |
| 894 | "Return a list of all completions of file name FILE in directory DIRECTORY. |
| 895 | These are all file names in directory DIRECTORY which begin with FILE." |
| 896 | (url-dav-directory-files url nil (concat "^" file ".*"))) |
| 897 | |
| 898 | (defun url-dav-file-name-completion (file url) |
| 899 | "Complete file name FILE in directory DIRECTORY. |
| 900 | Returns the longest string |
| 901 | common to all file names in DIRECTORY that start with FILE. |
| 902 | If there is only one and FILE matches it exactly, returns t. |
| 903 | Returns nil if DIR contains no name starting with FILE." |
| 904 | (let ((matches (url-dav-file-name-all-completions file url)) |
| 905 | (result nil)) |
| 906 | (cond |
| 907 | ((null matches) |
| 908 | ;; No matches |
| 909 | nil) |
| 910 | ((and (= (length matches) 1) |
| 911 | (string= file (car matches))) |
| 912 | ;; Only one file and FILE matches it exactly... |
| 913 | t) |
| 914 | (t |
| 915 | ;; Need to figure out the longest string that they have in commmon |
| 916 | (setq matches (sort matches (lambda (a b) (> (length a) (length b))))) |
| 917 | (let ((n (length file)) |
| 918 | (searching t) |
| 919 | (regexp nil) |
| 920 | (failed nil)) |
| 921 | (while (and searching |
| 922 | (< n (length (car matches)))) |
| 923 | (setq regexp (concat "^" (substring (car matches) 0 (1+ n))) |
| 924 | failed nil) |
| 925 | (dolist (potential matches) |
| 926 | (if (not (string-match regexp potential)) |
| 927 | (setq failed t))) |
| 928 | (if failed |
| 929 | (setq searching nil) |
| 930 | (incf n))) |
| 931 | (substring (car matches) 0 n)))))) |
| 932 | |
| 933 | (defun url-dav-register-handler (op) |
| 934 | (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op)))) |
| 935 | |
| 936 | (mapcar 'url-dav-register-handler |
| 937 | ;; These handlers are disabled because they incorrectly presume that |
| 938 | ;; the URL specifies an HTTP location and thus break FTP URLs. |
| 939 | '(;; file-name-all-completions |
| 940 | ;; file-name-completion |
| 941 | ;; rename-file |
| 942 | ;; make-directory |
| 943 | ;; file-directory-p |
| 944 | ;; directory-files |
| 945 | ;; delete-file |
| 946 | ;; delete-directory |
| 947 | ;; file-attributes |
| 948 | )) |
| 949 | |
| 950 | \f |
| 951 | ;;; Version Control backend cruft |
| 952 | |
| 953 | ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered) |
| 954 | |
| 955 | ;;;###autoload |
| 956 | (defun url-dav-vc-registered (url) |
| 957 | (if (and (string-match "\\`https?" url) |
| 958 | (plist-get (url-http-options url) 'dav)) |
| 959 | (progn |
| 960 | (vc-file-setprop url 'vc-backend 'dav) |
| 961 | t))) |
| 962 | |
| 963 | \f |
| 964 | ;;; Miscellaneous stuff. |
| 965 | |
| 966 | (provide 'url-dav) |
| 967 | |
| 968 | ;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e |
| 969 | ;;; url-dav.el ends here |