(eval-when-compile
(require 'cl))
(require 'xml)
(require 'url-util)
(require 'url-handlers)
(defvar url-dav-supported-protocols '(1 2)
"List of supported DAV versions.")
(defun url-intersection (l1 l2)
"Return a list of the elements occuring in both of the lists L1 and L2."
(if (null l2)
l2
(let (result)
(while l1
(if (member (car l1) l2)
(setq result (cons (pop l1) result))
(pop l1)))
(nreverse result))))
(defun url-dav-supported-p (url)
(and (featurep 'xml)
(fboundp 'xml-expand-namespace)
(url-intersection url-dav-supported-protocols
(plist-get (url-http-options url) 'dav))))
(defun url-dav-node-text (node)
"Return the text data from the XML node NODE."
(mapconcat (lambda (txt)
(if (stringp txt)
txt
"")) (xml-node-children node) " "))
(defconst url-dav-datatype-attribute
'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
(defun url-dav-process-integer-property (node)
(truncate (string-to-number (url-dav-node-text node))))
(defun url-dav-process-number-property (node)
(string-to-number (url-dav-node-text node)))
(defconst url-dav-iso8601-regexp
(let* ((dash "-?")
(colon ":?")
(4digit "\\([0-9][0-9][0-9][0-9]\\)")
(2digit "\\([0-9][0-9]\\)")
(date-fullyear 4digit)
(date-month 2digit)
(date-mday 2digit)
(time-hour 2digit)
(time-minute 2digit)
(time-second 2digit)
(time-secfrac "\\(\\.[0-9]+\\)?")
(time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
(time-offset (concat "Z" time-numoffset))
(partial-time (concat time-hour colon time-minute colon time-second
time-secfrac))
(full-date (concat date-fullyear dash date-month dash date-mday))
(full-time (concat partial-time time-offset))
(date-time (concat full-date "T" full-time)))
(list (concat "^" full-date)
(concat "T" partial-time)
(concat "Z" time-numoffset)))
"List of regular expressions matching iso8601 dates.
1st regular expression matches the date.
2nd regular expression matches the time.
3rd regular expression matches the (optional) timezone specification.")
(defun url-dav-process-date-property (node)
(require 'parse-time)
(let* ((date-re (nth 0 url-dav-iso8601-regexp))
(time-re (nth 1 url-dav-iso8601-regexp))
(tz-re (nth 2 url-dav-iso8601-regexp))
(date-string (url-dav-node-text node))
re-start
time seconds minute hour fractional-seconds
day month year day-of-week dst tz)
(when (string-match date-re date-string re-start)
(setq year (string-to-number (match-string 1 date-string))
month (string-to-number (match-string 2 date-string))
day (string-to-number (match-string 3 date-string))
re-start (match-end 0))
(when (string-match time-re date-string re-start)
(setq hour (string-to-number (match-string 1 date-string))
minute (string-to-number (match-string 2 date-string))
seconds (string-to-number (match-string 3 date-string))
fractional-seconds (string-to-number (or
(match-string 4 date-string)
"0"))
re-start (match-end 0))
(when (string-match tz-re date-string re-start)
(setq tz (match-string 1 date-string)))
(url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
(setq time (list seconds minute hour day month year day-of-week dst tz))))
(when (not time)
(setq time (parse-time-string date-string)))
(if time
(setq time (apply 'encode-time time))
(url-debug 'dav "Unable to decode date (%S) (%s)"
(xml-node-name node) date-string))
time))
(defun url-dav-process-boolean-property (node)
(/= 0 (string-to-number (url-dav-node-text node))))
(defun url-dav-process-uri-property (node)
(url-generic-parse-url (url-dav-node-text node)))
(defun url-dav-find-parser (node)
"Find a function to parse the XML node NODE."
(or (get (xml-node-name node) 'dav-parser)
(let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
(if (not (fboundp fn))
(setq fn 'url-dav-node-text)
(put (xml-node-name node) 'dav-parser fn))
fn)))
(defmacro url-dav-dispatch-node (node)
`(funcall (url-dav-find-parser ,node) ,node))
(defun url-dav-process-DAV:prop (node)
(let ((children (xml-node-children node))
(node-type nil)
(props nil)
(value nil)
(handler-func nil))
(when (not children)
(error "No child nodes in DAV:prop"))
(while children
(setq node (car children)
node-type (intern
(or
(cdr-safe (assq url-dav-datatype-attribute
(xml-node-attributes node)))
"unknown"))
value nil)
(case node-type
((dateTime.iso8601tz
dateTime.iso8601
dateTime.tz
dateTime.rfc1123
dateTime
date) (setq value (url-dav-process-date-property node)))
(int
(setq value (url-dav-process-integer-property node)))
((number float)
(setq value (url-dav-process-number-property node)))
(boolean
(setq value (url-dav-process-boolean-property node)))
(uri
(setq value (url-dav-process-uri-property node)))
(otherwise
(if (not (eq node-type 'unknown))
(url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
node-type))
(setq value (url-dav-dispatch-node node))))
(setq props (plist-put props (xml-node-name node) value)
children (cdr children)))
props))
(defun url-dav-process-DAV:supportedlock (node)
(let ((children (xml-node-children node))
(results nil)
scope type)
(while children
(when (and (not (stringp (car children)))
(eq (xml-node-name (car children)) 'DAV:lockentry))
(setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
type (assq 'DAV:locktype (xml-node-children (car children))))
(when (and scope type)
(setq scope (xml-node-name (car (xml-node-children scope)))
type (xml-node-name (car (xml-node-children type))))
(push (cons type scope) results)))
(setq children (cdr children)))
results))
(defun url-dav-process-subnode-property (node)
(delq nil (mapcar 'car-safe (xml-node-children node))))
(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
(defun url-dav-process-DAV:locktoken (node)
(delq nil (mapcar (lambda (n)
(if (stringp n)
n
(url-dav-dispatch-node n)))
(xml-node-children node))))
(defun url-dav-process-DAV:owner (node)
(delq nil (mapcar (lambda (n)
(if (stringp n)
n
(url-dav-dispatch-node n)))
(xml-node-children node))))
(defun url-dav-process-DAV:activelock (node)
(let ((children (xml-node-children node))
(results nil))
(while children
(if (listp (car children))
(push (cons (xml-node-name (car children))
(url-dav-dispatch-node (car children)))
results))
(setq children (cdr children)))
results))
(defun url-dav-process-DAV:lockdiscovery (node)
(let ((children (xml-node-children node))
(results nil))
(while children
(cond
((stringp (car children))
nil)
((eq (xml-node-name (car children)) 'DAV:activelock)
(push (url-dav-dispatch-node (car children)) results))
(t
nil))
(setq children (cdr children)))
results))
(defun url-dav-process-DAV:status (node)
(let ((status (url-dav-node-text node)))
(if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
(string-to-number (match-string 1 status))
500)))
(defun url-dav-process-DAV:propstat (node)
(let ((children (xml-node-children node))
(props nil)
(status nil))
(when (not children)
(error "No child nodes in DAV:propstat"))
(setq props (url-dav-dispatch-node (assq 'DAV:prop children))
status (url-dav-dispatch-node (assq 'DAV:status children)))
(setq props (plist-put props 'DAV:status status))
props))
(defun url-dav-process-DAV:response (node)
(let ((children (xml-node-children node))
(propstat nil)
(href))
(when (not children)
(error "No child nodes in DAV:response"))
(setq propstat (assq 'DAV:propstat children)
href (assq 'DAV:href children))
(when (not href)
(error "No href in DAV:response"))
(when (not propstat)
(error "No propstat in DAV:response"))
(setq propstat (url-dav-dispatch-node propstat)
href (url-dav-dispatch-node href))
(cons href propstat)))
(defun url-dav-process-DAV:multistatus (node)
(let ((children (xml-node-children node))
(results nil))
(while children
(push (url-dav-dispatch-node (car children)) results)
(setq children (cdr children)))
results))
(defun url-dav-process-response (buffer url)
"Parse a WebDAV response from BUFFER, interpreting it relative to URL.
The buffer must have been retrieved by HTTP or HTTPS and contain an
XML document."
(declare (special url-http-content-type
url-http-response-status
url-http-end-of-headers))
(let ((tree nil)
(overall-status nil))
(when buffer
(unwind-protect
(with-current-buffer buffer
(goto-char url-http-end-of-headers)
(setq overall-status url-http-response-status)
(if (and
url-http-content-type
(string-match "\\`\\(text\\|application\\)/xml"
url-http-content-type))
(setq tree (xml-parse-region (point) (point-max)))))
(kill-buffer buffer)))
(if (eq (xml-node-name (car tree)) 'DAV:multistatus)
(url-dav-dispatch-node (car tree))
(url-debug 'dav "Got back singleton response for URL(%S)" url)
(let ((properties (url-dav-dispatch-node (car tree))))
(setq properties (plist-put properties 'DAV:status overall-status))
(list (cons url properties))))))
(defun url-dav-request (url method tag body
&optional depth headers namespaces)
"Perform WebDAV operation METHOD on URL. Return the parsed responses.
Automatically creates an XML request body if TAG is non-nil.
BODY is the XML document fragment to be enclosed by <TAG></TAG>.
DEPTH is how deep the request should propogate. Default is 0, meaning
it should apply only to URL. A negative number means to use
`Infinity' for the depth. Not all WebDAV servers support this depth
though.
HEADERS is an assoc list of extra headers to send in the request.
NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
added to the <TAG> element. The DAV=DAV: namespace is automatically
added to this list, so most requests can just pass in nil."
(setq depth (or depth 0))
(if (< depth 0)
(setq depth "Infinity")
(setq depth (int-to-string depth)))
(if (not (assoc "DAV" namespaces))
(setq namespaces (cons '("DAV" . "DAV:") namespaces)))
(let* ((url-request-extra-headers `(("Depth" . ,depth)
("Content-type" . "text/xml")
,@headers))
(url-request-method method)
(url-request-data
(if tag
(concat
"<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
"<" (symbol-name tag) " "
(mapconcat (lambda (ns)
(concat "xmlns:" (car ns) "='" (cdr ns) "'"))
namespaces "\n ")
">\n"
body
"</" (symbol-name tag) ">\n"))))
(url-dav-process-response (url-retrieve-synchronously url) url)))
(defun url-dav-get-properties (url &optional attributes depth namespaces)
"Return properties for URL, up to DEPTH levels deep.
Returns an assoc list, where the key is the filename (possibly a full
URI), and the value is a standard property list of DAV property
names (ie: DAV:resourcetype)."
(url-dav-request url "PROPFIND" 'DAV:propfind
(if attributes
(mapconcat (lambda (attr)
(concat "<DAV:prop><"
(symbol-name attr)
"/></DAV:prop>"))
attributes "\n ")
" <DAV:allprop/>")
depth nil namespaces))
(defmacro url-dav-http-success-p (status)
"Return whether PROPERTIES was the result of a successful DAV request."
`(= (/ (or ,status 500) 100) 2))
(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
"*URL used as contact information when creating locks in DAV.
This will be used as the contents of the DAV:owner/DAV:href tag to
identify the owner of a LOCK when requesting it. This will be shown
to other users when the DAV:lockdiscovery property is requested, so
make sure you are comfortable with it leaking to the outside world.")
(defun url-dav-lock-resource (url exclusive &optional depth)
"Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
Optional 3rd argument DEPTH says how deep the lock should go, default is 0
\(lock only the resource and none of its children\).
Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
FAILURE-RESULTS is a list of (URL STATUS)."
(setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
(let* ((body
(concat
" <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
" <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
" <DAV:owner>\n"
" <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
" </DAV:owner>\n"))
(response nil) (result nil) (child-url nil)
(child-status nil)
(failures nil) (successes nil)) (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
depth '(("Timeout" . "Infinite"))))
(if (not (vectorp url))
(setq url (url-generic-parse-url url)))
(while response
(setq result (pop response)
child-url (url-expand-file-name (pop result) url)
child-status (or (plist-get result 'DAV:status) 500))
(if (url-dav-http-success-p child-status)
(push (list url child-status "huh") successes)
(push (list url child-status) failures)))
(cons successes failures)))
(defun url-dav-active-locks (url &optional depth)
"Return an assoc list of all active locks on URL."
(let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
(properties nil)
(child nil)
(child-url nil)
(child-results nil)
(results nil))
(if (not (vectorp url))
(setq url (url-generic-parse-url url)))
(while response
(setq child (pop response)
child-url (pop child)
child-results nil)
(when (and (url-dav-http-success-p (plist-get child 'DAV:status))
(setq child (plist-get child 'DAV:lockdiscovery)))
(while child
(if (assq 'DAV:locktoken (car child))
(let ((tokens (cdr (assq 'DAV:locktoken (car child))))
(owners (cdr (assq 'DAV:owner (car child)))))
(dolist (token tokens)
(dolist (owner owners)
(push (cons token owner) child-results)))))
(pop child)))
(if child-results
(push (cons (url-expand-file-name child-url url) child-results)
results)))
results))
(defun url-dav-unlock-resource (url lock-token)
"Release the lock on URL represented by LOCK-TOKEN.
Returns t iff the lock was successfully released."
(declare (special url-http-response-status))
(let* ((url-request-extra-headers (list (cons "Lock-Token"
(concat "<" lock-token ">"))))
(url-request-method "UNLOCK")
(url-request-data nil)
(buffer (url-retrieve-synchronously url))
(result nil))
(when buffer
(unwind-protect
(with-current-buffer buffer
(setq result (url-dav-http-success-p url-http-response-status)))
(kill-buffer buffer)))
result))
(defun url-dav-file-attributes-mode-string (properties)
(let ((modes (make-string 10 ?-))
(supported-locks (plist-get properties 'DAV:supportedlock))
(executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
"T"))
(directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
(readable t)
(lock nil))
(when readable
(aset modes 1 ?r)
(aset modes 4 ?r)
(aset modes 7 ?r))
(when directory-p
(aset modes 0 ?d))
(when executable-p
(aset modes 3 ?x)
(aset modes 6 ?x)
(aset modes 9 ?x))
(while supported-locks
(setq lock (car supported-locks)
supported-locks (cdr supported-locks))
(case (car lock)
(DAV:write
(case (cdr lock)
(DAV:shared (aset modes 5 ?w))
(DAV:exclusive
(aset modes 2 ?w)) (otherwise
(url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
(otherwise
(url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
modes))
(autoload 'url-http-head-file-attributes "url-http")
(defun url-dav-file-attributes (url &optional id-format)
(let ((properties (cdar (url-dav-get-properties url))))
(if (and properties
(url-dav-http-success-p (plist-get properties 'DAV:status)))
(list
(if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
1
0
0
nil
(plist-get properties 'DAV:getlastmodified)
(plist-get properties 'DAV:getlastmodified)
(or (plist-get properties 'DAV:getcontentlength) 0)
(url-dav-file-attributes-mode-string properties)
nil
nil
nil)
(url-http-head-file-attributes url id-format))))
(defun url-dav-save-resource (url obj &optional content-type lock-token)
"Save OBJ as URL using WebDAV.
URL must be a fully qualified URL.
OBJ may be a buffer or a string."
(declare (special url-http-response-status))
(let ((buffer nil)
(result nil)
(url-request-extra-headers nil)
(url-request-method "PUT")
(url-request-data
(cond
((bufferp obj)
(with-current-buffer obj
(buffer-string)))
((stringp obj)
obj)
(t
(error "Invalid object to url-dav-save-resource")))))
(if lock-token
(push
(cons "If" (concat "(<" lock-token ">)"))
url-request-extra-headers))
(push
(cons "Content-type" (or content-type "application/octet-stream"))
url-request-extra-headers)
(setq buffer (url-retrieve-synchronously url))
(when buffer
(unwind-protect
(with-current-buffer buffer
(setq result (url-dav-http-success-p url-http-response-status)))
(kill-buffer buffer)))
result))
(eval-when-compile
(defmacro url-dav-delete-something (url lock-token &rest error-checking)
"Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
This is defined as a macro that will not be visible from compiled files.
Use with care, and even then think three times.
"
`(progn
,@error-checking
(url-dav-request ,url "DELETE" nil nil -1
(if ,lock-token
(list
(cons "If"
(concat "(<" ,lock-token ">)"))))))))
(defun url-dav-delete-directory (url &optional recursive lock-token)
"Delete the WebDAV collection URL.
If optional second argument RECURSIVE is non-nil, then delete all
files in the collection as well."
(let ((status nil)
(props nil)
(props nil))
(setq props (url-dav-delete-something
url lock-token
(setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
(if (and (not recursive)
(/= (length props) 1))
(signal 'file-error (list "Removing directory"
"directory not empty" url)))))
(mapc (lambda (result)
(setq status (plist-get (cdr result) 'DAV:status))
(if (not (url-dav-http-success-p status))
(signal 'file-error (list "Removing directory"
"Errror removing"
(car result) status))))
props))
nil)
(defun url-dav-delete-file (url &optional lock-token)
"Delete file named URL."
(let ((props nil)
(status nil))
(setq props (url-dav-delete-something
url lock-token
(setq props (url-dav-get-properties url))
(if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
(signal 'file-error (list "Removing old name" "is a collection" url)))))
(mapc (lambda (result)
(setq status (plist-get (cdr result) 'DAV:status))
(if (not (url-dav-http-success-p status))
(signal 'file-error (list "Removing old name"
"Errror removing"
(car result) status))))
props))
nil)
(defun url-dav-directory-files (url &optional full match nosort files-only)
"Return a list of names of files in DIRECTORY.
There are three optional arguments:
If FULL is non-nil, return absolute file names. Otherwise return names
that are relative to the specified directory.
If MATCH is non-nil, mention only file names that match the regexp MATCH.
If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
NOSORT is useful if you plan to sort the result yourself."
(let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
(child-url nil)
(child-props nil)
(files nil)
(parsed-url (url-generic-parse-url url)))
(if (= (length properties) 1)
(signal 'file-error (list "Opening directory" "not a directory" url)))
(while properties
(setq child-props (pop properties)
child-url (pop child-props))
(if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
files-only)
nil
(setq child-url (url-expand-file-name child-url parsed-url))
(if (not full)
(setq child-url (substring child-url (length url))))
(if (string-match "/$" child-url)
(setq child-url (substring child-url 0 -1)))
(if (or (and match (not (string-match match child-url)))
(string= child-url "")
(string= child-url url))
nil
(push child-url files))))
(if nosort
files
(sort files 'string-lessp))))
(defun url-dav-file-directory-p (url)
"Return t if URL names an existing DAV collection."
(let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
(eq (plist-get properties 'DAV:resourcetype) 'DAV:collection)))
(defun url-dav-make-directory (url &optional parents)
"Create the directory DIR and any nonexistent parent dirs."
(declare (special url-http-response-status))
(let* ((url-request-extra-headers nil)
(url-request-method "MKCOL")
(url-request-data nil)
(buffer (url-retrieve-synchronously url))
(result nil))
(when buffer
(unwind-protect
(with-current-buffer buffer
(case url-http-response-status
(201 (setq result t))
(403 nil)
(405 nil)
(409 nil)
(415 nil)
(507 nil)
(otherwise
nil)))
(kill-buffer buffer)))
result))
(defun url-dav-rename-file (oldname newname &optional overwrite)
(if (not (and (string-match url-handler-regexp oldname)
(string-match url-handler-regexp newname)))
(signal 'file-error
(list "Cannot rename between different URL backends"
oldname newname)))
(let* ((headers nil)
(props nil)
(status nil)
(directory-p (url-dav-file-directory-p oldname))
(exists-p (url-http-file-exists-p newname)))
(if (and exists-p
(or
(null overwrite)
(and (numberp overwrite)
(not (yes-or-no-p
(format "File %s already exists; rename to it anyway? "
newname))))))
(signal 'file-already-exists (list "File already exists" newname)))
(if overwrite (push '("Overwrite" . "T") headers))
(push (cons "Destination" newname) headers)
(setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
headers))
(mapc (lambda (result)
(setq status (plist-get (cdr result) 'DAV:status))
(if (not (url-dav-http-success-p status))
(signal 'file-error (list "Renaming" oldname newname status))))
props)
t))
(defun url-dav-file-name-all-completions (file url)
"Return a list of all completions of file name FILE in directory DIRECTORY.
These are all file names in directory DIRECTORY which begin with FILE."
(url-dav-directory-files url nil (concat "^" file ".*")))
(defun url-dav-file-name-completion (file url)
"Complete file name FILE in directory DIRECTORY.
Returns the longest string
common to all file names in DIRECTORY that start with FILE.
If there is only one and FILE matches it exactly, returns t.
Returns nil if DIR contains no name starting with FILE."
(let ((matches (url-dav-file-name-all-completions file url))
(result nil))
(cond
((null matches)
nil)
((and (= (length matches) 1)
(string= file (car matches)))
t)
(t
(setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
(let ((n (length file))
(searching t)
(regexp nil)
(failed nil))
(while (and searching
(< n (length (car matches))))
(setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
failed nil)
(dolist (potential matches)
(if (not (string-match regexp potential))
(setq failed t)))
(if failed
(setq searching nil)
(incf n)))
(substring (car matches) 0 n))))))
(defun url-dav-register-handler (op)
(put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
(mapcar 'url-dav-register-handler
'( ))
(defun url-dav-vc-registered (url)
(if (and (string-match "\\`https?" url)
(plist-get (url-http-options url) 'dav))
(progn
(vc-file-setprop url 'vc-backend 'dav)
t)))
(provide 'url-dav)