From 6a054e35df8eb60be98e15140116bfc3d0b9e7ae Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Thu, 7 Sep 2017 15:40:25 +0100
Subject: [PATCH] [functional-tests] Scheme interface to the block cache.

---
 functional-tests/bcache/bcache-tests.scm  |  38 ++++++++
 functional-tests/bcache/block-manager.scm | 103 ++++++++++++++++++++++
 functional-tests/run-tests                |   5 ++
 3 files changed, 146 insertions(+)
 create mode 100644 functional-tests/bcache/bcache-tests.scm
 create mode 100644 functional-tests/bcache/block-manager.scm

diff --git a/functional-tests/bcache/bcache-tests.scm b/functional-tests/bcache/bcache-tests.scm
new file mode 100644
index 0000000..997f4dd
--- /dev/null
+++ b/functional-tests/bcache/bcache-tests.scm
@@ -0,0 +1,38 @@
+(library
+  (bcache bcache-tests)
+  (export register-bcache-tests)
+  (import (bcache block-manager)
+          (chezscheme)
+          (functional-tests)
+          (fmt fmt)
+          (process)
+          (temp-file))
+
+  (define-syntax with-empty-metadata
+    (syntax-rules ()
+      ((_ (md nr-blocks) b1 b2 ...)
+       (with-temp-file-sized ((md "bcache.bin" (* 4096 nr-blocks)))
+                            b1 b2 ...))))
+
+  ;; We have to export something that forces all the initialisation expressions
+  ;; to run.
+  (define (register-bcache-tests) #t)
+
+  ;;;-----------------------------------------------------------
+  ;;; scenarios
+  ;;;-----------------------------------------------------------
+
+  (define-scenario (bcache create)
+    "create and destroy a block cache"
+    (with-empty-metadata (md 16)
+      (with-bcache (cache md 16)
+                   #t)))
+
+  (define-scenario (bcache read-ref)
+    "get a read-ref on a block"
+    (with-empty-metadata (md 16)
+      (with-bcache (cache md 16)
+        (with-block (b cache 0 (get-flags))
+                    #f))))
+  )
+
diff --git a/functional-tests/bcache/block-manager.scm b/functional-tests/bcache/block-manager.scm
new file mode 100644
index 0000000..83c2191
--- /dev/null
+++ b/functional-tests/bcache/block-manager.scm
@@ -0,0 +1,103 @@
+(library
+  ;; We can't call this (bcache bcache) because it'll clash with the C lib
+  (bcache block-manager)
+  (export with-bcache
+          get-nr-blocks
+          get-nr-locked
+          get-block
+          block-data
+          block-index
+          release-block
+          flush-cache
+          get-flags
+          prefetch-block
+          with-block)
+  (import (chezscheme)
+          (fmt fmt)
+          (utils))
+
+  (define __ (load-shared-object "./bcache/bcache.so"))
+
+  (define bcache-simple
+    (foreign-procedure "bcache_simple" (string unsigned) ptr))
+
+  (define bcache-destroy
+    (foreign-procedure "bcache_destroy" (ptr) void))
+
+  (define-syntax with-bcache
+    (syntax-rules ()
+      ((_ (name path nr-cache-blocks) b1 b2 ...)
+       (let ((name (bcache-simple path nr-cache-blocks)))
+        (dynamic-wind
+          (lambda () #f)
+          (lambda () b1 b2 ...)
+          (lambda () (bcache-destroy name)))))))
+
+  (define get-nr-blocks
+    (foreign-procedure "get_nr_blocks" (ptr) unsigned-64))
+
+  (define get-nr-locked
+    (foreign-procedure "get_nr_locked" (ptr) unsigned-64))
+
+  (define-enumeration get-flag-element
+    (zero dirty barrier) get-flags)
+
+  (define (build-flags es)
+    (define (to-bits e)
+            (case e
+                  ((zero) 1)
+                  ((dirty) 2)
+                  ((barrier) 4)))
+
+    (define (combine fs e)
+            (fxior fs (to-bits e)))
+
+    (fold-left combine 0 (enum-set->list es)))
+
+  (define (fail msg)
+    (raise
+     (condition
+       (make-error)
+       (make-message-condition msg))))
+
+  (define-ftype Block
+    (struct
+      (data void*)
+      (index unsigned-64)))
+
+  (define (block-data b)
+    (ftype-ref Block (data) b))
+
+  (define (block-index b)
+    (ftype-ref Block (index) b))
+
+  (define (get-block cache index flags)
+    (define getb (foreign-procedure "get_block" (ptr unsigned-64 unsigned) (* Block)))
+
+    (let ((b (getb cache index (build-flags flags))))
+     (if (ftype-pointer-null? b)
+         (fail (fmt #f "unable to get block " index))
+         b)))
+
+  (define release-block
+    (foreign-procedure "release_block" ((* Block)) void))
+
+  (define (flush-cache cache)
+    (define flush (foreign-procedure "flush_cache" (ptr) int))
+
+    (let ((r (flush cache)))
+     (when (< 0 r)
+           (fail "flush_cache failed"))))
+
+  (define prefetch-block
+    (foreign-procedure "prefetch_block" (ptr unsigned-64) void))
+
+  (define-syntax with-block
+    (syntax-rules ()
+      ((_ (b cache index flags) b1 b2 ...)
+       (let ((b (get-block cache index flags)))
+        (dynamic-wind
+          (lambda () #f)
+          (lambda () b1 b2 ...)
+          (lambda () (release-block b)))))))
+)
diff --git a/functional-tests/run-tests b/functional-tests/run-tests
index 6239ff6..59f39aa 100755
--- a/functional-tests/run-tests
+++ b/functional-tests/run-tests
@@ -1,9 +1,11 @@
 #! /usr/bin/scheme-script
 
 (import (rnrs)
+        (only (chezscheme) load-shared-object)
         (fmt fmt)
         (list-utils)
         (functional-tests)
+	(bcache bcache-tests)
         (cache-functional-tests)
         (era-functional-tests)
         (parser-combinators)
@@ -169,9 +171,12 @@
 
 ;;------------------------------------------------
 
+(load-shared-object "./bcache/bcache.so")
+
 (register-thin-tests)
 (register-cache-tests)
 (register-era-tests)
+(register-bcache-tests)
 
 (with-dir "test-output"
  ((parse-command-line)))