Commit | Line | Data |
---|---|---|
8c8b8430 SM |
1 | ;;; url-dav.el --- WebDAV support |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2001, 2004-2014 Free Software Foundation, Inc. |
8c8b8430 SM |
4 | |
5 | ;; Author: Bill Perry <wmperry@gnu.org> | |
93a583ee | 6 | ;; Maintainer: emacs-devel@gnu.org |
8c8b8430 SM |
7 | ;; Keywords: url, vc |
8 | ||
76827ca4 SM |
9 | ;; This file is part of GNU Emacs. |
10 | ||
4936186e | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
8c8b8430 | 12 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
8c8b8430 SM |
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 | |
4936186e | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
8c8b8430 | 23 | |
0aa70d32 SM |
24 | ;; DAV is in RFC 2518. |
25 | ||
76827ca4 SM |
26 | ;;; Commentary: |
27 | ||
28 | ;;; Code: | |
29 | ||
a464a6c7 | 30 | (eval-when-compile (require 'cl-lib)) |
8c8b8430 SM |
31 | |
32 | (require 'xml) | |
33 | (require 'url-util) | |
34 | (require 'url-handlers) | |
f440830d | 35 | (require 'url-http) |
8c8b8430 SM |
36 | |
37 | (defvar url-dav-supported-protocols '(1 2) | |
38 | "List of supported DAV versions.") | |
39 | ||
f440830d | 40 | ;; Dynamically bound. |
a464a6c7 SM |
41 | (defvar url-http-content-type) |
42 | (defvar url-http-response-status) | |
43 | (defvar url-http-end-of-headers) | |
44 | ||
0aa70d32 | 45 | (defun url-intersection (l1 l2) |
d1ce47b0 | 46 | "Return a list of the elements occurring in both of the lists L1 and L2." |
0aa70d32 SM |
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 | ||
8c8b8430 SM |
56 | ;;;###autoload |
57 | (defun url-dav-supported-p (url) | |
7fa20d96 DE |
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))) | |
8c8b8430 SM |
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. | |
76827ca4 SM |
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. | |
8c8b8430 SM |
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))) | |
d1ce47b0 | 108 | "List of regular expressions matching ISO 8601 dates. |
8c8b8430 SM |
109 | 1st regular expression matches the date. |
110 | 2nd regular expression matches the time. | |
76827ca4 | 111 | 3rd regular expression matches the (optional) timezone specification.") |
8c8b8430 SM |
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 | ||
c7015153 | 125 | ;; Nobody else handles iso8601 correctly, let's do it ourselves. |
8c8b8430 | 126 | (when (string-match date-re date-string re-start) |
216d3806 JB |
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)) | |
8c8b8430 SM |
130 | re-start (match-end 0)) |
131 | (when (string-match time-re date-string re-start) | |
216d3806 JB |
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")) | |
8c8b8430 SM |
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) | |
216d3806 | 155 | (/= 0 (string-to-number (url-dav-node-text node)))) |
8c8b8430 SM |
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 | |
259b63b4 | 200 | (or |
8c8b8430 SM |
201 | (cdr-safe (assq url-dav-datatype-attribute |
202 | (xml-node-attributes node))) | |
203 | "unknown")) | |
204 | value nil) | |
205 | ||
a464a6c7 SM |
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... | |
8c8b8430 SM |
213 | ;; Some type of date/time string. |
214 | (setq value (url-dav-process-date-property node))) | |
a464a6c7 | 215 | (`int |
8c8b8430 SM |
216 | ;; Integer type... |
217 | (setq value (url-dav-process-integer-property node))) | |
a464a6c7 | 218 | ((or `number `float) |
8c8b8430 | 219 | (setq value (url-dav-process-number-property node))) |
a464a6c7 | 220 | (`boolean |
8c8b8430 | 221 | (setq value (url-dav-process-boolean-property node))) |
a464a6c7 | 222 | (`uri |
8c8b8430 | 223 | (setq value (url-dav-process-uri-property node))) |
a464a6c7 | 224 | (_ |
8c8b8430 SM |
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) | |
216d3806 | 324 | (string-to-number (match-string 1 status)) |
8c8b8430 SM |
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) | |
76827ca4 | 381 | "Parse a WebDAV response from BUFFER, interpreting it relative to URL. |
8c8b8430 SM |
382 | |
383 | The buffer must have been retrieved by HTTP or HTTPS and contain an | |
76827ca4 | 384 | XML document." |
8c8b8430 SM |
385 | (let ((tree nil) |
386 | (overall-status nil)) | |
387 | (when buffer | |
388 | (unwind-protect | |
f1bfaf65 | 389 | (with-current-buffer buffer |
7fa20d96 | 390 | ;; First remove all indentation and line endings |
8c8b8430 | 391 | (goto-char url-http-end-of-headers) |
7fa20d96 DE |
392 | (indent-rigidly (point) (point-max) -1000) |
393 | (save-excursion | |
394 | (while (re-search-forward "\r?\n" nil t) | |
395 | (replace-match ""))) | |
8c8b8430 SM |
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 | |
f1bfaf65 SM |
403 | (string-match "\\`\\(text\\|application\\)/xml" |
404 | url-http-content-type)) | |
7fa20d96 | 405 | (setq tree (xml-parse-region (point) (point-max) nil nil 'symbol-qnames)))) |
8c8b8430 | 406 | ;; Clean up after ourselves. |
f1bfaf65 | 407 | (kill-buffer buffer))) |
8c8b8430 | 408 | |
f1bfaf65 | 409 | ;; We should now be |
8c8b8430 SM |
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 | ||
7fa20d96 | 421 | ;;;###autoload |
8c8b8430 SM |
422 | (defun url-dav-request (url method tag body |
423 | &optional depth headers namespaces) | |
76827ca4 | 424 | "Perform WebDAV operation METHOD on URL. Return the parsed responses. |
8c8b8430 SM |
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 | ||
e1dbe924 | 428 | DEPTH is how deep the request should propagate. Default is 0, meaning |
8c8b8430 SM |
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 | |
76827ca4 | 437 | added to this list, so most requests can just pass in nil." |
8c8b8430 SM |
438 | ;; Take care of the default value for depth... |
439 | (setq depth (or depth 0)) | |
440 | ||
c7015153 | 441 | ;; Now let's translate it into something webdav can understand. |
8c8b8430 SM |
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 | ||
8c8b8430 SM |
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 | |
76827ca4 | 471 | names (ie: DAV:resourcetype)." |
8c8b8430 SM |
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) | |
d1ce47b0 | 483 | "Return whether STATUS was the result of a successful DAV request." |
8c8b8430 SM |
484 | `(= (/ (or ,status 500) 100) 2)) |
485 | ||
486 | \f | |
487 | ;;; Locking support | |
488 | (defvar url-dav-lock-identifier (concat "mailto:" user-mail-address) | |
fb7ada5f | 489 | "URL used as contact information when creating locks in DAV. |
8c8b8430 SM |
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 | |
76827ca4 | 493 | make sure you are comfortable with it leaking to the outside world.") |
8c8b8430 | 494 | |
8c8b8430 SM |
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). | |
76827ca4 | 502 | FAILURE-RESULTS is a list of (URL STATUS)." |
8c8b8430 SM |
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 | ||
8c8b8430 SM |
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 | ||
8c8b8430 SM |
569 | (defun url-dav-unlock-resource (url lock-token) |
570 | "Release the lock on URL represented by LOCK-TOKEN. | |
3ecd3a56 | 571 | Returns t if the lock was successfully released." |
8c8b8430 SM |
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 | |
f1bfaf65 | 580 | (with-current-buffer buffer |
8c8b8430 SM |
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)) | |
a464a6c7 SM |
613 | (pcase (car lock) |
614 | (`DAV:write | |
615 | (pcase (cdr lock) | |
616 | (`DAV:shared ; group permissions (possibly world) | |
8c8b8430 | 617 | (aset modes 5 ?w)) |
a464a6c7 | 618 | (`DAV:exclusive |
8c8b8430 | 619 | (aset modes 2 ?w)) ; owner permissions? |
a464a6c7 | 620 | (_ |
8c8b8430 | 621 | (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) |
a464a6c7 | 622 | (_ |
8c8b8430 SM |
623 | (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock))))) |
624 | modes)) | |
625 | ||
f1bfaf65 | 626 | (defun url-dav-file-attributes (url &optional id-format) |
5e047764 | 627 | (let ((properties (cdar (url-dav-get-properties url)))) |
8c8b8430 SM |
628 | (if (and properties |
629 | (url-dav-http-success-p (plist-get properties 'DAV:status))) | |
630 | ;; We got a good DAV response back.. | |
5e047764 SM |
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) | |
8c8b8430 | 636 | |
5e047764 SM |
637 | ;; Number of links to file... Needs DAV Bindings. |
638 | 1 | |
8c8b8430 | 639 | |
5e047764 SM |
640 | ;; File uid - no way to figure out? |
641 | 0 | |
8c8b8430 | 642 | |
5e047764 SM |
643 | ;; File gid - no way to figure out? |
644 | 0 | |
8c8b8430 | 645 | |
5e047764 SM |
646 | ;; Last access time - ??? |
647 | nil | |
8c8b8430 | 648 | |
5e047764 SM |
649 | ;; Last modification time |
650 | (plist-get properties 'DAV:getlastmodified) | |
8c8b8430 | 651 | |
5e047764 SM |
652 | ;; Last status change time... just reuse last-modified |
653 | ;; for now. | |
654 | (plist-get properties 'DAV:getlastmodified) | |
8c8b8430 | 655 | |
5e047764 SM |
656 | ;; size in bytes |
657 | (or (plist-get properties 'DAV:getcontentlength) 0) | |
8c8b8430 | 658 | |
5e047764 | 659 | ;; file modes as a string like `ls -l' |
3ecd3a56 | 660 | ;; |
5e047764 SM |
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) | |
8c8b8430 | 665 | |
3ecd3a56 | 666 | ;; t if file's gid would change if it were deleted & |
5e047764 SM |
667 | ;; recreated. No way for us to know that thru DAV. |
668 | nil | |
8c8b8430 | 669 | |
5e047764 SM |
670 | ;; inode number - meaningless |
671 | nil | |
8c8b8430 | 672 | |
5e047764 SM |
673 | ;; device number - meaningless |
674 | nil) | |
8c8b8430 | 675 | ;; Fall back to just the normal http way of doing things. |
5e047764 | 676 | (url-http-head-file-attributes url id-format)))) |
8c8b8430 | 677 | |
8c8b8430 SM |
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) | |
f1bfaf65 | 689 | (with-current-buffer obj |
8c8b8430 SM |
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 | |
f1bfaf65 | 712 | (with-current-buffer buffer |
8c8b8430 SM |
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. | |
d1ce47b0 | 721 | Use with care, and even then think three times." |
8c8b8430 SM |
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 | ||
8c8b8430 SM |
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 | |
76827ca4 | 734 | files in the collection as well." |
8c8b8430 SM |
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" | |
3d54861a | 750 | "Error removing" |
8c8b8430 SM |
751 | (car result) status)))) |
752 | props)) | |
753 | nil) | |
754 | ||
8c8b8430 SM |
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" | |
c7015153 | 769 | "Error removing" |
8c8b8430 SM |
770 | (car result) status)))) |
771 | props)) | |
772 | nil) | |
773 | ||
8c8b8430 | 774 | (defun url-dav-directory-files (url &optional full match nosort files-only) |
d1ce47b0 | 775 | "Return a list of names of files in URL. |
8c8b8430 | 776 | There are three optional arguments: |
7fa20d96 DE |
777 | If FULL is non-nil, return absolute URLs. Otherwise return names |
778 | that are relative to the specified URL. | |
8c8b8430 SM |
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. | |
76827ca4 | 781 | NOSORT is useful if you plan to sort the result yourself." |
8c8b8430 SM |
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 | ||
7fa20d96 DE |
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))) | |
8c8b8430 SM |
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) | |
7fa20d96 DE |
804 | ;; Parts of the URL might be hex'ed. |
805 | (setq child-url (substring (url-unhex-string child-url) | |
806 | (length url)))) | |
8c8b8430 SM |
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 | ||
8c8b8430 SM |
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))))) | |
7fa20d96 DE |
826 | (when (member 'DAV:collection (plist-get properties 'DAV:resourcetype)) |
827 | t))) | |
8c8b8430 | 828 | |
8c8b8430 SM |
829 | (defun url-dav-make-directory (url &optional parents) |
830 | "Create the directory DIR and any nonexistent parent dirs." | |
8c8b8430 SM |
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 | |
f1bfaf65 | 838 | (with-current-buffer buffer |
a464a6c7 | 839 | (pcase url-http-response-status |
8c8b8430 SM |
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) | |
a464a6c7 | 852 | (_ |
8c8b8430 SM |
853 | nil))) |
854 | (kill-buffer buffer))) | |
855 | result)) | |
856 | ||
8c8b8430 SM |
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))) | |
0aa70d32 SM |
860 | (signal 'file-error |
861 | (list "Cannot rename between different URL backends" | |
862 | oldname newname))) | |
8c8b8430 SM |
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 | |
259b63b4 | 871 | (or |
8c8b8430 SM |
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 | ||
8c8b8430 | 897 | (defun url-dav-file-name-all-completions (file url) |
d1ce47b0 JB |
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." | |
8c8b8430 SM |
900 | (url-dav-directory-files url nil (concat "^" file ".*"))) |
901 | ||
8c8b8430 | 902 | (defun url-dav-file-name-completion (file url) |
d1ce47b0 JB |
903 | "Complete file name FILE in URL. |
904 | Returns the longest string common to all file names in URL | |
905 | that start with FILE. | |
8c8b8430 | 906 | If there is only one and FILE matches it exactly, returns t. |
d1ce47b0 | 907 | Returns nil if URL contains no name starting with FILE." |
8c8b8430 SM |
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 | |
da6062e6 | 919 | ;; Need to figure out the longest string that they have in common |
8c8b8430 SM |
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) | |
a464a6c7 | 934 | (cl-incf n))) |
8c8b8430 SM |
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 | ||
259b63b4 JB |
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 | )) | |
8c8b8430 SM |
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) | |
e5566bd5 | 971 | |
76827ca4 | 972 | ;;; url-dav.el ends here |