blob: 047336c5c8e221b497ee9d8e8d05541ef7a0788e (
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
|
(define-module (calp webdav resource virtual)
:use-module (oop goops)
:use-module (datetime)
:use-module (rnrs bytevectors)
:use-module (hnh util)
:use-module (hnh util type)
:use-module (sxml namespaced)
:use-module (sxml namespaced util)
:use-module (calp webdav resource)
:use-module (calp webdav property)
:use-module (calp namespaces)
:export (<virtual-resource>
virtual-resource?
virtual-ns
;; content
isvirtual
)
)
(define virtual-ns (string->symbol "http://example.com/virtual"))
(define-class <virtual-resource> (<resource>)
(content* init-value: #vu8()
init-keyword: content:
accessor: content*)
(creation-time init-form: (current-datetime)
init-keyword: creation-time:
getter: creation-time))
(define-method (initialize (self <virtual-resource>) args)
(next-method)
(typecheck (content* self) bytevector? "<virtual-resource>.content*")
(typecheck (creation-time self) datetime? "<virtual-resource>.creation-time"))
(define (virtual-resource? x)
(is-a? x <virtual-resource>))
(define-method (write (self <virtual-resource>) port)
(format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>"
(name self)
(creation-time self)
(content self)))
(define-method (live-properties (self <virtual-resource>))
(append
(next-method)
(list (cons ((xml virtual-ns 'isvirtual))
(make-live-property isvirtual set-isvirtual!)))))
(define-method (content (self <virtual-resource>))
(content* self))
(define-method (set-content! (self <virtual-resource>) data)
(set! (content* self) data))
(define-method (creationdate (self <virtual-resource>))
(propstat 200
(list
((xml webdav 'creationdate)
(-> (creation-time self)
(datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
(define-method (getcontenttype (self <resource>))
(propstat 200
(list
((xml webdav 'getcontenttype)
"application/binary"))))
(define-method (isvirtual (self <virtual-resource>))
(propstat 200
(list
((xml virtual-ns 'isvirtual)
"true"))))
(define-method (set-isvirtual! (self <virtual-resource>) _)
(throw 'protected-resource "isvirtual"))
|
