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 2, 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 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. 1061st regular expression matches the date. 1072nd regular expression matches the time. 1083rd 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 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 380The buffer must have been retrieved by HTTP or HTTPS and contain an 381XML 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. 419Automatically creates an XML request body if TAG is non-nil. 420BODY is the XML document fragment to be enclosed by <TAG></TAG>. 421 422DEPTH is how deep the request should propogate. Default is 0, meaning 423it should apply only to URL. A negative number means to use 424`Infinity' for the depth. Not all WebDAV servers support this depth 425though. 426 427HEADERS is an assoc list of extra headers to send in the request. 428 429NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are 430added to the <TAG> element. The DAV=DAV: namespace is automatically 431added 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 463Returns an assoc list, where the key is the filename (possibly a full 464URI), and the value is a standard property list of DAV property 465names (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 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. 484This will be used as the contents of the DAV:owner/DAV:href tag to 485identify the owner of a LOCK when requesting it. This will be shown 486to other users when the DAV:lockdiscovery property is requested, so 487make 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. 491Optional 3rd argument DEPTH says how deep the lock should go, default is 0 492\(lock only the resource and none of its children\). 493 494Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS). 495SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken). 496FAILURE-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. 565Returns t iff 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 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 iff 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. 677URL must be a fully qualified URL. 678OBJ 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. 718This is defined as a macro that will not be visible from compiled files. 719Use 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. 732If optional second argument RECURSIVE is non-nil, then delete all 733files 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. 775There are three optional arguments: 776If FULL is non-nil, return absolute file names. Otherwise return names 777 that are relative to the specified directory. 778If MATCH is non-nil, mention only file names that match the regexp MATCH. 779If 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. 895These 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. 900Returns the longest string 901common to all file names in DIRECTORY that start with FILE. 902If there is only one and FILE matches it exactly, returns t. 903Returns 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 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 964;;; Miscellaneous stuff. 965 966(provide 'url-dav) 967 968;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e 969;;; url-dav.el ends here 970