(library (device-mapper dm-tests) (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) (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 fast-dev "/dev/vda") (define mk-fast-allocator (let ((size (get-dev-size fast-dev))) (lambda () (make-allocator fast-dev (to-sectors size))))) (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 (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 (to-sectors len)))) (if (> e dev-len) (fail "not enough space for allocation") (begin (set! offset e) (linear (make-segment dev b e)))))))) (define (linear-table allocator nr-targets) (let loop ((nr-targets nr-targets) (acc '())) (if (zero? nr-targets) (reverse acc) (loop (- nr-targets 1) (cons (allocator (sectors (* 8 (random-integer 1024)))) acc))))) (define (similar-targets t1 t2) (and (equal? (target-type t1) (target-type t2)) (equal? (target-len t1) (target-len t2)))) (define-syntax define-dm-scenario (syntax-rules () ((_ path desc b1 b2 ...) (define-scenario path desc (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 ...))))) ;;;----------------------------------------------------------- ;;; 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" (with-dm #t)) (define-scenario (dm create-device) "create and destroy a device" (with-dm (with-empty-device (dev "foo" "uuidd") #t))) (define-scenario (dm duplicate-name-fails) "You can't create two devices with the same name" (with-dm (with-empty-device (dev1 "foo" "uuid1") (assert-raises (with-empty-device (dev2 "foo" "uuid2") #t))))) (define-scenario (dm duplicate-uuid-fails) "You can't create two devices with the same uuid" (with-dm (with-empty-device (dev1 "foo" "uuid") (assert-raises (with-empty-device (dev2 "bar" "uuid") #t))))) (define-scenario (dm load-single-target) "You can load a single target table" (with-dm (with-empty-device (dev "foo" "uuid") ;; FIXME: export contructor for linear targets (load-table dev (list (linear (make-segment fast-dev 0 102400))))))) (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 (mk-fast-allocator) 32)))) (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 (mk-fast-allocator) 8)) (resume-device dev))) (define-dm-scenario (dm suspend-resume-cycle) "You can pause a device." (with-device (dev "foo" "uuid" (linear-table (mk-fast-allocator) 8)) (suspend-device dev) (resume-device dev))) (define-dm-scenario (dm reload-table) "You can reload a table" (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) "list-devices works" (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) "get-status works" (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) "get-table works" (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)))) (define-dm-scenario (thin discard recover-space) "Discarding blocks frees up space" (let ((data-size (meg 128))) (with-pool (pool (default-md-table) (default-data-table data-size) (kilo 64) (thin-pool-options error-if-no-space skip-block-zeroing)) (with-new-thin (thin pool 0 data-size) (zero-dev thin) (discard (dm-device-path thin) 0 (to-sectors data-size)) (assert-pool-used-data pool (kilo 64) (sectors 0)))))) )