[functional-tests] a bunch of thin tests

functional-tests/cache-functional-tests.scm

@@ -25,7 +25,7 @@
   (define-syntax with-valid-metadata
     (syntax-rules ()
       ((_ (md) b1 b2 ...)
-       (with-temp-file-sized ((md "cache.bin" (meg 4)))
+       (with-temp-file-sized ((md "cache.bin" (to-bytes (meg 4))))
          (with-cache-xml (xml)
            (run-ok (cache-restore "-i" xml "-o" md))
            b1 b2 ...)))))
@@ -34,13 +34,13 @@
   (define-syntax with-corrupt-metadata
     (syntax-rules ()
       ((_ (md) b1 b2 ...)
-       (with-temp-file-sized ((md "cache.bin" (meg 4)))
+       (with-temp-file-sized ((md "cache.bin" (to-bytes (meg 4))))
          b1 b2 ...))))
 
   (define-syntax with-empty-metadata
     (syntax-rules ()
       ((_ (md) b1 b2 ...)
-       (with-temp-file-sized ((md "cache.bin" (meg 4)))
+       (with-temp-file-sized ((md "cache.bin" (to-bytes (meg 4))))
                             b1 b2 ...))))
 
   ;; We have to export something that forces all the initialisation expressions
@@ -315,7 +315,7 @@
 
   (define-scenario (cache-metadata-size device-size-only)
     "Just --device-size causes fail"
-    (run-fail-rcv (_ stderr) (cache-metadata-size "--device-size" (meg 100))
+    (run-fail-rcv (_ stderr) (cache-metadata-size "--device-size" (to-bytes (meg 100)))
       (assert-equal "If you specify --device-size you must also give --block-size."
                     stderr)))
 

functional-tests/device-mapper/dm-tests.scm

@@ -1,22 +1,40 @@
 (library
   (device-mapper dm-tests)
-  (export register-dm-tests make-allocator)
+  (export register-dm-tests
+          get-dev-size)
   (import (device-mapper ioctl)
+          (disk-units)
           (chezscheme)
           (functional-tests)
           (fmt fmt)
           (list-utils)
+          (loops)
           (process)
           (srfi s27 random-bits)
-          (temp-file))
+          (temp-file)
+          (utils))
 
   ;; We have to export something that forces all the initialisation expressions
   ;; to run.
   (define (register-dm-tests) #t)
 
+  ;; FIXME: use memoisation to avoid running blockdev so much
+  (define (get-dev-size dev)
+    (run-ok-rcv (stdout stderr) (fmt #f "blockdev --getsz " dev)
+                (string->number (chomp stdout))))
+
   ;; Hard coded, get these from the command line
-  (define test-dev "/dev/vda")
+  (define fast-dev "/dev/vda")
-  (define test-dev-size 209715200)
+  (define mk-fast-allocator
+    (let ((size (get-dev-size fast-dev)))
+     (lambda ()
+       (make-allocator fast-dev size))))
+
+  (define slow-dev "/dev/vdb")
+  (define mk-slow-allocator
+    (let ((size (get-dev-size slow-dev)))
+     (lambda ()
+       (make-allocator slow-dev size))))
 
   (define-record-type segment (fields (mutable dev)
                                       (mutable start)
@@ -27,30 +45,25 @@
                  "linear"
                  (fmt #f (segment-dev seg) " " (segment-start seg))))
 
+  ;; FIXME: move above first use
   (define (make-allocator dev dev-len)
     (let ((offset 0))
       (lambda (len)
         (let ((b offset)
-              (e (+ offset len)))
+              (e (+ offset (to-sectors len))))
           (if (> e dev-len)
               (fail "not enough space for allocation")
               (begin
                 (set! offset e)
                 (linear (make-segment dev b e))))))))
 
-  (define-syntax with-test-allocator
-    (syntax-rules ()
-      ((_ (var) b1 b2 ...)
-       (let ((var (make-allocator test-dev test-dev-size)))
-         b1 b2 ...))))
-
   (define (linear-table allocator nr-targets)
     (let loop ((nr-targets nr-targets)
                (acc '()))
       (if (zero? nr-targets)
           (reverse acc)
           (loop (- nr-targets 1)
-                (cons (allocator (* 8 (random-integer 1024)))
+                (cons (allocator (sectors (* 8 (random-integer 1024))))
                       acc)))))
 
   (define (similar-targets t1 t2)
@@ -61,14 +74,147 @@
 
   (define-syntax define-dm-scenario
     (syntax-rules ()
-      ((_ path (pv) desc b1 b2 ...)
+      ((_ path desc b1 b2 ...)
        (define-scenario path desc
-         (with-dm
+         (with-dm b1 b2 ...)))))
-           (with-test-allocator (pv)
+
-             b1 b2 ...))))))
+  ;;----------------
+  ;; Thin utilities
+  ;;----------------
+  (define-enumeration thin-pool-option
+    (skip-block-zeroing ignore-discard no-discard-passdown read-only error-if-no-space)
+    thin-pool-options)
+
+  ;; Expands the above option set into a list of strings to be passed to the
+  ;; target.
+  (define (expand-thin-options opts)
+    (define (expand-opt o)
+      (case o
+        ((skip-block-zeroing) "skip_block_zeroing")
+        ((ignore-discard) "ignore_discard")
+        ((no-discard-passdown) "no_discard_passdown")
+        ((read-only) "read_only")
+        ((error-if-no-space) "error_if_no_space")))
+    (map expand-opt (enum-set->list opts)))
+
+  ;; Builds a string of space separated args
+  (define (build-args-string . args)
+    (fmt #f (fmt-join dsp args (dsp " "))))
+
+  (define (pool-table md-dev data-dev data-size block-size opts)
+    (let ((opts-str (expand-thin-options opts)))
+      (list
+        (make-target (to-sectors data-size) "thin-pool"
+          (apply build-args-string
+                 (dm-device-path md-dev)
+                 (dm-device-path data-dev)
+                 (to-sectors block-size)
+                 80 ;; low water mark
+                 (length opts-str) opts-str)))))
+
+  ;; FIXME: move somewhere else, and do IO in bigger blocks
+  (define (zero-dev dev size)
+    (define (dd . args)
+      (build-command-line (cons "dd" args)))
+
+    (run-ok (dd "if=/dev/zero"
+                (string-append "of=" (dm-device-path dev))
+                "bs=512" (fmt #f "count=" (to-sectors size)))))
+
+  ;; The contents should be
+  (define (with-ini-file-fn section contents fn)
+    (define (expand-elt pair)
+      (cat (car pair) "=" (cadr pair) nl))
+
+    (let ((expanded-contents
+            (fmt #f
+                 (cat "[" section "]" nl)
+                 (apply-cat (map expand-elt contents)))))
+         (with-temp-file-containing ((v "fio" expanded-contents))
+           (fn v))))
+
+  (define-syntax with-ini-file
+    (syntax-rules ()
+      ((_ (tmp section contents) b1 b2 ...)
+       (with-ini-file-fn section contents (lambda (tmp) b1 b2 ...)))))
+
+  (define (rand-write-and-verify dev)
+    (with-ini-file (fio-input "write-and-verify"
+                              `(("rw" "randwrite")
+                                ("bs" "4k")
+                                ("direct" 1)
+                                ("ioengine" "libaio")
+                                ("iodepth" 16)
+                                ("verify" "crc32c")
+                                ("filename" ,(dm-device-path dev))))
+                   (run-ok (fmt #f "fio " fio-input))))
+
+  (define (with-pool-fn fast-allocator slow-allocator size block-size fn)
+    (let ((metadata-table (list (fast-allocator (meg 32))))
+          (data-table (list (slow-allocator size))))
+         (with-devices ((md (generate-dev-name) "" metadata-table)
+                        (data (generate-dev-name) "" data-table))
+           (zero-dev md (kilo 4))
+           (let ((ptable (pool-table md data size block-size (thin-pool-options))))
+            (with-device (pool (generate-dev-name) "" ptable)
+                         (fn pool))))))
+
+  (define-syntax with-pool
+    (syntax-rules ()
+      ((_ (pool md-allocator data-allocator size block-size) b1 b2 ...)
+       (with-pool-fn md-allocator
+                     data-allocator
+                     size
+                     block-size
+                     (lambda (pool) b1 b2 ...)))))
+
+  (define-syntax define-thin-scenario
+    (syntax-rules ()
+      ((_ path (pool size) desc b1 b2 ...)
+       (define-dm-scenario path desc
+         (with-pool-fn (mk-fast-allocator)
+                       (mk-slow-allocator)
+                       size
+                       (kilo 64)
+                       (lambda (pool) b1 b2 ...))))))
+
+  (define generate-dev-name
+    (let ((nr 0))
+     (lambda ()
+       (let ((name (fmt #f "test-dev-" nr)))
+        (set! nr (+ nr 1))
+        name))))
+
+  (define (thin-table pool id size)
+    (list
+      (make-target (to-sectors size) "thin" (build-args-string (dm-device-path pool) id))))
+
+  (define (create-thin pool id)
+    (message pool 0 (fmt #f "create_thin " id)))
+
+  (define (create-snap pool new-id origin-id)
+    (message pool 0 (fmt #f "create_snap " new-id " " origin-id)))
+
+  (define (with-thin-fn pool id size fn)
+    (with-device-fn (generate-dev-name) "" (thin-table pool id size) fn))
+
+  (define (with-new-thin-fn pool id size fn)
+    (create-thin pool id)
+    (with-thin-fn pool id size fn))
+
+  (define-syntax with-thin
+    (syntax-rules ()
+      ((_ (thin pool id size) b1 b2 ...)
+       (with-thin-fn pool id size (lambda (thin) b1 b2 ...)))))
+
+  (define-syntax with-new-thin
+    (syntax-rules ()
+      ((_ (thin pool id size) b1 b2 ...)
+       (with-new-thin-fn pool id size (lambda (thin)
+                                        b1 b2 ...)))))
 
   ;;;-----------------------------------------------------------
-  ;;; scenarios
+  ;;; Fundamental dm scenarios
   ;;;-----------------------------------------------------------
   (define-scenario (dm create-interface)
     "create and destroy an ioctl interface object"
@@ -99,50 +245,146 @@
     (with-dm
       (with-empty-device (dev "foo" "uuid")
         ;; FIXME: export contructor for linear targets
-        (load-table dev (list (linear (make-segment test-dev 0 102400)))))))
+        (load-table dev (list (linear (make-segment fast-dev 0 102400)))))))
 
-  (define-dm-scenario (dm load-many-targets) (pv)
+  (define-dm-scenario (dm load-many-targets)
     "You can load a large target table"
     (with-empty-device (dev "foo" "uuid")
-      (load-table dev (linear-table pv 32))))
+      (load-table dev (linear-table (mk-fast-allocator) 32))))
 
-  (define-dm-scenario (dm resume-works) (pv)
+  (define-dm-scenario (dm resume-works)
     "You can resume a new target with a table"
     (with-empty-device (dev "foo" "uuid")
-      (load-table dev (linear-table pv 8))
+      (load-table dev (linear-table (mk-fast-allocator) 8))
       (resume-device dev)))
 
-  (define-dm-scenario (dm suspend-resume-cycle) (pv)
+  (define-dm-scenario (dm suspend-resume-cycle)
     "You can pause a device."
-    (with-device (dev "foo" "uuid" (linear-table pv 8))
+    (with-device (dev "foo" "uuid" (linear-table (mk-fast-allocator) 8))
       (suspend-device dev)
       (resume-device dev)))
 
-  (define-dm-scenario (dm reload-table) (pv)
+  (define-dm-scenario (dm reload-table)
     "You can reload a table"
+    (let ((pv (mk-fast-allocator)))
       (with-device (dev "foo" "uuid" (linear-table pv 16))
         (pause-device dev
-        (load-table dev (linear-table pv 8)))))
+          (load-table dev (linear-table pv 8))))))
 
-  (define-dm-scenario (dm list-devices) (pv)
+  (define-dm-scenario (dm list-devices)
     "list-devices works"
+    (let ((pv (mk-fast-allocator)))
      (with-devices ((dev1 "foo" "uuid" (linear-table pv 4))
                     (dev2 "bar" "uuid2" (linear-table pv 4)))
                    (let ((names (map device-details-name (list-devices))))
                     (assert-member? "foo" names)
-       (assert-member? "bar" names))))
+                    (assert-member? "bar" names)))))
 
-  (define-dm-scenario (dm get-status) (pv)
+  (define-dm-scenario (dm get-status)
     "get-status works"
-    (let ((table (linear-table pv 4)))
+    (let ((table (linear-table (mk-fast-allocator) 4)))
       (with-device (dev "foo" "uuid" table)
         (let ((status (get-status dev)))
          (assert-every similar-targets table status)))))
 
-  (define-dm-scenario (dm get-table) (pv)
+  (define-dm-scenario (dm get-table)
     "get-table works"
-    (let ((table (linear-table pv 4)))
+    (let ((table (linear-table (mk-fast-allocator) 4)))
       (with-device (dev "foo" "uuid" table)
         (let ((table-out (get-table dev)))
           (assert-every similar-targets table table-out)))))
+
+  ;;;-----------------------------------------------------------
+  ;;; Thin scenarios
+  ;;;-----------------------------------------------------------
+  (define-thin-scenario (thin create-pool) (pool (gig 10))
+    "create a pool"
+    #t)
+
+  (define-thin-scenario (thin create-thin) (pool (gig 10))
+    "create a thin volume larger than the pool"
+    (with-new-thin (thin pool 0 (gig 100))
+                   #t))
+
+  (define-thin-scenario (thin zero-thin) (pool (gig 10))
+    "zero a 1 gig thin device"
+    (let ((thin-size (gig 1)))
+     (with-new-thin (thin pool 0 thin-size)
+       (zero-dev thin thin-size))))
+
+  ;;;-----------------------------------------------------------
+  ;;; Thin creation scenarios
+  ;;;-----------------------------------------------------------
+  (define-thin-scenario (thin create lots-of-thins) (pool (gig 10))
+    "create lots of empty thin volumes"
+    (upto (n 1000) (create-thin pool n)))
+
+  (define-thin-scenario (thin create lots-of-snaps) (pool (gig 10))
+    "create lots of snapshots of a single volume"
+    (create-thin pool 0)
+    (upto (n 999)
+          (create-snap pool (+ n 1) 0)))
+
+  (define-thin-scenario (thin create lots-of-recursive-snaps) (pool (gig 10))
+    "create lots of recursive snapshots"
+    (create-thin pool 0)
+    (upto (n 999)
+          (create-snap pool (+ n 1) n)))
+
+  (define-thin-scenario (thin create activate-thin-while-pool-suspended-fails) (pool (gig 10))
+    "you can't activate a thin device while the pool is suspended"
+    (create-thin pool 0)
+    (pause-device pool
+      (assert-raises
+        (with-thin (thin pool 0 (gig 1))
+          (fail "activate shouldn't work")))))
+
+  (define-dm-scenario (thin create huge-block-size)
+    "huge block sizes are possible"
+    (let ((size (sectors 524288)))
+     (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) size)
+       (with-new-thin (thin pool 0 size)
+                      (rand-write-and-verify thin)))))
+
+  ;; FIXME: I thought we supported this?
+  (define-dm-scenario (thin create non-power-2-block-size-fails)
+    "The block size must be a power of 2"
+    (assert-raises
+      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 57))
+                 #t)))
+
+  (define-dm-scenario (thin create tiny-block-size-fails)
+    "The block size must be at least 64k"
+    (assert-raises
+      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 32))
+                 #t)))
+
+  (define-dm-scenario (thin create too-large-block-size-fails)
+    "The block size must be less than 2^21 sectors"
+    (assert-raises
+      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (sectors (expt 2 22)))
+                 #t)))
+
+  (define-dm-scenario (thin create largest-block-size-succeeds)
+    "The block size 2^21 sectors should work"
+    (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (sectors (expt 2 21)))
+               #t))
+
+  (define-dm-scenario (thin create too-large-thin-dev-fails)
+    "The thin-id must be less 2^24"
+    (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
+      (assert-raises
+        (create-thin pool (expt 2 24)))))
+
+  (define-dm-scenario (thin create largest-thin-dev-succeeds)
+    "The thin-id must be less 2^24"
+    (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
+      (create-thin pool (- (expt 2 24) 1))))
+
+;;  (define-dm-scenario (thin create too-small-metadata-fails)
+;;    "16k metadata is way too small"
+;;    (assert-raises
+;;      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
+;;                 )))
 )
+

functional-tests/device-mapper/ioctl.scm

@@ -6,6 +6,10 @@
           with-dm-thunk
           with-dm
 
+          dm-device
+          dm-device-name
+          dm-device-path
+
           dm-version
           get-version
           remove-all
@@ -21,7 +25,9 @@
 
           load-table
           remove-device
+          with-empty-device-fn
           with-empty-device
+          with-device-fn
           with-device
           with-devices
           suspend-device
@@ -37,7 +43,9 @@
           device-details-minor
 
           get-status
-          get-table)
+          get-table
+
+          message)
 
   (import (chezscheme)
           (fmt fmt)
@@ -58,6 +66,9 @@
 
   (define-record-type dm-device (fields (mutable name)))
 
+  (define (dm-device-path d)
+    (fmt #f (dsp "/dev/mapper/") (dsp (dm-device-name d))))
+
   (define open% (foreign-procedure "dm_open" () (* DMIoctlInterface)))
 
   (define (dm-open)
@@ -272,22 +283,29 @@
        (unless (zero? (load (current-dm-interface) (dm-device-name dev) ctargets))
          (fail "dm_load failed")))))
 
+  (define (with-empty-device-fn name uuid fn)
+    (let ((v (create-device name uuid)))
+     (dynamic-wind
+             (lambda () #f)
+             (lambda () (fn v))
+             (lambda () (remove-device v)))))
+
   (define-syntax with-empty-device
     (syntax-rules ()
       ((_ (var name uuid) b1 b2 ...)
-       (let ((var (create-device name uuid)))
+       (with-empty-device-fn name uuid (lambda (var) b1 b2 ...)))))
-        (dynamic-wind
+
-          (lambda () #f)
+  (define (with-device-fn name uuid table fn)
-          (lambda () b1 b2 ...)
+    (with-empty-device-fn name uuid
-          (lambda () (remove-device var)))))))
+                          (lambda (v)
+                            (load-table v table)
+                            (resume-device v)
+                            (fn v))))
 
   (define-syntax with-device
     (syntax-rules ()
       ((_ (var name uuid table) b1 b2 ...)
-       (with-empty-device (var name uuid)
+       (with-device-fn name uuid table (lambda (var) b1 b2 ...)))))
-         (load-table var table)
-         (resume-device var)
-         b1 b2 ...))))
 
   (define-syntax with-devices
     (syntax-rules ()
@@ -337,4 +355,11 @@
       (foreign-procedure "dm_table" ((* DMIoctlInterface) string (* TargetPtr)) int))
 
     (do-status dev get-status "dm_table"))
+
+  (define (message dev sector msg)
+    (define c-message
+      (foreign-procedure "dm_message" ((* DMIoctlInterface) string unsigned-64 string) int))
+
+    (unless (zero? (c-message (current-dm-interface) (dm-device-name dev) sector msg))
+      (fail (fmt #f "message ioctl failed"))))
 )

functional-tests/disk-units.scm

@@ -1,6 +1,25 @@
 (library
   (disk-units)
-  (export meg)
+  (export bytes
-  (import (rnrs))
+          sectors
+          kilo
+          meg
+          gig
+          tera
+          to-bytes
+          to-sectors)
+  (import (rnrs)
+          (math-utils))
 
-  (define (meg n) (* 1024 1024 n)))
+  (define-record-type disk-size (fields (mutable sectors)))
+
+  (define (bytes n) (make-disk-size (div-up n 512)))
+  (define (sectors n) (make-disk-size n))
+  (define (kilo n) (make-disk-size (* n 2)))
+  (define (meg n) (make-disk-size (* n 2 1024)))
+  (define (gig n) (make-disk-size (* n 1024 1024)))
+  (define (tera n) (make-disk-size (* n 1024 104 1024)))
+
+  (define (to-bytes ds) (* 512 (disk-size-sectors ds)))
+  (define (to-sectors ds) (disk-size-sectors ds))
+  )