[functional tests] first steps in parsing the binary format.

functional-tests/check-superblock.scm

@@ -0,0 +1,151 @@
+(import
+  (fmt fmt)
+  (matchable))
+
+;;;;---------------------------------------------------
+;;;; Constants
+;;;;---------------------------------------------------
+
+;; FIXME: duplicate with main.scm
+(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 4k bytevector
+(define (read-block port b)
+  (set-port-position! port (* b metadata-block-size))
+  (let ((data (get-bytevector-n port metadata-block-size)))
+   (unless (and (not (eof-object? data))
+                (= metadata-block-size (bytevector-length data)))
+     (io-error (fmt #f (dsp "unable to read metadata block: ") (num b))))
+   data))
+
+;;;;---------------------------------------------------
+;;;; 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->datum
+    (syntax-case t (le32 le64 bytes)
+                 (le32 #'4)
+                 (le64 #'8)
+                 ((bytes count) #'count))))
+
+(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 (+ acc (size-type (car types))) (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)
+  (block-nr le64)
+  (uuid (bytes 16))
+  (magic le64)
+  (version le32)
+  (time le32)
+  (trans-id le64)
+  (metadata-snap le64)
+  (data-space-map-root (bytes 128))
+  (metadata-space-map-root (bytes 128))
+  (data-mapping-root le64)
+  (device-details-root le64)
+  (data-block-size le32)
+  (metadata-block-size le32)
+  (metadata-nr-blocks le64)
+  (compat-flags le32)
+  (compat-ro-flags le32)
+  (incompat-flags le32))
+
+;;;;---------------------------------------------------
+;;;; Top level
+;;;;---------------------------------------------------
+
+(define (check-magic sb)
+  ((let ((m (bytevector-u32-ref sb 32 (endianness little))))
+    (fmt #t (dsp "on disk magic: ") (num m) nl)
+    )))
+
+(define (read-superblock)
+  (with-metadata (md (current-metadata))
+                 (unpack-superblock (read-block md 0) 0)))
+
+(define (check-superblock)
+  (with-metadata (md (current-metadata))
+                 (let ((superblock (read-block md 0)))
+                  (fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl)
+                  (fmt #t (dsp "calculated checksum: ") (dsp (crc32-region superblock-salt superblock 4 4092)) nl)
+                  (check-magic superblock))))