Ugarit
Check-in [7debb510ed]
Login

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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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")