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   "Return WebDAV protocol version supported by URL.
  57 Returns nil if WebDAV is not supported."
  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             ;; First remove all indentation and line endings
 389             (goto-char url-http-end-of-headers)
 390             (indent-rigidly (point) (point-max) -1000)
 391             (save-excursion
 392               (while (re-search-forward "\r?\n" nil t)
 393                 (replace-match "")))
 394             (setq overall-status url-http-response-status)
 395
 396             ;; XML documents can be transferred as either text/xml or
 397             ;; application/xml, and we are required to accept both of
 398             ;; them.
 399             (if (and
 400                  url-http-content-type
 401                  (string-match "\\`\\(text\\|application\\)/xml"
 402                                url-http-content-type))
 403                 (setq tree (xml-parse-region (point) (point-max) nil nil 'symbol-qnames))))
 404         ;; Clean up after ourselves.
 405         (kill-buffer buffer)))
 406
 407     ;; We should now be
 408     (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
 409         (url-dav-dispatch-node (car tree))
 410       (url-debug 'dav "Got back singleton response for URL(%S)" url)
 411       (let ((properties (url-dav-dispatch-node (car tree))))
 412         ;; We need to make sure we have a DAV:status node in there for
 413         ;; higher-level code;
 414         (setq properties (plist-put properties 'DAV:status overall-status))
 415         ;; Make this look like a DAV:multistatus parse tree so that
 416         ;; nobody but us needs to know the difference.
 417         (list (cons url properties))))))
 418
 419 ;;;###autoload
 420 (defun url-dav-request (url method tag body
 421                                  &optional depth headers namespaces)
 422   "Perform WebDAV operation METHOD on URL.  Return the parsed responses.
 423 Automatically creates an XML request body if TAG is non-nil.
 424 BODY is the XML document fragment to be enclosed by <TAG></TAG>.
 425
 426 DEPTH is how deep the request should propagate.  Default is 0, meaning
 427 it should apply only to URL.  A negative number means to use
 428 `Infinity' for the depth.  Not all WebDAV servers support this depth
 429 though.
 430
 431 HEADERS is an assoc list of extra headers to send in the request.
 432
 433 NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
 434 added to the <TAG> element.  The DAV=DAV: namespace is automatically
 435 added to this list, so most requests can just pass in nil."
 436   ;; Take care of the default value for depth...
 437   (setq depth (or depth 0))
 438
 439   ;; Now let's translate it into something webdav can understand.
 440   (if (< depth 0)
 441       (setq depth "Infinity")
 442     (setq depth (int-to-string depth)))
 443   (if (not (assoc "DAV" namespaces))
 444       (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
 445
 446   (let* ((url-request-extra-headers `(("Depth" . ,depth)
 447                                       ("Content-type" . "text/xml")
 448                                       ,@headers))
 449          (url-request-method method)
 450          (url-request-data
 451           (if tag
 452               (concat
 453                "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
 454                "<" (symbol-name tag) " "
 455                ;; add in the appropriate namespaces...
 456                (mapconcat (lambda (ns)
 457                             (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
 458                           namespaces "\n    ")
 459                ">\n"
 460                body
 461                "</" (symbol-name tag) ">\n"))))
 462     (url-dav-process-response (url-retrieve-synchronously url) url)))
 463
 464 (defun url-dav-get-properties (url &optional attributes depth namespaces)
 465   "Return properties for URL, up to DEPTH levels deep.
 466
 467 Returns an assoc list, where the key is the filename (possibly a full
 468 URI), and the value is a standard property list of DAV property
 469 names (ie: DAV:resourcetype)."
 470   (url-dav-request url "PROPFIND" 'DAV:propfind
 471                    (if attributes
 472                        (mapconcat (lambda (attr)
 473                                     (concat "<DAV:prop><"
 474                                             (symbol-name attr)
 475                                             "/></DAV:prop>"))
 476                                   attributes "\n  ")
 477                      "  <DAV:allprop/>")
 478                    depth nil namespaces))
 479
 480 (defmacro url-dav-http-success-p (status)
 481   "Return whether STATUS was the result of a successful DAV request."
 482   `(= (/ (or ,status 500) 100) 2))
 483
 484 \f
 485 ;;; Locking support
 486 (defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
 487   "URL used as contact information when creating locks in DAV.
 488 This will be used as the contents of the DAV:owner/DAV:href tag to
 489 identify the owner of a LOCK when requesting it.  This will be shown
 490 to other users when the DAV:lockdiscovery property is requested, so
 491 make sure you are comfortable with it leaking to the outside world.")
 492
 493 (defun url-dav-lock-resource (url exclusive &optional depth)
 494   "Request a lock on URL.  If EXCLUSIVE is non-nil, get an exclusive lock.
 495 Optional 3rd argument DEPTH says how deep the lock should go, default is 0
 496 \(lock only the resource and none of its children\).
 497
 498 Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
 499 SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
 500 FAILURE-RESULTS is a list of (URL STATUS)."
 501   (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
 502   (let* ((body
 503           (concat
 504            "  <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
 505            "  <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
 506            "  <DAV:owner>\n"
 507            "    <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
 508            "  </DAV:owner>\n"))
 509          (response nil)           ; Responses to the LOCK request
 510          (result nil)             ; For walking thru the response list
 511          (child-url nil)
 512          (child-status nil)
 513          (failures nil)           ; List of failure cases (URL . STATUS)
 514          (successes nil))         ; List of success cases (URL . STATUS)
 515     (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
 516                                     depth '(("Timeout" . "Infinite"))))
 517
 518     ;; Get the parent URL ready for expand-file-name
 519     (if (not (vectorp url))
 520         (setq url (url-generic-parse-url url)))
 521
 522     ;; Walk thru the response list, fully expand the URL, and grab the
 523     ;; status code.
 524     (while response
 525       (setq result (pop response)
 526             child-url (url-expand-file-name (pop result) url)
 527             child-status (or (plist-get result 'DAV:status) 500))
 528       (if (url-dav-http-success-p child-status)
 529           (push (list url child-status "huh") successes)
 530         (push (list url child-status) failures)))
 531     (cons successes failures)))
 532
 533 (defun url-dav-active-locks (url &optional depth)
 534   "Return an assoc list of all active locks on URL."
 535   (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
 536         (properties nil)
 537         (child nil)
 538         (child-url nil)
 539         (child-results nil)
 540         (results nil))
 541     (if (not (vectorp url))
 542         (setq url (url-generic-parse-url url)))
 543
 544     (while response
 545       (setq child (pop response)
 546             child-url (pop child)
 547             child-results nil)
 548       (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
 549                  (setq child (plist-get child 'DAV:lockdiscovery)))
 550         ;; After our parser has had its way with it, The
 551         ;; DAV:lockdiscovery property is a list of DAV:activelock
 552         ;; objects, which are comprised of DAV:activelocks, which
 553         ;; assoc lists of properties and values.
 554         (while child
 555           (if (assq 'DAV:locktoken (car child))
 556               (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
 557                     (owners (cdr (assq 'DAV:owner (car child)))))
 558                 (dolist (token tokens)
 559                   (dolist (owner owners)
 560                     (push (cons token owner) child-results)))))
 561           (pop child)))
 562       (if child-results
 563           (push (cons (url-expand-file-name child-url url) child-results)
 564                 results)))
 565     results))
 566
 567 (defun url-dav-unlock-resource (url lock-token)
 568   "Release the lock on URL represented by LOCK-TOKEN.
 569 Returns t if the lock was successfully released."
 570   (let* ((url-request-extra-headers (list (cons "Lock-Token"
 571                                                 (concat "<" lock-token ">"))))
 572          (url-request-method "UNLOCK")
 573          (url-request-data nil)
 574          (buffer (url-retrieve-synchronously url))
 575          (result nil))
 576     (when buffer
 577       (unwind-protect
 578           (with-current-buffer buffer
 579             (setq result (url-dav-http-success-p url-http-response-status)))
 580         (kill-buffer buffer)))
 581     result))
 582
 583 \f
 584 ;;; file-name-handler stuff
 585 (defun url-dav-file-attributes-mode-string (properties)
 586   (let ((modes (make-string 10 ?-))
 587         (supported-locks (plist-get properties 'DAV:supportedlock))
 588         (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
 589                              "T"))
 590         (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
 591         (readable t)
 592         (lock nil))
 593     ;; Assume we can read this, otherwise the PROPFIND would have
 594     ;; failed.
 595     (when readable
 596       (aset modes 1 ?r)
 597       (aset modes 4 ?r)
 598       (aset modes 7 ?r))
 599
 600     (when directory-p
 601       (aset modes 0 ?d))
 602
 603     (when executable-p
 604       (aset modes 3 ?x)
 605       (aset modes 6 ?x)
 606       (aset modes 9 ?x))
 607
 608     (while supported-locks
 609       (setq lock (car supported-locks)
 610             supported-locks (cdr supported-locks))
 611       (pcase (car lock)
 612         (`DAV:write
 613          (pcase (cdr lock)
 614            (`DAV:shared                 ; group permissions (possibly world)
 615             (aset modes 5 ?w))
 616            (`DAV:exclusive
 617             (aset modes 2 ?w))          ; owner permissions?
 618            (_
 619             (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
 620         (_
 621          (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
 622     modes))
 623
 624 (autoload 'url-http-head-file-attributes "url-http")
 625
 626 (defun url-dav-file-attributes (url &optional id-format)
 627   (let ((properties (cdar (url-dav-get-properties url))))
 628     (if (and properties
 629              (url-dav-http-success-p (plist-get properties 'DAV:status)))
 630         ;; We got a good DAV response back..
 631         (list
 632          ;; t for directory, string for symbolic link, or nil
 633          ;; Need to support DAV Bindings to figure out the
 634          ;; symbolic link issues.
 635          (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
 636
 637          ;; Number of links to file... Needs DAV Bindings.
 638          1
 639
 640          ;; File uid - no way to figure out?
 641          0
 642
 643          ;; File gid - no way to figure out?
 644          0
 645
 646          ;; Last access time - ???
 647          nil
 648
 649          ;; Last modification time
 650          (plist-get properties 'DAV:getlastmodified)
 651
 652          ;; Last status change time... just reuse last-modified
 653          ;; for now.
 654          (plist-get properties 'DAV:getlastmodified)
 655
 656          ;; size in bytes
 657          (or (plist-get properties 'DAV:getcontentlength) 0)
 658
 659          ;; file modes as a string like `ls -l'
 660          ;;
 661          ;; Should be able to build this up from the
 662          ;; DAV:supportedlock attribute pretty easily.  Getting
 663          ;; the group info could be impossible though.
 664          (url-dav-file-attributes-mode-string properties)
 665
 666          ;; t if file's gid would change if it were deleted &
 667          ;; recreated.  No way for us to know that thru DAV.
 668          nil
 669
 670          ;; inode number - meaningless
 671          nil
 672
 673          ;; device number - meaningless
 674          nil)
 675       ;; Fall back to just the normal http way of doing things.
 676       (url-http-head-file-attributes url id-format))))
 677
 678 (defun url-dav-save-resource (url obj &optional content-type lock-token)
 679   "Save OBJ as URL using WebDAV.
 680 URL must be a fully qualified URL.
 681 OBJ may be a buffer or a string."
 682   (let ((buffer nil)
 683         (result nil)
 684         (url-request-extra-headers nil)
 685         (url-request-method "PUT")
 686         (url-request-data
 687          (cond
 688           ((bufferp obj)
 689            (with-current-buffer obj
 690              (buffer-string)))
 691           ((stringp obj)
 692            obj)
 693           (t
 694            (error "Invalid object to url-dav-save-resource")))))
 695
 696     (if lock-token
 697         (push
 698          (cons "If" (concat "(<" lock-token ">)"))
 699          url-request-extra-headers))
 700
 701     ;; Everything must always have a content-type when we submit it.
 702     (push
 703      (cons "Content-type" (or content-type "application/octet-stream"))
 704      url-request-extra-headers)
 705
 706     ;; Do the save...
 707     (setq buffer (url-retrieve-synchronously url))
 708
 709     ;; Sanity checking
 710     (when buffer
 711       (unwind-protect
 712           (with-current-buffer buffer
 713             (setq result (url-dav-http-success-p url-http-response-status)))
 714         (kill-buffer buffer)))
 715     result))
 716
 717 (eval-when-compile
 718   (defmacro url-dav-delete-something (url lock-token &rest error-checking)
 719     "Delete URL completely, with no sanity checking whatsoever.  DO NOT USE.
 720 This is defined as a macro that will not be visible from compiled files.
 721 Use with care, and even then think three times."
 722     `(progn
 723        ,@error-checking
 724        (url-dav-request ,url "DELETE" nil nil -1
 725                         (if ,lock-token
 726                             (list
 727                              (cons "If"
 728                                    (concat "(<" ,lock-token ">)"))))))))
 729
 730
 731 (defun url-dav-delete-directory (url &optional recursive lock-token)
 732   "Delete the WebDAV collection URL.
 733 If optional second argument RECURSIVE is non-nil, then delete all
 734 files in the collection as well."
 735   (let ((status nil)
 736         (props nil)
 737         (props nil))
 738     (setq props (url-dav-delete-something
 739                  url lock-token
 740                  (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
 741                  (if (and (not recursive)
 742                           (/= (length props) 1))
 743                      (signal 'file-error (list "Removing directory"
 744                                                "directory not empty" url)))))
 745
 746      (mapc (lambda (result)
 747              (setq status (plist-get (cdr result) 'DAV:status))
 748              (if (not (url-dav-http-success-p status))
 749                  (signal 'file-error (list "Removing directory"
 750                                            "Error removing"
 751                                            (car result) status))))
 752            props))
 753   nil)
 754
 755 (defun url-dav-delete-file (url &optional lock-token)
 756   "Delete file named URL."
 757   (let ((props nil)
 758         (status nil))
 759     (setq props (url-dav-delete-something
 760                  url lock-token
 761                  (setq props (url-dav-get-properties url))
 762                  (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
 763                      (signal 'file-error (list "Removing old name" "is a collection" url)))))
 764
 765     (mapc (lambda (result)
 766             (setq status (plist-get (cdr result) 'DAV:status))
 767             (if (not (url-dav-http-success-p status))
 768                 (signal 'file-error (list "Removing old name"
 769                                           "Error removing"
 770                                           (car result) status))))
 771           props))
 772   nil)
 773
 774 (defun url-dav-directory-files (url &optional full match nosort files-only)
 775   "Return a list of names of files in URL.
 776 There are three optional arguments:
 777 If FULL is non-nil, return absolute URLs.  Otherwise return names
 778  that are relative to the specified URL.
 779 If MATCH is non-nil, mention only file names that match the regexp MATCH.
 780 If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
 781  NOSORT is useful if you plan to sort the result yourself."
 782   (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
 783         (child-url nil)
 784         (child-props nil)
 785         (files nil)
 786         (parsed-url (url-generic-parse-url url)))
 787
 788     (when (and (= (length properties) 1)
 789                (not (url-dav-file-directory-p url)))
 790       (signal 'file-error (list "Opening directory" "not a directory" url)))
 791
 792     (while properties
 793       (setq child-props (pop properties)
 794             child-url (pop child-props))
 795       (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
 796                files-only)
 797           ;; It is a directory, and we were told to return just files.
 798           nil
 799
 800         ;; Fully expand the URL and then rip off the beginning if we
 801         ;; are not supposed to return fully-qualified names.
 802         (setq child-url (url-expand-file-name child-url parsed-url))
 803         (if (not full)
 804             ;; Parts of the URL might be hex'ed.
 805             (setq child-url (substring (url-unhex-string child-url)
 806                                        (length url))))
 807
 808         ;; We don't want '/' as the last character in filenames...
 809         (if (string-match "/$" child-url)
 810             (setq child-url (substring child-url 0 -1)))
 811
 812         ;; If we have a match criteria, then apply it.
 813         (if (or (and match (not (string-match match child-url)))
 814                 (string= child-url "")
 815                 (string= child-url url))
 816             nil
 817           (push child-url files))))
 818
 819     (if nosort
 820         files
 821       (sort files 'string-lessp))))
 822
 823 (defun url-dav-file-directory-p (url)
 824   "Return t if URL names an existing DAV collection."
 825   (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
 826     (when (member 'DAV:collection (plist-get properties 'DAV:resourcetype))
 827       t)))
 828
 829 (defun url-dav-make-directory (url &optional parents)
 830   "Create the directory DIR and any nonexistent parent dirs."
 831   (let* ((url-request-extra-headers nil)
 832          (url-request-method "MKCOL")
 833          (url-request-data nil)
 834          (buffer (url-retrieve-synchronously url))
 835          (result nil))
 836     (when buffer
 837       (unwind-protect
 838           (with-current-buffer buffer
 839             (pcase url-http-response-status
 840               (201                      ; Collection created in its entirety
 841                (setq result t))
 842               (403                      ; Forbidden
 843                nil)
 844               (405                      ; Method not allowed
 845                nil)
 846               (409                      ; Conflict
 847                nil)
 848               (415                      ; Unsupported media type (WTF?)
 849                nil)
 850               (507                      ; Insufficient storage
 851                nil)
 852               (_
 853                nil)))
 854         (kill-buffer buffer)))
 855     result))
 856
 857 (defun url-dav-rename-file (oldname newname &optional overwrite)
 858   (if (not (and (string-match url-handler-regexp oldname)
 859                 (string-match url-handler-regexp newname)))
 860       (signal 'file-error
 861               (list "Cannot rename between different URL backends"
 862                     oldname newname)))
 863
 864   (let* ((headers nil)
 865          (props nil)
 866          (status nil)
 867          (directory-p (url-dav-file-directory-p oldname))
 868          (exists-p (url-http-file-exists-p newname)))
 869
 870     (if (and exists-p
 871              (or
 872               (null overwrite)
 873               (and (numberp overwrite)
 874                    (not (yes-or-no-p
 875                          (format "File %s already exists; rename to it anyway? "
 876                                  newname))))))
 877         (signal 'file-already-exists (list "File already exists" newname)))
 878
 879     ;; Honor the overwrite flag...
 880     (if overwrite (push '("Overwrite" . "T") headers))
 881
 882     ;; Have to tell them where to copy it to!
 883     (push (cons "Destination" newname) headers)
 884
 885     ;; Always send a depth of -1 in case we are moving a collection.
 886     (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
 887                                  headers))
 888
 889     (mapc (lambda (result)
 890             (setq status (plist-get (cdr result) 'DAV:status))
 891
 892             (if (not (url-dav-http-success-p status))
 893                 (signal 'file-error (list "Renaming" oldname newname status))))
 894           props)
 895     t))
 896
 897 (defun url-dav-file-name-all-completions (file url)
 898   "Return a list of all completions of file name FILE in URL.
 899 These are all file names in URL which begin with FILE."
 900   (url-dav-directory-files url nil (concat "^" file ".*")))
 901
 902 (defun url-dav-file-name-completion (file url)
 903   "Complete file name FILE in URL.
 904 Returns the longest string common to all file names in URL
 905 that start with FILE.
 906 If there is only one and FILE matches it exactly, returns t.
 907 Returns nil if URL contains no name starting with FILE."
 908   (let ((matches (url-dav-file-name-all-completions file url))
 909         (result nil))
 910     (cond
 911      ((null matches)
 912       ;; No matches
 913       nil)
 914      ((and (= (length matches) 1)
 915            (string= file (car matches)))
 916       ;; Only one file and FILE matches it exactly...
 917       t)
 918      (t
 919       ;; Need to figure out the longest string that they have in common
 920       (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
 921       (let ((n (length file))
 922             (searching t)
 923             (regexp nil)
 924             (failed nil))
 925         (while (and searching
 926                     (< n (length (car matches))))
 927           (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
 928                 failed nil)
 929           (dolist (potential matches)
 930             (if (not (string-match regexp potential))
 931                 (setq failed t)))
 932           (if failed
 933               (setq searching nil)
 934             (cl-incf n)))
 935         (substring (car matches) 0 n))))))
 936
 937 (defun url-dav-register-handler (op)
 938   (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
 939
 940 (mapc 'url-dav-register-handler
 941       ;; These handlers are disabled because they incorrectly presume that
 942       ;; the URL specifies an HTTP location and thus break FTP URLs.
 943       '(;; file-name-all-completions
 944         ;; file-name-completion
 945         ;; rename-file
 946         ;; make-directory
 947         ;; file-directory-p
 948         ;; directory-files
 949         ;; delete-file
 950         ;; delete-directory
 951         ;; file-attributes
 952         ))
 953
 954 \f
 955 ;;; Version Control backend cruft
 956
 957 ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
 958
 959 ;;;###autoload
 960 (defun url-dav-vc-registered (url)
 961   (if (and (string-match "\\`https?" url)
 962            (plist-get (url-http-options url) 'dav))
 963       (progn
 964         (vc-file-setprop url 'vc-backend 'dav)
 965         t)))
 966
 967 \f
 968 ;;; Miscellaneous stuff.
 969
 970 (provide 'url-dav)
 971
 972 ;;; url-dav.el ends here