* unexmacosx.c (copy_data_segment): Port to GCC 4.6+.
[emacs.git] / lisp / url / url-dav.el
1 ;;; url-dav.el --- WebDAV support
2
3 ;; Copyright (C) 2001, 2004-2014 Free Software Foundation, Inc.
4
5 ;; Author: Bill Perry <wmperry@gnu.org>
6 ;; Maintainer: emacs-devel@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 (require 'url-http)
36
37 (defvar url-dav-supported-protocols '(1 2)
38   "List of supported DAV versions.")
39
40 ;; Dynamically bound.
41 (defvar url-http-content-type)
42 (defvar url-http-response-status)
43 (defvar url-http-end-of-headers)
44
45 (defun url-intersection (l1 l2)
46   "Return a list of the elements occurring in both of the lists L1 and L2."
47   (if (null l2)
48       l2
49     (let (result)
50       (while l1
51         (if (member (car l1) l2)
52             (setq result (cons (pop l1) result))
53           (pop l1)))
54       (nreverse result))))
55
56 ;;;###autoload
57 (defun url-dav-supported-p (url)
58   "Return WebDAV protocol version supported by URL.
59 Returns nil if WebDAV is not supported."
60   (url-intersection url-dav-supported-protocols
61                     (plist-get (url-http-options url) 'dav)))
62
63 (defun url-dav-node-text (node)
64   "Return the text data from the XML node NODE."
65   (mapconcat (lambda (txt)
66                (if (stringp txt)
67                    txt
68                  "")) (xml-node-children node) " "))
69
70 \f
71 ;;; Parsing routines for the actual node contents.
72 ;;
73 ;; I am not incredibly happy with how this code looks/works right
74 ;; now, but it DOES work, and if we get the API right, our callers
75 ;; won't have to worry about the internal representation.
76
77 (defconst url-dav-datatype-attribute
78   'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
79
80 (defun url-dav-process-integer-property (node)
81   (truncate (string-to-number (url-dav-node-text node))))
82
83 (defun url-dav-process-number-property (node)
84   (string-to-number (url-dav-node-text node)))
85
86 (defconst url-dav-iso8601-regexp
87   (let* ((dash "-?")
88          (colon ":?")
89          (4digit "\\([0-9][0-9][0-9][0-9]\\)")
90          (2digit "\\([0-9][0-9]\\)")
91          (date-fullyear 4digit)
92          (date-month 2digit)
93          (date-mday 2digit)
94          (time-hour 2digit)
95          (time-minute 2digit)
96          (time-second 2digit)
97          (time-secfrac "\\(\\.[0-9]+\\)?")
98          (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
99          (time-offset (concat "Z" time-numoffset))
100          (partial-time (concat time-hour colon time-minute colon time-second
101                                time-secfrac))
102          (full-date (concat date-fullyear dash date-month dash date-mday))
103          (full-time (concat partial-time time-offset))
104          (date-time (concat full-date "T" full-time)))
105     (list (concat "^" full-date)
106           (concat "T" partial-time)
107           (concat "Z" time-numoffset)))
108   "List of regular expressions matching ISO 8601 dates.
109 1st regular expression matches the date.
110 2nd regular expression matches the time.
111 3rd regular expression matches the (optional) timezone specification.")
112
113 (defun url-dav-process-date-property (node)
114   (require 'parse-time)
115   (let* ((date-re (nth 0 url-dav-iso8601-regexp))
116          (time-re (nth 1 url-dav-iso8601-regexp))
117          (tz-re (nth 2 url-dav-iso8601-regexp))
118          (date-string (url-dav-node-text node))
119          re-start
120          time seconds minute hour fractional-seconds
121          day month year day-of-week dst tz)
122     ;; We need to populate 'time' with
123     ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
124
125     ;; Nobody else handles iso8601 correctly, let's do it ourselves.
126     (when (string-match date-re date-string re-start)
127       (setq year (string-to-number (match-string 1 date-string))
128             month (string-to-number (match-string 2 date-string))
129             day (string-to-number (match-string 3 date-string))
130             re-start (match-end 0))
131       (when (string-match time-re date-string re-start)
132         (setq hour (string-to-number (match-string 1 date-string))
133               minute (string-to-number (match-string 2 date-string))
134               seconds (string-to-number (match-string 3 date-string))
135               fractional-seconds (string-to-number (or
136                                                     (match-string 4 date-string)
137                                                     "0"))
138               re-start (match-end 0))
139         (when (string-match tz-re date-string re-start)
140           (setq tz (match-string 1 date-string)))
141         (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
142         (setq time (list seconds minute hour day month year day-of-week dst tz))))
143
144     ;; Fall back to having Gnus do fancy things for us.
145     (when (not time)
146       (setq time (parse-time-string date-string)))
147
148     (if time
149         (setq time (apply 'encode-time time))
150       (url-debug 'dav "Unable to decode date (%S) (%s)"
151                  (xml-node-name node) date-string))
152     time))
153
154 (defun url-dav-process-boolean-property (node)
155   (/= 0 (string-to-number (url-dav-node-text node))))
156
157 (defun url-dav-process-uri-property (node)
158   ;; Returns a parsed representation of the URL...
159   (url-generic-parse-url (url-dav-node-text node)))
160
161 (defun url-dav-find-parser (node)
162   "Find a function to parse the XML node NODE."
163   (or (get (xml-node-name node) 'dav-parser)
164       (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
165         (if (not (fboundp fn))
166             (setq fn 'url-dav-node-text)
167           (put (xml-node-name node) 'dav-parser fn))
168         fn)))
169
170 (defmacro url-dav-dispatch-node (node)
171   `(funcall (url-dav-find-parser ,node) ,node))
172
173 (defun url-dav-process-DAV:prop (node)
174   ;; A prop node has content model of ANY
175   ;;
176   ;; Some predefined nodes have special meanings though.
177   ;;
178   ;; DAV:supportedlock    - list of DAV:lockentry
179   ;; DAV:source
180   ;; DAV:iscollection     - boolean
181   ;; DAV:getcontentlength - integer
182   ;; DAV:ishidden         - boolean
183   ;; DAV:getcontenttype   - string
184   ;; DAV:resourcetype     - node who's name is the resource type
185   ;; DAV:getlastmodified  - date
186   ;; DAV:creationdate     - date
187   ;; DAV:displayname      - string
188   ;; DAV:getetag          - unknown
189   (let ((children (xml-node-children node))
190         (node-type nil)
191         (props nil)
192         (value nil)
193         (handler-func nil))
194     (when (not children)
195       (error "No child nodes in DAV:prop"))
196
197     (while children
198       (setq node (car children)
199             node-type (intern
200                        (or
201                         (cdr-safe (assq url-dav-datatype-attribute
202                                         (xml-node-attributes node)))
203                         "unknown"))
204             value nil)
205
206       (pcase node-type
207         ((or `dateTime.iso8601tz
208              `dateTime.iso8601
209              `dateTime.tz
210              `dateTime.rfc1123
211              `dateTime
212              `date)                     ; date is our 'special' one...
213          ;; Some type of date/time string.
214          (setq value (url-dav-process-date-property node)))
215         (`int
216          ;; Integer type...
217          (setq value (url-dav-process-integer-property node)))
218         ((or `number `float)
219          (setq value (url-dav-process-number-property node)))
220         (`boolean
221          (setq value (url-dav-process-boolean-property node)))
222         (`uri
223          (setq value (url-dav-process-uri-property node)))
224         (_
225          (if (not (eq node-type 'unknown))
226              (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
227                         node-type))
228          (setq value (url-dav-dispatch-node node))))
229
230       (setq props (plist-put props (xml-node-name node) value)
231             children (cdr children)))
232     props))
233
234 (defun url-dav-process-DAV:supportedlock (node)
235   ;; DAV:supportedlock is a list of DAV:lockentry items.
236   ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
237   ;; The DAV:lockscope must have a single node beneath it, ditto for
238   ;; DAV:locktype.
239   (let ((children (xml-node-children node))
240         (results nil)
241         scope type)
242     (while children
243       (when (and (not (stringp (car children)))
244                  (eq (xml-node-name (car children)) 'DAV:lockentry))
245         (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
246               type (assq 'DAV:locktype (xml-node-children (car children))))
247         (when (and scope type)
248           (setq scope (xml-node-name (car (xml-node-children scope)))
249                 type (xml-node-name (car (xml-node-children type))))
250           (push (cons type scope) results)))
251       (setq children (cdr children)))
252     results))
253
254 (defun url-dav-process-subnode-property (node)
255   ;; Returns a list of child node names.
256   (delq nil (mapcar 'car-safe (xml-node-children node))))
257
258 (defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
259 (defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
260 (defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
261 (defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
262 (defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
263 (defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
264 (defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
265 (defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
266 (defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
267
268 (defun url-dav-process-DAV:locktoken (node)
269   ;; DAV:locktoken can have one or more DAV:href children.
270   (delq nil (mapcar (lambda (n)
271                       (if (stringp n)
272                           n
273                         (url-dav-dispatch-node n)))
274                     (xml-node-children node))))
275
276 (defun url-dav-process-DAV:owner (node)
277   ;; DAV:owner can contain anything.
278   (delq nil (mapcar (lambda (n)
279                       (if (stringp n)
280                           n
281                         (url-dav-dispatch-node n)))
282                     (xml-node-children node))))
283
284 (defun url-dav-process-DAV:activelock (node)
285   ;; DAV:activelock can contain:
286   ;;  DAV:lockscope
287   ;;  DAV:locktype
288   ;;  DAV:depth
289   ;;  DAV:owner (optional)
290   ;;  DAV:timeout (optional)
291   ;;  DAV:locktoken (optional)
292   (let ((children (xml-node-children node))
293         (results nil))
294     (while children
295       (if (listp (car children))
296           (push (cons (xml-node-name (car children))
297                       (url-dav-dispatch-node (car children)))
298                 results))
299       (setq children (cdr children)))
300     results))
301
302 (defun url-dav-process-DAV:lockdiscovery (node)
303   ;; Can only contain a list of DAV:activelock objects.
304   (let ((children (xml-node-children node))
305         (results nil))
306     (while children
307       (cond
308        ((stringp (car children))
309         ;; text node? why?
310         nil)
311        ((eq (xml-node-name (car children)) 'DAV:activelock)
312         (push (url-dav-dispatch-node (car children)) results))
313        (t
314         ;; Ignore unknown nodes...
315         nil))
316       (setq children (cdr children)))
317     results))
318
319 (defun url-dav-process-DAV:status (node)
320   ;; The node contains a standard HTTP/1.1 response line... we really
321   ;; only care about the numeric status code.
322   (let ((status (url-dav-node-text node)))
323     (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
324         (string-to-number (match-string 1 status))
325       500)))
326
327 (defun url-dav-process-DAV:propstat (node)
328   ;; A propstate node can have the following children...
329   ;;
330   ;; DAV:prop - a list of properties and values
331   ;; DAV:status - An HTTP/1.1 status line
332   (let ((children (xml-node-children node))
333         (props nil)
334         (status nil))
335     (when (not children)
336       (error "No child nodes in DAV:propstat"))
337
338     (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
339           status (url-dav-dispatch-node (assq 'DAV:status children)))
340
341     ;; Need to parse out the HTTP status
342     (setq props (plist-put props 'DAV:status status))
343     props))
344
345 (defun url-dav-process-DAV:response (node)
346   (let ((children (xml-node-children node))
347         (propstat nil)
348         (href))
349     (when (not children)
350       (error "No child nodes in DAV:response"))
351
352     ;; A response node can have the following children...
353     ;;
354     ;; DAV:href     - URL the response is for.
355     ;; DAV:propstat - see url-dav-process-propstat
356     ;; DAV:responsedescription - text description of the response
357     (setq propstat (assq 'DAV:propstat children)
358           href (assq 'DAV:href children))
359
360     (when (not href)
361       (error "No href in DAV:response"))
362
363     (when (not propstat)
364       (error "No propstat in DAV:response"))
365
366     (setq propstat (url-dav-dispatch-node propstat)
367           href (url-dav-dispatch-node href))
368     (cons href propstat)))
369
370 (defun url-dav-process-DAV:multistatus (node)
371   (let ((children (xml-node-children node))
372         (results nil))
373     (while children
374       (push (url-dav-dispatch-node (car children)) results)
375       (setq children (cdr children)))
376     results))
377
378 \f
379 ;;; DAV request/response generation/processing
380 (defun url-dav-process-response (buffer url)
381   "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
382
383 The buffer must have been retrieved by HTTP or HTTPS and contain an
384 XML document."
385   (let ((tree nil)
386         (overall-status nil))
387     (when buffer
388       (unwind-protect
389           (with-current-buffer buffer
390             ;; First remove all indentation and line endings
391             (goto-char url-http-end-of-headers)
392             (indent-rigidly (point) (point-max) -1000)
393             (save-excursion
394               (while (re-search-forward "\r?\n" nil t)
395                 (replace-match "")))
396             (setq overall-status url-http-response-status)
397
398             ;; XML documents can be transferred as either text/xml or
399             ;; application/xml, and we are required to accept both of
400             ;; them.
401             (if (and
402                  url-http-content-type
403                  (string-match "\\`\\(text\\|application\\)/xml"
404                                url-http-content-type))
405                 (setq tree (xml-parse-region (point) (point-max) nil nil 'symbol-qnames))))
406         ;; Clean up after ourselves.
407         (kill-buffer buffer)))
408
409     ;; We should now be
410     (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
411         (url-dav-dispatch-node (car tree))
412       (url-debug 'dav "Got back singleton response for URL(%S)" url)
413       (let ((properties (url-dav-dispatch-node (car tree))))
414         ;; We need to make sure we have a DAV:status node in there for
415         ;; higher-level code;
416         (setq properties (plist-put properties 'DAV:status overall-status))
417         ;; Make this look like a DAV:multistatus parse tree so that
418         ;; nobody but us needs to know the difference.
419         (list (cons url properties))))))
420
421 ;;;###autoload
422 (defun url-dav-request (url method tag body
423                                  &optional depth headers namespaces)
424   "Perform WebDAV operation METHOD on URL.  Return the parsed responses.
425 Automatically creates an XML request body if TAG is non-nil.
426 BODY is the XML document fragment to be enclosed by <TAG></TAG>.
427
428 DEPTH is how deep the request should propagate.  Default is 0, meaning
429 it should apply only to URL.  A negative number means to use
430 `Infinity' for the depth.  Not all WebDAV servers support this depth
431 though.
432
433 HEADERS is an assoc list of extra headers to send in the request.
434
435 NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
436 added to the <TAG> element.  The DAV=DAV: namespace is automatically
437 added to this list, so most requests can just pass in nil."
438   ;; Take care of the default value for depth...
439   (setq depth (or depth 0))
440
441   ;; Now let's translate it into something webdav can understand.
442   (if (< depth 0)
443       (setq depth "Infinity")
444     (setq depth (int-to-string depth)))
445   (if (not (assoc "DAV" namespaces))
446       (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
447
448   (let* ((url-request-extra-headers `(("Depth" . ,depth)
449                                       ("Content-type" . "text/xml")
450                                       ,@headers))
451          (url-request-method method)
452          (url-request-data
453           (if tag
454               (concat
455                "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
456                "<" (symbol-name tag) " "
457                ;; add in the appropriate namespaces...
458                (mapconcat (lambda (ns)
459                             (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
460                           namespaces "\n    ")
461                ">\n"
462                body
463                "</" (symbol-name tag) ">\n"))))
464     (url-dav-process-response (url-retrieve-synchronously url) url)))
465
466 (defun url-dav-get-properties (url &optional attributes depth namespaces)
467   "Return properties for URL, up to DEPTH levels deep.
468
469 Returns an assoc list, where the key is the filename (possibly a full
470 URI), and the value is a standard property list of DAV property
471 names (ie: DAV:resourcetype)."
472   (url-dav-request url "PROPFIND" 'DAV:propfind
473                    (if attributes
474                        (mapconcat (lambda (attr)
475                                     (concat "<DAV:prop><"
476                                             (symbol-name attr)
477                                             "/></DAV:prop>"))
478                                   attributes "\n  ")
479                      "  <DAV:allprop/>")
480                    depth nil namespaces))
481
482 (defmacro url-dav-http-success-p (status)
483   "Return whether STATUS was the result of a successful DAV request."
484   `(= (/ (or ,status 500) 100) 2))
485
486 \f
487 ;;; Locking support
488 (defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
489   "URL used as contact information when creating locks in DAV.
490 This will be used as the contents of the DAV:owner/DAV:href tag to
491 identify the owner of a LOCK when requesting it.  This will be shown
492 to other users when the DAV:lockdiscovery property is requested, so
493 make sure you are comfortable with it leaking to the outside world.")
494
495 (defun url-dav-lock-resource (url exclusive &optional depth)
496   "Request a lock on URL.  If EXCLUSIVE is non-nil, get an exclusive lock.
497 Optional 3rd argument DEPTH says how deep the lock should go, default is 0
498 \(lock only the resource and none of its children\).
499
500 Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
501 SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
502 FAILURE-RESULTS is a list of (URL STATUS)."
503   (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
504   (let* ((body
505           (concat
506            "  <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
507            "  <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
508            "  <DAV:owner>\n"
509            "    <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
510            "  </DAV:owner>\n"))
511          (response nil)           ; Responses to the LOCK request
512          (result nil)             ; For walking thru the response list
513          (child-url nil)
514          (child-status nil)
515          (failures nil)           ; List of failure cases (URL . STATUS)
516          (successes nil))         ; List of success cases (URL . STATUS)
517     (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
518                                     depth '(("Timeout" . "Infinite"))))
519
520     ;; Get the parent URL ready for expand-file-name
521     (if (not (vectorp url))
522         (setq url (url-generic-parse-url url)))
523
524     ;; Walk thru the response list, fully expand the URL, and grab the
525     ;; status code.
526     (while response
527       (setq result (pop response)
528             child-url (url-expand-file-name (pop result) url)
529             child-status (or (plist-get result 'DAV:status) 500))
530       (if (url-dav-http-success-p child-status)
531           (push (list url child-status "huh") successes)
532         (push (list url child-status) failures)))
533     (cons successes failures)))
534
535 (defun url-dav-active-locks (url &optional depth)
536   "Return an assoc list of all active locks on URL."
537   (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
538         (properties nil)
539         (child nil)
540         (child-url nil)
541         (child-results nil)
542         (results nil))
543     (if (not (vectorp url))
544         (setq url (url-generic-parse-url url)))
545
546     (while response
547       (setq child (pop response)
548             child-url (pop child)
549             child-results nil)
550       (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
551                  (setq child (plist-get child 'DAV:lockdiscovery)))
552         ;; After our parser has had its way with it, The
553         ;; DAV:lockdiscovery property is a list of DAV:activelock
554         ;; objects, which are comprised of DAV:activelocks, which
555         ;; assoc lists of properties and values.
556         (while child
557           (if (assq 'DAV:locktoken (car child))
558               (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
559                     (owners (cdr (assq 'DAV:owner (car child)))))
560                 (dolist (token tokens)
561                   (dolist (owner owners)
562                     (push (cons token owner) child-results)))))
563           (pop child)))
564       (if child-results
565           (push (cons (url-expand-file-name child-url url) child-results)
566                 results)))
567     results))
568
569 (defun url-dav-unlock-resource (url lock-token)
570   "Release the lock on URL represented by LOCK-TOKEN.
571 Returns t if the lock was successfully released."
572   (let* ((url-request-extra-headers (list (cons "Lock-Token"
573                                                 (concat "<" lock-token ">"))))
574          (url-request-method "UNLOCK")
575          (url-request-data nil)
576          (buffer (url-retrieve-synchronously url))
577          (result nil))
578     (when buffer
579       (unwind-protect
580           (with-current-buffer buffer
581             (setq result (url-dav-http-success-p url-http-response-status)))
582         (kill-buffer buffer)))
583     result))
584
585 \f
586 ;;; file-name-handler stuff
587 (defun url-dav-file-attributes-mode-string (properties)
588   (let ((modes (make-string 10 ?-))
589         (supported-locks (plist-get properties 'DAV:supportedlock))
590         (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
591                              "T"))
592         (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
593         (readable t)
594         (lock nil))
595     ;; Assume we can read this, otherwise the PROPFIND would have
596     ;; failed.
597     (when readable
598       (aset modes 1 ?r)
599       (aset modes 4 ?r)
600       (aset modes 7 ?r))
601
602     (when directory-p
603       (aset modes 0 ?d))
604
605     (when executable-p
606       (aset modes 3 ?x)
607       (aset modes 6 ?x)
608       (aset modes 9 ?x))
609
610     (while supported-locks
611       (setq lock (car supported-locks)
612             supported-locks (cdr supported-locks))
613       (pcase (car lock)
614         (`DAV:write
615          (pcase (cdr lock)
616            (`DAV:shared                 ; group permissions (possibly world)
617             (aset modes 5 ?w))
618            (`DAV:exclusive
619             (aset modes 2 ?w))          ; owner permissions?
620            (_
621             (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
622         (_
623          (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
624     modes))
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