Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Work in progress: Re-using buffers rather than consing new ones all the time! |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | alaricsp |
| Files: | files | file ages | folders |
| SHA1: | 7debb510ed5cba081a4991d613d90e9d6754f743 |
| User & Date: | alaric 2016-02-21 21:43:00 |
Context
|
2016-02-21
| ||
| 21:43 | Work in progress: Re-using buffers rather than consing new ones all the time! Leaf check-in: 7debb510ed user: alaric tags: alaricsp | |
|
2015-09-26
| ||
| 10:30 | fprintf had absorbed flush-output! Oops! check-in: 485a7f1e1a user: alaric tags: alaricsp | |
Changes
Changes to backend-cache.scm.
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 ... 153 154 155 156 157 158 159 160 |
(define (cache-clear!)
(exec (sql *db* "DELETE FROM cache")))
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data type) ; put!
(begin
((storage-put! be) key data type)
(cache-set! key type)
(void)))
(lambda () ; flush!
(begin
((storage-flush! be))
(flush!)
(void)))
(lambda (key) ; exists?
(let ((cached-result (cache-get key)))
................................................................................
(if cached-result
(begin
(inc! *hits*)
cached-result)
(begin
(inc! *misses*)
(cache-set! key ((storage-exists? be) key))))))
(lambda (key) ; get
((storage-get be) key))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key) ; unlink!
(let ((result ((storage-unlink! be) key)))
(if result
(begin
(cache-delete! key)
result)
result)))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key)
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-cache")
(printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
#f)))
(if backend
(export-storage! backend))
|
| | | | | | | | | | |
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 ... 153 154 155 156 157 158 159 160 |
(define (cache-clear!)
(exec (sql *db* "DELETE FROM cache")))
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data length type) ; put!
(begin
((storage-put! be) key data length type)
(cache-set! key type)
(void)))
(lambda () ; flush!
(begin
((storage-flush! be))
(flush!)
(void)))
(lambda (key) ; exists?
(let ((cached-result (cache-get key)))
................................................................................
(if cached-result
(begin
(inc! *hits*)
cached-result)
(begin
(inc! *misses*)
(cache-set! key ((storage-exists? be) key))))))
(lambda (key buffer) ; get
((storage-get be) key buffer))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key buffer) ; unlink!
(let ((result ((storage-unlink! be) key buffer)))
(if result
(begin
(cache-delete! key)
result)
result)))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key)
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-cache")
(printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
#f)))
(if backend
(export-storage! backend #f))
|
Changes to backend-cluster.scm.
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(define (cache-clear!)
(exec (sql *db* "DELETE FROM cache")))
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data type) ; put!
(begin
((storage-put! be) key data type)
(cache-set! key type)
(void)))
(lambda () ; flush!
(begin
((storage-flush! be))
(flush!)
(void)))
................................................................................
(if cached-result
(begin
(inc! *hits*)
cached-result)
(begin
(inc! *misses*)
(cache-set! key ((storage-exists? be) key))))))
(lambda (key) ; get
((storage-get be) key))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key) ; unlink!
(let ((result ((storage-unlink! be) key)))
(if result
(begin
(cache-delete! key)
result)
result)))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key)
|
|
|
|
|
|
|
|
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(define (cache-clear!)
(exec (sql *db* "DELETE FROM cache")))
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data length type) ; put!
(begin
((storage-put! be) key data length type)
(cache-set! key type)
(void)))
(lambda () ; flush!
(begin
((storage-flush! be))
(flush!)
(void)))
................................................................................
(if cached-result
(begin
(inc! *hits*)
cached-result)
(begin
(inc! *misses*)
(cache-set! key ((storage-exists? be) key))))))
(lambda (key buffer) ; get
((storage-get be) key buffer))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key buffer) ; unlink!
(let ((result ((storage-unlink! be) key buffer)))
(if result
(begin
(cache-delete! key)
result)
result)))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key)
|
Changes to backend-devtools.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
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
|
(define (backend-nullwrap be)
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data type) ; put!
((storage-put! be) key data type))
(lambda () ; flush!
((storage-flush! be)))
(lambda (key) ; exists?
((storage-exists? be) key))
(lambda (key) ; get
((storage-get be) key))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key) ; unlink!
((storage-unlink! be) key))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key))
(lambda (tag) ; tag
((storage-tag be) tag))
(lambda () ; all-tags
((storage-all-tags be)))
(lambda (tag) ; remove-tag!
................................................................................
((storage-close! be)))))
(define (backend-limit-block-size be max-block-size)
(make-storage
(min max-block-size (storage-max-block-size be))
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data type) ; put!
((storage-put! be) key data type))
(lambda () ; flush!
((storage-flush! be)))
(lambda (key) ; exists?
((storage-exists? be) key))
(lambda (key) ; get
((storage-get be) key))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key) ; unlink!
((storage-unlink! be) key))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key))
(lambda (tag) ; tag
((storage-tag be) tag))
(lambda () ; all-tags
((storage-all-tags be)))
(lambda (tag) ; remove-tag!
|
|
|
|
|
|
|
|
|
|
|
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
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
|
(define (backend-nullwrap be)
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data length type) ; put!
((storage-put! be) key data length type))
(lambda () ; flush!
((storage-flush! be)))
(lambda (key) ; exists?
((storage-exists? be) key))
(lambda (key buffer) ; get
((storage-get be) key buffer))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key buffer) ; unlink!
((storage-unlink! be) key buffer))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key))
(lambda (tag) ; tag
((storage-tag be) tag))
(lambda () ; all-tags
((storage-all-tags be)))
(lambda (tag) ; remove-tag!
................................................................................
((storage-close! be)))))
(define (backend-limit-block-size be max-block-size)
(make-storage
(min max-block-size (storage-max-block-size be))
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data length type) ; put!
((storage-put! be) key data length type))
(lambda () ; flush!
((storage-flush! be)))
(lambda (key) ; exists?
((storage-exists? be) key))
(lambda (key buffer) ; get
((storage-get be) key buffer))
(lambda (key) ; link!
((storage-link! be) key))
(lambda (key buffer) ; unlink!
((storage-unlink! be) key buffer))
(lambda (tag key) ; set-tag!
((storage-set-tag! be) tag key))
(lambda (tag) ; tag
((storage-tag be) tag))
(lambda () ; all-tags
((storage-all-tags be)))
(lambda (tag) ; remove-tag!
|
Changes to backend-fs.scm.
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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 ... 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 ... 524 525 526 527 528 529 530 531 |
(define block-size (* 1024 1024))
(make-storage
block-size
#t ; We are writable
#t ; We support unlink!
(lambda (key data type) ; put!
(if (file-read-access? (make-name key ".type"))
(signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type)))
(begin
(ensure-directory! key)
; Note: We save to ...~ files then mv them into place, so as to avoid ending up with a partial block
; in the archive if it dies in mid-write. We move the .type file in last, since the existance of that is what
; makes the block "official".
; The only thing we need worry about is a race between two snapshots writing the same block at once...
; However, since we can't easily provide atomicity on link!, we just say "don't do that" for now.
(with-output-to-file (make-name key ".data~")
(lambda () (write-u8vector data)))
(with-output-to-file (make-name key ".type~")
(lambda () (write type)))
(with-output-to-file (make-name key ".refcount~")
(lambda () (write 1)))
(rename-file (make-name key ".data~") (make-name key ".data"))
(rename-file (make-name key ".refcount~") (make-name key ".refcount"))
(rename-file (make-name key ".type~") (make-name key ".type"))
................................................................................
(void))))
(lambda () (void)) ; flush! - a no-op for us
(lambda (key) ; exists?
(if (file-read-access? (make-name key ".data"))
(with-input-from-file (make-name key ".type")
(lambda () (read)))
#f))
(lambda (key) ; get
(if (file-read-access? (make-name key ".data"))
(with-input-from-file (make-name key ".data")
(lambda () (read-u8vector)))
#f))
(lambda (key) ; link!
(if
(file-read-access? (make-name key ".data"))
(let
((current-refcount
(with-input-from-file (make-name key ".refcount")
(lambda () (read)))))
(begin
(with-output-to-file (make-name key ".refcount~")
(lambda () (write (+ current-refcount 1))))
(rename-file (make-name key ".refcount~") (make-name key ".refcount"))))))
(lambda (key) ; unlink!
(and-let*
(((file-read-access? (make-name key ".data")))
(current-refcount
(with-input-from-file (make-name key ".refcount")
(lambda () (read))))
(new-refcount (- current-refcount 1)))
(if (zero? new-refcount)
(let
((data (with-input-from-file (make-name key ".data")
(lambda () (read-u8vector)))))
(begin
(delete-file (make-name key ".data"))
(delete-file (make-name key ".type"))
(delete-file (make-name key ".refcount"))
(delete-dir-if-empty! key)
data)) ; returned in case of deletion
(begin
................................................................................
(void))))
(make-storage
block-size
writable?
#f ; We DO NOT support unlink!
(lambda (key data type) ; put!
(check-writable)
(when (pair? (get-block-data key))
(error "Duplicate block" key type))
(set-file-position! *log* 0 seek/end)
(let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
(posn (file-position *log*)))
(if (and (not (zero? posn)) (> (+ (u8vector-length data) (string-length header) posn) max-logpart-size))
(begin
(file-close *log*)
(set! posn 0)
(set-logcount! (+ *logcount* 1))
(set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
(bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))))
(file-write *log* header)
(file-write *log* (u8vector->blob/shared data))
(set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
(void)))
(lambda () ; flush!
(flush!)
(void))
(lambda (key) ; exists?
(let ((bd (get-block-data key)))
(if (pair? bd)
(car bd)
#f)))
(lambda (key) ; get
(let* ((entry (get-block-data key)))
(if (pair? entry)
(let* ((type (first entry))
(index (second entry))
(position (third entry))
(length (fourth entry))
(buffer (make-blob length))
(logpart (get-log index)))
(set-file-position! logpart position seek/set)
(file-read logpart length buffer)
(blob->u8vector/shared buffer))
#f)))
(lambda (key) ; link!
(check-writable)
(void))
(lambda (key) ; unlink!
(check-writable)
(error "splitlog archives do not support unlinkined"))
(lambda (tag key) ; set-tag!
(check-writable)
(file-write *log* (sprintf "(tag ~S ~S)" tag key))
(set-tag! tag key)
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-fs")
(printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path>\n")
#f)))
(if backend
(export-storage! backend))
|
| | | | | | | | | | | | < | < > | | |
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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 ... 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 ... 523 524 525 526 527 528 529 530 |
(define block-size (* 1024 1024))
(make-storage
block-size
#t ; We are writable
#t ; We support unlink!
(lambda (key data length type) ; put!
(if (file-read-access? (make-name key ".type"))
(signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type)))
(begin
(ensure-directory! key)
; Note: We save to ...~ files then mv them into place, so as to avoid ending up with a partial block
; in the archive if it dies in mid-write. We move the .type file in last, since the existance of that is what
; makes the block "official".
; The only thing we need worry about is a race between two snapshots writing the same block at once...
; However, since we can't easily provide atomicity on link!, we just say "don't do that" for now.
(with-output-to-file (make-name key ".data~")
(lambda () (write-u8vector data (current-output-port) 0 length)))
(with-output-to-file (make-name key ".type~")
(lambda () (write type)))
(with-output-to-file (make-name key ".refcount~")
(lambda () (write 1)))
(rename-file (make-name key ".data~") (make-name key ".data"))
(rename-file (make-name key ".refcount~") (make-name key ".refcount"))
(rename-file (make-name key ".type~") (make-name key ".type"))
................................................................................
(void))))
(lambda () (void)) ; flush! - a no-op for us
(lambda (key) ; exists?
(if (file-read-access? (make-name key ".data"))
(with-input-from-file (make-name key ".type")
(lambda () (read)))
#f))
(lambda (key buffer) ; get
(if (file-read-access? (make-name key ".data"))
(with-input-from-file (make-name key ".data")
(lambda () (read-u8vector! #f buffer)))
#f))
(lambda (key) ; link!
(if
(file-read-access? (make-name key ".data"))
(let
((current-refcount
(with-input-from-file (make-name key ".refcount")
(lambda () (read)))))
(begin
(with-output-to-file (make-name key ".refcount~")
(lambda () (write (+ current-refcount 1))))
(rename-file (make-name key ".refcount~") (make-name key ".refcount"))))))
(lambda (key buffer) ; unlink!
(and-let*
(((file-read-access? (make-name key ".data")))
(current-refcount
(with-input-from-file (make-name key ".refcount")
(lambda () (read))))
(new-refcount (- current-refcount 1)))
(if (zero? new-refcount)
(let
((data (with-input-from-file (make-name key ".data")
(lambda () (read-u8vector! #f buffer)))))
(begin
(delete-file (make-name key ".data"))
(delete-file (make-name key ".type"))
(delete-file (make-name key ".refcount"))
(delete-dir-if-empty! key)
data)) ; returned in case of deletion
(begin
................................................................................
(void))))
(make-storage
block-size
writable?
#f ; We DO NOT support unlink!
(lambda (key data length type) ; put!
(check-writable)
(when (pair? (get-block-data key))
(error "Duplicate block" key type))
(set-file-position! *log* 0 seek/end)
(let ((header (sprintf "(block ~S ~S ~S)" key type length))
(posn (file-position *log*)))
(if (and (not (zero? posn)) (> (+ length (string-length header) posn) max-logpart-size))
(begin
(file-close *log*)
(set! posn 0)
(set-logcount! (+ *logcount* 1))
(set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
(bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))))
(file-write *log* header)
(file-write *log* (u8vector->blob/shared data) length)
(set-block-data! key type *logcount* (+ (string-length header) posn) length)
(void)))
(lambda () ; flush!
(flush!)
(void))
(lambda (key) ; exists?
(let ((bd (get-block-data key)))
(if (pair? bd)
(car bd)
#f)))
(lambda (key buffer) ; get
(let* ((entry (get-block-data key)))
(if (pair? entry)
(let* ((type (first entry))
(index (second entry))
(position (third entry))
(length (fourth entry))
(logpart (get-log index)))
(set-file-position! logpart position seek/set)
(file-read logpart length (u8vector->blob/shared buffer))
length)
#f)))
(lambda (key) ; link!
(check-writable)
(void))
(lambda (key buffer) ; unlink!
(check-writable)
(error "splitlog archives do not support unlinkined"))
(lambda (tag key) ; set-tag!
(check-writable)
(file-write *log* (sprintf "(tag ~S ~S)" tag key))
(set-tag! tag key)
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-fs")
(printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path>\n")
#f)))
(if backend
(export-storage! backend #f))
|
Changes to backend-log.scm.
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
...
106
107
108
109
110
111
112
113
|
(fprintf logport "(use ugarit-backend)\n")
(fprintf logport "(use test)\n")
(fprintf logport "(let ((storage (import-storage ~S)))\n" name)
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data type) ; put!
(begin
(fprintf logport " (test (void) ((storage-put! storage) ~S '~S '~S))\n"
key (if include-bulk-data? data '...) type)
((storage-put! be) key data type)))
(lambda () ; flush!
(begin
(fprintf logport " (test (void) ((storage-flush! storage)))\n")
((storage-flush! be))))
(lambda (key) ; exists?
(let ((result ((storage-exists? be) key)))
(begin
(fprintf logport " (test '~S ((storage-exists? storage) ~S))\n"
result key)
result)))
(lambda (key) ; get
(let ((result ((storage-get be) key)))
(begin
(if include-bulk-data?
(fprintf logport " (test '~S ((storage-get storage) ~S))\n"
result key)
(fprintf logport " ((storage-get storage) ~S)\n"
key))
result)))
(lambda (key) ; link!
(begin
(fprintf logport " (test (void) ((storage-link! storage) ~S))\n" key)
((storage-link! be) key)))
(lambda (key) ; unlink!
(let ((result ((storage-unlink! be) key)))
(begin
(if include-bulk-data?
(fprintf logport " (test '~S ((storage-unlink! storage) ~S))\n"
result key)
(fprintf logport " ((storage-unlink! storage) ~S)\n"
key))
result)))
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-log")
(printf "USAGE:\nbackend-log <path-to-log-file> \"<backend command line>\"\n")
#f)))
(if backend
(export-storage! backend))
|
|
|
|
|
|
|
|
|
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
...
106
107
108
109
110
111
112
113
|
(fprintf logport "(use ugarit-backend)\n")
(fprintf logport "(use test)\n")
(fprintf logport "(let ((storage (import-storage ~S)))\n" name)
(make-storage
(storage-max-block-size be)
(storage-writable? be)
(storage-unlinkable? be)
(lambda (key data length type) ; put!
(begin
(fprintf logport " (test (void) ((storage-put! storage) ~S '~S '~S))\n"
key (if include-bulk-data? data '...) type)
((storage-put! be) key data length type)))
(lambda () ; flush!
(begin
(fprintf logport " (test (void) ((storage-flush! storage)))\n")
((storage-flush! be))))
(lambda (key) ; exists?
(let ((result ((storage-exists? be) key)))
(begin
(fprintf logport " (test '~S ((storage-exists? storage) ~S))\n"
result key)
result)))
(lambda (key buffer) ; get
(let ((result ((storage-get be) key buffer)))
(begin
(if include-bulk-data?
(fprintf logport " (test '~S ((storage-get storage) ~S))\n"
result key)
(fprintf logport " ((storage-get storage) ~S)\n"
key))
result)))
(lambda (key) ; link!
(begin
(fprintf logport " (test (void) ((storage-link! storage) ~S))\n" key)
((storage-link! be) key)))
(lambda (key buffer) ; unlink!
(let ((result ((storage-unlink! be) key buffer)))
(begin
(if include-bulk-data?
(fprintf logport " (test '~S ((storage-unlink! storage) ~S))\n"
result key)
(fprintf logport " ((storage-unlink! storage) ~S)\n"
key))
result)))
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-log")
(printf "USAGE:\nbackend-log <path-to-log-file> \"<backend command line>\"\n")
#f)))
(if backend
(export-storage! backend #f))
|
Changes to backend-sqlite.scm.
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 ... 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 ... 271 272 273 274 275 276 277 278 |
(exec set-block-data-query key (symbol->string type) (u8vector->blob/shared content))
(maybe-flush!)))
(link-block! (lambda (key)
(exec link-block-query key)
(maybe-flush!)))
(unlink-block! (lambda (key)
(exec unlink-block-query key)
(maybe-flush!)
(let ((rc (query fetch get-block-refcount-query key)))
(if (pair? rc)
(if (< (car rc) 1)
(let ((contents (second (get-block-data key))))
(exec delete-block-query key)
contents)
#f)
#f))))
(set-tag! (lambda (tag key)
(exec set-tag-query tag key)
(flush!)))
................................................................................
(map car (query fetch-all get-tags-query)))))
(make-storage
block-size
writable?
#t ; We DO support unlink!
(lambda (key data type) ; put!
(check-writable)
(when (get-block-metadata key)
(error "Duplicate block" key type))
(set-block-data! key type data)
(void))
(lambda () ; flush!
(flush!)
(void))
(lambda (key) ; exists?
(let ((bmd (get-block-metadata key)))
bmd))
(lambda (key) ; get
(let* ((entry (get-block-data key)))
(if (pair? entry)
(let* ((type (first entry))
(content (second entry)))
content)
#f)))
(lambda (key) ; link!
(check-writable)
(link-block! key)
(void))
(lambda (key) ; unlink!
(check-writable)
(unlink-block! key))
(lambda (tag key) ; set-tag!
(check-writable)
(set-tag! tag key)
(void))
(lambda (tag) ; tag
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-sqlite")
(printf "USAGE:\nbackend-sqlite <basedir-path>\n")
#f)))
(if backend
(export-storage! backend))
|
| > | | | | > | | | | |
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 ... 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 ... 273 274 275 276 277 278 279 280 |
(exec set-block-data-query key (symbol->string type) (u8vector->blob/shared content))
(maybe-flush!)))
(link-block! (lambda (key)
(exec link-block-query key)
(maybe-flush!)))
(unlink-block! (lambda (key buffer)
(exec unlink-block-query key)
(maybe-flush!)
(let ((rc (query fetch get-block-refcount-query key)))
(if (pair? rc)
(if (< (car rc) 1)
(let ((contents (second (get-block-data key))))
(exec delete-block-query key)
(move-memory! contents buffer 0 (u8vector-length contents))
(u8vector-length contents))
#f)
#f))))
(set-tag! (lambda (tag key)
(exec set-tag-query tag key)
(flush!)))
................................................................................
(map car (query fetch-all get-tags-query)))))
(make-storage
block-size
writable?
#t ; We DO support unlink!
(lambda (key data length type) ; put!
(check-writable)
(when (get-block-metadata key)
(error "Duplicate block" key type))
(set-block-data! key type (subu8vector data 0 length)) ; FIXME: COPY
(void))
(lambda () ; flush!
(flush!)
(void))
(lambda (key) ; exists?
(let ((bmd (get-block-metadata key)))
bmd))
(lambda (key buffer) ; get
(let* ((entry (get-block-data key)))
(if (pair? entry)
(let* ((type (first entry))
(content (second entry)))
(move-memory! content buffer (u8vector-length content))
(u8vector-length content))
#f)))
(lambda (key) ; link!
(check-writable)
(link-block! key)
(void))
(lambda (key buffer) ; unlink!
(check-writable)
(unlink-block! key buffer))
(lambda (tag key) ; set-tag!
(check-writable)
(set-tag! tag key)
(void))
(lambda (tag) ; tag
................................................................................
(else
(export-storage-error! "Invalid arguments to backend-sqlite")
(printf "USAGE:\nbackend-sqlite <basedir-path>\n")
#f)))
(if backend
(export-storage! backend #f))
|
Changes to test.conf.
1 2 3 |
(storage "backend-sqlite ugarit-test-4.vault") ;(hash tiger "foods") ;(file-cache "/tmp/ugarit-test-cache-4") |
| |
1 2 3 |
(storage "backend-sqlite /tmp/ugarit-test-4.vault")
;(hash tiger "foods")
;(file-cache "/tmp/ugarit-test-cache-4")
|
Changes to tests/run.scm.
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
...
599
600
601
602
603
604
605
606
607
608
609
610
611
612
|
(define var (void)) ...
(test-no-errors name (set!-values (var ...) expr))))))
;; Test utilities
; Basic smoke test of a backend
(define (test-backend w)
(parameterize
((backend-log! (lambda (type message) (void))))
(test-assert "Storage block size is valid" (exact? (storage-max-block-size w)))
(test-assert "Storage writable" (storage-writable? w))
(test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
(test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
(test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
(test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
(let ((long-name "caeef4a6ffe0cc5e25f9966c922366ec36b2bcf0dcd40754991ffe107b49fb33"))
(test "Nonexistant block with a long name reacts correctly" #f ((storage-get w) long-name))
(test "Load a block with a long name" (void) ((storage-put! w) long-name (list->u8vector (list 6 7 8 9 10)) 'test))
(test-assert "Block with a long name successfully loaded" ((storage-exists? w) long-name))
(test "Block contents with a long name reads back" (list 6 7 8 9 10) (u8vector->list ((storage-get w) long-name))))
(test "Nonexistant block reacts correctly" #f ((storage-get w) "NONEXISTANT"))
(test-error "Cannot update existing blocks" ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5 6)) 'test))
(if (storage-unlinkable? w)
(begin
(test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
(test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
(test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
(test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
(test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
(test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
(test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
(test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
(test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
(test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
(test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
(test "Tag list works" (list "TEST") ((storage-all-tags w)))
(test "Remove tag" (void) ((storage-remove-tag! w) "TEST"))
(test "Nonexistant tag is not locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
(test "Lock a nonexistant tag" #t ((storage-lock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is now locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
(test "Lock a nonexistant tag again" #f ((storage-lock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is still locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
(test "Unlock a locked nonexistant tag" (void) ((storage-unlock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is no longer locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
(test "Close storage" (void) ((storage-close! w)))))
(define (key-stream-cat a ks-hash ks-type level)
(define type (vault-exists? a ks-hash))
(if (eq? type ks-type)
(begin
(printf "ks(~A): ~A (~A)\n" level ks-hash type)
(for-each (lambda (subkey)
................................................................................
(test "Extract a directory" (void)
(extract-directory! a dir4-key extract4-dir))
(check-extract-results extract4-dir "Hello world again!" "Hello world 2")
;; Tidy up
(when (vault-unlinkable? a)
(begin
(test "Delete the first directory" (void) (unlink-directory! a dir1-key))
(check-extract-results extract2-dir "Hello world" "Hello world 2")
(test "Delete the second directory" (void) (unlink-directory! a dir2-key))
(check-extract-results extract3-dir "Hello world again!" "Hello world 2")
(test "Delete the third directory" (void) (unlink-directory! a dir3-key))
(check-extract-results extract4-dir "Hello world again!" "Hello world 2")
(test "Delete the fourth directory" (void) (unlink-directory! a dir4-key))
|
>
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
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
102
103
104
...
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
|
(define var (void)) ...
(test-no-errors name (set!-values (var ...) expr))))))
;; Test utilities
; Basic smoke test of a backend
(define (test-backend w)
(let ((buffer (make-u8vector 5)))
(parameterize
((backend-log! (lambda (type message) (void))))
(test-assert "Storage block size is valid" (exact? (storage-max-block-size w)))
(test-assert "Storage writable" (storage-writable? w))
(test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
(test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 5 'test))
(test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
(test "Block reads back" 5 ((storage-get w) "TEST" buffer))
(test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list buffer))
(let ((long-name "caeef4a6ffe0cc5e25f9966c922366ec36b2bcf0dcd40754991ffe107b49fb33"))
(test "Nonexistant block with a long name reacts correctly" #f ((storage-get w) long-name buffer))
(test "Load a block with a long name" (void) ((storage-put! w) long-name (list->u8vector (list 6 7 8 9 10)) 5 'test))
(test-assert "Block with a long name successfully loaded" ((storage-exists? w) long-name))
(test "Block with a long name reads back" 5 ((storage-get w) long-name buffer))
(test "Block contents with a long name reads back" (list 6 7 8 9 10) (u8vector->list buffer)))
(test "Nonexistant block reacts correctly" #f ((storage-get w) "NONEXISTANT" buffer))
(test-error "Cannot update existing blocks" ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5 6)) 6 'test))
(if (storage-unlinkable? w)
(begin
(test "Unlink returns data" 5 ((storage-unlink! w) "TEST" buffer))
(test "Unlink returns correct data" (list 1 2 3 4 5) (u8vector->list buffer))
(test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
(test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
(test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
(test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
(test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
(test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
(test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
(test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
(test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
(test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
(test "Tag list works" (list "TEST") ((storage-all-tags w)))
(test "Remove tag" (void) ((storage-remove-tag! w) "TEST"))
(test "Nonexistant tag is not locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
(test "Lock a nonexistant tag" #t ((storage-lock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is now locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
(test "Lock a nonexistant tag again" #f ((storage-lock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is still locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
(test "Unlock a locked nonexistant tag" (void) ((storage-unlock-tag! w) "NONEXISTANT"))
(test "Nonexistant tag is no longer locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
(test "Close storage" (void) ((storage-close! w))))))
(define (key-stream-cat a ks-hash ks-type level)
(define type (vault-exists? a ks-hash))
(if (eq? type ks-type)
(begin
(printf "ks(~A): ~A (~A)\n" level ks-hash type)
(for-each (lambda (subkey)
................................................................................
(test "Extract a directory" (void)
(extract-directory! a dir4-key extract4-dir))
(check-extract-results extract4-dir "Hello world again!" "Hello world 2")
;; Tidy up
(when (vault-unlinkable? a)
(begin
(printf "Get dir: ~s\n" (vault-get a dir1-key))
(printf "Unlink dir: ~s\n" (vault-unlink! a dir1-key))
(exit 0)
(test "Delete the first directory" (void) (unlink-directory! a dir1-key))
(check-extract-results extract2-dir "Hello world" "Hello world 2")
(test "Delete the second directory" (void) (unlink-directory! a dir2-key))
(check-extract-results extract3-dir "Hello world again!" "Hello world 2")
(test "Delete the third directory" (void) (unlink-directory! a dir3-key))
(check-extract-results extract4-dir "Hello world again!" "Hello world 2")
(test "Delete the fourth directory" (void) (unlink-directory! a dir4-key))
|
Changes to ugarit-api.scm.
503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
;; This bit will throw an error if the vault's encryption or
;; hashing is set up incorrectly.
(let ((configuration
(handle-exceptions
exn
(signal (make-property-condition
'exn
'location 'open-vault
'message "Reading the vault header failed. Most likely, your hash or encryption settings are incorrect, or there is a problem with the vault."))
(read-sexpr vault (tag-key conf-tag) 'ugarit-vault-configuration))))
(match configuration
(((? integer? ver) . alist)
|
> | |
503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
;; This bit will throw an error if the vault's encryption or
;; hashing is set up incorrectly.
(let ((configuration
(handle-exceptions
exn
(signal exn)
#;(signal (make-property-condition
'exn
'location 'open-vault
'message "Reading the vault header failed. Most likely, your hash or encryption settings are incorrect, or there is a problem with the vault."))
(read-sexpr vault (tag-key conf-tag) 'ugarit-vault-configuration))))
(match configuration
(((? integer? ver) . alist)
|
Changes to ugarit-backend.scm.
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 .. 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 ... 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 ... 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 ... 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 ... 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 ... 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 ... 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 ... 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 ... 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
(use ports) (use matchable) (use posix) (use srfi-4) (use data-structures) (use miscmacros) ; FIXME: If we can get process% working and returning ; ports that we can use port->fileno on, we can swap these ; over to the faster implementations. (define fast-write-u8vector write-u8vector) (define fast-read-u8vector read-u8vector) #;(define (fast-write-u8vector vector port) (file-write (port->fileno port) (u8vector->blob/shared vector))) #;(define (fast-read-u8vector length port) (let ((result (file-read (port->fileno port) length))) (car result))) ; Backends can call the procedure found in this paramter to log ; things. type should be 'warning, 'error or 'info. message should ; be any string. (define backend-log! (make-parameter (lambda (type message) (error "No backend log handler has been defined")))) ................................................................................ (define-record-type storage (make-storage* name max-block-size ; Integer: largest size of block we can store writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!? unlinkable? ; Boolean: Can we call unlink? put! ; Procedure: (put! key data type) - stores the data (u8vector) under the key (string) with the given type tag (symbol) and a refcount of 1. Does nothing of the key is already in use. flush! ; Procedure: (flush!) - all previous changes must be flushed to disk by the time the continuation is applied. exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise get ; Procedure: (get key) - returns the contents (u8vector) of the block with the given key (string) if it exists, or #f otherwise link! ; Procedure: (link key) - increments the refcount of the block unlink! ; Procedure: (unlink key) - decrements the refcount of the block. If it's now zero, deletes it but returns its value as a u8vector. If not, returns #f. set-tag! ; Procedure: (set-tag! name key) - assigns the given key (string) to the given tag (named with a string). Creates a new tag if the name has not previously been used, otherwise updates an existing tag tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist. all-tags ; Procedure: (all-tags) - returns a list of all existing tag names remove-tag! ; Procedure: (remove-tag! name) - removes the named tag lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, returning #t if all went well, or #f if it can't be locked. tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag ................................................................................ (lambda (type message) (queue-add! log (cons type message)) (void)))) (let ((result (begin body ...))) (write (list (queue->list log) result))))))) ; Return the result of the body as a data block, and any logs (define-syntax-rule (with-error-reporting-and-block body ...) (handle-exceptions exn (write (list "error" (describe-exception exn))) (let ((log (make-queue))) (parameterize ((backend-log! (lambda (type message) (queue-add! log (cons type message)) (void)))) (let ((result (begin body ...))) (if result (begin (write (list (queue->list log) (u8vector-length result))) (fast-write-u8vector result (current-output-port))) (write (list (queue->list log) #f)))))))) ; Return any logs (define-syntax-rule (with-error-reporting body ...) (handle-exceptions exn (write (list "error" (describe-exception exn))) (let ((log (make-queue))) ................................................................................ ; Write the error header (write *magic-v2*) (newline) (write (list "error" message))) ;; Given a storage object, provide the storage remote access protocol ;; via current-input-port / current-output-port until the storage is closed ;; via the protocol. (define (export-storage! storage-thunk) (set-buffering-mode! (current-output-port) #:none) ; Write the header (write *magic-v2*) (newline) (let ((storage #f)) (with-error-reporting-and-result ; Initialise and send the header ................................................................................ (set! storage storage*) ; This feels hacky (list (storage-max-block-size storage) (storage-writable? storage) (storage-unlinkable? storage)))) ; Engage command loop (if storage (let loop () (newline) (let ((command (read))) (if (eof-object? command) (begin (with-error-reporting ((storage-close! storage))) (void)) (match command (('put! key type length) (let ((data (fast-read-u8vector length (current-input-port)))) (with-error-reporting ((storage-put! storage) key data type))) (loop)) (('flush!) (with-error-reporting ((storage-flush! storage))) (loop)) (('exists? key) (with-error-reporting-and-result ((storage-exists? storage) key)) (loop)) (('get key) (with-error-reporting-and-block ((storage-get storage) key)) (loop)) (('link! key) (with-error-reporting ((storage-link! storage) key)) (loop)) (('unlink! key) (with-error-reporting-and-block ((storage-unlink! storage) key)) (loop)) (('set-tag! name key) (with-error-reporting ((storage-set-tag! storage) name key)) (loop)) (('tag name) (with-error-reporting-and-result ((storage-tag storage) name)) (loop)) (('all-tags) (with-error-reporting-and-result ((storage-all-tags storage))) (loop)) (('remove-tag! name) (with-error-reporting ((storage-remove-tag! storage) name)) (loop)) (('lock-tag! name) (with-error-reporting-and-result ((storage-lock-tag! storage) name)) (loop)) (('tag-locked? name) (with-error-reporting-and-result ((storage-tag-locked? storage) name)) (loop)) (('unlock-tag! name) (with-error-reporting ((storage-unlock-tag! storage) name)) (loop)) (('admin! command) (with-error-reporting-and-result ((storage-admin! storage) command)) (loop)) (('close!) (with-error-reporting ((storage-close! storage))) (void)) (else (write (list "error" (sprintf "Bad command ~s" command))) (loop))))))))) ;; Importing a storage - taking a command line to a backend protocol ;; server and turning it into a storage record (define (protocol-error message backend operation . irritants) (abort (make-composite-condition ................................................................................ (define (read-response-v1 port backend operation) (let ((response (read port))) (match response (("error" err) (protocol-error "Backend protocol error" backend operation err)) (else response)))) (define (read-response-v1-body port backend operation) (let ((response (read-response-v1 port backend operation))) (if response (fast-read-u8vector (car response) port) #f))) (define (import-storage-v1 command-line debug responses commands pid) (let ((header (rewrite-i/o-errors command-line 'read-header (lambda () (read responses))))) (if debug (printf "~a: read header ~a~%" command-line header)) (if (not (list? header)) (protocol-error "Invalid backend protocol header" command-line 'read-header header)) (if (not (= (length header) 3)) (protocol-error "Invalid backend protocol header" command-line 'read-header header)) (let ((max-block-size (car header)) (writable? (cadr header)) (unlinkable? (caddr header))) (make-storage* command-line max-block-size writable? unlinkable? (lambda (key data type) ; put! (rewrite-i/o-errors command-line 'put! (lambda () (if debug (printf "~a: put!" command-line)) (write `(put! ,key ,type ,(u8vector-length data)) commands) (fast-write-u8vector data commands) (read-response-v1 responses command-line 'put!) (void)))) (lambda () ; flush! (rewrite-i/o-errors command-line 'flush! (lambda () (if debug (printf "~a: flush!" command-line)) ................................................................................ (lambda (key) ; exists? (rewrite-i/o-errors command-line 'exists? (lambda () (if debug (printf "~a: exists?" command-line)) (write `(exists? ,key) commands) (read-response-v1 responses command-line 'exists?)))) (lambda (key) ; get (rewrite-i/o-errors command-line 'get (lambda () (if debug (printf "~a: get" command-line)) (write `(get ,key) commands) (read-response-v1-body responses command-line 'get)))) (lambda (key) ; link! (rewrite-i/o-errors command-line 'link! (lambda () (if debug (printf "~a: link!" command-line)) (write `(link! ,key) commands) (read-response-v1 responses command-line 'link!) (void)))) (lambda (key) ; unlink! (rewrite-i/o-errors command-line 'unlink! (lambda () (if debug (printf "~a: unlink! ~s" command-line key)) (write `(unlink! ,key) commands) (read-response-v1-body responses command-line 'unlink!)))) (lambda (name key) ; set-tag! (rewrite-i/o-errors command-line 'set-tag! (lambda () (if debug (printf "~a: set-tag!" command-line)) (write `(set-tag! ,name ,key) commands) (read-response-v1 responses command-line 'set-tag!) ................................................................................ ((log value) (for-each (lambda (logentry) ((backend-log!) (car logentry) (cdr logentry))) log) value) (else (error "Malformed response from backend" response))))) (define (read-response-v2-body port backend operation) (let ((response-length (read-response-v2-result port backend operation))) (if response-length (fast-read-u8vector response-length port) #f))) (define (import-storage-v2 command-line debug responses commands pid) (let ((header (rewrite-i/o-errors command-line 'read-header (lambda () (read-response-v2-result responses command-line 'read-header))))) (if debug (printf "~a: read header ~a~%" command-line header)) (if (not (list? header)) (protocol-error "Invalid backend protocol header" command-line 'read-header header)) (if (not (= (length header) 3)) (protocol-error "Invalid backend protocol header" command-line 'read-header header)) (let ((max-block-size (car header)) (writable? (cadr header)) (unlinkable? (caddr header))) (make-storage* command-line max-block-size writable? unlinkable? (lambda (key data type) ; put! (rewrite-i/o-errors command-line 'put! (lambda () (if debug (printf "~a: put!" command-line)) (write `(put! ,key ,type ,(u8vector-length data)) commands) (fast-write-u8vector data commands) (read-response-v2 responses command-line 'put!) (void)))) (lambda () ; flush! (rewrite-i/o-errors command-line 'flush! (lambda () (if debug (printf "~a: flush!" command-line)) ................................................................................ (lambda (key) ; exists? (rewrite-i/o-errors command-line 'exists? (lambda () (if debug (printf "~a: exists?" command-line)) (write `(exists? ,key) commands) (read-response-v2-result responses command-line 'exists?)))) (lambda (key) ; get (rewrite-i/o-errors command-line 'get (lambda () (if debug (printf "~a: get" command-line)) (write `(get ,key) commands) (read-response-v2-body responses command-line 'get)))) (lambda (key) ; link! (rewrite-i/o-errors command-line 'link! (lambda () (if debug (printf "~a: link!" command-line)) (write `(link! ,key) commands) (read-response-v2 responses command-line 'link!) (void)))) (lambda (key) ; unlink! (rewrite-i/o-errors command-line 'unlink! (lambda () (if debug (printf "~a: unlink! ~s" command-line key)) (write `(unlink! ,key) commands) (read-response-v2-body responses command-line 'unlink!)))) (lambda (name key) ; set-tag! (rewrite-i/o-errors command-line 'set-tag! (lambda () (if debug (printf "~a: set-tag!" command-line)) (write `(set-tag! ,name ,key) commands) (read-response-v2 responses command-line 'set-tag!) ................................................................................ (if debug (printf "~a: close!!" command-line)) (write '(close!) commands) (read-response-v2 responses command-line 'close!) (close-input-port responses) (close-output-port commands) (void)))))))) ;; A replacement for process that uses proper open-[input|ouput]-file* ;; so we can port->fileno it for faster block I/O. Written by the good ;; Moritz Heidkamp, from https://bugs.call-cc.org/ticket/766 ; FIXME: Produces wrong kind of port, reverted to using process for now (define (process% cmd #!optional args env) (let*-values (((in-in in-out) (create-pipe)) ((out-in out-out) (create-pipe)) ((pid) (process-fork (lambda () (duplicate-fileno in-in fileno/stdin) (duplicate-fileno out-out fileno/stdout) (file-close in-out) (file-close in-in) (file-close out-in) (file-close out-out) (process-execute cmd (if args args '()) (if env env '())))))) (file-close in-in) (file-close out-out) (values (open-input-file* out-in) (open-output-file* in-out) pid))) ;; Given the command line to a storage remote access protocol server, ;; activate it and return a storage object providing access to the ;; server. (define (import-storage command-line . args) (let-optionals args ((debug #f)) (let-values (((responses commands pid) (process command-line))) ; FIXME: use process% when it's fixed ; FIXME: When process% works, make sure to turn off buffering #;(set-buffering-mode! commands #:none) (if debug (printf "~a: process opened~%" command-line)) (let ((magic (rewrite-i/o-errors command-line 'read-magic (lambda () (read responses))))) (if debug (printf "~a: read magic ~a~%" command-line magic)) (cond ((equal? magic *magic-v1*) (import-storage-v1 command-line debug responses commands pid)) ((equal? magic *magic-v2*) (import-storage-v2 command-line debug responses commands pid)) (else (protocol-error (sprintf "Unrecognised backend protocol header magic: ~A" magic) command-line 'read-magic magic)))))))) |
< < < < < < < < < < < < < | | | | | | | | | > | | | | | > | | | | | | < > > | > | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | > | | | | | | | | | | | > | | | | | | | | | | | > | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < | < < < |
37 38 39 40 41 42 43 44 45 46 47 48 49 50 .. 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 ... 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 ... 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 ... 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 ... 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 ... 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 ... 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 ... 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 ... 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
(use ports)
(use matchable)
(use posix)
(use srfi-4)
(use data-structures)
(use miscmacros)
; Backends can call the procedure found in this paramter to log
; things. type should be 'warning, 'error or 'info. message should
; be any string.
(define backend-log! (make-parameter
(lambda (type message)
(error "No backend log handler has been defined"))))
................................................................................
(define-record-type storage
(make-storage*
name
max-block-size ; Integer: largest size of block we can store
writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!?
unlinkable? ; Boolean: Can we call unlink?
put! ; Procedure: (put! key data length type) - stores the data (u8vector) under the key (string) with the given type tag (symbol) and a refcount of 1. Does nothing of the key is already in use.
flush! ; Procedure: (flush!) - all previous changes must be flushed to disk by the time the continuation is applied.
exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise
get ; Procedure: (get key buffer) - returns the contents of the block with the given key (string) into the u8vector buffer and returns the length used if it exists, or #f otherwise
link! ; Procedure: (link key) - increments the refcount of the block
unlink! ; Procedure: (unlink key buffer) - decrements the refcount of the block. If it's now zero, deletes it but loads it into the u8vector buffer and returns the length. If not, returns #f.
set-tag! ; Procedure: (set-tag! name key) - assigns the given key (string) to the given tag (named with a string). Creates a new tag if the name has not previously been used, otherwise updates an existing tag
tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist.
all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, returning #t if all went well, or #f if it can't be locked.
tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise
unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
................................................................................
(lambda (type message)
(queue-add! log (cons type message))
(void))))
(let ((result (begin body ...)))
(write (list (queue->list log) result)))))))
; Return the result of the body as a data block, and any logs
(define-syntax-rule (with-error-reporting-and-block buffer body ...)
(handle-exceptions
exn (write (list "error" (describe-exception exn)))
(let ((log (make-queue)))
(parameterize ((backend-log!
(lambda (type message)
(queue-add! log (cons type message))
(void))))
(let ((length (begin body ...)))
(if length
(begin
(write (list (queue->list log) length))
(write-u8vector buffer (current-output-port) 0 length))
(write (list (queue->list log) #f))))))))
; Return any logs
(define-syntax-rule (with-error-reporting body ...)
(handle-exceptions
exn (write (list "error" (describe-exception exn)))
(let ((log (make-queue)))
................................................................................
; Write the error header
(write *magic-v2*) (newline)
(write (list "error" message)))
;; Given a storage object, provide the storage remote access protocol
;; via current-input-port / current-output-port until the storage is closed
;; via the protocol.
(define (export-storage! storage-thunk debug)
(set-buffering-mode! (current-output-port) #:none)
; Write the header
(write *magic-v2*) (newline)
(let ((storage #f))
(with-error-reporting-and-result ; Initialise and send the header
................................................................................
(set! storage storage*) ; This feels hacky
(list (storage-max-block-size storage)
(storage-writable? storage)
(storage-unlinkable? storage))))
; Engage command loop
(if storage
(let ((*buffer* (make-u8vector (storage-max-block-size storage))))
(let loop ()
(newline)
(let ((command (read)))
(if (eof-object? command)
(begin
(if debug (printf "~a: EOF~%" debug))
(with-error-reporting
((storage-close! storage)))
(void))
(match
command
(('put! key type length)
(if debug (printf "~a: put! ~a ~a ~a~%" debug key type length))
(let ((bytes-read (read-u8vector! length *buffer* (current-input-port))))
(with-error-reporting
;; FIXME: assert (= bytes-read length) in case of short read due to EOF
((storage-put! storage) key *buffer* length type)))
(loop))
(('flush!)
(if debug (printf "~a: flush!~%" debug))
(with-error-reporting
((storage-flush! storage)))
(loop))
(('exists? key)
(if debug (printf "~a: exists? ~a~%" debug key))
(with-error-reporting-and-result
((storage-exists? storage) key))
(loop))
(('get key)
(if debug (printf "~a: get ~a~%" debug key))
(with-error-reporting-and-block *buffer*
((storage-get storage) key *buffer*))
(loop))
(('link! key)
(if debug (printf "~a: link! ~a~%" debug key))
(with-error-reporting
((storage-link! storage) key))
(loop))
(('unlink! key)
(if debug (printf "~a: unlink! ~a~%" debug key))
(with-error-reporting-and-block *buffer*
((storage-unlink! storage) key *buffer*))
(loop))
(('set-tag! name key)
(if debug (printf "~a: set-tag! ~a ~a~%" debug name key))
(with-error-reporting
((storage-set-tag! storage) name key))
(loop))
(('tag name)
(if debug (printf "~a: tag ~a~%" debug name))
(with-error-reporting-and-result
((storage-tag storage) name))
(loop))
(('all-tags)
(if debug (printf "~a: all-tags~%" debug))
(with-error-reporting-and-result
((storage-all-tags storage)))
(loop))
(('remove-tag! name)
(if debug (printf "~a: remove-tag! ~a~%" debug name))
(with-error-reporting
((storage-remove-tag! storage) name))
(loop))
(('lock-tag! name)
(if debug (printf "~a: lock-tag! ~a~%" debug name))
(with-error-reporting-and-result
((storage-lock-tag! storage) name))
(loop))
(('tag-locked? name)
(if debug (printf "~a: tag-locked? ~a~%" debug name))
(with-error-reporting-and-result
((storage-tag-locked? storage) name))
(loop))
(('unlock-tag! name)
(if debug (printf "~a: unlock-tag! ~a~%" debug name))
(with-error-reporting
((storage-unlock-tag! storage) name))
(loop))
(('admin! command)
(if debug (printf "~a: admin! ~a~%" debug command))
(with-error-reporting-and-result
((storage-admin! storage) command))
(loop))
(('close!)
(if debug (printf "~a: close!~%" debug))
(with-error-reporting
((storage-close! storage)))
(void))
(else
(write (list "error" (sprintf "Bad command ~s" command)))
(loop))))))))))
;; Importing a storage - taking a command line to a backend protocol
;; server and turning it into a storage record
(define (protocol-error message backend operation . irritants)
(abort
(make-composite-condition
................................................................................
(define (read-response-v1 port backend operation)
(let ((response (read port)))
(match response
(("error" err) (protocol-error "Backend protocol error" backend operation err))
(else response))))
(define (read-response-v1-body port backend operation buffer)
(let ((response (read-response-v1 port backend operation)))
(if response
(read-u8vector! (car response) buffer port)
#f)))
(define (import-storage-v1 command-line debug responses commands pid)
(let ((header
(rewrite-i/o-errors command-line 'read-header
(lambda () (read responses)))))
(if debug (printf "~a: read header ~a~%" command-line header))
(if (not (list? header))
(protocol-error "Invalid backend protocol header" command-line 'read-header header))
(if (not (= (length header) 3))
(protocol-error "Invalid backend protocol header" command-line 'read-header header))
(let* ((max-block-size (car header))
(writable? (cadr header))
(unlinkable? (caddr header))
(buffer (make-u8vector max-block-size)))
(make-storage*
command-line
max-block-size
writable?
unlinkable?
(lambda (key data length type) ; put!
(rewrite-i/o-errors command-line 'put!
(lambda ()
(if debug (printf "~a: put!" command-line))
(write `(put! ,key ,type ,(u8vector-length data)) commands)
(write-u8vector data commands 0 length)
(read-response-v1 responses command-line 'put!)
(void))))
(lambda () ; flush!
(rewrite-i/o-errors command-line 'flush!
(lambda ()
(if debug (printf "~a: flush!" command-line))
................................................................................
(lambda (key) ; exists?
(rewrite-i/o-errors command-line 'exists?
(lambda ()
(if debug (printf "~a: exists?" command-line))
(write `(exists? ,key) commands)
(read-response-v1 responses command-line 'exists?))))
(lambda (key buffer) ; get
(rewrite-i/o-errors command-line 'get
(lambda ()
(if debug (printf "~a: get" command-line))
(write `(get ,key) commands)
(read-response-v1-body responses command-line 'get buffer))))
(lambda (key) ; link!
(rewrite-i/o-errors command-line 'link!
(lambda ()
(if debug (printf "~a: link!" command-line))
(write `(link! ,key) commands)
(read-response-v1 responses command-line 'link!)
(void))))
(lambda (key buffer) ; unlink!
(rewrite-i/o-errors command-line 'unlink!
(lambda ()
(if debug (printf "~a: unlink! ~s" command-line key))
(write `(unlink! ,key) commands)
(read-response-v1-body responses command-line 'unlink! buffer))))
(lambda (name key) ; set-tag!
(rewrite-i/o-errors command-line 'set-tag!
(lambda ()
(if debug (printf "~a: set-tag!" command-line))
(write `(set-tag! ,name ,key) commands)
(read-response-v1 responses command-line 'set-tag!)
................................................................................
((log value)
(for-each (lambda (logentry)
((backend-log!) (car logentry) (cdr logentry)))
log)
value)
(else (error "Malformed response from backend" response)))))
(define (read-response-v2-body port backend operation buffer)
(let ((response-length (read-response-v2-result port backend operation)))
(if response-length
(read-u8vector! response-length buffer port)
#f)))
(define (import-storage-v2 command-line debug responses commands pid)
(let ((header
(rewrite-i/o-errors command-line 'read-header
(lambda ()
(read-response-v2-result responses command-line 'read-header)))))
(if debug (printf "~a: read header ~a~%" command-line header))
(if (not (list? header))
(protocol-error "Invalid backend protocol header" command-line 'read-header header))
(if (not (= (length header) 3))
(protocol-error "Invalid backend protocol header" command-line 'read-header header))
(let* ((max-block-size (car header))
(writable? (cadr header))
(unlinkable? (caddr header))
(buffer (make-u8vector max-block-size)))
(make-storage*
command-line
max-block-size
writable?
unlinkable?
(lambda (key data length type) ; put!
(rewrite-i/o-errors command-line 'put!
(lambda ()
(if debug (printf "~a: put!" command-line))
(write `(put! ,key ,type ,length) commands)
(write-u8vector data commands 0 length)
(read-response-v2 responses command-line 'put!)
(void))))
(lambda () ; flush!
(rewrite-i/o-errors command-line 'flush!
(lambda ()
(if debug (printf "~a: flush!" command-line))
................................................................................
(lambda (key) ; exists?
(rewrite-i/o-errors command-line 'exists?
(lambda ()
(if debug (printf "~a: exists?" command-line))
(write `(exists? ,key) commands)
(read-response-v2-result responses command-line 'exists?))))
(lambda (key buffer) ; get
(rewrite-i/o-errors command-line 'get
(lambda ()
(if debug (printf "~a: get ~s" command-line key))
(write `(get ,key) commands)
(read-response-v2-body responses command-line 'get buffer))))
(lambda (key) ; link!
(rewrite-i/o-errors command-line 'link!
(lambda ()
(if debug (printf "~a: link!" command-line))
(write `(link! ,key) commands)
(read-response-v2 responses command-line 'link!)
(void))))
(lambda (key buffer) ; unlink!
(rewrite-i/o-errors command-line 'unlink!
(lambda ()
(if debug (printf "~a: unlink! ~s" command-line key))
(write `(unlink! ,key) commands)
(read-response-v2-body responses command-line 'unlink! buffer))))
(lambda (name key) ; set-tag!
(rewrite-i/o-errors command-line 'set-tag!
(lambda ()
(if debug (printf "~a: set-tag!" command-line))
(write `(set-tag! ,name ,key) commands)
(read-response-v2 responses command-line 'set-tag!)
................................................................................
(if debug (printf "~a: close!!" command-line))
(write '(close!) commands)
(read-response-v2 responses command-line 'close!)
(close-input-port responses)
(close-output-port commands)
(void))))))))
;; Given the command line to a storage remote access protocol server,
;; activate it and return a storage object providing access to the
;; server.
(define (import-storage command-line . args)
(let-optionals args ((debug #f))
(let-values (((responses commands pid)
(process command-line)))
(if debug (printf "~a: process opened~%" command-line))
(let ((magic
(rewrite-i/o-errors command-line 'read-magic
(lambda () (read responses)))))
(if debug (printf "~a: read magic ~a~%" command-line magic))
(cond
((equal? magic *magic-v1*)
(import-storage-v1 command-line debug responses commands pid))
((equal? magic *magic-v2*)
(import-storage-v2 command-line debug responses commands pid))
(else (protocol-error (sprintf "Unrecognised backend protocol header magic: ~A" magic) command-line 'read-magic magic))))))))
|
Changes to ugarit-core.scm.
279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 ... 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 ... 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
(define cache-commit-interval 1000)
(define (vault-cache-updated! vault)
(inc! (vault-cache-updates-uncommitted vault))
(when (> cache-commit-interval (vault-cache-updates-uncommitted vault))
(vault-cache-flush! vault)))
;; Take a block, and return a compressed and encrypted block
(define (wrap-block vault block)
((vault-encrypt vault)
((vault-compress vault) block)))
;; Take a compressed and encrypted block, and recover the original data
(define (unwrap-block vault block)
................................................................................
" "
(string-pad (number->string (vector-ref localtime 2)) 2 #\0)
":"
(string-pad (number->string (vector-ref localtime 1)) 2 #\0)
":"
(string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
(define (vault-put! vault key data type)
(unless (vault-writable? vault)
(error 'vault-put! "This isn't a writable vault"))
(with-backend-logging
((storage-put! (vault-storage vault))
key
(wrap-block vault data)
type))
(inc! (job-blocks-stored (current-job)))
(inc! (job-bytes-stored (current-job)) (u8vector-length data))
(void))
(define (vault-conf-get vault key default)
(let ((result (assq key (vault-conf-alist vault))))
(if result
................................................................................
;; vault-cache-flush also flushes the backend
(vault-cache-flush! vault))
(define (vault-exists? vault key)
(with-backend-logging ((storage-exists? (vault-storage vault)) key)))
(define (vault-get vault key type)
(let* ((raw-data (with-backend-logging ((storage-get (vault-storage vault)) key)))
(data (if raw-data
(unwrap-block vault raw-data)
(error 'vault-get (sprintf "Nonexistant block ~A ~A" key type)))))
(unless (string=? key ((vault-hash vault) data type))
(error 'vault-get (sprintf "Consistency check failure: asked for ~A, got ~A" key ((vault-hash vault) data type))))
data))
(define (vault-link! vault key)
(unless (vault-writable? vault)
(error 'vault-link! "This isn't a writable vault"))
(with-backend-logging ((storage-link! (vault-storage vault)) key)))
(define (vault-unlink! vault key)
(unless (vault-writable? vault)
(error 'vault-unlink! "This isn't a writable vault"))
(let ((result (with-backend-logging ((storage-unlink! (vault-storage vault)) key))))
(if result
(unwrap-block vault result)
#f)))
(define (vault-admin! vault command)
(with-backend-logging ((storage-admin! (vault-storage vault)) command)))
(define-record-type tag
(make-tag name type key)
|
< | > | | | < > > | | > > | | | | > | | | |
279 280 281 282 283 284 285 286 287 288 289 290 291 292 ... 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 ... 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
(define cache-commit-interval 1000)
(define (vault-cache-updated! vault)
(inc! (vault-cache-updates-uncommitted vault))
(when (> cache-commit-interval (vault-cache-updates-uncommitted vault))
(vault-cache-flush! vault)))
;; Take a block, and return a compressed and encrypted block
(define (wrap-block vault block)
((vault-encrypt vault)
((vault-compress vault) block)))
;; Take a compressed and encrypted block, and recover the original data
(define (unwrap-block vault block)
................................................................................
" "
(string-pad (number->string (vector-ref localtime 2)) 2 #\0)
":"
(string-pad (number->string (vector-ref localtime 1)) 2 #\0)
":"
(string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
(define (vault-put! vault key data type) ; FIXME: Update to reuse buffer
(unless (vault-writable? vault)
(error 'vault-put! "This isn't a writable vault"))
(let ((wrapped-block (wrap-block vault data)))
(with-backend-logging
((storage-put! (vault-storage vault))
key
wrapped-block
(u8vector-length wrapped-block)
type)))
(inc! (job-blocks-stored (current-job)))
(inc! (job-bytes-stored (current-job)) (u8vector-length data))
(void))
(define (vault-conf-get vault key default)
(let ((result (assq key (vault-conf-alist vault))))
(if result
................................................................................
;; vault-cache-flush also flushes the backend
(vault-cache-flush! vault))
(define (vault-exists? vault key)
(with-backend-logging ((storage-exists? (vault-storage vault)) key)))
(define (vault-get vault key type) ; FIXME: Update to reuse buffer
(let* ((block-size (vault-max-block-size vault))
(buffer (make-u8vector block-size))
(length (with-backend-logging ((storage-get (vault-storage vault)) key buffer)))
(data (if length
(unwrap-block vault (subu8vector buffer 0 length))
(error 'vault-get (sprintf "Nonexistant block ~A ~A" key type)))))
(unless (string=? key ((vault-hash vault) data type))
(error 'vault-get (sprintf "Consistency check failure: asked for ~A, got ~A" key ((vault-hash vault) data type))))
data))
(define (vault-link! vault key)
(unless (vault-writable? vault)
(error 'vault-link! "This isn't a writable vault"))
(with-backend-logging ((storage-link! (vault-storage vault)) key)))
(define (vault-unlink! vault key) ;; FIXME: Update to reuse buffer
(unless (vault-writable? vault)
(error 'vault-unlink! "This isn't a writable vault"))
(let* ((buffer (make-u8vector (vault-max-block-size vault)))
(length (with-backend-logging ((storage-unlink! (vault-storage vault)) key buffer))))
(if length
(unwrap-block vault (subu8vector buffer 0 length)) ;; FIXME: COPIES
#f)))
(define (vault-admin! vault command)
(with-backend-logging ((storage-admin! (vault-storage vault)) command)))
(define-record-type tag
(make-tag name type key)
|
Changes to ugarit.setup.
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 |
(let ((source-file (string-append name ".scm"))
(so-file (string-append name ".so"))
(import-file (string-append name ".import.scm"))
(import-so-file (string-append name ".import.so"))
(o-file (string-append name ".o")))
(when (newer source-file so-file)
(compile -profile -s -optimize-level 3 -debug-level 2 ,(string->symbol source-file) -j ,(string->symbol name))
(compile -profile -s -optimize-level 3 -debug-level 2 ,(string->symbol import-file))
(compile -profile -c -optimize-level 3 -debug-level 2 ,(string->symbol source-file) -unit ,(string->symbol name)))
(install-extension (string->symbol name) `(,so-file ,o-file ,import-so-file)
`((version ,*version*)
(static o-file)))))
(define (build-program name)
(let ((source-file (string-append name ".scm"))
(exec-file name))
(when (newer source-file exec-file)
(compile -profile -optimize-level 3 -debug-level 2 ,(string->symbol source-file)))
(install-program (string->symbol name) exec-file
`((version ,*version*)))))
(build-module "directory-rules")
(build-module "ugarit-mime")
(build-module "ugarit-backend")
(build-module "ugarit-core")
|
| | | | |
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 |
(let ((source-file (string-append name ".scm"))
(so-file (string-append name ".so"))
(import-file (string-append name ".import.scm"))
(import-so-file (string-append name ".import.so"))
(o-file (string-append name ".o")))
(when (newer source-file so-file)
(compile -s -optimize-level 3 -debug-level 2 ,(string->symbol source-file) -j ,(string->symbol name))
(compile -s -optimize-level 3 -debug-level 2 ,(string->symbol import-file))
(compile -c -optimize-level 3 -debug-level 2 ,(string->symbol source-file) -unit ,(string->symbol name)))
(install-extension (string->symbol name) `(,so-file ,o-file ,import-so-file)
`((version ,*version*)
(static o-file)))))
(define (build-program name)
(let ((source-file (string-append name ".scm"))
(exec-file name))
(when (newer source-file exec-file)
(compile -optimize-level 3 -debug-level 2 ,(string->symbol source-file)))
(install-program (string->symbol name) exec-file
`((version ,*version*)))))
(build-module "directory-rules")
(build-module "ugarit-mime")
(build-module "ugarit-backend")
(build-module "ugarit-core")
|