Update eieio tests for recent eieio-core change.
[emacs.git] / lisp / url / url-dav.el
blob61ca0885ec51eda75ed1f9687478f7e04717a09a
1 ;;; url-dav.el --- WebDAV support
3 ;; Copyright (C) 2001, 2004-2015 Free Software Foundation, Inc.
5 ;; Author: Bill Perry <wmperry@gnu.org>
6 ;; Maintainer: emacs-devel@gnu.org
7 ;; Keywords: url, vc
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
24 ;; DAV is in RFC 2518.
26 ;;; Commentary:
28 ;;; Code:
30 (eval-when-compile (require 'cl-lib))
32 (require 'xml)
33 (require 'url-util)
34 (require 'url-handlers)
35 (require 'url-http)
37 (defvar url-dav-supported-protocols '(1 2)
38 "List of supported DAV versions.")
40 ;; Dynamically bound.
41 (defvar url-http-content-type)
42 (defvar url-http-response-status)
43 (defvar url-http-end-of-headers)
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))))
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)))
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) " "))
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.
77 (defconst url-dav-datatype-attribute
78 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
80 (defun url-dav-process-integer-property (node)
81 (truncate (string-to-number (url-dav-node-text node))))
83 (defun url-dav-process-number-property (node)
84 (string-to-number (url-dav-node-text node)))
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.")
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)
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))))
144 ;; Fall back to having Gnus do fancy things for us.
145 (when (not time)
146 (setq time (parse-time-string date-string)))
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))
154 (defun url-dav-process-boolean-property (node)
155 (/= 0 (string-to-number (url-dav-node-text node))))
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)))
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)))
170 (defmacro url-dav-dispatch-node (node)
171 `(funcall (url-dav-find-parser ,node) ,node))
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"))
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)
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))))
230 (setq props (plist-put props (xml-node-name node) value)
231 children (cdr children)))
232 props))
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))
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))))
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)
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)
273 (url-dav-dispatch-node n)))
274 (xml-node-children node))))
276 (defun url-dav-process-DAV:owner (node)
277 ;; DAV:owner can contain anything.
278 (delq nil (mapcar (lambda (n)
279 (if (stringp n)
281 (url-dav-dispatch-node n)))
282 (xml-node-children node))))
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))
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))
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)))
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"))
338 (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
339 status (url-dav-dispatch-node (assq 'DAV:status children)))
341 ;; Need to parse out the HTTP status
342 (setq props (plist-put props 'DAV:status status))
343 props))
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"))
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))
360 (when (not href)
361 (error "No href in DAV:response"))
363 (when (not propstat)
364 (error "No propstat in DAV:response"))
366 (setq propstat (url-dav-dispatch-node propstat)
367 href (url-dav-dispatch-node href))
368 (cons href propstat)))
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))
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.
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)
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)))
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))))))
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>.
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.
433 HEADERS is an assoc list of extra headers to send in the request.
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))
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)))
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)))
466 (defun url-dav-get-properties (url &optional attributes depth namespaces)
467 "Return properties for URL, up to DEPTH levels deep.
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))
482 (define-inline url-dav-http-success-p (status)
483 "Return whether STATUS was the result of a successful DAV request."
484 (inline-quote (= (/ (or ,status 500) 100) 2)))
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.")
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\).
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"))))
520 ;; Get the parent URL ready for expand-file-name
521 (if (not (vectorp url))
522 (setq url (url-generic-parse-url url)))
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)))
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)))
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))
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))
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))
602 (when directory-p
603 (aset modes 0 ?d))
605 (when executable-p
606 (aset modes 3 ?x)
607 (aset modes 6 ?x)
608 (aset modes 9 ?x))
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))
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)
637 ;; Number of links to file... Needs DAV Bindings.
640 ;; File uid - no way to figure out?
643 ;; File gid - no way to figure out?
646 ;; Last access time - ???
647 nil
649 ;; Last modification time
650 (plist-get properties 'DAV:getlastmodified)
652 ;; Last status change time... just reuse last-modified
653 ;; for now.
654 (plist-get properties 'DAV:getlastmodified)
656 ;; size in bytes
657 (or (plist-get properties 'DAV:getcontentlength) 0)
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)
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
670 ;; inode number - meaningless
671 nil
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))))
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")))))
696 (if lock-token
697 (push
698 (cons "If" (concat "(<" lock-token ">)"))
699 url-request-extra-headers))
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)
706 ;; Do the save...
707 (setq buffer (url-retrieve-synchronously url))
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))
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 ">)"))))))))
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)))))
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)
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)))))
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)
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)))
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)))
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
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))))
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)))
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))))
819 (if nosort
820 files
821 (sort files 'string-lessp))))
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)))
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))
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)))
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)))
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)))
879 ;; Honor the overwrite flag...
880 (if overwrite (push '("Overwrite" . "T") headers))
882 ;; Have to tell them where to copy it to!
883 (push (cons "Destination" newname) headers)
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))
889 (mapc (lambda (result)
890 (setq status (plist-get (cdr result) 'DAV:status))
892 (if (not (url-dav-http-success-p status))
893 (signal 'file-error (list "Renaming" oldname newname status))))
894 props)
895 t))
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 ".*")))
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))))))
937 (defun url-dav-register-handler (op)
938 (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
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 ))
954 \f
955 ;;; Version Control backend cruft
957 ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
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)))
967 \f
968 ;;; Miscellaneous stuff.
970 (provide 'url-dav)
972 ;;; url-dav.el ends here