[functional-tests] Some work on thin-check and thin-dump

functional-tests/command-line/thin-check.scm

@@ -0,0 +1,93 @@
+(library
+  (command-line thin-check)
+  
+  (export )
+  
+  (import (thin thin-check))
+
+(define (help port)
+ (fmt port
+   "Usage: thin_check [options] {device|file}\n"
+   "Options:\n"
+   "  {-q|--quiet}\n"
+   "  {-h|--help}\n"
+   "  {-V|--version}\n"
+   "  {--clear-needs-check-flag}\n"
+   "  {--ignore-non-fatal-errors}\n"
+   "  {--skip-mappings}\n"
+   "  {--super-block-only}\n"))
+
+(define whitespace
+ (many+ (charset " \t\n")))
+
+(define (whitespace-delim ma)
+ (>> (opt whitespace)
+  (<* ma (opt whitespace))))
+
+(define (switch str)
+ (whitespace-delim (>> (lit "--") (lit str))))
+
+(define (switch-set . syms)
+ (whitespace-delim
+  (>> (lit "--")
+   (apply one-of (map (lambda (s)
+		       (>> (lit (symbol->string s)) (pure s)))
+		  syms)))))
+
+(define (short str)
+ (whitespace-delim (>> (lit "-") (lit str))))
+
+(define help-command-line
+ (>> (one-of (switch "help") (switch "h"))
+  (pure (lambda ()
+	 (help (current-output-port))))))
+
+;; FIXME: move somewhere
+(define tools-version "0.8.0")
+
+(define version-command-line
+ (>> (one-of (short "V") (switch "version"))
+  (pure (lambda ()
+	 (display tools-version)
+	 (display "\n")))))
+
+(define switches
+  (many*
+   (switch-set
+    'quiet
+    'clear-needs-check-flag
+    'ignore-non-fatal-errors
+    'skip-mappings
+    'super-block-only)))
+
+(define not-switch
+ (whitespace-delim
+  (parse-m
+   (<- c (neg-charset "- \t"))
+   (<- cs (many* (neg-charset " \t")))
+   (pure (list->string (cons c cs))))))
+
+(define main-command-line
+ (parse-m
+  (<- ss switches)
+  (<- path not-switch)
+  eof
+  (pure (lambda () (run ss path)))))
+
+(define command-line-parser
+ (one-of
+    help-command-line
+    version-command-line
+    main-command-line))
+
+(define (bad-command-line)
+  (fmt (current-error-port) (dsp "bad command line\n"))
+  (help (current-error-port))
+  (exit 1))
+
+(define (parse-command-line args)
+  (receive (v st) (parse command-line-parser
+		   (apply string-append (intersperse " " args)))
+   ((if (success? st) v bad-command-line))))
+
+)

functional-tests/thin/check.scm

@@ -1,10 +1,20 @@
-(import
+(library
-  (bcache block-manager)
+ (thin check)
-  (btree)
+
-  (fmt fmt)
+ (export thin-check
-  (matchable)
+         thin-check-flags)
-  (mapping-tree)
+
-  (chezscheme))
+ (import
+   (bcache block-manager)
+   (persistent-data btree)
+   (fmt fmt)
+   (list-utils)
+   (matchable)
+   (parser-combinators)
+   (srfi s8 receive)
+   (thin metadata)
+   (thin mapping-tree)
+   (chezscheme))
 
 ;;;;---------------------------------------------------
 ;;;; Constants
@@ -18,74 +28,64 @@
 (define $uuid-size 16)
 (define $space-map-root-size 128)
 
-(define-ftype Superblock
+(define-compound-value-type device-details-vt ThinDeviceDetails)
-  (packed
-    (endian little
-      (struct
-        (csum unsigned-32)
-        (flags unsigned-32)
-        (block-nr unsigned-64)
-        (uuid (bytes $uuid-size))
-        (magic unsigned-32)
-        (version unsigned-32)
-        (time unsigned-32)
-        (trans-id unsigned-64)
-        (metadata-snap unsigned-64)
-        (data-space-map-root (bytes $space-map-root-size))
-        (metadata-space-map-root (bytes $space-map-root-size))
-        (data-mapping-root unsigned-64)
-        (device-details-root unsigned-64)
-        (data-block-size unsigned-32)
-        (metadata-block-size unsigned-32)
-        (metadata-nr-blocks unsigned-64)
-        (compat-flags unsigned-32)
-        (compat-ro-flags unsigned-32)
-        (incompat-flags unsigned-32)))))
 
-;;;;---------------------------------------------------
+(define (block->superblock b)
-;;;; Top level
+ (make-ftype-pointer ThinSuperblock (block-data b)))
-;;;;---------------------------------------------------
 
-(define (check-magic sb)
+;;;------------------------------------------------
-  ((let ((m (bytevector-u32-ref sb 32 (endianness little))))
+;;; Fluid vars for the switches
-    (fmt #t (dsp "on disk magic: ") (num m) nl)
-    )))
 
-(define (read-superblock)
+(define quiet #f)
-  (with-metadata (md (current-metadata))
+(define clear-needs-check-flag #f)
-                 (superblock-unpack (read-block md 0) 0)))
+(define ignore-non-fatal-errors #f)
+(define skip-mappings #f)
+(define super-block-only #f)
 
-(define (dump-dev-tree)
+(define (dump-dev-tree cache root)
-  (with-metadata (md (current-metadata))
+ (btree-each (btree-open device-details-vt cache root)
-                 (let ((sb (superblock-unpack (read-block md 0) 0)))
+             (lambda (k v)
-                  (btree-each (btree-open le64-type md (superblock-data-mapping-root sb))
+	      (fmt #t
-                              (lambda (k v)
+                   "dev-id: " k "\n"
-                                (fmt #t (dsp "dev-id: ") (num k)
+                   "  mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n"
-                                     (dsp ", mapping root: ") (num v) nl))))))
+                   "  transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n"
+                   "  creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n"
+                   "  snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n"))))
 
-(define (dump-mappings root)
+(define-enumeration thin-check-element
-  (with-metadata (md (current-metadata))
+  (quiet
-                 (btree-each (btree-open le64-type md root)
+   clear-needs-check-flag
-                             (lambda (k v)
+   ignore-non-fatal-errors
-                               (fmt #t (dsp "vblock: ") (num k)
+   skip-mappings
-                                    (dsp ", pblock: ") (num v) nl)))))
+   super-block-only)
+  thin-check-flags)
 
-(define (dump-all-mappings)
+(define (thin-check metadata-path flags)
-  (with-metadata (md (current-metadata))
+ (define (member? s)
-                 (let ((sb (superblock-unpack (read-block md 0) 0)))
+   (enum-set-member? s flags))
-                  (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
-                   (mapping-tree-each mappings
-                                      (lambda (dev-id vblock pblock time)
-                                        (fmt #t
-                                             (dsp "thin dev ") (num dev-id)
-                                             (dsp ", vblock ") (num vblock)
-                                             (dsp ", pblock ") (num pblock)
-                                             (dsp ", time ") (num time)
-                                             nl)))))))
 
-(define (check-superblock)
+ (fluid-let ((quiet (member? 'quiet))
-  (with-metadata (md (current-metadata))
+	     (clear-needs-check-flag (member? 'clear-needs-check-flag))
-                 (let ((superblock (read-block md 0)))
+	     (ignore-non-fatal-errors (member? 'ignore-non-fatal-errors))
-                  (fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl)
+	     (skip-mappings (member? 'skip-mappings))
-                  ;(fmt #t (dsp "calculated checksum: ") (dsp (crc32-region $superblock-salt superblock 4 4092)) nl)
+	     (super-block-only (member? 'super-block-only)))
-                  (check-magic superblock))))
+
+  (fmt (current-output-port)
+   "quiet: " quiet "\n"
+   "clear-needs-check-flag: " clear-needs-check-flag "\n"
+   "ignore-non-fatal-errors: " ignore-non-fatal-errors "\n"
+   "skip-mappings: " skip-mappings "\n"
+   "super-block-only: " super-block-only "\n"
+   "input-file: " metadata-path "\n")
+
+  (with-bcache (cache metadata-path 1024)
+   (with-block (b cache 0 (get-flags))
+    (let ((sb (block->superblock b)))
+     (fmt (current-output-port)
+      "block-nr: " (ftype-ref ThinSuperblock (block-nr) sb) "\n"
+      "magic: " (ftype-ref ThinSuperblock (magic) sb) "\n"
+      "data-mapping-root: " (ftype-ref ThinSuperblock (data-mapping-root) sb) "\n"
+      "device-details-root: " (ftype-ref ThinSuperblock (device-details-root) sb) "\n")
+     (dump-dev-tree cache (ftype-ref ThinSuperblock (device-details-root) sb)))))))
+
+ )

functional-tests/thin/dump.scm

@@ -0,0 +1,56 @@
+(library
+ (thin check)
+
+ (export thin-dump
+         thin-dump-flags)
+
+ (import
+   (bcache block-manager)
+   (persistent-data btree)
+   (fmt fmt)
+   (list-utils)
+   (matchable)
+   (parser-combinators)
+   (srfi s8 receive)
+   (thin metadata)
+   (thin mapping-tree)
+   (chezscheme))
+
+(define (dump-dev-tree cache root)
+ (btree-each (btree-open device-details-vt cache root)
+             (lambda (k v)
+	      (fmt #t
+                   "dev-id: " k "\n"
+                   "  mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n"
+                   "  transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n"
+                   "  creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n"
+                   "  snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n"))))
+
+(define-enumeration thin-check-element
+  (quiet
+   clear-needs-check-flag
+   ignore-non-fatal-errors
+   skip-mappings
+   super-block-only)
+  thin-check-flags)
+
+(define (thin-check metadata-path flags)
+ (tag 'superblock `((uuid . "<not implemented yet>")
+                    (time . )
+                    (transaction . 1)
+                    (flags . 0)
+                    (version . 2)
+                    (data-block-size . 128)
+                    (nr-data-blocks . ,(apply + nr-mappings)))
+
+  (with-bcache (cache metadata-path 1024)
+   (with-block (b cache 0 (get-flags))
+    (let ((sb (block->superblock b)))
+     (fmt (current-output-port)
+      "block-nr: " (ftype-ref ThinSuperblock (block-nr) sb) "\n"
+      "magic: " (ftype-ref ThinSuperblock (magic) sb) "\n"
+      "data-mapping-root: " (ftype-ref ThinSuperblock (data-mapping-root) sb) "\n"
+      "device-details-root: " (ftype-ref ThinSuperblock (device-details-root) sb) "\n")
+     (dump-dev-tree cache (ftype-ref ThinSuperblock (device-details-root) sb)))))))
+
+ )

functional-tests/thin/mapping-tree.scm

@@ -1,11 +1,11 @@
 (library
-  (mapping-tree)
+  (thin mapping-tree)
 
   (export mapping-tree-open
           mapping-tree-lookup
           mapping-tree-each)
 
-  (import (btree)
+  (import (persistent-data btree)
           (chezscheme)
           (srfi s8 receive))
 
@@ -35,8 +35,8 @@
 
      (define (visit-dev dev-id mapping-root)
        (btree-each (btree-open le64-vt (btree-bcache dev-tree) mapping-root)
-                   (lambda (vblock mapping)
+         (lambda (vblock mapping)
-                     (receive (block time) (unpack-block-time mapping)
+           (receive (block time) (unpack-block-time mapping)
-                              (fn dev-id vblock block time)))))
+             (fn dev-id vblock block time)))))
 
      (btree-each dev-tree visit-dev))))

functional-tests/thin/metadata.scm

@@ -0,0 +1,53 @@
+(library
+  (thin metadata)
+
+  (export ThinSuperblock
+          ThinDeviceDetails)
+
+  (import (chezscheme))
+
+  (define $superblock-magic 27022010)
+  (define $superblock-salt 160774)
+  (define $uuid-size 16)
+  (define $space-map-root-size 128)
+
+  (define-compound-value-type device-details-vt ThinDeviceDetails)
+
+  (define (block->superblock b)
+          (make-ftype-pointer ThinSuperblock (block-data b)))
+
+  (define-ftype ThinSuperblock
+                (packed
+                  (endian little
+                          (struct
+                            (csum unsigned-32)
+                            (flags unsigned-32)
+                            (block-nr unsigned-64)
+                            (uuid (array 16 unsigned-8))
+                            (magic unsigned-64)
+                            (version unsigned-32)
+                            (time unsigned-32)
+                            (trans-id unsigned-64)
+                            (metadata-snap unsigned-64)
+                            (data-space-map-root (array 128 unsigned-8))
+                            (metadata-space-map-root (array 128 unsigned-8))
+                            (data-mapping-root unsigned-64)
+                            (device-details-root unsigned-64)
+                            (data-block-size unsigned-32)
+                            (metadata-block-size unsigned-32)
+                            (metadata-nr-blocks unsigned-64)
+                            (compat-flags unsigned-32)
+                            (compat-ro-flags unsigned-32)
+                            (incompat-flags unsigned-32)))))
+
+  (define-ftype ThinDeviceDetails
+                (packed
+                  (endian little
+                          (struct
+                            (mapped-blocks unsigned-64)
+                            (transaction-id unsigned-64)
+                            (creation-time unsigned-32)
+                            (snapshotted-time unsigned-32)))))
+
+  )
+

functional-tests/thin/xml.scm

@@ -1,5 +1,5 @@
 (library
-  (thin-xml)
+  (thin xml)
   (export generate-xml)
   (import (rnrs)
           (list-utils)