Merge branch 'master' of github.com:jthornber/thin-provisioning-tools

base/file_utils.cc

@@ -151,6 +151,8 @@ file_utils::zero_superblock(std::string const &path)
 	memset(buffer, 0, SUPERBLOCK_SIZE);
 	if (::write(fd, buffer, SUPERBLOCK_SIZE) != SUPERBLOCK_SIZE)
 		throw runtime_error("couldn't zero superblock");
+
+	::close(fd);
 }
 
 //----------------------------------------------------------------

ft-lib/dm-ioctl.c

@@ -1,4 +1,6 @@
 #include <linux/dm-ioctl.h>
+#include <linux/kdev_t.h>
+#include <linux/fs.h>
 #include <stdbool.h>
 #include <stdint.h>
 #include <stdlib.h>
@@ -239,7 +241,7 @@ static bool list_devices(struct dm_interface *dmi, struct dm_ioctl *ctl,
 
 	if (nl->dev) {
 		for (;;) {
-			dlb_append(&dlb, major(nl->dev), minor(nl->dev), nl->name);
+			dlb_append(&dlb, MAJOR(nl->dev), MINOR(nl->dev), nl->name);
 
 			if (!nl->next)
 				break;
@@ -273,7 +275,9 @@ int dm_list_devices(struct dm_interface *dmi, struct dev_list **devs)
 	return r;
 }
 
-int dm_create_device(struct dm_interface *dmi, const char *name, const char *uuid)
+// Obviously major and minor are only valid if successful.
+int dm_create_device(struct dm_interface *dmi, const char *name, const char *uuid,
+		     uint32_t *major_result, uint32_t *minor_result)
 {
 	int r;
 	struct dm_ioctl *ctl = alloc_ctl(0);
@@ -294,8 +298,11 @@ int dm_create_device(struct dm_interface *dmi, const char *name, const char *uui
 	}
 
 	r = ioctl(dmi->fd, DM_DEV_CREATE, ctl);
+	if (!r) {
+		*major_result = MAJOR(ctl->dev);
+		*minor_result = MINOR(ctl->dev);
+	}
 	free_ctl(ctl);
-
 	return r;
 }
 
@@ -304,6 +311,9 @@ static int dev_cmd(struct dm_interface *dmi, const char *name, int request, unsi
 	int r;
 	struct dm_ioctl *ctl = alloc_ctl(0);
 
+	if (!ctl)
+		return -ENOMEM;
+
 	ctl->flags = flags;
 	r = copy_name(ctl, name);
 	if (r) {
@@ -400,8 +410,6 @@ static struct target *tb_get(struct target_builder *tb)
 }
 
 //----------------------------------------------------------------
-// FIXME: provide some way of freeing a target list.
-// FIXME: check the result from alloc_ctl is always being checked.
 
 static size_t calc_load_payload(struct target *t)
 {
@@ -589,4 +597,18 @@ int dm_message(struct dm_interface *dmi, const char *name, uint64_t sector,
 	return r;
 }
 
+int get_dev_size(const char *path, uint64_t *sectors)
+{
+	int r, fd;
+
+	fd = open(path, O_RDONLY);
+	if (fd < 0)
+		return -EINVAL;
+
+	r = ioctl(fd, BLKGETSIZE64, sectors);
+	(*sectors) /= 512;
+	close(fd);
+	return r;
+}
+
 //----------------------------------------------------------------

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,44 +1,58 @@
 (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)
+          (logging)
+          (loops)
+          (prefix (parser-combinators) p:)
           (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)
 
   ;; 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 (to-sectors size)))))
 
-  (define (linear dev begin end)
+  (define slow-dev "/dev/vdb")
-    (make-target (- end begin)
+  (define mk-slow-allocator
+    (let ((size (get-dev-size slow-dev)))
+     (lambda ()
+       (make-allocator slow-dev (to-sectors size)))))
+
+  (define-record-type segment (fields (mutable dev)
+                                      (mutable start)
+                                      (mutable end)))
+
+  (define (linear seg)
+    (make-target (- (segment-end seg) (segment-start seg))
                  "linear"
-                 (fmt #f dev " " begin)))
+                 (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 dev b 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)
@@ -46,7 +60,7 @@
       (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)
@@ -57,14 +71,323 @@
 
   (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 block-size opts)
+    (let ((opts-str (expand-thin-options opts))
+          (data-size (get-dev-size (dm-device-path data-dev))))
+      (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)))))
+
+  (define (dd-cmd . args)
+    (build-command-line (cons "dd" args)))
+
+  ;; FIXME: move somewhere else, and do IO in bigger blocks
+  (define zero-dev
+    (case-lambda
+      ((dev)
+       (zero-dev dev
+                 (get-dev-size
+                   (dm-device-path dev))))
+      ((dev size)
+       (run-ok (dd-cmd "if=/dev/zero"
+                       "oflag=direct"
+                       (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 generate-dev-name
+    (let ((nr 0))
+     (lambda ()
+       (let ((name (fmt #f "test-dev-" nr)))
+        (set! nr (+ nr 1))
+        name))))
+
+  (define (with-pool-fn md-table data-table block-size opts fn)
+    (with-devices ((md (generate-dev-name) "" md-table)
+                   (data (generate-dev-name) "" data-table))
+      (zero-dev md (kilo 4))
+      (let ((ptable (pool-table md data block-size opts)))
+       (with-device (pool (generate-dev-name) "" ptable)
+                    (fn pool)))))
+
+  (define-syntax with-pool
+    (syntax-rules ()
+      ((_ (pool md-table data-table block-size) b1 b2 ...)
+       (with-pool-fn md-table
+                     data-table
+                     block-size
+                     (thin-pool-options)
+                     (lambda (pool) b1 b2 ...)))
+      ((_ (pool md-table data-table block-size opts) b1 b2 ...)
+       (with-pool-fn md-table
+                     data-table
+                     block-size
+                     opts
+                     (lambda (pool) b1 b2 ...)))))
+
+  (define-syntax with-default-pool
+    (syntax-rules ()
+      ((_ (pool) b1 b2 ...)
+       (with-pool (pool (default-md-table)
+                        (default-data-table (gig 10))
+                        (kilo 64))
+                  b1 b2 ...))))
+
+  (define default-md-table
+    (case-lambda
+      (() (default-md-table (meg 32)))
+      ((size) (list ((mk-fast-allocator) size)))))
+
+  (define default-data-table
+    (case-lambda
+      (() (default-data-table (gig 10)))
+      ((size) (list ((mk-slow-allocator) size)))))
+
+  (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 (delete-thin pool id)
+    (message pool 0 (fmt #f "delete " 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
+  ;;; Pool status
+  ;;;-----------------------------------------------------------
+  (define-record-type pool-status
+    (fields (mutable transaction-id)
+            (mutable used-metadata)
+            (mutable total-metadata)
+            (mutable used-data)
+            (mutable total-data)
+            (mutable held-root)          ; (bool . root?)
+            (mutable needs-check)        ; bool
+            (mutable discard)            ; bool
+            (mutable discard-passdown)   ; bool
+            (mutable block-zeroing)      ; bool
+            (mutable io-mode)            ; 'out-of-data-space, 'ro, 'rw
+            (mutable no-space-behaviour) ; 'error, 'queue
+            (mutable fail)               ; bool
+            ))
+
+  (define (default-pool-status)
+    (make-pool-status 0  ; trans id
+                      0  ; used md
+                      0  ; total md
+                      0  ; used data
+                      0  ; total data
+                      (cons #f 0)  ; held root
+                      #f  ; need check
+                      #t  ; discard
+                      #t  ; discard passdown
+                      #t  ; block zeroing
+                      'rw  ; io-mode
+                      'queue  ; no space behaviour
+                      #f  ; fail
+                      ))
+
+  (define (fmt-pool-status status)
+    (if (pool-status-fail status)
+        "pool failed"
+        (cat "transaction-id: " (pool-status-transaction-id status) ", "
+             (pool-status-used-metadata status) "/" (pool-status-total-metadata status) " metadata, "
+             (pool-status-used-data status) "/" (pool-status-total-data status) " data, "
+             (let ((hr (pool-status-held-root status)))
+              (if (car hr)
+                  (cat "held root: " (cdr hr) ", ")
+                  ""))
+             (if (pool-status-needs-check status) "needs-check, " "")
+             (if (pool-status-discard status) "discard, " "")
+             (if (pool-status-discard-passdown status) "discard-passdown, " "")
+             (if (pool-status-block-zeroing status) "block-zero, " "")
+             "io-mode: " (pool-status-io-mode status) ", "
+             "no-space-behaviour: " (pool-status-no-space-behaviour status))))
+
+  (define digit (p:charset "0123456789"))
+
+  (define number
+    (p:lift (lambda (cs)
+              (string->number
+                (apply string cs)))
+            (p:many+ digit)))
+
+  (define held-root
+    (p:alt
+      (p:>> (p:lit "-")
+            (p:pure (cons #f 0)))
+      (p:parse-m (p:<- root number)
+                 (p:pure (cons #t root)))))
+
+  (define space
+    (p:many+ (p:charset " \t")))
+
+  (define slash
+    (p:lit "/"))
+
+  ;; The options parser returns a function that mutates the status.
+  (define-syntax opt-mut
+    (syntax-rules ()
+      ((_ (status txt) b1 b2 ...)
+       (p:>> (p:lit txt)
+             (p:pure (lambda (status) b1 b2 ...))))))
+
+  (define pool-option
+    (p:one-of
+      (opt-mut (status "skip_block_zeroing")
+        (pool-status-block-zeroing-set! status #f))
+
+      (opt-mut (status "ignore_discard")
+        (pool-status-discard-set! status #f))
+
+      (opt-mut (status "no_discard_passdown")
+        (pool-status-discard-passdown-set! status #f))
+
+      (opt-mut (status "discard_passdown")
+        (pool-status-discard-passdown-set! status #t))
+
+      (opt-mut (status "out_of_data_space")
+        (pool-status-io-mode-set! status 'out-of-data-space))
+
+      (opt-mut (status "ro")
+        (pool-status-io-mode-set! status 'ro))
+
+      (opt-mut (status "rw")
+        (pool-status-io-mode-set! status 'rw))
+
+      (opt-mut (status "error_if_no_space")
+        (pool-status-no-space-behaviour-set! status 'error))
+
+      (opt-mut (status "queue_if_no_space")
+        (pool-status-no-space-behaviour-set! status 'queue))))
+
+  (define needs-check
+    (p:one-of
+      (p:>> (p:lit "needs_check")
+            (p:pure #t))
+      (p:pure #f)))
+
+  (define parse-pool-status
+    (p:parse-m (p:<- transaction-id number)
+               space
+               (p:<- used-metadata number)
+               slash
+               (p:<- total-metadata number)
+               space
+               (p:<- used-data number)
+               slash
+               (p:<- total-data number)
+               space
+               (p:<- metadata-snap held-root)
+               space
+               (p:<- options (p:many* (p:<* pool-option space)))
+               (p:<- check needs-check)
+
+               (let ((status (default-pool-status)))
+                (pool-status-transaction-id-set! status transaction-id)
+                (pool-status-used-metadata-set! status used-metadata)
+                (pool-status-total-metadata-set! status total-metadata)
+                (pool-status-used-data-set! status used-data)
+                (pool-status-total-data-set! status total-data)
+                (pool-status-held-root-set! status metadata-snap)
+                (pool-status-needs-check-set! status check)
+                (for-each (lambda (mut) (mut status)) options)
+                (p:pure status))))
+
+  (define (get-pool-status pool)
+    (p:parse-value parse-pool-status
+      (target-args (car (get-status pool)))))
+
+  ;; FIXME: we could get the block size by querying the pool table
+  (define (assert-pool-used-data pool block-size expected-size)
+    (let ((status (get-pool-status pool)))
+     (assert-equal (pool-status-used-data status)
+                   (/ (to-sectors expected-size)
+                      (to-sectors block-size)))))
+
+  ;;;-----------------------------------------------------------
+  ;;; Fundamental dm scenarios
   ;;;-----------------------------------------------------------
   (define-scenario (dm create-interface)
     "create and destroy an ioctl interface object"
@@ -95,50 +418,255 @@
     (with-dm
       (with-empty-device (dev "foo" "uuid")
         ;; FIXME: export contructor for linear targets
-        (load-table dev (list (linear 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"
-    (with-device (dev "foo" "uuid" (linear-table pv 16))
+    (let ((pv (mk-fast-allocator)))
-      (pause-device dev
+      (with-device (dev "foo" "uuid" (linear-table pv 16))
-        (load-table dev (linear-table pv 8)))))
+        (pause-device dev
+          (load-table dev (linear-table pv 8))))))
 
-  (define-dm-scenario (dm list-devices) (pv)
+  (define-dm-scenario (dm list-devices)
     "list-devices works"
-    (with-devices ((dev1 "foo" "uuid" (linear-table pv 4))
+    (let ((pv (mk-fast-allocator)))
-                   (dev2 "bar" "uuid2" (linear-table pv 4)))
+     (with-devices ((dev1 "foo" "uuid" (linear-table pv 4))
-      (let ((names (map device-details-name (list-devices))))
+                    (dev2 "bar" "uuid2" (linear-table pv 4)))
-       (assert-member? "foo" names)
+                   (let ((names (map dm-device-name (list-devices))))
-       (assert-member? "bar" names))))
+                    (assert-member? "foo" 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
+  ;;;-----------------------------------------------------------
+  ;; FIXME: I think these 3 can go
+  (define-dm-scenario (thin misc create-pool)
+    "create a pool"
+    (with-default-pool (pool)
+      #t))
+
+  (define-dm-scenario (thin misc create-thin)
+    "create a thin volume larger than the pool"
+    (with-default-pool (pool)
+      (with-new-thin (thin pool 0 (gig 100))
+                     #t)))
+
+  (define-dm-scenario (thin misc zero-thin)
+    "zero a 1 gig thin device"
+    (with-default-pool (pool)
+      (let ((thin-size (gig 1)))
+       (with-new-thin (thin pool 0 thin-size)
+         (zero-dev thin thin-size)))))
+
+  ;;;-----------------------------------------------------------
+  ;;; Thin creation scenarios
+  ;;;-----------------------------------------------------------
+  (define-dm-scenario (thin create lots-of-thins)
+    "create lots of empty thin volumes"
+    (with-default-pool (pool)
+      (upto (n 1000) (create-thin pool n))))
+
+  (define-dm-scenario (thin create lots-of-snaps)
+    "create lots of snapshots of a single volume"
+    (with-default-pool (pool)
+      (create-thin pool 0)
+      (upto (n 999)
+            (create-snap pool (+ n 1) 0))))
+
+  (define-dm-scenario (thin create lots-of-recursive-snaps)
+    "create lots of recursive snapshots"
+    (with-default-pool (pool)
+      (create-thin pool 0)
+      (upto (n 999)
+            (create-snap pool (+ n 1) n))))
+
+  (define-dm-scenario (thin create activate-thin-while-pool-suspended-fails)
+    "you can't activate a thin device while the pool is suspended"
+    (with-default-pool (pool)
+      (create-thin pool 0)
+      (pause-device pool
+        (assert-raises
+          (with-thin (thin pool 0 (gig 1))
+                     #t)))))
+
+  (define-dm-scenario (thin create huge-block-size)
+    "huge block sizes are possible"
+    (let ((size (sectors 524288)))
+     (with-pool (pool (default-md-table)
+                      (default-data-table size)
+                      (kilo 64))
+       (with-new-thin (thin pool 0 size)
+                      (rand-write-and-verify thin)))))
+
+  (define-dm-scenario (thin create bs-multiple-of-64k-good)
+    "The block size must be a multiple of 64k - good examples"
+    (for-each (lambda (bs)
+                (with-pool (pool (default-md-table)
+                                 (default-data-table (gig 10))
+                                 (kilo bs))
+                           #t))
+              '(64 128 192 512 1024)))
+
+  (define-dm-scenario (thin create bs-multiple-of-64k-bad)
+    "The block size must be a multiple of 64k - bad examples"
+    (for-each (lambda (bs)
+                (assert-raises
+                  (with-pool (pool (default-md-table)
+                                   (default-data-table (gig 10))
+                                   (kilo bs))
+                             #t)))
+              '(65 96)))
+
+  (define-dm-scenario (thin create tiny-block-size-fails)
+    "The block size must be at least 64k"
+    (assert-raises
+      (with-pool (pool (default-md-table)
+                       (default-data-table (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 (default-md-table)
+                       (default-data-table (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 (default-md-table)
+                     (default-data-table (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-default-pool (pool)
+      (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-default-pool (pool)
+      (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 (list ((mk-fast-allocator) (kilo 16)))
+                       (default-data-table (gig 10))
+                       (kilo 64))
+                 #t)))
+
+  ;; Chasing a bug in btree_split_beneath().  This triggers when a value
+  ;; smaller than the rest of the tree is inserted and the
+  ;; btree_split_beneath() path is taken.  The newly inserted key will not be
+  ;; present.  Once another low key is inserted that doesn't take the split
+  ;; beneath path the missing value reappears.
+  (define-dm-scenario (thin create devices-in-reverse-order)
+    "Keep adding a key that's lower than any in the tree."
+    (with-default-pool (pool)
+      (from-to (n 300 0 -1)
+        (create-thin pool n)
+        (with-thin (thin pool n (gig 1)) #t)))) ; activate to check it's there
+
+  ;;;-----------------------------------------------------------
+  ;;; Thin deletion scenarios
+  ;;;-----------------------------------------------------------
+  (define-dm-scenario (thin delete create-delete-cycle)
+    "Create and delete a thin 1000 times"
+    (with-default-pool (pool)
+      (upto (n 1000)
+            (create-thin pool 0)
+            (delete-thin pool 0))))
+
+  (define-dm-scenario (thin delete create-delete-many)
+    "Create and delete 1000 thins"
+    (with-default-pool (pool)
+      (upto (n 1000)
+            (create-thin pool n))
+      (upto (n 1000)
+            (delete-thin pool n))))
+
+  (define-dm-scenario (thin delete rolling-create-delete)
+    "Create and delete 1000 thins"
+    (with-default-pool (pool)
+      (upto (n 1000)
+            (create-thin pool n))
+      (upto (n 1000)
+            (delete-thin pool n)
+            (create-thin pool n))))
+
+  (define-dm-scenario (thin delete unknown-id)
+    "Fails if the thin id is unknown"
+    (with-default-pool (pool)
+      (upto (n 100)
+            (create-thin pool (* n 100)))
+      (assert-raises
+        (delete-thin pool 57))))
+
+  (define-dm-scenario (thin delete active-device-fails)
+    "You can't delete an active device"
+    (with-default-pool (pool)
+      (with-new-thin (thin pool 0 (gig 1))
+        (assert-raises
+          (delete-thin pool 0)))))
+
+  (define-dm-scenario (thin delete recover-space)
+    "Deleting a thin recovers data space"
+    (let ((thin-size (gig 1)))
+     (with-default-pool (pool)
+       (with-new-thin (thin pool 0 thin-size)
+         (assert-pool-used-data pool (kilo 64) (sectors 0))
+         (zero-dev thin))
+       (assert-pool-used-data pool (kilo 64) thin-size)
+       (delete-thin pool 0)
+       (assert-pool-used-data pool (kilo 64) (sectors 0)))))
+
+  (define-dm-scenario (thin delete after-no-space)
+    "You can delete after the pool has run out of data space"
+     (with-pool (pool (default-md-table)
+                      (default-data-table (meg 128))
+                      (kilo 64)
+                      (thin-pool-options error-if-no-space skip-block-zeroing))
+       (with-new-thin (thin pool 0 (gig 1))
+         ;;(assert-raises (zero-dev thin)))
+         (zero-dev thin))
+       (fmt #t (fmt-pool-status (get-pool-status pool)))
+       (assert-pool-used-data pool (kilo 64) (meg 128))
+       (delete-thin pool 0)
+       (assert-pool-used-data pool (kilo 64) (sectors 0))))
   )
+

functional-tests/device-mapper/ioctl.scm

@@ -6,6 +6,12 @@
           with-dm-thunk
           with-dm
 
+          dm-device
+          dm-device-name
+          dm-device-path
+          dm-device-minor
+          dm-device-major
+
           dm-version
           get-version
           remove-all
@@ -21,7 +27,9 @@
 
           load-table
           remove-device
+          with-empty-device-fn
           with-empty-device
+          with-device-fn
           with-device
           with-devices
           suspend-device
@@ -31,16 +39,17 @@
           pause-device
           pause-device-thunk
 
-          device-details
-          device-details-name
-          device-details-major
-          device-details-minor
-
           get-status
-          get-table)
+          get-table
+
+          message
+
+          get-dev-size)
 
   (import (chezscheme)
+          (disk-units)
           (fmt fmt)
+          (logging)
           (srfi s8 receive)
           (utils))
 
@@ -56,7 +65,10 @@
     (struct
       (fd int)))
 
-  (define-record-type dm-device (fields (mutable name)))
+  (define-record-type dm-device (fields name major minor))
+
+  (define (dm-device-path d)
+    (fmt #f (dsp "/dev/dm-") (dsp (dm-device-minor d))))
 
   (define open% (foreign-procedure "dm_open" () (* DMIoctlInterface)))
 
@@ -89,6 +101,34 @@
 
   (define-record-type dm-version (fields major minor patch))
 
+  (define (alloc-u32)
+    (make-ftype-pointer unsigned-32
+                        (foreign-alloc (ftype-sizeof unsigned-32))))
+
+  (define (deref-u32 p)
+    (ftype-ref unsigned-32 () p))
+
+  (define (free-u32 p)
+    (foreign-free (ftype-pointer-address p)))
+
+  (define-syntax with-u32
+    (syntax-rules ()
+      ((_ (v) b1 b2 ...)
+       (let ((v (alloc-u32)))
+        (dynamic-wind
+          (lambda () #f)
+          (lambda () b1 b2 ...)
+          (lambda () (free-u32 v)))))))
+
+  (define-syntax with-u32s
+    (syntax-rules ()
+      ((_ (v) b1 b2 ...)
+       (with-u32 (v) b1 b2 ...))
+
+      ((_ (v rest ...) b1 b2 ...)
+       (with-u32 (v)
+         (with-u32s (rest ...) b1 b2 ...)))))
+
   (define (get-version)
     (define get
       (foreign-procedure "dm_version" ((* DMIoctlInterface)
@@ -96,24 +136,12 @@
                                        (* unsigned-32)
                                        (* unsigned-32)) int))
 
-    (define (alloc-u32)
+    (with-u32s (major minor patch)
-      (make-ftype-pointer unsigned-32
-        (foreign-alloc (ftype-sizeof unsigned-32))))
-
-    (define (deref-u32 p)
-      (ftype-ref unsigned-32 () p))
-
-    (let ((major (alloc-u32))
-          (minor (alloc-u32))
-          (patch (alloc-u32)))
       (if (zero? (get (current-dm-interface) major minor patch))
           (let ((r (make-dm-version (deref-u32 major)
                                     (deref-u32 minor)
                                     (deref-u32 patch))))
-            (foreign-free (ftype-pointer-address major))
+               r)
-            (foreign-free (ftype-pointer-address minor))
-            (foreign-free (ftype-pointer-address patch))
-            r)
           (fail "couldn't get dm version"))))
 
   (define (remove-all)
@@ -133,9 +161,6 @@
 
   (define-ftype DevListPtr (* DevList))
 
-  (define-record-type device-details
-    (fields name major minor))
-
   (define (cstring->string str)
     (let loop ((i 0)
                (acc '()))
@@ -171,7 +196,7 @@
             (if (ftype-pointer-null? dl)
                 acc
                 (loop (ftype-ref DevList (next) dl)
-                      (cons (make-device-details
+                      (cons (make-dm-device
                               (cstring->string (ftype-ref DevList (name) dl))
                               (ftype-ref DevList (major) dl)
                               (ftype-ref DevList (minor) dl))
@@ -180,11 +205,13 @@
 
   (define (create-device name uuid)
     (define create
-      (foreign-procedure "dm_create_device" ((* DMIoctlInterface) string string) int))
+      (foreign-procedure "dm_create_device" ((* DMIoctlInterface) string string (* unsigned-32) (* unsigned-32)) int))
 
-    (if (zero? (create (current-dm-interface) name uuid))
+    (with-u32s (major minor)
-        (make-dm-device name)
+      (let ((r (create (current-dm-interface) name uuid major minor)))
-        (fail "create-device failed")))
+       (if (zero? r)
+           (make-dm-device name (deref-u32 major) (deref-u32 minor))
+           (fail (fmt #f "create-device failed with error code " r))))))
 
   (define-syntax define-dev-cmd
     (syntax-rules ()
@@ -267,27 +294,35 @@
     (define load
       (foreign-procedure "dm_load" ((* DMIoctlInterface) string (* Target)) int))
 
+    (info dev " <- " targets)
     (let* ((ctargets (build-c-targets targets)))
      (ensure-free-ctargets ctargets
        (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 +372,25 @@
       (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"))))
+
+  ;; Works with either a raw path, or a dm-device.  Returns a disk-size.
+  (define (get-dev-size dev)
+    (define c-get-size
+      (foreign-procedure "get_dev_size" (string (* unsigned-64)) int))
+
+    (let* ((path (if (string? dev) dev (dm-device-path dev)))
+           (size (make-ftype-pointer unsigned-64 (foreign-alloc (ftype-sizeof unsigned-64))))
+           (r (c-get-size path size)))
+          (let ((result (ftype-ref unsigned-64 () size)))
+           (foreign-free (ftype-pointer-address size))
+           (if (zero? r)
+               (sectors result)
+               (fail (fmt #f "get-dev-size failed: " r))))))
+  )

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))
+  )

functional-tests/functional-tests.scm

@@ -92,7 +92,7 @@
       (fmt #t
            (cat (fmt-keys prev-keys keys)
                 (dsp #\space)
-                (pad-char #\. (space-to 38))
+                (pad-char #\. (space-to 60))
                 (dsp #\space)))
       (flush)
       (fmt #t (cat (fn keys) nl))
@@ -111,6 +111,15 @@
     (apply string-append cwd "/"
            (intersperse "/" (map symbol->string keys))))
 
+  (define (log-exceptions thunk)
+    (with-exception-handler
+      (lambda (x)
+        (let-values (((txt-port get) (open-string-output-port)))
+          (display-condition x txt-port)
+          (log-error (get)))
+        (raise x))
+      thunk))
+
   (define-syntax define-scenario
     (lambda (x)
       (syntax-case x ()
@@ -124,7 +133,7 @@
                                        (file-options no-fail)
                                        (buffer-mode line)
                                        (native-transcoder))
-                        b1 b2 ...)))))))))
+                        (log-exceptions (lambda () b1 b2 ...)))))))))))
 
   (define (fail msg)
     (raise (condition
@@ -149,9 +158,9 @@
             (if (error? x)
                 (k #f)
                 (raise x)))
-            (lambda ()
+          (lambda ()
-              (thunk)
+            (thunk)
-              #t)))))
+            #t)))))
 
   ;; Returns #t if all tests pass.
   (define (run-scenarios ss)

functional-tests/loops.scm

@@ -1,6 +1,6 @@
 (library
   (loops)
-  (export upto while)
+  (export upto from-to while)
   (import (rnrs))
 
   (define-syntax upto
@@ -11,6 +11,14 @@
              (begin body ...)
              (loop (+ 1 var)))))))
 
+  (define-syntax from-to
+    (syntax-rules ()
+      ((_ (var f t step) b1 b2 ...)
+       (let loop ((var f))
+        (unless (= var t)
+                b1 b2 ...
+                (loop (+ var step)))))))
+
   (define-syntax while
     (syntax-rules ()
       ((_ (var exp) body ...)

functional-tests/math-utils.scm

@@ -0,0 +1,10 @@
+(library
+  (math-utils)
+
+  (export div-up)
+
+  (import (chezscheme))
+
+  (define (div-up n d)
+    (/ (+ n (- d 1)) d))
+  )