blob: 7510f82190fb1fe498418f18f0fb199829885898 (
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
|
(define-module (ldp resource unsafe save)
#:use-module (ldp resource)
#:use-module (ldp path)
#:use-module (ldp resource xml)
#:use-module (ice-9 ftw)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (web uri))
(define (clean-directories path kept)
;; Remove everything in path except kept
(define (enter-aux? x list)
(cond ((null? list)
#t)
((string=? x (car list))
#f)
(else (enter-aux? x (cdr list)))))
(define (enter? name stat result)
(enter-aux? name kept))
(define (leaf name stat result)
(delete-file name)
result)
(define (down name stat result)
result)
(define (up name stat result)
(unless (string=? name path)
(rmdir name))
result)
(define (skip name stat result) #f)
(define (error name stat errno result)
(unless (string=? name path)
(catch #t
(lambda ()
(delete-file name))
(lambda err #t))
(catch #t
(lambda ()
(rmdir name))
(lambda err #t)))
result)
(file-system-fold enter? leaf down up skip error #t path))
(define (fix-directories resource)
(let ((dirname (path->filename (resource-path resource))))
(map
(lambda (path)
(catch #t
(lambda ()
;; It may already exist, of course
(mkdir (path->filename path)))
(lambda err #t)))
(or (resource-contained resource) '()))
(clean-directories
dirname
(cons (string-append dirname "/representation")
(map path->filename
(or (resource-contained resource) '()))))))
(define-public (save-manifest resource)
(let* ((dirname (path->filename (resource-path resource)))
(filename (string-append dirname "/representation/manifest.xml"))
(temp-filename (string-append filename "~")))
(catch #t
(lambda ()
(mkdir (string-append dirname "/representation")))
(lambda err #t))
(call-with-output-file temp-filename
(lambda (port)
(resource->xml resource port)))
(rename-file temp-filename filename)
(fix-directories resource)))
(define-public (save resource content)
(let* ((dirname (path->filename (resource-path resource)))
(reprname (string-append dirname "/representation"))
(temp-reprname (string-append dirname "/representation~")))
(catch #t
(lambda ()
(mkdir temp-reprname))
(lambda err #t))
(call-with-output-file (string-append temp-reprname "/manifest.xml")
(lambda (port)
(resource->xml resource port)))
(call-with-output-file (string-append temp-reprname "/content")
(lambda (port)
(put-bytevector port
(if (string? content)
(string->utf8 content)
content)))
#:binary #t)
(rename-file temp-reprname reprname)
(fix-directories resource)))
|
