[functional tests] Break up check-superblock.scm into separate
libraries
This commit is contained in:
Joe Thornber
parent
2f355f64ff
commit
57db3a2b99
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,4 +1,6 @@
|
|||||||
*~
|
*~
|
||||||
|
*.swp
|
||||||
|
*.swo
|
||||||
*.o
|
*.o
|
||||||
*.so
|
*.so
|
||||||
*.a
|
*.a
|
||||||
|
|||||||
41
functional-tests/binary-format.scm
Normal file
41
functional-tests/binary-format.scm
Normal file
@ -0,0 +1,41 @@
|
|||||||
|
(library
|
||||||
|
(binary-format)
|
||||||
|
(export binary-format)
|
||||||
|
(import (rnrs))
|
||||||
|
|
||||||
|
(define-syntax unpack-type
|
||||||
|
(syntax-rules (le32 le64 bytes)
|
||||||
|
((_ bv offset le32)
|
||||||
|
(bytevector-u32-ref bv offset (endianness little)))
|
||||||
|
|
||||||
|
((_ bv offset le64)
|
||||||
|
(bytevector-u64-ref bv offset (endianness little)))
|
||||||
|
|
||||||
|
((_ bv offset (bytes count))
|
||||||
|
(let ((copy (make-bytevector count)))
|
||||||
|
(bytevector-copy! bv offset copy 0 count)
|
||||||
|
copy))))
|
||||||
|
|
||||||
|
(define (size-type t)
|
||||||
|
(syntax-case t (le32 le64 bytes)
|
||||||
|
(le32 #'4)
|
||||||
|
(le64 #'8)
|
||||||
|
((bytes count) #'count)))
|
||||||
|
|
||||||
|
;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
|
||||||
|
(define-syntax binary-format
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case x ()
|
||||||
|
((_ (name pack-name unpack-name) (field type) ...)
|
||||||
|
(with-syntax ((((t o) ...)
|
||||||
|
(let f ((acc 0) (types #'(type ...)))
|
||||||
|
(if (null? types)
|
||||||
|
'()
|
||||||
|
(cons (list (car types) acc)
|
||||||
|
(f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
|
||||||
|
#`(begin
|
||||||
|
(define-record-type name (fields field ...))
|
||||||
|
|
||||||
|
(define (unpack-name bv offset)
|
||||||
|
((record-constructor (record-type-descriptor name))
|
||||||
|
(unpack-type bv (+ offset o) t) ...)))))))))
|
||||||
53
functional-tests/block-io.scm
Normal file
53
functional-tests/block-io.scm
Normal file
@ -0,0 +1,53 @@
|
|||||||
|
(library
|
||||||
|
(block-io)
|
||||||
|
(export metadata-block-size
|
||||||
|
open-metadata
|
||||||
|
with-metadata
|
||||||
|
read-block)
|
||||||
|
(import (rnrs)
|
||||||
|
(fmt fmt))
|
||||||
|
|
||||||
|
;;;---------------------------------------------------
|
||||||
|
;;; TODO:
|
||||||
|
;;; - implement a little block cache.
|
||||||
|
;;; - writes
|
||||||
|
;;; - zero blocks
|
||||||
|
;;; - prefetching
|
||||||
|
;;;---------------------------------------------------
|
||||||
|
|
||||||
|
(define metadata-block-size 4096)
|
||||||
|
|
||||||
|
(define (open-metadata path)
|
||||||
|
(open-file-input-port path (file-options) (buffer-mode none)))
|
||||||
|
|
||||||
|
(define-syntax with-metadata
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ (port path) body ...) (let ((port (open-metadata path)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda () #f)
|
||||||
|
(lambda () body ...)
|
||||||
|
(lambda () (close-port port)))))))
|
||||||
|
|
||||||
|
;; FIXME: return our own condition?
|
||||||
|
(define (io-error msg)
|
||||||
|
(raise (condition
|
||||||
|
(make-error)
|
||||||
|
(make-message-condition msg))))
|
||||||
|
|
||||||
|
;;; Returns a boolean indicating success
|
||||||
|
(define (read-exact! port offset len bv start)
|
||||||
|
(set-port-position! port offset)
|
||||||
|
(let ((nr (get-bytevector-n! port bv start len)))
|
||||||
|
(and (not (eof-object? nr))
|
||||||
|
(= len nr))))
|
||||||
|
|
||||||
|
;;; Returns a 4k bytevector or #f
|
||||||
|
(define (read-exact port offset len)
|
||||||
|
(let ((bv (make-bytevector len)))
|
||||||
|
(if (read-exact! port offset len bv 0) bv #f)))
|
||||||
|
|
||||||
|
(define (read-block port b)
|
||||||
|
(or (read-exact port (* b metadata-block-size) metadata-block-size)
|
||||||
|
(io-error (fmt #f (dsp "Unable to read metadata block: ") (num b))))))
|
||||||
|
|
||||||
|
|
||||||
@ -1,4 +1,5 @@
|
|||||||
(import
|
(import
|
||||||
|
(block-io)
|
||||||
(fmt fmt)
|
(fmt fmt)
|
||||||
(matchable))
|
(matchable))
|
||||||
|
|
||||||
@ -10,115 +11,11 @@
|
|||||||
(define (current-metadata)
|
(define (current-metadata)
|
||||||
"./metadata.bin")
|
"./metadata.bin")
|
||||||
|
|
||||||
(define metadata-block-size 4096)
|
|
||||||
(define superblock-magic 27022010)
|
(define superblock-magic 27022010)
|
||||||
(define superblock-salt 160774)
|
(define superblock-salt 160774)
|
||||||
(define uuid-size 16)
|
(define uuid-size 16)
|
||||||
(define space-map-root-size 128)
|
(define space-map-root-size 128)
|
||||||
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
;;;; Metadata IO
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
|
|
||||||
(define (open-metadata path)
|
|
||||||
(open-file-input-port path (file-options) (buffer-mode none)))
|
|
||||||
|
|
||||||
(define-syntax with-metadata
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ (port path) body ...) (let ((port (open-metadata path)))
|
|
||||||
(dynamic-wind
|
|
||||||
(lambda () #f)
|
|
||||||
(lambda () body ...)
|
|
||||||
(lambda () (close-port port)))))))
|
|
||||||
|
|
||||||
;; FIXME: return our own condition?
|
|
||||||
(define (io-error msg)
|
|
||||||
(raise (condition
|
|
||||||
(make-error)
|
|
||||||
(make-message-condition msg))))
|
|
||||||
|
|
||||||
;;; Returns a boolean indicating success
|
|
||||||
(define (read-exact! port offset len bv start)
|
|
||||||
(set-port-position! port offset)
|
|
||||||
(let ((nr (get-bytevector-n! port bv start len)))
|
|
||||||
(and (not (eof-object? nr))
|
|
||||||
(= len nr))))
|
|
||||||
|
|
||||||
;;; Returns a 4k bytevector or #f
|
|
||||||
(define (read-exact port offset len)
|
|
||||||
(let ((bv (make-bytevector len)))
|
|
||||||
(if (read-exact! port offset len bv 0) bv #f)))
|
|
||||||
|
|
||||||
(define (read-block port b)
|
|
||||||
(or (read-exact port (* b metadata-block-size) metadata-block-size)
|
|
||||||
(io-error (fmt #f (dsp "Unable to read metadata block: ") (num b)))))
|
|
||||||
|
|
||||||
;;; FIXME: implement a little block cache.
|
|
||||||
|
|
||||||
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
;;;; CRC32
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
|
|
||||||
;; FIXME: move to own library
|
|
||||||
(load-shared-object "libz.so")
|
|
||||||
(define crc32
|
|
||||||
(foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long))
|
|
||||||
|
|
||||||
(define crc32-combine
|
|
||||||
(foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long))
|
|
||||||
|
|
||||||
;; FIXME: stop copying the bytevector. I'm not sure how to pass an offset into
|
|
||||||
;; the bv.
|
|
||||||
(define (crc32-region salt bv start end)
|
|
||||||
(assert (< start end))
|
|
||||||
(let ((len (- end start)))
|
|
||||||
(let ((copy (make-bytevector len)))
|
|
||||||
(bytevector-copy! bv start copy 0 len)
|
|
||||||
(let ((crc (crc32 salt copy 0)))
|
|
||||||
(crc32 crc copy len)))))
|
|
||||||
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
;;;; Decoding
|
|
||||||
;;;;---------------------------------------------------
|
|
||||||
|
|
||||||
(define-syntax unpack-type
|
|
||||||
(syntax-rules (le32 le64 bytes)
|
|
||||||
((_ bv offset le32)
|
|
||||||
(bytevector-u32-ref bv offset (endianness little)))
|
|
||||||
|
|
||||||
((_ bv offset le64)
|
|
||||||
(bytevector-u64-ref bv offset (endianness little)))
|
|
||||||
|
|
||||||
((_ bv offset (bytes count))
|
|
||||||
(let ((copy (make-bytevector count)))
|
|
||||||
(bytevector-copy! bv offset copy 0 count)
|
|
||||||
copy))))
|
|
||||||
|
|
||||||
(define (size-type t)
|
|
||||||
(syntax-case t (le32 le64 bytes)
|
|
||||||
(le32 #'4)
|
|
||||||
(le64 #'8)
|
|
||||||
((bytes count) #'count)))
|
|
||||||
|
|
||||||
;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
|
|
||||||
(define-syntax binary-format
|
|
||||||
(lambda (x)
|
|
||||||
(syntax-case x ()
|
|
||||||
((_ (name pack-name unpack-name) (field type) ...)
|
|
||||||
(with-syntax ((((t o) ...)
|
|
||||||
(let f ((acc 0) (types #'(type ...)))
|
|
||||||
(if (null? types)
|
|
||||||
'()
|
|
||||||
(cons (list (car types) acc)
|
|
||||||
(f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
|
|
||||||
#`(begin
|
|
||||||
(define-record-type name (fields field ...))
|
|
||||||
|
|
||||||
(define (unpack-name bv offset)
|
|
||||||
((record-constructor (record-type-descriptor name))
|
|
||||||
(unpack-type bv (+ offset o) t) ...))))))))
|
|
||||||
|
|
||||||
(binary-format (superblock pack-superblock unpack-superblock)
|
(binary-format (superblock pack-superblock unpack-superblock)
|
||||||
(csum le32)
|
(csum le32)
|
||||||
(flags le32)
|
(flags le32)
|
||||||
|
|||||||
23
functional-tests/crc32.scm
Normal file
23
functional-tests/crc32.scm
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
(library
|
||||||
|
(crc32)
|
||||||
|
(export crc32)
|
||||||
|
(import (chezscheme))
|
||||||
|
|
||||||
|
(load-shared-object "libz.so")
|
||||||
|
|
||||||
|
(define crc32
|
||||||
|
(foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long))
|
||||||
|
|
||||||
|
(define crc32-combine
|
||||||
|
(foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long))
|
||||||
|
|
||||||
|
;; FIXME: stop copying the bytevector. I'm not sure how to pass an offset
|
||||||
|
;; into the bv.
|
||||||
|
(define (crc32-region salt bv start end)
|
||||||
|
(assert (< start end))
|
||||||
|
(let ((len (- end start)))
|
||||||
|
(let ((copy (make-bytevector len)))
|
||||||
|
(bytevector-copy! bv start copy 0 len)
|
||||||
|
(let ((crc (crc32 salt copy 0)))
|
||||||
|
(crc32 crc copy len))))))
|
||||||
|
|
||||||
Loading…
Reference in New Issue
Block a user