diff --git a/.gitignore b/.gitignore index 4544b4f..47e6166 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,6 @@ *~ +*.swp +*.swo *.o *.so *.a diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm new file mode 100644 index 0000000..95c18e0 --- /dev/null +++ b/functional-tests/binary-format.scm @@ -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 ) 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) ...))))))))) diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm new file mode 100644 index 0000000..dc873a2 --- /dev/null +++ b/functional-tests/block-io.scm @@ -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)))))) + + diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm index 3129d1d..e3cccb8 100644 --- a/functional-tests/check-superblock.scm +++ b/functional-tests/check-superblock.scm @@ -1,4 +1,5 @@ (import + (block-io) (fmt fmt) (matchable)) @@ -10,115 +11,11 @@ (define (current-metadata) "./metadata.bin") -(define metadata-block-size 4096) (define superblock-magic 27022010) (define superblock-salt 160774) (define uuid-size 16) (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 ) 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) (csum le32) (flags le32) diff --git a/functional-tests/crc32.scm b/functional-tests/crc32.scm new file mode 100644 index 0000000..c50d8d0 --- /dev/null +++ b/functional-tests/crc32.scm @@ -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)))))) +