blob: 00615dcf861d3012eea3ecbea11d2cc9220dd3f8 (
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
|
(define-module (ldp)
#:use-module (ldp resource)
#:use-module (ldp path)
#:use-module (ldp resource load)
#:use-module (ldp resource update)
#:use-module (ldp response)
#:use-module (ldp content)
#:use-module (ldp precondition)
#:use-module (web request)
#:use-module (web response)
#:use-module (ldp precondition)
#:use-module (rnrs bytevectors))
(define-public (respond request request-body)
(when (string? request-body)
(set! request-body (string->utf8 request-body)))
(catch #t
(lambda ()
(let ((method (request-method request))
(path (uri->path (request-uri request)))
(precondition (request->precondition request)))
(cond ((or (eq? method 'POST) (eq? method 'PUT))
(let ((slug (assoc-ref (request-headers request) 'slug))
(link-header (assoc-ref (request-headers request) 'link))
(content-type (request-content-type request)))
(unless slug
(set! slug "sub"))
(unless content-type
(throw 'bad-request))
(set! content-type (car content-type))
(cond ((eq? method 'POST)
(let ((resource (post path
slug
precondition
link-header
content-type
request-body)))
(respond-to-post resource)))
((eq? method 'PUT)
(put path precondition link-header content-type request-body)
(respond-to-put)))))
((or (eq? method 'GET) (eq? method 'HEAD) (eq? method 'OPTIONS))
(call-with-values (load (request-uri request))
(lambda (resource port triples)
(let ((response-body
(and (eq? method 'GET)
(load-content
(make-content port triples)
(text-content-type?
(resource-content-type resource))))))
(case method
((GET)
(when (precondition-valid? precondition (resource-etag resource))
(throw 'not-modified))
(respond-to-get resource response-body))
((HEAD) (respond-to-head resource))
((OPTIONS) (respond-to-options resource)))))))
((eq? method 'DELETE)
(delete path precondition)
(respond-to-delete))
(else
(throw 'bad-request)))))
(lambda error
(apply respond-to-error error))))
|
