[functional-tests] thin_check scenarios now work.

functional-tests/list-utils.scm

@@ -0,0 +1,25 @@
+(library
+  (list-utils)
+  (export intersperse iterate accumulate)
+  (import (rnrs))
+
+  (define (intersperse sep xs)
+    (cond
+      ((null? xs) '())
+      ((null? (cdr xs)) xs)
+      (else (cons (car xs)
+                  (cons sep
+                        (intersperse sep (cdr xs)))))))
+
+  (define (iterate fn count)
+    (let loop ((count count))
+     (if (zero? count)
+        '()
+        (cons (fn) (loop (- count 1))))))
+
+  ;; calculates a running total for a list.  Returns a list.
+  (define (accumulate xs)
+    (let loop ((xs xs) (total 0))
+     (if (null? xs)
+         '()
+         (cons total (loop (cdr xs) (+ total (car xs))))))))

functional-tests/main.scm

@@ -1,4 +1,6 @@
-(import (fmt fmt))
+(import (fmt fmt)
+        (thin-xml)
+        (only (srfi s1 lists) drop-while))
 
 ;;;--------------------------------------------------------------------
 
@@ -30,16 +32,21 @@
                          info-lines)))
 
 ;;;--------------------------------------------------------------------
-;;; Run a sub process and capture it's output.
+
-;;; Ideally we'd use open-process-ports, but that loses us the exit code which
-;;; we need for testing.  So we use system, and redirect stderr and stdout to
-;;; temporary files, and subsequently read them in.  Messy, but fine for tests.
 (define temp-file
   (let ((counter 0))
    (lambda ()
-     (let ((path (cat (dsp "/tmp/thinp-functional-tests-") (pad-char #\0 (pad/left 4 (num counter))))))
+     (let loop ()
-      (set! counter (+ counter 1))
+       (let ((path (fmt #f (cat (dsp "/tmp/thinp-functional-tests-")
-      (fmt #f path)))))
+                                (pad-char #\0 (pad/left 4 (num counter)))))))
+         (set! counter (+ counter 1))
+         (if (file-exists? path) (loop) path))))))
+
+;; Creates a temporary file with the specified contents.
+(define (temp-file-containing contents)
+  (let ((path (temp-file)))
+   (with-output-to-file path (lambda () (put-string (current-output-port) contents)))
+   path))
 
 (define (slurp-file path)
   (define (slurp)
@@ -50,6 +57,12 @@
 
   (with-input-from-file path slurp))
 
+;;;--------------------------------------------------------------------
+;;; Run a sub process and capture it's output.
+;;; Ideally we'd use open-process-ports, but that loses us the exit code which
+;;; we need for testing.  So we use system, and redirect stderr and stdout to
+;;; temporary files, and subsequently read them in.  Messy, but fine for tests.
+
 (define (build-command-line cmd-and-args)
   (apply fmt #f (map dsp (intersperse " " cmd-and-args))))
 
@@ -97,12 +110,14 @@
   (hashtable-set! scenarios sym s))
 
 (define (list-scenarios)
-  (vector->list (vector-sort-by string<? symbol->string (hashtable-keys scenarios))))
+  (vector->list
+        (vector-sort-by string<? symbol->string (hashtable-keys scenarios))))
 
 (define (describe-scenarios ss)
   (define (describe sym)
     (fmt #t
-         (columnar (dsp sym) (justify (scenario-desc (hashtable-ref scenarios sym #f))))
+         (columnar (dsp sym)
+                   (justify (scenario-desc (hashtable-ref scenarios sym #f))))
          nl))
 
   (for-each describe ss))
@@ -145,16 +160,6 @@
                (dsp ", ")
                (wrt str2)))))
 
-(scenario thin-check-v
-          "thin_check -V"
-          (let-values (((stdout stderr) (thin-check "-V")))
-                      (assert-equal tools-version stdout)))
-
-(scenario thin-check-version
-          "thin_check --version"
-          (let-values (((stdout stderr) (thin-check "--version")))
-                      (assert-equal tools-version stdout)))
-
 (define thin-check-help
   "Usage: thin_check [options] {device|file}
 Options:
@@ -166,26 +171,11 @@ Options:
   {--skip-mappings}
   {--super-block-only}")
 
-(scenario thin-check-h
-          "print help (-h)"
-          (let-values (((stdout stderr) (thin-check "-h")))
-                      (assert-equal thin-check-help stdout)))
-
-(scenario thin-check-help
-          "print help (--help)"
-          (let-values (((stdout stderr) (thin-check "--help")))
-                      (assert-equal thin-check-help stdout)))
-
-(scenario thin-bad-option
-          "Unrecognised option should cause failure"
-          (run-fail "thin_check --hedgehogs-only"))
-
 (define (current-metadata)
   "metadata.bin")
 
 (define (%with-valid-metadata thunk)
-  (let ((xml-file (temp-file)))
+  (let ((xml-file (temp-file-containing (fmt #f (generate-xml 10 1000)))))
-   (run-ok "thinp_xml create --nr-thins uniform[4..9] --nr-mappings uniform[1000..10000] > " xml-file)
    (run-ok "thin_restore" "-i" xml-file "-o" (current-metadata))
    (thunk)))
 
@@ -202,15 +192,63 @@ Options:
   (syntax-rules ()
     ((_ body ...) (%with-corrupt-metadata (lambda () body ...)))))
 
-(scenario thin-check-valid
+;;;-----------------------------------------------------------
+;;; Scenarios
+;;;-----------------------------------------------------------
+
+(scenario thin-check-v
+          "thin_check -V"
+          (let-values (((stdout stderr) (thin-check "-V")))
+                      (assert-equal tools-version stdout)))
+
+(scenario thin-check-version
+          "thin_check --version"
+          (let-values (((stdout stderr) (thin-check "--version")))
+                      (assert-equal tools-version stdout)))
+
+(scenario thin-check-h
+          "print help (-h)"
+          (let-values (((stdout stderr) (thin-check "-h")))
+                      (assert-equal thin-check-help stdout)))
+
+(scenario thin-check-help
+          "print help (--help)"
+          (let-values (((stdout stderr) (thin-check "--help")))
+                      (assert-equal thin-check-help stdout)))
+
+(scenario thin-bad-option
+          "Unrecognised option should cause failure"
+          (run-fail "thin_check --hedgehogs-only"))
+
+(scenario thin-check-superblock-only-valid
           "--super-block-only check passes on valid metadata"
           (with-valid-metadata
-            (thin_check "--super-block-only" (current-metadata))))
+            (thin-check "--super-block-only" (current-metadata))))
 
-(scenario thin-check-invalid
+(scenario thin-check-superblock-only-invalid
           "--super-block-only check fails with corrupt metadata"
           (with-corrupt-metadata
             (let-values (((stdout stderr) (run-fail "thin_check" "--super-block-only" (current-metadata))))
                         #t)))
 
+(scenario thin-check-skip-mappings-valid
+          "--skip-mappings check passes on valid metadata"
+          (with-valid-metadata
+            (thin-check "--skip-mappings" (current-metadata))))
+
+(scenario thin-check-ignore-non-fatal-errors
+          "--ignore-non-fatal-errors check passes on valid metadata"
+          (with-valid-metadata
+            (thin-check "--ignore-non-fatal-errors" (current-metadata))))
+
+(scenario thin-check-quiet
+          "--quiet should give no output"
+          (with-invalid-metadata
+            (run-fail "thin_check" "--quiet" (current-metadata))))
+
+(scenario thin-check-clear-needs-check-flag
+          "Accepts --clear-needs-check-flag"
+          (with-valid-metadata
+            (thin-check "--clear-needs-check-flag" (current-metadata))))
+
 ;;;--------------------------------------------------------------------

functional-tests/thin-xml.scm

@@ -0,0 +1,104 @@
+(library
+  (thin-xml)
+  (export generate-xml to-attribute-name)
+  (import (rnrs)
+          (list-utils)
+          (fmt fmt)
+          (only (srfi s1 lists) iota)
+          (srfi s27 random-bits))
+
+  ;;;----------------------------------------
+
+  (define (make-const-generator n)
+    (lambda () n))
+
+  (define (make-uniform-generator low hi)
+    (assert (<= low hi))
+
+    (let ((range (- hi low)))
+     (lambda ()
+      (+ low (random-integer range)))))
+
+  ;;;----------------------------------------
+
+  (define (dquote doc)
+    (cat (dsp #\") doc (dsp #\")))
+
+  (define (to-attribute-name sym)
+    (define (to-underscore c)
+      (if (eq? #\- c) #\_ c))
+
+    (list->string (map to-underscore (string->list (symbol->string sym)))))
+
+  (define (attribute dotted-pair)
+    (let ((key (to-attribute-name (car dotted-pair)))
+          (val (cdr dotted-pair)))
+      (cat (dsp key)
+           (dsp "=")
+           (dquote ((if (string? val) dsp wrt) val)))))
+
+  (define (%open-tag sym attrs end)
+    (cat (dsp "<")
+         (dsp sym)
+         (dsp " ")
+         (apply cat (intersperse (dsp " ")
+                                 (map attribute attrs)))
+         (dsp end)))
+
+  (define (open-tag sym attrs)
+    (%open-tag sym attrs ">"))
+
+  (define (simple-tag sym attrs)
+    (%open-tag sym attrs "/>"))
+
+  (define (close-tag sym)
+    (cat (dsp "</")
+         (dsp sym)
+         (dsp ">")))
+
+  (define (tag sym attrs . body)
+    (if (null? body)
+        (simple-tag sym attrs)
+        (begin
+          (cat (open-tag sym attrs)
+               nl
+               (apply cat body)
+               nl
+               (close-tag sym)))))
+
+  (define (vcat docs)
+    (apply cat (intersperse nl docs)))
+
+  ;;;----------------------------------------
+
+  (define (div-down n d)
+    (floor (/ n d)))
+
+  (define (generate-dev dev-id nr-mappings data-offset)
+    (tag 'device `((dev-id . ,dev-id)
+                   (mapped-blocks . ,nr-mappings)
+                   (transaction . 1)
+                   (creation-time . 0)
+                   (snap-time . 0))
+         (tag 'range_mapping `((origin-begin . 0)
+                         (data-begin . ,data-offset)
+                         (length . ,nr-mappings)
+                         (time . 1)))))
+
+  (define (generate-xml max-thins max-mappings)
+    (let ((nr-thins ((make-uniform-generator 1 max-thins)))
+          (nr-mappings-g (make-uniform-generator (div-down max-mappings 2)
+                                                 max-mappings)))
+      (let ((nr-mappings (iterate nr-mappings-g nr-thins)))
+       (tag 'superblock `((uuid . "")
+                         (time . 1)
+                         (transaction . 1)
+                         (flags . 0)
+                         (version . 2)
+                         (data-block-size . 128)
+                         (nr-data-blocks . ,(apply + nr-mappings)))
+            (vcat (map generate-dev
+                       (iota nr-thins)
+                       nr-mappings
+                       (accumulate nr-mappings))))))))
+