cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/url-dav.el

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