blob: db7f5f95f7327f855affc68c783bf71ffad15a7d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
(define-module (calp webdav proppatch)
:use-module (srfi srfi-1)
:use-module (srfi srfi-71)
:use-module (srfi srfi-88)
:use-module (calp webdav property)
:use-module (calp webdav resource)
:use-module (sxml match)
:use-module (sxml namespaced)
:use-module ((hnh util) :select (for))
:export (parse-propertyupdate)
)
(define (parse-propertyupdate body namespaces resource)
(merge-propstats
(sxml-match body
[(d:propertyupdate . ,changes)
(define continuations
(concatenate
(for change in changes
(sxml-match change
[(d:remove (d:prop . ,properties))
(map (lambda (prop) (cons prop
(remove-property
resource
(car
(sxml->namespaced-sxml prop namespaces)))))
properties)]
;; TODO handle xmllang correctly
[(d:set (d:prop . ,properties))
(map (lambda (prop) (cons prop
(set-property resource
(sxml->namespaced-sxml prop namespaces))))
properties)]
[,else (scm-error 'bad-request ""
"Invalid propertyupdate: ~s"
(list body)
(list body))]))))
;; (format (current-error-port) "~s~%" continuations)
(let loop ((continuations continuations))
(if (null? continuations)
'()
(let ((tag proc (car+cdr (car continuations))))
(set! tag (sxml->namespaced-sxml tag namespaces))
;; (format (current-error-port) "tag: ~s~%" tag)
(catch #t (lambda ()
;; This is expected to throw quite often
(proc)
(cons (propstat 200 (list tag))
(loop (cdr continuations))))
(lambda err
(cons (propstat 409 (list tag))
(mark-remaining-as-failed-dependency (cdr continuations))))))))]
[,else (scm-error 'bad-request ""
"Invalid root element: ~s"
(list else)
(list else))])))
(define (mark-remaining-as-failed-dependency pairs)
(map (lambda (item)
(propstat 424 (list (car item))))
pairs))
|
