blob: 23f8867bb40526f56ba57f96553694d0c2534187 (
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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
(define-module (ldp resource update)
#:use-module (ldp etag)
#:use-module (ldp path)
#:use-module (ldp resource)
#:use-module (ldp http-link)
#:use-module (ldp precondition)
#:use-module (ldp resource unsafe save)
#:use-module (ice-9 threads)
#:use-module (web uri)
#:use-module ((ldp resource unsafe update) #:prefix unsafe:))
;; FIXME: use a bag of locks, so that we can have concurrent updates
;; of different resources.
(define lock (make-mutex))
(define-public (initialize-root)
(with-mutex lock
(unsafe:initialize-root)))
(define-public (delete path precondition)
(with-mutex lock
(unsafe:delete path precondition)))
(define (links-hint-for-a-container link-header)
(define (has-rel-type properties)
(if (null? properties)
#f
(let* ((prop (car properties))
(key (car prop))
(value (cdr prop)))
(if (and (string=? key "rel")
(or (string=? value "type")
(string=? value "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))
#t
(has-rel-type (cdr properties))))))
(and link-header
(let ((links (string->links link-header)))
(let ((for-basic-container
(or
(assoc-ref links
(string->uri
"http://www.w3.org/ns/ldp/BasicContainer"))
'()))
(for-container
(or
(assoc-ref links
(string->uri
"http://www.w3.org/ns/ldp/Container"))
'())))
(has-rel-type (append for-basic-container for-container))))))
(define-public (post path slug precondition
http-link-header content-type content)
(catch 'child-already-exists
(lambda ()
(let ((child-path (path-cons path slug)))
(let ((new-resource
(make-resource
child-path
(generate-etag)
content-type
(and (links-hint-for-a-container http-link-header)
'()))))
(with-mutex lock
(unsafe:mkcont-recursive path)
(unsafe:change-contained path precondition
(list child-path)
'())
(save new-resource content)
new-resource))))
(lambda err
(post path (string-append slug "-" (generate-etag))
precondition
http-link-header content-type content))))
(define-public (put path precondition
http-link-header content-type content)
(let ((new-resource
(make-resource
path
(generate-etag)
content-type
(and (links-hint-for-a-container http-link-header)
'()))))
(with-mutex lock
(if (is-root? path)
(unsafe:initialize-root)
(unsafe:mkcont-recursive (path-parent path)))
(catch 'not-found
(lambda ()
(unsafe:change-representation path precondition
content-type content))
(lambda error
;; path is not the root, because it exists from the
;; beginning of the locked section
(unsafe:change-contained (path-parent path)
(make-precondition #f #f)
(list path)
'())
(save new-resource content)
new-resource)))))
|
