[functional-tests] move thin-check and thin-xml into a sub dir

2017-09-14 11:39:38 +01:00
parent 40b257d42e
commit 205caab84c
2 changed files with 0 additions and 0 deletions
--- a/functional-tests/thin/xml.scm
+++ b/functional-tests/thin/xml.scm
@@ -0,0 +1,41 @@
+(library
+  (thin-xml)
+  (export generate-xml)
+  (import (rnrs)
+          (list-utils)
+          (generators)
+          (xml)
+          (fmt fmt)
+          (only (srfi s1 lists) iota))
+
+  (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))))))))
+