Changeset 20269 in project


Ignore:
Timestamp:
09/12/10 20:49:58 (9 years ago)
Author:
Alaric Snell-Pym
Message:

ugarit: Ongoing work to fix all the errors caused by merging in a load of untested code

Location:
release/4/ugarit/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/ugarit/trunk/ugarit-core.scm

    r20243 r20269  
    11(module ugarit-core
    2  ( open-archive
    3   archive?
    4   archive-writable?
    5   archive-unlinkable?
    6   archive-exists?
    7   archive-get
    8   archive-put!
    9   archive-remove-tag!
    10   archive-set-tag!
    11   archive-tag
    12   archive-lock-tag!
    13   archive-unlock-tag!
    14   archive-tag-locked?
    15   archive-close!
    16 
    17   archive-store-block!
    18    
    19   make-key-stream-writer*
    20   key-stream-writer?
    21   key-stream-writer-write!
    22   key-stream-writer-finish!
    23   unlink-key-stream!
    24   fold-key-stream
    25    
    26   make-sexpr-stream-writer*
    27   sexpr-stream-writer?
    28   sexpr-stream-writer-write!
    29   sexpr-stream-writer-finish!
    30   unlink-sexpr-stream!
    31   fold-sexpr-stream
    32    
    33   store-sexpr!
    34   read-sexpr
    35    
    36   epochtime->string
    37    
    38   store-file!
    39   store-directory!
    40   unlink-directory!
    41   extract-directory!
    42   extract-object!
    43   snapshot-directory-tree!
    44   tag-snapshot!
    45   fold-history
    46   fold-archive-node)
     2        (open-archive
     3        archive?
     4        archive-writable?
     5        archive-unlinkable?
     6        archive-exists?
     7        archive-get
     8        archive-put!
     9        archive-remove-tag!
     10        archive-set-tag!
     11        archive-tag
     12        archive-lock-tag!
     13        archive-unlock-tag!
     14        archive-tag-locked?
     15        archive-close!
     16
     17        archive-store-block!
     18
     19        make-key-stream-writer*
     20        key-stream-writer?
     21        key-stream-writer-write!
     22        key-stream-writer-finish!
     23        unlink-key-stream!
     24        fold-key-stream
     25
     26        make-sexpr-stream-writer*
     27        sexpr-stream-writer?
     28        sexpr-stream-writer-write!
     29        sexpr-stream-writer-finish!
     30        unlink-sexpr-stream!
     31        fold-sexpr-stream
     32
     33        store-sexpr!
     34        read-sexpr
     35
     36        epochtime->string
     37
     38        store-file!
     39        store-directory!
     40        unlink-directory!
     41        extract-directory!
     42        extract-object!
     43        snapshot-directory-tree!
     44        tag-snapshot!
     45        fold-history
     46        fold-archive-node)
    4747
    4848(import scheme)
     
    6666(use lolevel)
    6767(use data-structures)
     68(use directory-rules)
    6869(use miscmacros)
    6970(use posix)
     
    7879
    7980(define-record storage
    80    max-block-size  ; Integer: largest size of block we can store
    81    writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!?
    82    unlinkable? ; Boolean: Can we call unlink?
    83    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.
    84    exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise
    85    get ; Procedure: (get key) - returns the contents (u8vector) of the block with the given key (string) if it exists, or #f otherwise
    86    link! ; Procedure: (link key) - increments the refcount of the block
    87    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.
    88    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
    89    tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist.
    90    all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
    91    remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
    92    lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, or blocks if already locked
    93    tag-locked? ; Procedure: (tag-locked? name) - returns the locker identity string if the tag is locked, #f otherwise
    94    unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
    95    close!)  ; Procedure: (close!) - closes the storage engine
     81  max-block-size  ; Integer: largest size of block we can store
     82  writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!?
     83  unlinkable? ; Boolean: Can we call unlink?
     84  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.
     85  exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise
     86  get ; Procedure: (get key) - returns the contents (u8vector) of the block with the given key (string) if it exists, or #f otherwise
     87  link! ; Procedure: (link key) - increments the refcount of the block
     88  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.
     89  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
     90  tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist.
     91  all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
     92  remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
     93  lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, or blocks if already locked
     94  tag-locked? ; Procedure: (tag-locked? name) - returns the locker identity string if the tag is locked, #f otherwise
     95  unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
     96  close!)  ; Procedure: (close!) - closes the storage engine
    9697
    9798;;
     
    100101
    101102(define-record archive
    102    storage ; The storage instance we use
    103    check-correctness? ; boolean flag
    104    store-atime? ; boolean flag
    105    store-ctime? ; boolean flag
    106    hash ; the hash function, u8vector+type symbol->hex string
    107    compress ; the compressor, u8vector->smaller u8vector
    108    decompress ; the decompressor, inverse of the above
    109    encrypt ; the encryptor, u8vector -> u8vector
    110    decrypt) ; the decryptor, inverse of the above
     103  storage ; The storage instance we use
     104  check-correctness? ; boolean flag
     105  store-atime? ; boolean flag
     106  store-ctime? ; boolean flag
     107  hash ; the hash function, u8vector+type symbol->hex string
     108  compress ; the compressor, u8vector->smaller u8vector
     109  decompress ; the decompressor, inverse of the above
     110  encrypt ; the encryptor, u8vector -> u8vector
     111  decrypt ; the decryptor, inverse of the above
     112  global-directory-rules ; top-level directory rules
     113  file-cache ; gdbm map storing filesystem cache (see store-file! procedure); #f if not enabled
     114  )
    111115
    112116(include "posixextras.scm")
     
    116120
    117121(define (prepend-type-byte b v)
    118    (let* ((v-len (u8vector-length v))
    119           (v2 (make-u8vector (+ 1 v-len))))
    120    (set! (u8vector-ref v2 0) b)
    121    
    122    (move-memory! v v2 v-len 0 1)
    123    v2))
    124 
    125 (define (choose-compression-function config) 
    126    (match config
    127       (#f (lambda (block) (prepend-type-byte 0 block))) ; No compression
    128       (('deflate) (lambda (block) (prepend-type-byte 1 (blob->u8vector/shared (string->blob (z3:encode-buffer (blob->string (u8vector->blob/shared block)))))))) ; deflate compression
    129       (('lzma) (lambda (block) (prepend-type-byte 2 (blob->u8vector/shared (lzma:compress (u8vector->blob/shared block))))))
    130       (else (signal (make-property-condition 'exn 'message "Unknown compression type" 'arguments config)))))
    131 
    132 (define (decompress block) 
    133    (case (u8vector-ref block 0)
    134       ((0) (subu8vector block 1 (u8vector-length block))) ; No compression
    135       ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate
    136       ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma
     122  (let* ((v-len (u8vector-length v))
     123        (v2 (make-u8vector (+ 1 v-len))))
     124    (set! (u8vector-ref v2 0) b)
     125
     126    (move-memory! v v2 v-len 0 1)
     127    v2))
     128
     129(define (choose-compression-function config)
     130  (match config
     131        (#f (lambda (block) (prepend-type-byte 0 block))) ; No compression
     132        (('deflate) (lambda (block) (prepend-type-byte 1 (blob->u8vector/shared (string->blob (z3:encode-buffer (blob->string (u8vector->blob/shared block)))))))) ; deflate compression
     133        (('lzma) (lambda (block) (prepend-type-byte 2 (blob->u8vector/shared (lzma:compress (u8vector->blob/shared block))))))
     134         (else (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown compression type" 'arguments (list config))))))
     135
     136(define (decompress block)
     137  (case (u8vector-ref block 0)
     138    ((0) (subu8vector block 1 (u8vector-length block))) ; No compression
     139    ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate
     140    ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma
    137141
    138142(define (choose-hash-function config)
    139    (let ((make-basic-hash (lambda (hash) (lambda (block type) (string-append (hash block) (symbol->string type)))))
    140          (make-keyed-hash (lambda (hash key) (lambda (block type) (hash (string-append key (hash block) (symbol->string type)))))))
    141    (match config
    142       ((or #f ('tiger)) (make-basic-hash tiger192-digest))
    143       (('tiger key) (make-keyed-hash tiger192-digest key))
    144       (('sha256) (make-basic-hash sha256-digest))
    145       (('sha256 key) (make-keyed-hash sha256-digest key))
    146       (('sha384) (make-basic-hash sha384-digest))
    147       (('sha384 key) (make-keyed-hash sha384-digest key))
    148       (('sha512) (make-basic-hash sha512-digest))
    149       (('sha512 key) (make-keyed-hash sha512-digest key))
    150       (else (signal (make-property-condition 'exn 'message "Unknown hash algorithm" 'arguments config))))))
     143  (let ((make-basic-hash (lambda (hash) (lambda (block type) (string-append (hash block) (symbol->string type)))))
     144        (make-keyed-hash (lambda (hash key) (lambda (block type) (hash (string-append key (hash block) (symbol->string type)))))))
     145    (match config
     146           ((or #f ('tiger)) (make-basic-hash tiger192-digest))
     147           (('tiger key) (make-keyed-hash tiger192-digest key))
     148           (('sha256) (make-basic-hash sha256-digest))
     149           (('sha256 key) (make-keyed-hash sha256-digest key))
     150           (('sha384) (make-basic-hash sha384-digest))
     151           (('sha384 key) (make-keyed-hash sha384-digest key))
     152           (('sha512) (make-basic-hash sha512-digest))
     153           (('sha512 key) (make-keyed-hash sha512-digest key))
     154           (else (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown hash algorithm" 'arguments (list config)))))))
    151155
    152156(define (read-password prompt)
     
    154158  (with-stty '(not echo) read-line))
    155159
    156 ; Key specs are "hexhexhex" or (number-of-bytes "passphrase")
     160                                        ; Key specs are "hexhexhex" or (number-of-bytes "passphrase")
    157161(define (key->blob keyspec)
    158    (cond
    159       ((string? keyspec)
    160          (hexstring->blob keyspec))
    161       ((pair? keyspec)
    162          (let* ((get-passphrase (lambda (maybe-passphrase)
    163                   (if (eq? maybe-passphrase 'prompt)
    164                     (read-password "Passphrase: ")
    165                     maybe-passphrase)))
    166                 (length (car keyspec))
    167                 (passphrase (get-passphrase (cadr keyspec)))
    168                 (key (sha512-binary-digest passphrase)))
    169             (if (> length 64) ; 512 bits = 64 bytes
    170                (signal (make-property-condition 'exn 'message "Cannot generate a key that large due to a shortage of a big enough hash function (max 64)" 'arguments keyspec))
    171                (string->blob (substring/shared key 0 length)))))))
    172          
     162  (cond
     163   ((string? keyspec)
     164    (hexstring->blob keyspec))
     165   ((pair? keyspec)
     166    (let* ((get-passphrase (lambda (maybe-passphrase)
     167                             (if (eq? maybe-passphrase 'prompt)
     168                                (read-password "Passphrase: ")
     169                                maybe-passphrase)))
     170           (length (car keyspec))
     171           (passphrase (get-passphrase (cadr keyspec)))
     172           (key (sha512-binary-digest passphrase)))
     173      (if (> length 64) ; 512 bits = 64 bytes
     174          (signal (make-property-condition 'exn 'location 'open-archive  'message "Cannot generate a key that large due to a shortage of a big enough hash function (max 64)" 'arguments (list keyspec)))
     175          (string->blob (substring/shared key 0 length)))))))
     176
    173177
    174178(define (choose-crypto-functions config)
    175    (match config
    176       (#f (values
    177          (lambda (block) block)
    178          (lambda (block) block))) ; No encryption
    179       (('aes keyspec)
    180          (let ((key (key->blob keyspec))
    181                (iv (make-blob 16)) ; IV is pseudo-randomly generated based on the blocks we are fed as an entropy source
    182                (stir-iv! (lambda (iv block)
    183                   (move-memory! (string->blob
    184                      (tiger192-binary-digest (string-append (tiger192-binary-digest block) (blob->string iv))))
    185                      iv 16))))
    186 
    187                ; Generate initial IV from the key and current time
    188                (move-memory! (string->blob (tiger192-binary-digest
    189                   (string-append (blob->string key) (number->string (time->seconds (current-time)))))) iv 16)
    190 
    191                (let-values (((encryptor decryptor)
    192                   (case (blob-size key)
    193                      ((16) (values
    194                         (make-aes128-encryptor key)
    195                         (make-aes128-decryptor key)))
    196                      ((24) (values
    197                         (make-aes192-encryptor key)
    198                         (make-aes192-decryptor key)))
    199                      ((32) (values
    200                         (make-aes256-encryptor key)
    201                         (make-aes256-decryptor key)))
    202                      (else
    203                         (signal (make-property-condition 'exn 'message "AES keys must be 16, 24, or 32 bytes long" 'arguments keyspec))))))
    204                   (let ((cbc-encryptor (make-cbc*-encryptor encryptor 16))
    205                         (cbc-decryptor (make-cbc*-decryptor decryptor 16)))
    206                      (values
    207                         (lambda (block)
    208                            (stir-iv! iv block)
    209                            (blob->u8vector/shared (cbc-encryptor (u8vector->blob/shared block) iv)))
    210                         (lambda (block) (blob->u8vector/shared (cbc-decryptor (u8vector->blob/shared block)))))))))
    211       (else (signal (make-property-condition 'exn 'message "Unknown encryption type" 'arguments config)))))
    212 
    213 ; A config is an sexpr of the form:
    214 ; ((<key> <value>)|<flag>...)
    215 ; Valid keys:
    216 ; storage (expression to create a storage backend)
    217 ; compression algorithm name
    218 ; encryption (algorithm-name "key")
    219 ; Valid flags:
    220 ; double-check - check correctness lots, even if it costs efficiency
     179  (match config
     180        (#f (values
     181              (lambda (block) block)
     182              (lambda (block) block))) ; No encryption
     183        (('aes keyspec)
     184          (let ((key (key->blob keyspec))
     185                (iv (make-blob 16)) ; IV is pseudo-randomly generated based on the blocks we are fed as an entropy source
     186                (stir-iv! (lambda (iv block)
     187                            (move-memory! (string->blob
     188                                           (tiger192-binary-digest (string-append (tiger192-binary-digest block) (blob->string iv))))
     189                                          iv 16))))
     190
     191                                        ; Generate initial IV from the key and current time
     192            (move-memory! (string->blob (tiger192-binary-digest
     193                                        (string-append (blob->string key) (number->string (time->seconds (current-time)))))) iv 16)
     194
     195            (let-values (((encryptor decryptor)
     196                          (case (blob-size key)
     197                            ((16) (values
     198                                   (make-aes128-encryptor key)
     199                                   (make-aes128-decryptor key)))
     200                            ((24) (values
     201                                   (make-aes192-encryptor key)
     202                                   (make-aes192-decryptor key)))
     203                            ((32) (values
     204                                   (make-aes256-encryptor key)
     205                                   (make-aes256-decryptor key)))
     206                            (else
     207                             (signal (make-property-condition 'exn 'location 'open-archive 'message "AES keys must be 16, 24, or 32 bytes long" 'arguments (list keyspec)))))))
     208              (let ((cbc-encryptor (make-cbc*-encryptor encryptor 16))
     209                    (cbc-decryptor (make-cbc*-decryptor decryptor 16)))
     210                (values
     211                 (lambda (block)
     212                   (stir-iv! iv block)
     213                   (blob->u8vector/shared (cbc-encryptor (u8vector->blob/shared block) iv)))
     214                (lambda (block) (blob->u8vector/shared (cbc-decryptor (u8vector->blob/shared block)))))))))
     215         (else (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown encryption type" 'arguments (list config))))))
     216
     217                                        ; A config is an sexpr of the form:
     218                                        ; ((<key> <value>)|<flag>...)
     219                                        ; Valid keys:
     220                                        ; storage (expression to create a storage backend)
     221                                        ; compression algorithm name
     222                                        ; encryption (algorithm-name "key")
     223                                        ; Valid flags:
     224                                        ; double-check - check correctness lots, even if it costs efficiency
    221225(define (open-archive config store-atime? store-ctime?)
    222    (let ((*storage* #f)
    223          (*compression* #f)
    224          (*crypto* #f)
    225          (*hash* #f)
    226          (*double-check?* #f))
    227    
    228       (for-each (lambda (confentry)
    229          (match confentry
    230             ('double-check (set! *double-check?* #t))
    231             (('storage 'fs path) (set! *storage* ; FIXME: Split this into a plugin registry thingy
    232                (backend-fs path)))
    233             (('storage 'log logpath indexpath tagspath) (set! *storage*
    234                (backend-log logpath indexpath tagspath)))
    235             (('storage 'splitlog logdir metadir maxlen) (set! *storage*
    236                (backend-splitlog logdir metadir maxlen)))
    237             (('storage 'debug 'fs path) (set! *storage*
    238                (backend-debug (backend-fs path) "DEBUG")))
    239             (('hash . conf) (set! *hash* conf))
    240             (('compression . conf) (set! *compression* conf))
    241             (('encryption . conf) (set! *crypto* conf))
    242             (_ (signal (make-property-condition 'exn 'message "Unknown configuration entry" 'arguments confentry)))))
    243          config)
    244    
    245       (if (not *storage*)
    246          (signal (make-property-condition 'exn 'message "No archive storage was specified in the configuration!")))
    247    
    248       (let-values
    249          (((compress) (choose-compression-function *compression*))
    250           ((hash) (choose-hash-function *hash*))
    251           ((encrypt decrypt) (choose-crypto-functions *crypto*)))
    252 
    253          (make-archive
    254             *storage*
    255             *double-check?*
    256             store-atime?
    257             store-ctime?
    258             hash
    259             compress
    260             decompress
    261             encrypt
    262             decrypt))))
    263 
    264 ; Take a block, and return a compressed and encrypted block
     226  (let ((*storage* #f)
     227        (*compression* #f)
     228        (*crypto* #f)
     229        (*hash* #f)
     230        (*double-check?* #f)
     231        (*file-cache* #f)
     232        (*global-rules* '()))
     233
     234    (for-each (lambda (confentry)
     235                (match confentry
     236                       ('double-check (set! *double-check?* #t))
     237                       (('storage 'fs path) (set! *storage* ; FIXME: Split this into a plugin registry thingy
     238                                                  (backend-fs path)))
     239                       (('storage 'log logpath indexpath tagspath) (set! *storage*
     240                                                                         (backend-log logpath indexpath tagspath)))
     241                       (('storage 'splitlog logdir metadir maxlen) (set! *storage*
     242                                                                         (backend-splitlog logdir metadir maxlen)))
     243                       (('storage 'debug 'fs path) (set! *storage*
     244                                                         (backend-debug (backend-fs path) "DEBUG")))
     245                       (('hash . conf) (set! *hash* conf))
     246                       (('compression . conf) (set! *compression* conf))
     247                       (('encryption . conf) (set! *crypto* conf))
     248                       (('file-cache path)
     249                        (set! *file-cache* (gdbm-open path)))
     250                       (('rule . conf) (set! *global-rules* (cons conf *global-rules*)))
     251                       (_ (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown configuration entry" 'arguments (list confentry))))))
     252              config)
     253
     254    (if (not *storage*)
     255        (signal (make-property-condition 'exn 'location 'open-archive 'message "No archive storage was specified in the configuration!" 'arguments (list config))))
     256
     257    (let-values
     258        (((compress) (choose-compression-function *compression*))
     259         ((hash) (choose-hash-function *hash*))
     260         ((encrypt decrypt) (choose-crypto-functions *crypto*)))
     261
     262      (make-archive
     263       *storage*
     264       *double-check?*
     265       store-atime?
     266       store-ctime?
     267       hash
     268       compress
     269       decompress
     270       encrypt
     271       decrypt
     272       *global-rules*
     273       *file-cache*))))
     274
     275                                        ; Take a block, and return a compressed and encrypted block
    265276(define (wrap-block archive block)
    266    ((archive-encrypt archive)
    267       ((archive-compress archive) block)))
     277  ((archive-encrypt archive)
     278   ((archive-compress archive) block)))
    268279
    269280;; Take a compressed and encrypted block, and recover the original data
    270281(define (unwrap-block archive block)
    271    ((archive-decompress archive)
    272       ((archive-decrypt archive) block)))
     282  ((archive-decompress archive)
     283   ((archive-decrypt archive) block)))
    273284
    274285(define (archive-max-block-size archive)
    275    (storage-max-block-size (archive-storage archive)))
     286  (storage-max-block-size (archive-storage archive)))
    276287
    277288(define (archive-writable? archive)
    278    (storage-writable? (archive-storage archive)))
     289  (storage-writable? (archive-storage archive)))
    279290
    280291(define (archive-unlinkable? archive)
    281    (storage-unlinkable? (archive-storage archive)))
     292  (storage-unlinkable? (archive-storage archive)))
    282293
    283294(define (check-archive-writable archive)
    284    (if (not (archive-writable? archive))
    285       (signal (make-property-condition 'exn 'message "This isn't a writable archive"))))
     295  (if (not (archive-writable? archive))
     296      (signal (make-property-condition 'exn 'location 'check-archive-writable 'message "This isn't a writable archive"))))
    286297
    287298(define (check-archive-unlinkable archive)
    288    (if (not (archive-writable? archive))
    289       (signal (make-property-condition 'exn 'message "This isn't an unlinkable archive - it's append-only"))))
     299  (if (not (archive-writable? archive))
     300      (signal (make-property-condition 'exn 'location 'check-archive-unlinkable 'message "This isn't an unlinkable archive - it's append-only"))))
    290301
    291302(define (archive-put! archive key data type)
    292    (if (not (archive-writable? archive))
    293       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    294    ((storage-put! (archive-storage archive)) key (wrap-block archive data) type))
     303  (if (not (archive-writable? archive))
     304      (signal (make-property-condition 'exn 'location 'archive-put! 'message "This isn't a writable archive")))
     305  ((storage-put! (archive-storage archive)) key (wrap-block archive data) type))
    295306
    296307(define (archive-exists? archive key)
    297    ((storage-exists? (archive-storage archive)) key))
     308  ((storage-exists? (archive-storage archive)) key))
    298309
    299310(define (archive-get archive key)
    300    (let ((data (unwrap-block archive ((storage-get (archive-storage archive)) key))))
    301       (if (archive-check-correctness? archive)
    302          (if (string=? key ((archive-hash archive) data (archive-exists? archive key)))
    303             data
    304             (begin
    305                (printf "CONSISTENCY CHECK FAILURE: Block ~A comes back as ~A which has hash ~A\n" key data ((archive-hash archive) data))
    306                (assert #f))))
    307       data))
     311  (let ((data (unwrap-block archive ((storage-get (archive-storage archive)) key))))
     312    (if (archive-check-correctness? archive)
     313        (if (string=? key ((archive-hash archive) data (archive-exists? archive key)))
     314            data
     315            (begin
     316              (printf "CONSISTENCY CHECK FAILURE: Block ~A comes back as ~A which has hash ~A\n" key data ((archive-hash archive) data (archive-exists? archive key)))
     317              (assert #f))))
     318    data))
    308319
    309320(define (archive-link! archive key)
    310    (if (not (archive-writable? archive))
    311       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    312    ((storage-link! (archive-storage archive)) key))
     321  (if (not (archive-writable? archive))
     322      (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't a writable archive")))
     323  ((storage-link! (archive-storage archive)) key))
    313324
    314325(define (archive-unlink! archive key)
    315    (if (not (archive-writable? archive))
    316       (signal (make-property-condition 'exn 'message "This isn't an unlinkable archive - it's append-only")))
    317    (let ((result ((storage-unlink! (archive-storage archive)) key)))
    318       (if result
    319          (unwrap-block archive result)
    320          #f)))
     326  (if (not (archive-writable? archive))
     327      (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't an unlinkable archive - it's append-only")))
     328  (let ((result ((storage-unlink! (archive-storage archive)) key)))
     329    (if result
     330        (unwrap-block archive result)
     331        #f)))
    321332
    322333(define (archive-set-tag! archive tag key)
    323    (if (not (archive-writable? archive))
    324       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    325    ((storage-set-tag! (archive-storage archive)) tag key))
     334  (if (not (archive-writable? archive))
     335      (signal (make-property-condition 'exn 'location 'archive-set-tag! 'message "This isn't a writable archive")))
     336  ((storage-set-tag! (archive-storage archive)) tag key))
    326337
    327338(define (archive-tag archive tag)
    328    ((storage-tag (archive-storage archive)) tag))
     339  ((storage-tag (archive-storage archive)) tag))
    329340
    330341(define (archive-all-tags archive)
    331    ((storage-all-tags (archive-storage archive))))
     342  ((storage-all-tags (archive-storage archive))))
    332343
    333344(define (archive-remove-tag! archive tag)
    334    (if (not (archive-writable? archive))
    335       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    336    ((storage-remove-tag! (archive-storage archive)) tag))
     345  (if (not (archive-writable? archive))
     346      (signal (make-property-condition 'exn 'location 'archive-remove-tag! 'message "This isn't a writable archive")))
     347  ((storage-remove-tag! (archive-storage archive)) tag))
    337348
    338349(define (archive-lock-tag! archive tag)
    339    (if (not (archive-writable? archive))
    340       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    341    ((storage-lock-tag! (archive-storage archive)) tag))
     350  (if (not (archive-writable? archive))
     351      (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message "This isn't a writable archive")))
     352  ((storage-lock-tag! (archive-storage archive)) tag))
    342353
    343354(define (archive-tag-locked? archive tag)
    344    (if (not (archive-writable? archive))
     355  (if (not (archive-writable? archive))
    345356      #f)
    346    ((storage-tag-locked? (archive-storage archive)) tag))
     357  ((storage-tag-locked? (archive-storage archive)) tag))
    347358
    348359(define (archive-unlock-tag! archive tag)
    349    (if (not (archive-writable? archive))
    350       (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
    351    ((storage-unlock-tag! (archive-storage archive)) tag))
     360  (if (not (archive-writable? archive))
     361      (signal (make-property-condition 'exn 'location 'archive-unlock-tag! 'message "This isn't a writable archive")))
     362  ((storage-unlock-tag! (archive-storage archive)) tag))
    352363
    353364(define (archive-close! archive)
    354    ((storage-close! (archive-storage archive))))
     365  ((storage-close! (archive-storage archive))))
    355366
    356367;;
     
    359370
    360371;; Philosophy: insertion routines
    361 ;; Insertion routines insert an object into the archive, correctly managing reference counts.
    362 ;; In order to do this, they all return two values: the key the object went in under,
    363 ;; and a boolean flag that is true if the object was already in the archive.
    364 ;; This is so that a parent object that calls that function can construct its data
    365 ;; block from the supplied child keys, then do an exists? check to see if it
    366 ;; already exists in the archive itself, if all of its children were already in the archive.
    367 ;; If it was, then it in turn can just return the key and #t
    368 ;; But if not, then it can link! every child that WAS already in the
    369 ;; archive, and then put! its own value into the archive and return that with #f
    370 ;; Thus, the reference counts are maintained correctly.
     372
     373;; Insertion routines insert an object into the archive, correctly
     374;; managing reference counts.  In order to do this, they all return
     375;; two values: the key the object went in under, and a boolean flag
     376;; that is true if the object was already in the archive.  This is so
     377;; that a parent object that calls that function can construct its
     378;; data block from the supplied child keys, then do an exists? check
     379;; to see if it already exists in the archive itself, if all of its
     380;; children were already in the archive.  If it was, then it in turn
     381;; can just return the key and #t But if not, then it can link! every
     382;; child that WAS already in the archive, and then put! its own value
     383;; into the archive and return that with #f Thus, the reference counts
     384;; are maintained correctly.
    371385
    372386(define (reusing hash)
    373 ;   (printf "REUSING: ~A\n" hash)
    374    hash)
     387                                        ;   (printf "REUSING: ~A\n" hash)
     388  hash)
    375389
    376390(define (virgin hash)
    377 ;   (printf "CREATED: ~A\n" hash)
    378    hash)
     391                                        ;   (printf "CREATED: ~A\n" hash)
     392  hash)
    379393
    380394;; BLOCKS OF RAW DATA THAT CANNOT CONTAIN CHILD KEYS
    381395;; We never have any child keys to link!, so the not-reused case is simple.
    382396(define (archive-store-block! archive data type)
    383    (check-archive-writable archive)
    384    
    385    (let ((hash ((archive-hash archive) data type)))
    386    
    387       (if (archive-exists? archive hash)
    388          (values (reusing hash) #t)
    389          (begin
    390             (archive-put! archive hash data type)
    391             (values (virgin hash) #f)))))
     397  (check-archive-writable archive)
     398
     399  (let ((hash ((archive-hash archive) data type)))
     400
     401    (if (archive-exists? archive hash)
     402        (values (reusing hash) #t)
     403        (begin
     404          (archive-put! archive hash data type)
     405          (values (virgin hash) #f)))))
    392406
    393407;; GENERIC STREAMS OF KEYS
     
    398412
    399413(define-record key-stream-writer
    400    write! ;; Write a single string key to the stream. Accepts the key, and the already-existed boolean for proper reference counting.
    401    finish!) ;; Terminate the stream. Returns two values: key of the stream, and an already-existed boolean.
    402 
    403 ;
     414  write! ;; Write a single string key to the stream. Accepts the key, and the already-existed boolean for proper reference counting.
     415  finish!) ;; Terminate the stream. Returns two values: key of the stream, and an already-existed boolean.
     416
    404417(define (copy-string-into-place! u8v offset string string-offs string-len)
    405    (move-memory! string u8v (- string-len string-offs) string-offs offset)
    406    (void))
    407    
     418  (move-memory! string u8v (- string-len string-offs) string-offs offset)
     419  (void))
     420
    408421(define (serialise-strings! u8v offset strings)
    409    (if (null? strings)
     422  (if (null? strings)
    410423      (void)
    411424      (begin
    412          (let* ((string (blob->u8vector/shared (string->blob (string-append (car strings) "\n"))))
    413                 (string-len (u8vector-length string)))
    414          (copy-string-into-place! u8v (- offset string-len) string 0 string-len)
    415          (serialise-strings! u8v (- offset string-len) (cdr strings))))))
     425        (let* ((string (blob->u8vector/shared (string->blob (string-append (car strings) "\n"))))
     426               (string-len (u8vector-length string)))
     427          (copy-string-into-place! u8v (- offset string-len) string 0 string-len)
     428          (serialise-strings! u8v (- offset string-len) (cdr strings))))))
    416429
    417430(define (make-key-stream-writer* archive type)
    418    (check-archive-writable archive)
    419 
    420    (let* ((*key-buffer* '())
    421         (*key-buffer-bytes* 0)
    422         (*key-buffer-reused?* #t)
    423         (*parent-stream* #f)
    424          
    425         (next-write-will-overflow? (lambda (key)
    426             (assert (< (string-length key) (archive-max-block-size archive)))
    427             (> (+ *key-buffer-bytes* (string-length key) 1) (archive-max-block-size archive))))
    428            
    429         (flush! (lambda ()
    430             (let ((keys-serialised (make-u8vector *key-buffer-bytes*)))
    431                (serialise-strings! keys-serialised *key-buffer-bytes* (map car *key-buffer*))
    432      
    433                (let ((hash ((archive-hash archive) keys-serialised type)))
    434      
    435                   (if (and *key-buffer-reused?* (archive-exists? archive hash))
    436                      (begin
    437                         (set! *key-buffer* '())
    438                         (set! *key-buffer-bytes* 0)
    439                         (set! *key-buffer-reused?* #t)
    440                         (values (reusing hash) #t)) ; We, too, are reused
    441                      (begin ; We are unique and new and precious!
    442                         (for-each (lambda (x) ; link! all reused children
    443                           (let ((key (car x))
    444                                  (reused? (cdr x)))
    445                               (if reused?
    446                                  (archive-link! archive key))))
    447                               *key-buffer*)
    448            
    449                         (archive-put! archive hash keys-serialised type)
    450 
    451                         (set! *key-buffer* '())
    452                         (set! *key-buffer-bytes* 0)
    453                         (set! *key-buffer-reused?* #t)
    454 
    455                         (values (virgin hash) #f)))))))
    456                        
    457         (write! (lambda (key reused?)
    458             (if (next-write-will-overflow? key)
    459                (let-values (((flush-key flush-reused?) (flush!)))
    460                   (if (not *parent-stream*)
    461                      (set! *parent-stream* (make-key-stream-writer* archive type)))
    462                   ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
    463 
    464                   ;; What happens if the same key comes up twice, eh?
    465             (set! *key-buffer* (cons (cons key reused?) *key-buffer*))
    466             (set! *key-buffer-reused?* (and *key-buffer-reused?* reused?))
    467             (set! *key-buffer-bytes* (+ *key-buffer-bytes* (string-length key) 1))))
    468          
    469         (finish! (lambda ()
    470             (cond
    471                (*parent-stream*
    472                   (begin
    473                      (if (not (null? *key-buffer*))
    474                         (let-values (((flush-key flush-reused?) (flush!)))
    475                            ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
    476                      ((key-stream-writer-finish! *parent-stream*))))
    477                ((null? *key-buffer*) ; Empty stream
    478                   (archive-store-block! archive (make-u8vector 0) type))
    479                ((null? (cdr *key-buffer*)) ; Single-element stream
    480                   (values (caar *key-buffer*) (cdar *key-buffer*))) ; Just return the one element!
    481                (else ; More than one key, but not enough to have flushed before
    482                   (flush!))))))
    483    
    484       (make-key-stream-writer
    485          write!
    486          finish!)))
     431  (check-archive-writable archive)
     432
     433  (let* ((*key-buffer* '())
     434        (*key-buffer-bytes* 0)
     435        (*key-buffer-reused?* #t)
     436        (*parent-stream* #f)
     437
     438        (next-write-will-overflow? (lambda (key)
     439                                      (assert (< (string-length key) (archive-max-block-size archive)))
     440                                      (> (+ *key-buffer-bytes* (string-length key) 1) (archive-max-block-size archive))))
     441
     442        (flush! (lambda ()
     443                   (let ((keys-serialised (make-u8vector *key-buffer-bytes*)))
     444                     (serialise-strings! keys-serialised *key-buffer-bytes* (map car *key-buffer*))
     445
     446                     (let ((hash ((archive-hash archive) keys-serialised type)))
     447
     448                       (if (and *key-buffer-reused?* (archive-exists? archive hash))
     449                           (begin
     450                             (set! *key-buffer* '())
     451                             (set! *key-buffer-bytes* 0)
     452                             (set! *key-buffer-reused?* #t)
     453                             (values (reusing hash) #t)) ; We, too, are reused
     454                           (begin ; We are unique and new and precious!
     455                             (for-each (lambda (x) ; link! all reused children
     456                                        (let ((key (car x))
     457                                               (reused? (cdr x)))
     458                                           (if reused?
     459                                               (archive-link! archive key))))
     460                                       *key-buffer*)
     461
     462                             (archive-put! archive hash keys-serialised type)
     463
     464                             (set! *key-buffer* '())
     465                             (set! *key-buffer-bytes* 0)
     466                             (set! *key-buffer-reused?* #t)
     467
     468                             (values (virgin hash) #f)))))))
     469
     470        (write! (lambda (key reused?)
     471                   (if (next-write-will-overflow? key)
     472                       (let-values (((flush-key flush-reused?) (flush!)))
     473                        (if (not *parent-stream*)
     474                             (set! *parent-stream* (make-key-stream-writer* archive type)))
     475                        ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
     476
     477                   ;; What happens if the same key comes up twice, eh?
     478                   (set! *key-buffer* (cons (cons key reused?) *key-buffer*))
     479                   (set! *key-buffer-reused?* (and *key-buffer-reused?* reused?))
     480                   (set! *key-buffer-bytes* (+ *key-buffer-bytes* (string-length key) 1))))
     481
     482        (finish! (lambda ()
     483                    (cond
     484                     (*parent-stream*
     485                      (begin
     486                        (if (not (null? *key-buffer*))
     487                            (let-values (((flush-key flush-reused?) (flush!)))
     488                              ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
     489                        ((key-stream-writer-finish! *parent-stream*))))
     490                     ((null? *key-buffer*) ; Empty stream
     491                      (archive-store-block! archive (make-u8vector 0) type))
     492                     ((null? (cdr *key-buffer*)) ; Single-element stream
     493                      (values (caar *key-buffer*) (cdar *key-buffer*))) ; Just return the one element!
     494                     (else ; More than one key, but not enough to have flushed before
     495                      (flush!))))))
     496
     497    (make-key-stream-writer
     498     write!
     499     finish!)))
    487500
    488501(define (deserialise-key-stream block) ; Convert a key stream block to a list of key strings
    489    (string-split (blob->string (u8vector->blob/shared block)) "\n"))
     502  (string-split (blob->string (u8vector->blob/shared block)) "\n"))
    490503
    491504;; kons is called on (key type accumulator) for every key in the stream, in order
    492505(define (fold-key-stream archive key ks-type kons knil)
    493    (let ((type (archive-exists? archive key)))
    494       (if (eq? ks-type type)
    495          ; Recurse
    496          (begin
    497             (let ((subkeys (deserialise-key-stream (archive-get archive key))))
    498                (fold
    499                   (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc))
    500                   knil
    501                   subkeys)))
    502          ; Leaf node
    503          (kons key type knil))))
    504 
    505 ; (child-unlink! archive key type) is called on every child key of a deleted block
     506  (let ((type (archive-exists? archive key)))
     507    (if (eq? ks-type type)
     508                                        ; Recurse
     509        (begin
     510          (let ((subkeys (deserialise-key-stream (archive-get archive key))))
     511            (fold
     512             (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc))
     513             knil
     514             subkeys)))
     515                                        ; Leaf node
     516        (kons key type knil))))
     517
     518                                        ; (child-unlink! archive key type) is called on every child key of a deleted block
    506519(define (unlink-key-stream! archive key type child-unlink!)
    507    (check-archive-unlinkable archive)
    508 
    509    (let ((result (archive-unlink! archive key)))
    510       (if result ; result is now list of keys, \n separated, to recursively unlink
    511          (for-each (lambda (subkey)
    512             (let ((child-type (archive-exists? archive subkey)))
    513                (if child-type ; The child may not actually exist any more, in which case, job done!
    514                   (if (eq? child-type type)
    515                      (unlink-key-stream! archive subkey type child-unlink!)
    516                      (child-unlink! archive subkey child-type)))))
    517                   (deserialise-key-stream result)))))
     520  (check-archive-unlinkable archive)
     521
     522  (let ((result (archive-unlink! archive key)))
     523    (if result ; result is now list of keys, \n separated, to recursively unlink
     524        (for-each (lambda (subkey)
     525                    (let ((child-type (archive-exists? archive subkey)))
     526                      (if child-type ; The child may not actually exist any more, in which case, job done!
     527                          (if (eq? child-type type)
     528                              (unlink-key-stream! archive subkey type child-unlink!)
     529                              (child-unlink! archive subkey child-type)))))
     530                  (deserialise-key-stream result)))))
    518531
    519532;; FILE STORAGE
     
    524537;; Uses standard input port for the file data
    525538;; Returns key and reused?
    526 (define (store-file! archive)
    527    (check-archive-writable archive)
    528    ;; FIXME: memory-map the file in 1MB chunks, and copy them into u8vectors?
    529    (letrec ((blocksize (archive-max-block-size archive))
    530             (*buffer* (make-u8vector blocksize))
    531             (ksw (make-key-stream-writer* archive 'fi))
    532             (upload-file (lambda ()
    533                (let ((bytes-read (read-u8vector! blocksize *buffer*)))
    534                   (if (not (zero? bytes-read))
    535                      (let-values (((data-key data-reused?)
    536                         (archive-store-block! archive (subu8vector *buffer* 0 bytes-read) 'f)))
    537                            ((key-stream-writer-write! ksw) data-key data-reused?)
    538                            (upload-file))
    539                      ((key-stream-writer-finish! ksw)))))))
    540          (upload-file)))
     539(define (store-file! archive file-path file-stat)
     540  (let* ((store-file-without-caching!
     541          (lambda ()
     542            ;; Actually upload the file
     543            ;; FIXME: memory-map the file in 1MB chunks, and copy them into u8vectors?
     544            (letrec ((blocksize (archive-max-block-size archive))
     545                     (*buffer* (make-u8vector blocksize))
     546                     (ksw (make-key-stream-writer* archive 'fi))
     547                     (upload-file (lambda ()
     548                                    (let ((bytes-read (read-u8vector! blocksize *buffer*)))
     549                                      (if (not (zero? bytes-read))
     550                                          (let-values (((data-key data-reused?)
     551                                                        (archive-store-block! archive (subu8vector *buffer* 0 bytes-read) 'f)))
     552                                            ((key-stream-writer-write! ksw) data-key data-reused?)
     553                                            (upload-file))
     554                                          ((key-stream-writer-finish! ksw)))))))
     555              (upload-file))))
     556         (store-file-and-cache!
     557          (lambda (mtime)
     558            (let-values (((key reused?) (store-file-without-caching!)))
     559              (gdbm-store (archive-file-cache archive)
     560                          file-path
     561                          (with-output-to-string (lambda ()
     562                                                   (write (list mtime key))))
     563                          GDBM_REPLACE)
     564              (values key reused?)))))
     565
     566    (check-archive-writable archive)
     567
     568    ;; Firstly, if we have an mtime cache, use it to see if the file is already in the archive
     569    ;; The cache is keyed on file paths, and the contents are
     570    ;; sexprs of the form (mtime hash)
     571    (if (archive-file-cache archive)
     572        (let* ((mtime (vector-ref file-stat 8)) ; Should have used and-let*
     573               (cache-result-bytes (gdbm-fetch (archive-file-cache archive) file-path))
     574               (cache-result (if cache-result-bytes
     575                                 (with-input-from-string cache-result-bytes read)
     576                                 #f))
     577               (cached-mtime (if cache-result (car cache-result) #f))
     578               (cached-hash (if cache-result (cadr cache-result) #f)))
     579          (if cache-result
     580              (if (= cached-mtime mtime)
     581                  (values cached-hash #t) ; Found in cache! Woot!
     582                  (store-file-and-cache! mtime)) ; in cache, but mtime differs
     583              (store-file-and-cache! mtime))) ; not in cache
     584        (store-file-without-caching!)))) ; no mtime cache
    541585
    542586;; Call kons on each u8vector block of the file in turn
    543587;; with an accumulator that starts as knil as a second argument
    544588(define (fold-file archive key kons knil)
    545    (fold-key-stream archive key 'fi
    546       (lambda (key type acc)
    547          (kons (archive-get archive key) acc))
    548       knil))
    549      
     589  (fold-key-stream archive key 'fi
     590                   (lambda (key type acc)
     591                     (kons (archive-get archive key) acc))
     592                   knil))
     593
    550594;; Write the contents of the file to the standard output port
    551595(define (write-file-contents archive key)
    552    (fold-file archive key
    553       (lambda (block acc)
    554          (begin
    555             (write-u8vector block)
    556             #f))
    557       #f))
     596  (fold-file archive key
     597             (lambda (block acc)
     598               (begin
     599                (write-u8vector block)
     600                #f))
     601             #f))
    558602
    559603(define (unlink-file! archive key)
    560    (check-archive-unlinkable archive)
    561    
    562    (unlink-key-stream! archive key 'fi (lambda (archive key type)
    563    (archive-unlink! archive key))))
     604  (check-archive-unlinkable archive)
     605
     606  (unlink-key-stream! archive key 'fi (lambda (archive key type)
     607                                        (archive-unlink! archive key))))
    564608
    565609;; GENERIC STREAMS OF S-EXPRESSIONS
     
    568612
    569613(define-record sexpr-stream-writer
    570    write! ;; Write an sexpr to the stream. Second argument is a list of pairs, one per key mentioned in the sexpr, car is the key and cdr is the reused? flag.
    571    finish!) ;; Return the key and reused? flag for the whole thing
     614  write! ;; Write an sexpr to the stream. Second argument is a list of pairs, one per key mentioned in the sexpr, car is the key and cdr is the reused? flag.
     615  finish!) ;; Return the key and reused? flag for the whole thing
    572616
    573617;; FIXME: Examine this and make-key-stream-writer*
     
    575619;; if it's worth it. They share a lot, yet also differ a lot.
    576620(define (make-sexpr-stream-writer* archive type ks-type)
    577    (check-archive-writable archive)
    578    (let* ((*sexpr-buffer* '()) ; List of strings
    579           (*sexpr-buffer-bytes* 0) ; Bytes used so far
    580           (*key-buffer* '()) ; List of key-reused? pairs
    581           (*key-buffer-reused?* #t) ; All reused in the buffer so far?
    582           (*parent-stream* #f) ; Key stream
    583    
    584           (flush! (lambda ()
    585             (let ((serialised-buffer (make-u8vector *sexpr-buffer-bytes*)))
    586                (begin
    587                   (serialise-strings! serialised-buffer *sexpr-buffer-bytes* *sexpr-buffer*)
    588                   (let ((hash ((archive-hash archive) serialised-buffer type)))
    589                     (begin
    590      
    591                         (if (archive-check-correctness? archive)
    592                            (if *key-buffer-reused?*
    593                               (assert (every cdr *key-buffer*) "Key buffer thinks it's all reused, but it isn't:" *key-buffer*)
    594                               ; else
    595                               (assert (not (every cdr *key-buffer*)) "Key buffer thinks it's not all reused, but it is:" *key-buffer*)))
    596      
    597                         (if (and *key-buffer-reused?* (archive-exists? archive hash))
    598                            (begin
    599                               (set! *sexpr-buffer* '())
    600                               (set! *sexpr-buffer-bytes* 0)
    601                               (set! *key-buffer* '())
    602                               (set! *key-buffer-reused?* #t)
    603                               (values (reusing hash) #t)) ; We, too, are reused
    604                            (begin ; We are unique and new and precious!
    605                               (for-each (lambda (x) ; link! all reused children
    606                                  (let ((key (car x))
    607                                        (reused? (cdr x)))
    608                                     (if reused?
    609                                        (archive-link! archive key))))
    610                                  *key-buffer*)
    611            
    612                               (archive-put! archive hash serialised-buffer type)
    613 
    614                               (set! *sexpr-buffer* '())
    615                               (set! *sexpr-buffer-bytes* 0)
    616                               (set! *key-buffer* '())
    617                               (set! *key-buffer-reused?* #t)
    618 
    619                               (values (virgin hash) #f)))))))))
    620                  
    621           (write! (lambda (sexpr keys)
    622             (let* ((sexpr-string
    623                      (with-output-to-string (lambda ()
    624                         (write sexpr))))
    625                    (sexpr-len (string-length sexpr-string)))
    626      
    627                (assert (< sexpr-len (archive-max-block-size archive)))
    628      
    629                (if (> (+ *sexpr-buffer-bytes* sexpr-len 1) (archive-max-block-size archive))
    630                   (let-values (((flush-key flush-reused?) (flush!)))
    631                      (if (not *parent-stream*)
    632                         (set! *parent-stream* (make-key-stream-writer* archive ks-type)))
    633                      ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
    634      
    635                (set! *sexpr-buffer* (cons sexpr-string *sexpr-buffer*))
    636                (set! *key-buffer* (append keys *key-buffer*))
    637                (set! *key-buffer-reused?* (and *key-buffer-reused?* (every cdr keys)))
    638                (set! *sexpr-buffer-bytes* (+ *sexpr-buffer-bytes* sexpr-len 1)))))
    639    
    640           (finish! (lambda ()
    641             (cond
    642                (*parent-stream*
    643                   (begin
    644                      (if (not (null? *sexpr-buffer*))
    645                         (let-values (((flush-key flush-reused?) (flush!)))
    646                            ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
    647                      ((key-stream-writer-finish! *parent-stream*))))
    648                ((null? *sexpr-buffer*) ; Empty stream
    649                   (archive-store-block! archive (make-u8vector 0) type))
    650                (else ; Some sexprs, but not enough to have flushed before
    651                   (flush!))))))
    652 
    653       (make-sexpr-stream-writer write! finish!)))
     621  (check-archive-writable archive)
     622  (let* ((*sexpr-buffer* '()) ; List of strings
     623        (*sexpr-buffer-bytes* 0) ; Bytes used so far
     624        (*key-buffer* '()) ; List of key-reused? pairs
     625        (*key-buffer-reused?* #t) ; All reused in the buffer so far?
     626        (*parent-stream* #f) ; Key stream
     627
     628        (flush! (lambda ()
     629                   (let ((serialised-buffer (make-u8vector *sexpr-buffer-bytes*)))
     630                     (begin
     631                       (serialise-strings! serialised-buffer *sexpr-buffer-bytes* *sexpr-buffer*)
     632                       (let ((hash ((archive-hash archive) serialised-buffer type)))
     633                        (begin
     634
     635                           (if (archive-check-correctness? archive)
     636                               (if *key-buffer-reused?*
     637                                   (assert (every cdr *key-buffer*) "Key buffer thinks it's all reused, but it isn't:" *key-buffer*)
     638                                        ; else
     639                                   (assert (not (every cdr *key-buffer*)) "Key buffer thinks it's not all reused, but it is:" *key-buffer*)))
     640
     641                           (if (and *key-buffer-reused?* (archive-exists? archive hash))
     642                               (begin
     643                                (set! *sexpr-buffer* '())
     644                                (set! *sexpr-buffer-bytes* 0)
     645                                (set! *key-buffer* '())
     646                                (set! *key-buffer-reused?* #t)
     647                                (values (reusing hash) #t)) ; We, too, are reused
     648                               (begin ; We are unique and new and precious!
     649                                (for-each (lambda (x) ; link! all reused children
     650                                             (let ((key (car x))
     651                                                   (reused? (cdr x)))
     652                                               (if reused?
     653                                                   (archive-link! archive key))))
     654                                           *key-buffer*)
     655
     656                                (archive-put! archive hash serialised-buffer type)
     657
     658                                (set! *sexpr-buffer* '())
     659                                (set! *sexpr-buffer-bytes* 0)
     660                                (set! *key-buffer* '())
     661                                (set! *key-buffer-reused?* #t)
     662
     663                                (values (virgin hash) #f)))))))))
     664
     665        (write! (lambda (sexpr keys)
     666                   (let* ((sexpr-string
     667                           (with-output-to-string (lambda ()
     668                                                    (write sexpr))))
     669                          (sexpr-len (string-length sexpr-string)))
     670
     671                     (assert (< sexpr-len (archive-max-block-size archive)))
     672
     673                     (if (> (+ *sexpr-buffer-bytes* sexpr-len 1) (archive-max-block-size archive))
     674                        (let-values (((flush-key flush-reused?) (flush!)))
     675                           (if (not *parent-stream*)
     676                               (set! *parent-stream* (make-key-stream-writer* archive ks-type)))
     677                           ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
     678
     679                     (set! *sexpr-buffer* (cons sexpr-string *sexpr-buffer*))
     680                     (set! *key-buffer* (append keys *key-buffer*))
     681                     (set! *key-buffer-reused?* (and *key-buffer-reused?* (every cdr keys)))
     682                     (set! *sexpr-buffer-bytes* (+ *sexpr-buffer-bytes* sexpr-len 1)))))
     683
     684        (finish! (lambda ()
     685                    (cond
     686                     (*parent-stream*
     687                      (begin
     688                        (if (not (null? *sexpr-buffer*))
     689                            (let-values (((flush-key flush-reused?) (flush!)))
     690                              ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
     691                        ((key-stream-writer-finish! *parent-stream*))))
     692                     ((null? *sexpr-buffer*) ; Empty stream
     693                      (archive-store-block! archive (make-u8vector 0) type))
     694                     (else ; Some sexprs, but not enough to have flushed before
     695                      (flush!))))))
     696
     697    (make-sexpr-stream-writer write! finish!)))
    654698
    655699(define (deserialise-sexpr-stream block) ; Convert a sexpr stream block to a list of sexprs
    656    (map
    657       (lambda (string)
    658          (with-input-from-string string read))
    659       (string-split (blob->string (u8vector->blob/shared block)) "\n")))
     700  (map
     701   (lambda (string)
     702     (with-input-from-string string read))
     703   (string-split (blob->string (u8vector->blob/shared block)) "\n")))
    660704
    661705(define (fold-sexpr-stream archive key leaf-type ks-type kons knil)
    662    (fold-key-stream archive key ks-type
    663       (lambda (key found-leaf-type acc)
    664          (assert (eq? found-leaf-type leaf-type))
    665          (let ((sexprs (deserialise-sexpr-stream (archive-get archive key))))
    666             (fold
    667                kons
    668                acc
    669                sexprs)))
    670       knil))
     706  (fold-key-stream archive key ks-type
     707                   (lambda (key found-leaf-type acc)
     708                     (assert (eq? found-leaf-type leaf-type))
     709                     (let ((sexprs (deserialise-sexpr-stream (archive-get archive key))))
     710                       (fold
     711                        kons
     712                        acc
     713                        sexprs)))
     714                   knil))
    671715
    672716(define (unlink-sexpr-stream-block! archive key sexpr-unlink!)
    673    (let ((result (archive-unlink! archive key)))
    674       (if result
    675          (for-each sexpr-unlink! (deserialise-sexpr-stream result)))))
     717  (let ((result (archive-unlink! archive key)))
     718    (if result
     719        (for-each sexpr-unlink! (deserialise-sexpr-stream result)))))
    676720
    677721(define (unlink-sexpr-stream! archive key leaf-type ks-type sexpr-unlink!)
    678    (check-archive-unlinkable archive)
    679    (let ((type (archive-exists? archive key)))
    680       (cond
    681          ((eq? type ks-type)
    682             (unlink-key-stream! archive key ks-type
    683                (lambda (archive leaf-key found-leaf-type)
    684                   (assert (eq? found-leaf-type leaf-type))
    685                   (unlink-sexpr-stream-block! archive leaf-key sexpr-unlink!))))
    686          ((eq? type leaf-type)
    687             (unlink-sexpr-stream-block! archive key sexpr-unlink!))
    688          (else
    689             (assert (or (eq? type leaf-type) (eq? type ks-type)))))))
     722  (check-archive-unlinkable archive)
     723  (let ((type (archive-exists? archive key)))
     724    (cond
     725     ((eq? type ks-type)
     726      (unlink-key-stream! archive key ks-type
     727                          (lambda (archive leaf-key found-leaf-type)
     728                            (assert (eq? found-leaf-type leaf-type))
     729                            (unlink-sexpr-stream-block! archive leaf-key sexpr-unlink!))))
     730     ((eq? type leaf-type)
     731      (unlink-sexpr-stream-block! archive key sexpr-unlink!))
     732     (else
     733      (assert (or (eq? type leaf-type) (eq? type ks-type)))))))
    690734
    691735;; DIRECTORY STORAGE
     
    702746;; 2) An indirect block of type "di" that's a keystream of keys to direct or indirect blocks
    703747
     748;; Look for a .ugarit file in the given directory
     749;; If one is found, return its contents
     750(define (read-local-rules archive path)
     751  (let ((conf-file (make-pathname path ".ugarit")))
     752    (if (file-exists? conf-file)
     753        (with-input-from-file conf-file read-file)
     754        '())))
     755
     756;; Do the rules list say to ignore the file?
     757;; Statements towards the head of the list take priority
     758;; And we want to accept the most recent 'ignore' or 'include',
     759;; defaulting to 'include' if neither is found
     760(define (rules-say-ignore rules)
     761  (match rules
     762         ('() #f)
     763         ((('exclude) . _) #t)
     764         ((('include) . _) #f)
     765         ((_ . more) (rules-say-ignore more))))
     766
    704767;; Store a directory
    705768;; Returns the usual key and reused? values
    706769(define (store-directory! archive path)
    707    (check-archive-writable archive)
    708 
    709    (let ((ssw (make-sexpr-stream-writer* archive 'd 'di)))
    710    
    711       (for-each (lambda (filename)
    712          (let* ((file-path (make-pathname path filename))
    713                 (stats (file-stat file-path #t))
    714                 (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt)))
    715                 (uid (vector-ref stats 3))
    716                 (gid (vector-ref stats 4))
    717                 (atime (vector-ref stats 6))
    718                 (ctime (vector-ref stats 7))
    719                 (mtime (vector-ref stats 8))
    720                 (type (bitwise-and (vector-ref stats 1) stat/ifmt))
    721                 (standard-file-attributes
    722                   (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime))))
    723             (if (archive-store-ctime? archive)
    724                (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes)))
    725             (if (archive-store-atime? archive)
    726                (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes)))
    727             (cond
    728                ((eq? type stat/ifsock)
    729                   (printf "~A is a socket, ignoring...\n" file-path))
    730                ((eq? type stat/ifreg)
    731                   ;; FIXME: We can store a gdbm cache file
    732                   ;; mapping file-path (or device+inode?) to an (mtime hash) pair
    733                   ;; We can check the filename in the cache, and if the file's mtime has not changed,
    734                   ;; consider it already uploaded and reuse the hash, thus avoiding hashing the entire file.
    735                   ;; When we upload a file, we store its mtime and hash in the cache.
    736                   (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive)))))
    737                      ((sexpr-stream-writer-write! ssw)
    738                         (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes)
    739                         (list (cons content-key content-reused?)))))
    740                ((eq? type stat/ifdir)
    741                   (let-values (((content-key content-reused?) (store-directory! archive file-path)))
    742                      ((sexpr-stream-writer-write! ssw)
    743                         (append (list filename 'dir (cons 'contents content-key)) standard-file-attributes)
    744                         (list (cons content-key content-reused?)))))
    745                ((eq? type stat/iflnk)
    746                   ((sexpr-stream-writer-write! ssw)
    747                      (append (list filename 'symlink (cons 'target (read-symbolic-link file-path))) standard-file-attributes)
    748                      '()))
    749                ((eq? type stat/ifblk)
    750                   (let ((devnum (vector-ref stats 10)))
    751                      ((sexpr-stream-writer-write! ssw)
    752                         (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes)
    753                         '())))
    754                ((eq? type stat/ifchr)
    755                   (let ((devnum (vector-ref stats 10)))
    756                      ((sexpr-stream-writer-write! ssw)
    757                         (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes)
    758                         '())))
    759                ((eq? type stat/ififo)
    760                   ((sexpr-stream-writer-write! ssw)
    761                      (append (list filename 'fifo) standard-file-attributes)
    762                      '()))
    763                (else
    764                   ; WTF?
    765                   (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path)))))
    766       (directory path #t))
    767    
    768       ((sexpr-stream-writer-finish! ssw))))
     770  (printf "TEST 1\n")
     771  (call-with-context
     772   (read-local-rules archive path)
     773   path
     774   (lambda ()
     775     (printf "TEST 2\n")
     776     (check-archive-writable archive)
     777
     778     (let ((ssw (make-sexpr-stream-writer* archive 'd 'di))
     779           (rules-checker (make-filesystem-object-pattern-checker path)))
     780
     781       (for-each (lambda (filename)
     782                   (let* ((file-path (make-pathname path filename))
     783                          (stats (file-stat file-path #t))
     784                          (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt)))
     785                          (uid (vector-ref stats 3))
     786                          (gid (vector-ref stats 4))
     787                          (atime (vector-ref stats 6))
     788                          (ctime (vector-ref stats 7))
     789                          (mtime (vector-ref stats 8))
     790                          (type (bitwise-and (vector-ref stats 1) stat/ifmt))
     791                          (standard-file-attributes
     792                           (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime)))
     793                          (file-rules
     794                           (object-matches filename rules-checker)))
     795                     (if (archive-store-ctime? archive)
     796                         (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes)))
     797                     (if (archive-store-atime? archive)
     798                         (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes)))
     799                     (if (not (rules-say-ignore file-rules))
     800                         (cond
     801                          ((eq? type stat/ifsock)
     802                           (printf "~A is a socket, ignoring...\n" file-path))
     803                          ((eq? type stat/ifreg)
     804                           ;; FIXME: We can store a gdbm cache file
     805                           ;; mapping file-path (or device+inode?) to an (mtime hash) pair
     806                           ;; We can check the filename in the cache, and if the file's mtime has not changed,
     807                           ;; consider it already uploaded and reuse the hash, thus avoiding hashing the entire file.
     808                           ;; When we upload a file, we store its mtime and hash in the cache.
     809                           (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats)))))
     810                             ((sexpr-stream-writer-write! ssw)
     811                              (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes)
     812                              (list (cons content-key content-reused?)))))
     813                          ((eq? type stat/ifdir)
     814                           (let-values (((content-key content-reused?) (store-directory! archive file-path)))
     815                             ((sexpr-stream-writer-write! ssw)
     816                              (append (list filename 'dir (cons 'contents content-key)) standard-file-attributes)
     817                              (list (cons content-key content-reused?)))))
     818                          ((eq? type stat/iflnk)
     819                           ((sexpr-stream-writer-write! ssw)
     820                            (append (list filename 'symlink (cons 'target (read-symbolic-link file-path))) standard-file-attributes)
     821                            '()))
     822                          ((eq? type stat/ifblk)
     823                           (let ((devnum (vector-ref stats 10)))
     824                             ((sexpr-stream-writer-write! ssw)
     825                              (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes)
     826                              '())))
     827                          ((eq? type stat/ifchr)
     828                           (let ((devnum (vector-ref stats 10)))
     829                             ((sexpr-stream-writer-write! ssw)
     830                              (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes)
     831                              '())))
     832                          ((eq? type stat/ififo)
     833                           ((sexpr-stream-writer-write! ssw)
     834                            (append (list filename 'fifo) standard-file-attributes)
     835                            '()))
     836                          (else
     837                                        ; WTF?
     838                           (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path))))))
     839                 (directory path #t))
     840
     841       ((sexpr-stream-writer-finish! ssw))))))
    769842
    770843(define (unlink-directory! archive key)
    771    (check-archive-unlinkable archive)
    772 
    773    (unlink-sexpr-stream! archive key 'd 'di
    774       (lambda (dirent)
    775          (let ((type (cadr dirent))
    776                (name (car dirent))
    777                (props (cddr dirent)))
    778             (cond
    779                ((eq? type 'file)
    780                   (unlink-file! archive (cdr (assq 'contents props))))
    781                ((eq? type 'dir)
    782                   (unlink-directory! archive (cdr (assq 'contents props)))))))))
     844  (check-archive-unlinkable archive)
     845
     846  (unlink-sexpr-stream! archive key 'd 'di
     847                        (lambda (dirent)
     848                          (let ((type (cadr dirent))
     849                                (name (car dirent))
     850                                (props (cddr dirent)))
     851                            (cond
     852                             ((eq? type 'file)
     853                              (unlink-file! archive (cdr (assq 'contents props))))
     854                             ((eq? type 'dir)
     855                              (unlink-directory! archive (cdr (assq 'contents props)))))))))
    783856
    784857(define (set-standard-file-metadata! path props)
    785    (let ((mode (assq 'mode props))
    786          (uid (assq 'uid props))
    787          (gid (assq 'gid props))
    788          (mtime (assq 'mtime props))
    789          (atime (assq 'atime props)))
    790    
    791    ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
    792    ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
    793    ;        for unprived restores.
    794    
    795    (if mode
    796       (change-file-mode path (cdr mode)))
    797    
    798    (if (or uid gid)
    799       (change-file-owner path
    800          (if uid (cdr uid) (current-user-id))
    801          (if gid (cdr gid) (current-group-id))))
    802 
    803    (if (or mtime atime)
    804       (change-file-times path
    805          (if atime (cdr atime) (time->seconds (current-time)))
    806          (if mtime (cdr mtime) (time->seconds (current-time)))))
    807      
    808    (void)))
     858  (let ((mode (assq 'mode props))
     859        (uid (assq 'uid props))
     860        (gid (assq 'gid props))
     861        (mtime (assq 'mtime props))
     862        (atime (assq 'atime props)))
     863
     864                                        ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
     865                                        ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
     866                                        ;        for unprived restores.
     867
     868    (if mode
     869        (change-file-mode path (cdr mode)))
     870
     871    (if (or uid gid)
     872        (change-file-owner path
     873                           (if uid (cdr uid) (current-user-id))
     874                           (if gid (cdr gid) (current-group-id))))
     875
     876    (if (or mtime atime)
     877        (change-file-times path
     878                           (if atime (cdr atime) (time->seconds (current-time)))
     879                           (if mtime (cdr mtime) (time->seconds (current-time)))))
     880
     881    (void)))
    809882
    810883(define (extract-file! archive props path)
    811    (let ((contents-key (cdr (assq 'contents props))))
    812       (with-output-to-file path
    813          (lambda ()
    814             (write-file-contents archive contents-key)))
    815       (set-standard-file-metadata! path props)))
     884  (let ((contents-key (cdr (assq 'contents props))))
     885    (with-output-to-file path
     886      (lambda ()
     887        (write-file-contents archive contents-key)))
     888    (set-standard-file-metadata! path props)))
    816889
    817890(define (extract-subdirectory! archive props path)
    818    (if (not (directory? path))
     891  (if (not (directory? path))
    819892      (create-directory path))
    820    
    821    (let ((contents-key (cdr (assq 'contents props))))
    822 
    823       (extract-directory! archive contents-key path)
    824    
    825       (set-standard-file-metadata! path props)))
     893
     894  (let ((contents-key (cdr (assq 'contents props))))
     895
     896    (extract-directory! archive contents-key path)
     897
     898    (set-standard-file-metadata! path props)))
    826899
    827900(define (extract-symlink! archive props path)
    828    (let ((target (cdr (assq 'target props)))
    829          (mode (assq 'mode props))
    830          (uid (assq 'uid props))
    831          (gid (assq 'gid props))
    832          (mtime (assq 'mtime props))
    833         (atime (assq 'atime props)))
    834    
    835       (create-symbolic-link target path)
    836    
    837       ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
    838       ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
    839       ;        for unprived restores.
    840    
    841       ; Alas, there is no portable way to set the atime/mtime on a link.
    842       ; I think, somehow, we will manage to live our lives without the atime and mtime on links...
    843       (if mode
    844          (change-link-mode path (cdr mode)))
    845    
    846       (if (or uid gid)
    847          (change-link-owner path
    848             (or (cdr uid) (current-user-id))
    849             (or (cdr gid) (current-group-id))))))
     901  (let ((target (cdr (assq 'target props)))
     902        (mode (assq 'mode props))
     903        (uid (assq 'uid props))
     904        (gid (assq 'gid props))
     905        (mtime (assq 'mtime props))
     906        (atime (assq 'atime props)))
     907
     908    (create-symbolic-link target path)
     909
     910                                        ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
     911                                        ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
     912                                        ;        for unprived restores.
     913
     914                                        ; Alas, there is no portable way to set the atime/mtime on a link.
     915                                        ; I think, somehow, we will manage to live our lives without the atime and mtime on links...
     916    (if mode
     917        (change-link-mode path (cdr mode)))
     918
     919    (if (or uid gid)
     920        (change-link-owner path
     921                           (or (cdr uid) (current-user-id))
     922                           (or (cdr gid) (current-group-id))))))
    850923
    851924(define (extract-fifo! archive props path)
    852    
    853    (create-fifo path)
    854 
    855    (set-standard-file-metadata! path props))
     925
     926  (create-fifo path)
     927
     928  (set-standard-file-metadata! path props))
    856929
    857930(define (extract-block-device! archive props path)
    858    (let ((number (cdr (assq 'number props))))
    859    
    860       ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
    861       (create-special-file path stat/ifblk number)
    862    
    863       (set-standard-file-metadata! path props)))
     931  (let ((number (cdr (assq 'number props))))
     932
     933                                        ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
     934    (create-special-file path stat/ifblk number)
     935
     936    (set-standard-file-metadata! path props)))
    864937
    865938(define (extract-character-device! archive props path)
    866    (let ((number (cdr (assq 'number props))))
    867    
    868       ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
    869       (create-special-file path stat/ifchr number)
    870    
    871       (set-standard-file-metadata! path props)))
     939  (let ((number (cdr (assq 'number props))))
     940
     941                                        ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
     942    (create-special-file path stat/ifchr number)
     943
     944    (set-standard-file-metadata! path props)))
    872945
    873946(define (extract-object! archive dirent target-path)
    874    (let ((type (cadr dirent))
    875          (name (car dirent))
    876          (props (cddr dirent)))
    877       (cond
    878          ((eq? type 'file)
    879             (extract-file! archive props (make-pathname target-path name)))
    880          ((eq? type 'dir)
    881             (extract-subdirectory! archive props (make-pathname target-path name)))
    882          ((eq? type 'symlink)
    883             (extract-symlink! archive props (make-pathname target-path name)))
    884          ((eq? type 'fifo)
    885             (extract-fifo! archive props (make-pathname target-path name)))
    886          ((eq? type 'block-device)
    887             (extract-block-device! archive props (make-pathname target-path name)))
    888          ((eq? type 'character-device)
    889             (extract-character-device! archive props (make-pathname target-path name)))
    890          (else
    891             (printf "ERROR: Found an object (~A) of unknown type (~A), skipping...\n" name type)))))
    892    
     947  (let ((type (cadr dirent))
     948        (name (car dirent))
     949        (props (cddr dirent)))
     950    (cond
     951     ((eq? type 'file)
     952      (extract-file! archive props (make-pathname target-path name)))
     953     ((eq? type 'dir)
     954      (extract-subdirectory! archive props (make-pathname target-path name)))
     955     ((eq? type 'symlink)
     956      (extract-symlink! archive props (make-pathname target-path name)))
     957     ((eq? type 'fifo)
     958      (extract-fifo! archive props (make-pathname target-path name)))
     959     ((eq? type 'block-device)
     960      (extract-block-device! archive props (make-pathname target-path name)))
     961     ((eq? type 'character-device)
     962      (extract-character-device! archive props (make-pathname target-path name)))
     963     (else
     964      (printf "ERROR: Found an object (~A) of unknown type (~A), skipping...\n" name type)))))
     965
    893966(define (extract-directory! archive key target-path)
    894    (fold-sexpr-stream archive key 'd 'di
    895       (lambda (dirent acc)
    896          (extract-object! archive dirent target-path)
    897          (void))
    898       '()))
     967  (fold-sexpr-stream archive key 'd 'di
     968                     (lambda (dirent acc)
     969                       (extract-object! archive dirent target-path)
     970                       (void))
     971                     '()))
    899972
    900973;; SINGLE SEXPRS
     
    902975;; Given an sexpr, a type and a list of (key . reused?) pairs, returns a key and a reused? flag.
    903976(define (store-sexpr! archive sexpr type keys)
    904    (let* ((data (blob->u8vector/shared (string->blob (with-output-to-string (lambda () (write sexpr))))))
    905           (hash ((archive-hash archive) data type)))
    906    
    907       (if (archive-exists? archive hash)
    908          (values (reusing hash) #t)
    909          (begin
    910             (for-each (lambda (key)
    911                (if (cdr key) ; reused?
    912                   (archive-link! archive (car key))))
    913                keys)
    914             (archive-put! archive hash data type)
    915             (values (virgin hash) #f)))))
     977  (let* ((data (blob->u8vector/shared (string->blob (with-output-to-string (lambda () (write sexpr))))))
     978        (hash ((archive-hash archive) data type)))
     979
     980    (if (archive-exists? archive hash)
     981        (values (reusing hash) #t)
     982        (begin
     983          (for-each (lambda (key)
     984                      (if (cdr key) ; reused?
     985                          (archive-link! archive (car key))))
     986                    keys)
     987          (archive-put! archive hash data type)
     988          (values (virgin hash) #f)))))
    916989
    917990(define (read-sexpr archive key)
    918    (let ((data (archive-get archive key)))
    919       (with-input-from-string
    920          (blob->string (u8vector->blob/shared data))
    921          (lambda ()
    922             (read)))))
     991  (let ((data (archive-get archive key)))
     992    (with-input-from-string
     993        (blob->string (u8vector->blob/shared data))
     994      (lambda ()
     995        (read)))))
    923996
    924997;; SNAPSHOT STORAGE
     
    9321005;; Returns the snapshot's key.
    9331006(define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties)
    934    (check-archive-writable archive)
    935    (archive-lock-tag! archive tag)
    936    (let ((previous (archive-tag archive tag))
    937           (snapshot
    938             (append
    939                (list
    940                   (cons 'mtime (time->seconds (current-time)))
    941                   (cons 'contents contents-key))
    942                snapshot-properties))
    943           (keys
    944             (list ; We do not list the previous snapshot - since we are about to overwrite the tag that points to it, which would be a decrement.
    945                (cons contents-key contents-reused?))))
    946       (if previous
    947          (begin
    948             (set! snapshot (cons
    949                (cons 'previous previous)
    950                snapshot))))
    951       (let-values (((snapshot-key snapshot-reused?)
    952                      (store-sexpr! archive snapshot 'snapshot keys)))
    953          (archive-set-tag! archive tag snapshot-key)
    954          (archive-unlock-tag! archive tag)
    955          snapshot-key)))
     1007  (check-archive-writable archive)
     1008  (archive-lock-tag! archive tag)
     1009  (let ((previous (archive-tag archive tag))
     1010        (snapshot
     1011        (append
     1012          (list
     1013           (cons 'mtime (time->seconds (current-time)))
     1014           (cons 'contents contents-key))
     1015          snapshot-properties))
     1016        (keys
     1017        (list ; We do not list the previous snapshot - since we are about to overwrite the tag that points to it, which would be a decrement.
     1018          (cons contents-key contents-reused?))))
     1019    (if previous
     1020        (begin
     1021          (set! snapshot (cons
     1022                          (cons 'previous previous)
     1023                          snapshot))))
     1024    (let-values (((snapshot-key snapshot-reused?)
     1025                  (store-sexpr! archive snapshot 'snapshot keys)))
     1026      (archive-set-tag! archive tag snapshot-key)
     1027      (archive-unlock-tag! archive tag)
     1028      snapshot-key)))
    9561029
    9571030(define (fold-history archive snapshot-key kons knil)
    958    (let ((snapshot (read-sexpr archive snapshot-key)))
    959       (if (assq 'previous snapshot)
    960          (kons snapshot-key snapshot
    961             (fold-history archive (cdr (assq 'previous snapshot)) kons knil))
    962          (kons snapshot-key snapshot knil))))
    963      
     1031  (let ((snapshot (read-sexpr archive snapshot-key)))
     1032    (if (assq 'previous snapshot)
     1033        (kons snapshot-key snapshot
     1034              (fold-history archive (cdr (assq 'previous snapshot)) kons knil))
     1035        (kons snapshot-key snapshot knil))))
     1036
    9641037;; BRING IT ALL TOGETHER
    9651038
    9661039(define (snapshot-directory-tree! archive tag path props)
    967    (check-archive-writable archive)
    968    (let-values (((root-key root-reused?)
    969                   (store-directory! archive path)))
    970       (tag-snapshot! archive tag root-key root-reused?
    971          (append
    972             (list
    973                (cons 'hostname (get-host-name))
    974                (cons 'prefix path))
    975             props))))
     1040  (check-archive-writable archive)
     1041  (let-values (((root-key root-reused?)
     1042                (call-with-context-support
     1043                 (archive-global-directory-rules archive)
     1044                 (lambda () (store-directory! archive path)))))
     1045    (tag-snapshot! archive tag root-key root-reused?
     1046                   (append
     1047                    (list
     1048                     (cons 'hostname (get-host-name))
     1049                     (cons 'prefix path))
     1050                    props))))
    9761051
    9771052(define (epochtime->string e)
    978    (let ((localtime (seconds->local-time e)))
    979       (string-append
    980          (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
    981          "-"
    982          (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
    983          "-"
    984          (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
    985          " "
    986          (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
    987          ":"
    988          (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
    989          ":"
    990          (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
    991 
    992 ; If given '() as the directory-key, makes a list of all tags
    993 ; If given '(tag . "tag-name"), makes a list of snapshots of that tag
    994 ; If given a key, if that key points to a directory, makes a list of the contents of that directory
    995 ; Either way, the list of results are folded into the provided kons and knil functions
    996 ; kons is called with three arguments: a directory-key for the object, a directory entry in the usual format, and the accumulator.
     1053  (let ((localtime (seconds->local-time e)))
     1054    (string-append
     1055     (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
     1056     "-"
     1057     (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
     1058     "-"
     1059     (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
     1060     " "
     1061     (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
     1062     ":"
     1063     (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
     1064     ":"
     1065     (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
     1066
     1067
     1068                                        ; If given '() as the directory-key, makes a list of all tags
     1069                                        ; If given '(tag . "tag-name"), makes a list of snapshots of that tag
     1070                                        ; If given a key, if that key points to a directory, makes a list of the contents of that directory
     1071                                        ; Either way, the list of results are folded into the provided kons and knil functions
     1072                                        ; kons is called with three arguments: a directory-key for the object, a directory entry in the usual format, and the accumulator.
    9971073(define (fold-archive-node archive directory-key kons knil)
    998    (cond
    999       ((null? directory-key)
    1000          ; List tags
    1001          (fold (lambda (tag acc)
    1002             (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag))) acc))
    1003             knil (archive-all-tags archive)))
    1004       ((and (pair? directory-key) (eq? (car directory-key) 'tag))
    1005          ; List a tag's snapshots
    1006          (let* ((tag (cdr directory-key))
    1007                 (current (archive-tag archive tag))
    1008                 (current-contents (read-sexpr archive current)))
    1009             (kons
    1010                (cdr (assq 'contents current-contents))
    1011                (cons "current" (cons 'snapshot current-contents))
    1012                (fold-history archive current
    1013                   (lambda (key snapshot acc)
    1014                      (kons
    1015                         (cdr (assq 'contents snapshot))
    1016                         (append
    1017                           (list (epochtime->string (cdr (assq 'mtime snapshot)))
    1018                            'snapshot)
    1019                           snapshot)
    1020                         acc))
    1021                   knil))))
    1022       ((string? directory-key)
    1023          ; List directory
    1024          (fold-sexpr-stream archive directory-key 'd 'di
    1025             (lambda (dirent acc)
    1026                   (let ((name (car dirent))
    1027                         (type (cadr dirent))
    1028                         (props (cddr dirent)))
    1029                      (cond
    1030                         ((eq? type 'file)
    1031                            (kons #f dirent acc))
    1032                         ((eq? type 'dir)
    1033                            (kons (cdr (assq 'contents props)) dirent acc))
    1034                         ((eq? type 'symlink)
    1035                            (kons #f dirent acc))
    1036                         (else
    1037                            (kons #f dirent acc)))))
    1038             knil)))) )
    1039 
     1074  (cond
     1075   ((null? directory-key)
     1076                                        ; List tags
     1077    (fold (lambda (tag acc)
     1078            (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag))) acc))
     1079          knil (archive-all-tags archive)))
     1080   ((and (pair? directory-key) (eq? (car directory-key) 'tag))
     1081                                        ; List a tag's snapshots
     1082    (let* ((tag (cdr directory-key))
     1083           (current (archive-tag archive tag))
     1084           (current-contents (read-sexpr archive current)))
     1085      (kons
     1086       (cdr (assq 'contents current-contents))
     1087       (cons "current" (cons 'snapshot current-contents))
     1088       (fold-history archive current
     1089                     (lambda (key snapshot acc)
     1090                       (kons
     1091                        (cdr (assq 'contents snapshot))
     1092                        (append
     1093                        (list (epochtime->string (cdr (assq 'mtime snapshot)))
     1094                               'snapshot)
     1095                        snapshot)
     1096                        acc))
     1097                     knil))))
     1098   ((string? directory-key)
     1099                                        ; List directory
     1100    (fold-sexpr-stream archive directory-key 'd 'di
     1101                       (lambda (dirent acc)
     1102                        (let ((name (car dirent))
     1103                               (type (cadr dirent))
     1104                               (props (cddr dirent)))
     1105                           (cond
     1106                            ((eq? type 'file)
     1107                             (kons #f dirent acc))
     1108                            ((eq? type 'dir)
     1109                             (kons (cdr (assq 'contents props)) dirent acc))
     1110                            ((eq? type 'symlink)
     1111                             (kons #f dirent acc))
     1112                            (else
     1113                             (kons #f dirent acc)))))
     1114                       knil))))
     1115)
  • release/4/ugarit/trunk/ugarit.meta

    r20243 r20269  
    11((egg "ugarit.egg")
    22 (files "ugarit.scm" "ugarit-core.scm" "backend-fs.scm" "backend-cache.scm" "backend-devtools.scm" "posixextras.scm" "ugarit.html" "ugarit.setup" "test.scm")
    3  (doc-from-wiki)
    4  (documentation "ugarit.html")
    53 (license "BSD")
    64 (category data)
  • release/4/ugarit/trunk/ugarit.setup

    r15242 r20269  
     1(compile -s -O2 -d1 directory-rules.scm -j directory-rules)
     2(compile -s -O2 -d1 directory-rules.import.scm)
     3(compile -c -O2 -d1 directory-rules.scm -unit directory-rules)
     4
     5(install-extension 'directory-rules '("directory-rules.so" "directory-rules.o" "directory-rules.import.so")
     6  '((version 0.7)
     7    (static "directory-rules.o")))
     8
    19(compile -s -O2 -d1 ugarit-core.scm -j ugarit-core)
    210(compile -s -O2 -d1 ugarit-core.import.scm)
    311(compile -c -O2 -d1 ugarit-core.scm -unit ugarit-core)
     12
    413(install-extension 'ugarit-core '("ugarit-core.so" "ugarit-core.o" "ugarit-core.import.so")
    5   '((version 0.5)
    6     (static "ugarit-core.o")
    7     (documentation "ugarit.html")))
     14  '((version 0.7)
     15    (static "ugarit-core.o")))
    816
    917(compile ugarit.scm)
    1018(install-program 'ugarit "ugarit"
    11   '((version 0.5)
    12     (documentation "ugarit.html")))
     19  '((version 0.7)))
Note: See TracChangeset for help on using the changeset viewer.