code.delx.au - gnu-emacs/blob - lisp/url/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 (require 'cl-lib))
  31
  32 (require 'xml)
  33 (require 'url-util)
  34 (require 'url-handlers)
  35
  36 (defvar url-dav-supported-protocols '(1 2)
  37   "List of supported DAV versions.")
  38
  39 (defvar url-http-content-type)
  40 (defvar url-http-response-status)
  41 (defvar url-http-end-of-headers)
  42
  43 (defun url-intersection (l1 l2)
  44   "Return a list of the elements occurring in both of the lists L1 and L2."
  45   (if (null l2)
  46       l2
  47     (let (result)
  48       (while l1
  49         (if (member (car l1) l2)
  50             (setq result (cons (pop l1) result))
  51           (pop l1)))
  52       (nreverse result))))
  53
  54 ;;;###autoload
  55 (defun url-dav-supported-p (url)
  56   (and (featurep 'xml)
  57        (fboundp 'xml-expand-namespace)
  58        (url-intersection url-dav-supported-protocols
  59                          (plist-get (url-http-options url) 'dav))))
  60
  61 (defun url-dav-node-text (node)
  62   "Return the text data from the XML node NODE."
  63   (mapconcat (lambda (txt)
  64                (if (stringp txt)
  65                    txt
  66                  "")) (xml-node-children node) " "))
  67
  68 \f
  69 ;;; Parsing routines for the actual node contents.
  70 ;;
  71 ;; I am not incredibly happy with how this code looks/works right
  72 ;; now, but it DOES work, and if we get the API right, our callers
  73 ;; won't have to worry about the internal representation.
  74
  75 (defconst url-dav-datatype-attribute
  76   'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
  77
  78 (defun url-dav-process-integer-property (node)
  79   (truncate (string-to-number (url-dav-node-text node))))
  80
  81 (defun url-dav-process-number-property (node)
  82   (string-to-number (url-dav-node-text node)))
  83
  84 (defconst url-dav-iso8601-regexp
  85   (let* ((dash "-?")
  86          (colon ":?")
  87          (4digit "\\([0-9][0-9][0-9][0-9]\\)")
  88          (2digit "\\([0-9][0-9]\\)")
  89          (date-fullyear 4digit)
  90          (date-month 2digit)
  91          (date-mday 2digit)
  92          (time-hour 2digit)
  93          (time-minute 2digit)
  94          (time-second 2digit)
  95          (time-secfrac "\\(\\.[0-9]+\\)?")
  96          (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
  97          (time-offset (concat "Z" time-numoffset))
  98          (partial-time (concat time-hour colon time-minute colon time-second
  99                                time-secfrac))
 100          (full-date (concat date-fullyear dash date-month dash date-mday))
 101          (full-time (concat partial-time time-offset))
 102          (date-time (concat full-date "T" full-time)))
 103     (list (concat "^" full-date)
 104           (concat "T" partial-time)
 105           (concat "Z" time-numoffset)))
 106   "List of regular expressions matching ISO 8601 dates.
 107 1st regular expression matches the date.
 108 2nd regular expression matches the time.
 109 3rd regular expression matches the (optional) timezone specification.")
 110
 111 (defun url-dav-process-date-property (node)
 112   (require 'parse-time)
 113   (let* ((date-re (nth 0 url-dav-iso8601-regexp))
 114          (time-re (nth 1 url-dav-iso8601-regexp))
 115          (tz-re (nth 2 url-dav-iso8601-regexp))
 116          (date-string (url-dav-node-text node))
 117          re-start
 118          time seconds minute hour fractional-seconds
 119          day month year day-of-week dst tz)
 120     ;; We need to populate 'time' with
 121     ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
 122
 123     ;; Nobody else handles iso8601 correctly, let's do it ourselves.
 124     (when (string-match date-re date-string re-start)
 125       (setq year (string-to-number (match-string 1 date-string))
 126             month (string-to-number (match-string 2 date-string))
 127             day (string-to-number (match-string 3 date-string))
 128             re-start (match-end 0))
 129       (when (string-match time-re date-string re-start)
 130         (setq hour (string-to-number (match-string 1 date-string))
 131               minute (string-to-number (match-string 2 date-string))
 132               seconds (string-to-number (match-string 3 date-string))
 133               fractional-seconds (string-to-number (or
 134                                                     (match-string 4 date-string)
 135                                                     "0"))
 136               re-start (match-end 0))
 137         (when (string-match tz-re date-string re-start)
 138           (setq tz (match-string 1 date-string)))
 139         (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
 140         (setq time (list seconds minute hour day month year day-of-week dst tz))))
 141
 142     ;; Fall back to having Gnus do fancy things for us.
 143     (when (not time)
 144       (setq time (parse-time-string date-string)))
 145
 146     (if time
 147         (setq time (apply 'encode-time time))
 148       (url-debug 'dav "Unable to decode date (%S) (%s)"
 149                  (xml-node-name node) date-string))
 150     time))
 151
 152 (defun url-dav-process-boolean-property (node)
 153   (/= 0 (string-to-number (url-dav-node-text node))))
 154
 155 (defun url-dav-process-uri-property (node)
 156   ;; Returns a parsed representation of the URL...
 157   (url-generic-parse-url (url-dav-node-text node)))
 158
 159 (defun url-dav-find-parser (node)
 160   "Find a function to parse the XML node NODE."
 161   (or (get (xml-node-name node) 'dav-parser)
 162       (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
 163         (if (not (fboundp fn))
 164             (setq fn 'url-dav-node-text)
 165           (put (xml-node-name node) 'dav-parser fn))
 166         fn)))
 167
 168 (defmacro url-dav-dispatch-node (node)
 169   `(funcall (url-dav-find-parser ,node) ,node))
 170
 171 (defun url-dav-process-DAV:prop (node)
 172   ;; A prop node has content model of ANY
 173   ;;
 174   ;; Some predefined nodes have special meanings though.
 175   ;;
 176   ;; DAV:supportedlock    - list of DAV:lockentry
 177   ;; DAV:source
 178   ;; DAV:iscollection     - boolean
 179   ;; DAV:getcontentlength - integer
 180   ;; DAV:ishidden         - boolean
 181   ;; DAV:getcontenttype   - string
 182   ;; DAV:resourcetype     - node who's name is the resource type
 183   ;; DAV:getlastmodified  - date
 184   ;; DAV:creationdate     - date
 185   ;; DAV:displayname      - string
 186   ;; DAV:getetag          - unknown
 187   (let ((children (xml-node-children node))
 188         (node-type nil)
 189         (props nil)
 190         (value nil)
 191         (handler-func nil))
 192     (when (not children)
 193       (error "No child nodes in DAV:prop"))
 194
 195     (while children
 196       (setq node (car children)
 197             node-type (intern
 198                        (or
 199                         (cdr-safe (assq url-dav-datatype-attribute
 200                                         (xml-node-attributes node)))
 201                         "unknown"))
 202             value nil)
 203
 204       (pcase node-type
 205         ((or `dateTime.iso8601tz
 206              `dateTime.iso8601
 207              `dateTime.tz
 208              `dateTime.rfc1123
 209              `dateTime
 210              `date)                     ; date is our 'special' one...
 211          ;; Some type of date/time string.
 212          (setq value (url-dav-process-date-property node)))
 213         (`int
 214          ;; Integer type...
 215          (setq value (url-dav-process-integer-property node)))
 216         ((or `number `float)
 217          (setq value (url-dav-process-number-property node)))
 218         (`boolean
 219          (setq value (url-dav-process-boolean-property node)))
 220         (`uri
 221          (setq value (url-dav-process-uri-property node)))
 222         (_
 223          (if (not (eq node-type 'unknown))
 224              (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
 225                         node-type))
 226          (setq value (url-dav-dispatch-node node))))
 227
 228       (setq props (plist-put props (xml-node-name node) value)
 229             children (cdr children)))
 230     props))
 231
 232 (defun url-dav-process-DAV:supportedlock (node)
 233   ;; DAV:supportedlock is a list of DAV:lockentry items.
 234   ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
 235   ;; The DAV:lockscope must have a single node beneath it, ditto for
 236   ;; DAV:locktype.
 237   (let ((children (xml-node-children node))
 238         (results nil)
 239         scope type)
 240     (while children
 241       (when (and (not (stringp (car children)))
 242                  (eq (xml-node-name (car children)) 'DAV:lockentry))
 243         (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
 244               type (assq 'DAV:locktype (xml-node-children (car children))))
 245         (when (and scope type)
 246           (setq scope (xml-node-name (car (xml-node-children scope)))
 247                 type (xml-node-name (car (xml-node-children type))))
 248           (push (cons type scope) results)))
 249       (setq children (cdr children)))
 250     results))
 251
 252 (defun url-dav-process-subnode-property (node)
 253   ;; Returns a list of child node names.
 254   (delq nil (mapcar 'car-safe (xml-node-children node))))
 255
 256 (defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
 257 (defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
 258 (defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
 259 (defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
 260 (defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
 261 (defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
 262 (defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
 263 (defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
 264 (defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
 265
 266 (defun url-dav-process-DAV:locktoken (node)
 267   ;; DAV:locktoken can have one or more DAV:href children.
 268   (delq nil (mapcar (lambda (n)
 269                       (if (stringp n)
 270                           n
 271                         (url-dav-dispatch-node n)))
 272                     (xml-node-children node))))
 273
 274 (defun url-dav-process-DAV:owner (node)
 275   ;; DAV:owner can contain anything.
 276   (delq nil (mapcar (lambda (n)
 277                       (if (stringp n)
 278                           n
 279                         (url-dav-dispatch-node n)))
 280                     (xml-node-children node))))
 281
 282 (defun url-dav-process-DAV:activelock (node)
 283   ;; DAV:activelock can contain:
 284   ;;  DAV:lockscope
 285   ;;  DAV:locktype
 286   ;;  DAV:depth
 287   ;;  DAV:owner (optional)
 288   ;;  DAV:timeout (optional)
 289   ;;  DAV:locktoken (optional)
 290   (let ((children (xml-node-children node))
 291         (results nil))
 292     (while children
 293       (if (listp (car children))
 294           (push (cons (xml-node-name (car children))
 295                       (url-dav-dispatch-node (car children)))
 296                 results))
 297       (setq children (cdr children)))
 298     results))
 299
 300 (defun url-dav-process-DAV:lockdiscovery (node)
 301   ;; Can only contain a list of DAV:activelock objects.
 302   (let ((children (xml-node-children node))
 303         (results nil))
 304     (while children
 305       (cond
 306        ((stringp (car children))
 307         ;; text node? why?
 308         nil)
 309        ((eq (xml-node-name (car children)) 'DAV:activelock)
 310         (push (url-dav-dispatch-node (car children)) results))
 311        (t
 312         ;; Ignore unknown nodes...
 313         nil))
 314       (setq children (cdr children)))
 315     results))
 316
 317 (defun url-dav-process-DAV:status (node)
 318   ;; The node contains a standard HTTP/1.1 response line... we really
 319   ;; only care about the numeric status code.
 320   (let ((status (url-dav-node-text node)))
 321     (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
 322         (string-to-number (match-string 1 status))
 323       500)))
 324
 325 (defun url-dav-process-DAV:propstat (node)
 326   ;; A propstate node can have the following children...
 327   ;;
 328   ;; DAV:prop - a list of properties and values
 329   ;; DAV:status - An HTTP/1.1 status line
 330   (let ((children (xml-node-children node))
 331         (props nil)
 332         (status nil))
 333     (when (not children)
 334       (error "No child nodes in DAV:propstat"))
 335
 336     (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
 337           status (url-dav-dispatch-node (assq 'DAV:status children)))
 338
 339     ;; Need to parse out the HTTP status
 340     (setq props (plist-put props 'DAV:status status))
 341     props))
 342
 343 (defun url-dav-process-DAV:response (node)
 344   (let ((children (xml-node-children node))
 345         (propstat nil)
 346         (href))
 347     (when (not children)
 348       (error "No child nodes in DAV:response"))
 349
 350     ;; A response node can have the following children...
 351     ;;
 352     ;; DAV:href     - URL the response is for.
 353     ;; DAV:propstat - see url-dav-process-propstat
 354     ;; DAV:responsedescription - text description of the response
 355     (setq propstat (assq 'DAV:propstat children)
 356           href (assq 'DAV:href children))
 357
 358     (when (not href)
 359       (error "No href in DAV:response"))
 360
 361     (when (not propstat)
 362       (error "No propstat in DAV:response"))
 363
 364     (setq propstat (url-dav-dispatch-node propstat)
 365           href (url-dav-dispatch-node href))
 366     (cons href propstat)))
 367
 368 (defun url-dav-process-DAV:multistatus (node)
 369   (let ((children (xml-node-children node))
 370         (results nil))
 371     (while children
 372       (push (url-dav-dispatch-node (car children)) results)
 373       (setq children (cdr children)))
 374     results))
 375
 376 \f
 377 ;;; DAV request/response generation/processing
 378 (defun url-dav-process-response (buffer url)
 379   "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
 380
 381 The buffer must have been retrieved by HTTP or HTTPS and contain an
 382 XML document."
 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   (let* ((url-request-extra-headers (list (cons "Lock-Token"
 565                                                 (concat "<" lock-token ">"))))
 566          (url-request-method "UNLOCK")
 567          (url-request-data nil)
 568          (buffer (url-retrieve-synchronously url))
 569          (result nil))
 570     (when buffer
 571       (unwind-protect
 572           (with-current-buffer buffer
 573             (setq result (url-dav-http-success-p url-http-response-status)))
 574         (kill-buffer buffer)))
 575     result))
 576
 577 \f
 578 ;;; file-name-handler stuff
 579 (defun url-dav-file-attributes-mode-string (properties)
 580   (let ((modes (make-string 10 ?-))
 581         (supported-locks (plist-get properties 'DAV:supportedlock))
 582         (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
 583                              "T"))
 584         (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
 585         (readable t)
 586         (lock nil))
 587     ;; Assume we can read this, otherwise the PROPFIND would have
 588     ;; failed.
 589     (when readable
 590       (aset modes 1 ?r)
 591       (aset modes 4 ?r)
 592       (aset modes 7 ?r))
 593
 594     (when directory-p
 595       (aset modes 0 ?d))
 596
 597     (when executable-p
 598       (aset modes 3 ?x)
 599       (aset modes 6 ?x)
 600       (aset modes 9 ?x))
 601
 602     (while supported-locks
 603       (setq lock (car supported-locks)
 604             supported-locks (cdr supported-locks))
 605       (pcase (car lock)
 606         (`DAV:write
 607          (pcase (cdr lock)
 608            (`DAV:shared                 ; group permissions (possibly world)
 609             (aset modes 5 ?w))
 610            (`DAV:exclusive
 611             (aset modes 2 ?w))          ; owner permissions?
 612            (_
 613             (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
 614         (_
 615          (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
 616     modes))
 617
 618 (autoload 'url-http-head-file-attributes "url-http")
 619
 620 (defun url-dav-file-attributes (url &optional id-format)
 621   (let ((properties (cdar (url-dav-get-properties url))))
 622     (if (and properties
 623              (url-dav-http-success-p (plist-get properties 'DAV:status)))
 624         ;; We got a good DAV response back..
 625         (list
 626          ;; t for directory, string for symbolic link, or nil
 627          ;; Need to support DAV Bindings to figure out the
 628          ;; symbolic link issues.
 629          (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
 630
 631          ;; Number of links to file... Needs DAV Bindings.
 632          1
 633
 634          ;; File uid - no way to figure out?
 635          0
 636
 637          ;; File gid - no way to figure out?
 638          0
 639
 640          ;; Last access time - ???
 641          nil
 642
 643          ;; Last modification time
 644          (plist-get properties 'DAV:getlastmodified)
 645
 646          ;; Last status change time... just reuse last-modified
 647          ;; for now.
 648          (plist-get properties 'DAV:getlastmodified)
 649
 650          ;; size in bytes
 651          (or (plist-get properties 'DAV:getcontentlength) 0)
 652
 653          ;; file modes as a string like `ls -l'
 654          ;;
 655          ;; Should be able to build this up from the
 656          ;; DAV:supportedlock attribute pretty easily.  Getting
 657          ;; the group info could be impossible though.
 658          (url-dav-file-attributes-mode-string properties)
 659
 660          ;; t if file's gid would change if it were deleted &
 661          ;; recreated.  No way for us to know that thru DAV.
 662          nil
 663
 664          ;; inode number - meaningless
 665          nil
 666
 667          ;; device number - meaningless
 668          nil)
 669       ;; Fall back to just the normal http way of doing things.
 670       (url-http-head-file-attributes url id-format))))
 671
 672 (defun url-dav-save-resource (url obj &optional content-type lock-token)
 673   "Save OBJ as URL using WebDAV.
 674 URL must be a fully qualified URL.
 675 OBJ may be a buffer or a string."
 676   (let ((buffer nil)
 677         (result nil)
 678         (url-request-extra-headers nil)
 679         (url-request-method "PUT")
 680         (url-request-data
 681          (cond
 682           ((bufferp obj)
 683            (with-current-buffer obj
 684              (buffer-string)))
 685           ((stringp obj)
 686            obj)
 687           (t
 688            (error "Invalid object to url-dav-save-resource")))))
 689
 690     (if lock-token
 691         (push
 692          (cons "If" (concat "(<" lock-token ">)"))
 693          url-request-extra-headers))
 694
 695     ;; Everything must always have a content-type when we submit it.
 696     (push
 697      (cons "Content-type" (or content-type "application/octet-stream"))
 698      url-request-extra-headers)
 699
 700     ;; Do the save...
 701     (setq buffer (url-retrieve-synchronously url))
 702
 703     ;; Sanity checking
 704     (when buffer
 705       (unwind-protect
 706           (with-current-buffer buffer
 707             (setq result (url-dav-http-success-p url-http-response-status)))
 708         (kill-buffer buffer)))
 709     result))
 710
 711 (eval-when-compile
 712   (defmacro url-dav-delete-something (url lock-token &rest error-checking)
 713     "Delete URL completely, with no sanity checking whatsoever.  DO NOT USE.
 714 This is defined as a macro that will not be visible from compiled files.
 715 Use with care, and even then think three times."
 716     `(progn
 717        ,@error-checking
 718        (url-dav-request ,url "DELETE" nil nil -1
 719                         (if ,lock-token
 720                             (list
 721                              (cons "If"
 722                                    (concat "(<" ,lock-token ">)"))))))))
 723
 724
 725 (defun url-dav-delete-directory (url &optional recursive lock-token)
 726   "Delete the WebDAV collection URL.
 727 If optional second argument RECURSIVE is non-nil, then delete all
 728 files in the collection as well."
 729   (let ((status nil)
 730         (props nil)
 731         (props nil))
 732     (setq props (url-dav-delete-something
 733                  url lock-token
 734                  (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
 735                  (if (and (not recursive)
 736                           (/= (length props) 1))
 737                      (signal 'file-error (list "Removing directory"
 738                                                "directory not empty" url)))))
 739
 740      (mapc (lambda (result)
 741              (setq status (plist-get (cdr result) 'DAV:status))
 742              (if (not (url-dav-http-success-p status))
 743                  (signal 'file-error (list "Removing directory"
 744                                            "Error removing"
 745                                            (car result) status))))
 746            props))
 747   nil)
 748
 749 (defun url-dav-delete-file (url &optional lock-token)
 750   "Delete file named URL."
 751   (let ((props nil)
 752         (status nil))
 753     (setq props (url-dav-delete-something
 754                  url lock-token
 755                  (setq props (url-dav-get-properties url))
 756                  (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
 757                      (signal 'file-error (list "Removing old name" "is a collection" url)))))
 758
 759     (mapc (lambda (result)
 760             (setq status (plist-get (cdr result) 'DAV:status))
 761             (if (not (url-dav-http-success-p status))
 762                 (signal 'file-error (list "Removing old name"
 763                                           "Error removing"
 764                                           (car result) status))))
 765           props))
 766   nil)
 767
 768 (defun url-dav-directory-files (url &optional full match nosort files-only)
 769   "Return a list of names of files in URL.
 770 There are three optional arguments:
 771 If FULL is non-nil, return absolute file names.  Otherwise return names
 772  that are relative to the specified directory.
 773 If MATCH is non-nil, mention only file names that match the regexp MATCH.
 774 If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
 775  NOSORT is useful if you plan to sort the result yourself."
 776   (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
 777         (child-url nil)
 778         (child-props nil)
 779         (files nil)
 780         (parsed-url (url-generic-parse-url url)))
 781
 782     (if (= (length properties) 1)
 783         (signal 'file-error (list "Opening directory" "not a directory" url)))
 784
 785     (while properties
 786       (setq child-props (pop properties)
 787             child-url (pop child-props))
 788       (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
 789                files-only)
 790           ;; It is a directory, and we were told to return just files.
 791           nil
 792
 793         ;; Fully expand the URL and then rip off the beginning if we
 794         ;; are not supposed to return fully-qualified names.
 795         (setq child-url (url-expand-file-name child-url parsed-url))
 796         (if (not full)
 797             (setq child-url (substring child-url (length url))))
 798
 799         ;; We don't want '/' as the last character in filenames...
 800         (if (string-match "/$" child-url)
 801             (setq child-url (substring child-url 0 -1)))
 802
 803         ;; If we have a match criteria, then apply it.
 804         (if (or (and match (not (string-match match child-url)))
 805                 (string= child-url "")
 806                 (string= child-url url))
 807             nil
 808           (push child-url files))))
 809
 810     (if nosort
 811         files
 812       (sort files 'string-lessp))))
 813
 814 (defun url-dav-file-directory-p (url)
 815   "Return t if URL names an existing DAV collection."
 816   (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
 817     (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection)))
 818
 819 (defun url-dav-make-directory (url &optional parents)
 820   "Create the directory DIR and any nonexistent parent dirs."
 821   (let* ((url-request-extra-headers nil)
 822          (url-request-method "MKCOL")
 823          (url-request-data nil)
 824          (buffer (url-retrieve-synchronously url))
 825          (result nil))
 826     (when buffer
 827       (unwind-protect
 828           (with-current-buffer buffer
 829             (pcase url-http-response-status
 830               (201                      ; Collection created in its entirety
 831                (setq result t))
 832               (403                      ; Forbidden
 833                nil)
 834               (405                      ; Method not allowed
 835                nil)
 836               (409                      ; Conflict
 837                nil)
 838               (415                      ; Unsupported media type (WTF?)
 839                nil)
 840               (507                      ; Insufficient storage
 841                nil)
 842               (_
 843                nil)))
 844         (kill-buffer buffer)))
 845     result))
 846
 847 (defun url-dav-rename-file (oldname newname &optional overwrite)
 848   (if (not (and (string-match url-handler-regexp oldname)
 849                 (string-match url-handler-regexp newname)))
 850       (signal 'file-error
 851               (list "Cannot rename between different URL backends"
 852                     oldname newname)))
 853
 854   (let* ((headers nil)
 855          (props nil)
 856          (status nil)
 857          (directory-p (url-dav-file-directory-p oldname))
 858          (exists-p (url-http-file-exists-p newname)))
 859
 860     (if (and exists-p
 861              (or
 862               (null overwrite)
 863               (and (numberp overwrite)
 864                    (not (yes-or-no-p
 865                          (format "File %s already exists; rename to it anyway? "
 866                                  newname))))))
 867         (signal 'file-already-exists (list "File already exists" newname)))
 868
 869     ;; Honor the overwrite flag...
 870     (if overwrite (push '("Overwrite" . "T") headers))
 871
 872     ;; Have to tell them where to copy it to!
 873     (push (cons "Destination" newname) headers)
 874
 875     ;; Always send a depth of -1 in case we are moving a collection.
 876     (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
 877                                  headers))
 878
 879     (mapc (lambda (result)
 880             (setq status (plist-get (cdr result) 'DAV:status))
 881
 882             (if (not (url-dav-http-success-p status))
 883                 (signal 'file-error (list "Renaming" oldname newname status))))
 884           props)
 885     t))
 886
 887 (defun url-dav-file-name-all-completions (file url)
 888   "Return a list of all completions of file name FILE in URL.
 889 These are all file names in URL which begin with FILE."
 890   (url-dav-directory-files url nil (concat "^" file ".*")))
 891
 892 (defun url-dav-file-name-completion (file url)
 893   "Complete file name FILE in URL.
 894 Returns the longest string common to all file names in URL
 895 that start with FILE.
 896 If there is only one and FILE matches it exactly, returns t.
 897 Returns nil if URL contains no name starting with FILE."
 898   (let ((matches (url-dav-file-name-all-completions file url))
 899         (result nil))
 900     (cond
 901      ((null matches)
 902       ;; No matches
 903       nil)
 904      ((and (= (length matches) 1)
 905            (string= file (car matches)))
 906       ;; Only one file and FILE matches it exactly...
 907       t)
 908      (t
 909       ;; Need to figure out the longest string that they have in common
 910       (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
 911       (let ((n (length file))
 912             (searching t)
 913             (regexp nil)
 914             (failed nil))
 915         (while (and searching
 916                     (< n (length (car matches))))
 917           (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
 918                 failed nil)
 919           (dolist (potential matches)
 920             (if (not (string-match regexp potential))
 921                 (setq failed t)))
 922           (if failed
 923               (setq searching nil)
 924             (cl-incf n)))
 925         (substring (car matches) 0 n))))))
 926
 927 (defun url-dav-register-handler (op)
 928   (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
 929
 930 (mapc 'url-dav-register-handler
 931       ;; These handlers are disabled because they incorrectly presume that
 932       ;; the URL specifies an HTTP location and thus break FTP URLs.
 933       '(;; file-name-all-completions
 934         ;; file-name-completion
 935         ;; rename-file
 936         ;; make-directory
 937         ;; file-directory-p
 938         ;; directory-files
 939         ;; delete-file
 940         ;; delete-directory
 941         ;; file-attributes
 942         ))
 943
 944 \f
 945 ;;; Version Control backend cruft
 946
 947 ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
 948
 949 ;;;###autoload
 950 (defun url-dav-vc-registered (url)
 951   (if (and (string-match "\\`https?" url)
 952            (plist-get (url-http-options url) 'dav))
 953       (progn
 954         (vc-file-setprop url 'vc-backend 'dav)
 955         t)))
 956
 957 \f
 958 ;;; Miscellaneous stuff.
 959
 960 (provide 'url-dav)
 961
 962 ;;; url-dav.el ends here