Merge branch 'master' of github.com:jthornber/thin-provisioning-tools
This commit is contained in:
Joe Thornber
commit
54c03f10e6
@ -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);
|
||||
}
|
||||
|
||||
//----------------------------------------------------------------
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
//----------------------------------------------------------------
|
||||
|
||||
@ -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)))
|
||||
|
||||
|
||||
@ -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 test-dev-size 209715200)
|
||||
(define fast-dev "/dev/vda")
|
||||
(define mk-fast-allocator
|
||||
(let ((size (get-dev-size fast-dev)))
|
||||
(lambda ()
|
||||
(make-allocator fast-dev (to-sectors size)))))
|
||||
|
||||
(define (linear dev begin end)
|
||||
(make-target (- end begin)
|
||||
(define slow-dev "/dev/vdb")
|
||||
(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)))))))
|
||||
|
||||
(define-syntax with-test-allocator
|
||||
(syntax-rules ()
|
||||
((_ (var) b1 b2 ...)
|
||||
(let ((var (make-allocator test-dev test-dev-size)))
|
||||
b1 b2 ...))))
|
||||
(linear (make-segment dev b e))))))))
|
||||
|
||||
(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-test-allocator (pv)
|
||||
b1 b2 ...))))))
|
||||
(with-dm 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))
|
||||
(pause-device dev
|
||||
(load-table dev (linear-table pv 8)))))
|
||||
(let ((pv (mk-fast-allocator)))
|
||||
(with-device (dev "foo" "uuid" (linear-table pv 16))
|
||||
(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))
|
||||
(dev2 "bar" "uuid2" (linear-table pv 4)))
|
||||
(let ((names (map device-details-name (list-devices))))
|
||||
(assert-member? "foo" names)
|
||||
(assert-member? "bar" names))))
|
||||
(let ((pv (mk-fast-allocator)))
|
||||
(with-devices ((dev1 "foo" "uuid" (linear-table pv 4))
|
||||
(dev2 "bar" "uuid2" (linear-table pv 4)))
|
||||
(let ((names (map dm-device-name (list-devices))))
|
||||
(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))))
|
||||
)
|
||||
|
||||
|
||||
@ -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)
|
||||
(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)))
|
||||
(with-u32s (major minor patch)
|
||||
(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))
|
||||
(foreign-free (ftype-pointer-address minor))
|
||||
(foreign-free (ftype-pointer-address patch))
|
||||
r)
|
||||
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))
|
||||
(make-dm-device name)
|
||||
(fail "create-device failed")))
|
||||
(with-u32s (major minor)
|
||||
(let ((r (create (current-dm-interface) name uuid major minor)))
|
||||
(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)))
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () b1 b2 ...)
|
||||
(lambda () (remove-device var)))))))
|
||||
(with-empty-device-fn name uuid (lambda (var) b1 b2 ...)))))
|
||||
|
||||
(define (with-device-fn name uuid table fn)
|
||||
(with-empty-device-fn name uuid
|
||||
(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)
|
||||
(load-table var table)
|
||||
(resume-device var)
|
||||
b1 b2 ...))))
|
||||
(with-device-fn name uuid table (lambda (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))))))
|
||||
)
|
||||
|
||||
@ -1,6 +1,25 @@
|
||||
(library
|
||||
(disk-units)
|
||||
(export meg)
|
||||
(import (rnrs))
|
||||
(export bytes
|
||||
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))
|
||||
)
|
||||
|
||||
@ -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 ()
|
||||
(thunk)
|
||||
#t)))))
|
||||
(lambda ()
|
||||
(thunk)
|
||||
#t)))))
|
||||
|
||||
;; Returns #t if all tests pass.
|
||||
(define (run-scenarios ss)
|
||||
|
||||
@ -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 ...)
|
||||
|
||||
10
functional-tests/math-utils.scm
Normal file
10
functional-tests/math-utils.scm
Normal file
@ -0,0 +1,10 @@
|
||||
(library
|
||||
(math-utils)
|
||||
|
||||
(export div-up)
|
||||
|
||||
(import (chezscheme))
|
||||
|
||||
(define (div-up n d)
|
||||
(/ (+ n (- d 1)) d))
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user