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