From d9b3133aca6580217f74181beb0a2882d4092a70 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Fri, 6 Oct 2017 15:26:10 +0100
Subject: [PATCH] [functional-tests] (device-mapper targets)

---
 functional-tests/device-mapper/ioctl.scm   |  6 +++-
 functional-tests/device-mapper/targets.scm | 36 ++++++++++++++++++++++
 functional-tests/fail.scm                  |  7 +++++
 functional-tests/process.scm               |  6 +---
 4 files changed, 49 insertions(+), 6 deletions(-)
 create mode 100644 functional-tests/device-mapper/targets.scm
 create mode 100644 functional-tests/fail.scm

diff --git a/functional-tests/device-mapper/ioctl.scm b/functional-tests/device-mapper/ioctl.scm
index 8093569..6f5643c 100644
--- a/functional-tests/device-mapper/ioctl.scm
+++ b/functional-tests/device-mapper/ioctl.scm
@@ -194,11 +194,15 @@
             (map foreign-free acc)
             (loop (ftype-ref Target (next) t) (cons t acc)))))
 
+  ;; targets should be dlambdas with 'size, 'type and 'format methods
   (define (load-table dm name targets)
     (define load
       (foreign-procedure "dm_load" ((* DMIoctlInterface) string (* Target)) int))
 
-    (let* ((ctargets (build-c-targets targets))
+    (define (dlambda->target t)
+      (make-target (t 'size) (t 'type) (t 'format)))
+
+    (let* ((ctargets (build-c-targets (map dlambda->target targets)))
            (r (load dm name ctargets)))
       (free-c-targets ctargets)
       (unless (zero? r)
diff --git a/functional-tests/device-mapper/targets.scm b/functional-tests/device-mapper/targets.scm
new file mode 100644
index 0000000..1271270
--- /dev/null
+++ b/functional-tests/device-mapper/targets.scm
@@ -0,0 +1,36 @@
+(library
+  (device-mapper targets)
+
+  (export linear-target)
+
+  (import (chezscheme)
+          (fmt fmt)
+          (list-utils))
+
+  (define-record-type segment
+    (fields (mutable dev) (mutable begin) (mutable end)))
+
+  (define (segment-size s)
+          (- (segment-end s)
+             (segment-begin s)))
+
+  (define (join docs)
+          (cat (intersperse (dsp " ") docs)))
+
+  (define (format-segment s)
+          (join (dsp (segment-dev s))))
+
+  (define (linear-target seg)
+    (dlambda
+      (type () 'linear)
+      (size () (segment-size seg))
+      (format () (fmt #f (format-segment s)))))
+
+  (define (stripe-target segments)
+    (unless (apply = (map segment-size segments))
+            (fail "stripe segments must all be the same size")
+    (dlambda
+      (type () 'stripe)
+      (size () (fold-right + 0 (map segment-size segments)))
+      (format () (fmt #f (join (map format-segment segments)))))))
+  )
diff --git a/functional-tests/fail.scm b/functional-tests/fail.scm
new file mode 100644
index 0000000..f2c8e45
--- /dev/null
+++ b/functional-tests/fail.scm
@@ -0,0 +1,7 @@
+(library
+  (fail)
+
+  (define (fail msg)
+    (raise (condition
+             (make-error)
+             (make-message-condition msg)))))
diff --git a/functional-tests/process.scm b/functional-tests/process.scm
index 4229399..d39bd9c 100644
--- a/functional-tests/process.scm
+++ b/functional-tests/process.scm
@@ -6,6 +6,7 @@
           run-fail)
 
   (import (chezscheme)
+          (fail)
           (fmt fmt)
           (logging)
           (list-utils)
@@ -19,11 +20,6 @@
   ;;; 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 (fail msg)
-    (raise (condition
-             (make-error)
-             (make-message-condition msg))))
-
   (define (build-command-line cmd-and-args)
     (apply fmt #f (map dsp (intersperse " " cmd-and-args))))