thin-provisioning-tools/functional-tests/device-mapper/dm-tests.scm

(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)
          (loops)
          (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)

  ;; FIXME: use memoisation to avoid running blockdev so much
  (define (get-dev-size dev)
    (run-ok-rcv (stdout stderr) (fmt #f "blockdev --getsz " dev)
                (string->number (chomp stdout))))

  ;; 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 size))))

  (define slow-dev "/dev/vdb")
  (define mk-slow-allocator
    (let ((size (get-dev-size slow-dev)))
     (lambda ()
       (make-allocator slow-dev 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 data-size block-size opts)
    (let ((opts-str (expand-thin-options opts)))
      (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)))))

  ;; FIXME: move somewhere else, and do IO in bigger blocks
  (define (zero-dev dev size)
    (define (dd . args)
      (build-command-line (cons "dd" args)))

    (run-ok (dd "if=/dev/zero"
                (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 (with-pool-fn fast-allocator slow-allocator size block-size fn)
    (let ((metadata-table (list (fast-allocator (meg 32))))
          (data-table (list (slow-allocator size))))
         (with-devices ((md (generate-dev-name) "" metadata-table)
                        (data (generate-dev-name) "" data-table))
           (zero-dev md (kilo 4))
           (let ((ptable (pool-table md data size block-size (thin-pool-options))))
            (with-device (pool (generate-dev-name) "" ptable)
                         (fn pool))))))

  (define-syntax with-pool
    (syntax-rules ()
      ((_ (pool md-allocator data-allocator size block-size) b1 b2 ...)
       (with-pool-fn md-allocator
                     data-allocator
                     size
                     block-size
                     (lambda (pool) b1 b2 ...)))))

  (define-syntax define-thin-scenario
    (syntax-rules ()
      ((_ path (pool size) desc b1 b2 ...)
       (define-dm-scenario path desc
         (with-pool-fn (mk-fast-allocator)
                       (mk-slow-allocator)
                       size
                       (kilo 64)
                       (lambda (pool) b1 b2 ...))))))

  (define generate-dev-name
    (let ((nr 0))
     (lambda ()
       (let ((name (fmt #f "test-dev-" nr)))
        (set! nr (+ nr 1))
        name))))

  (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 (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 ...)))))

  ;;;-----------------------------------------------------------
  ;;; 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 device-details-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
  ;;;-----------------------------------------------------------
  (define-thin-scenario (thin create-pool) (pool (gig 10))
    "create a pool"
    #t)

  (define-thin-scenario (thin create-thin) (pool (gig 10))
    "create a thin volume larger than the pool"
    (with-new-thin (thin pool 0 (gig 100))
                   #t))

  (define-thin-scenario (thin zero-thin) (pool (gig 10))
    "zero a 1 gig thin device"
    (let ((thin-size (gig 1)))
     (with-new-thin (thin pool 0 thin-size)
       (zero-dev thin thin-size))))

  ;;;-----------------------------------------------------------
  ;;; Thin creation scenarios
  ;;;-----------------------------------------------------------
  (define-thin-scenario (thin create lots-of-thins) (pool (gig 10))
    "create lots of empty thin volumes"
    (upto (n 1000) (create-thin pool n)))

  (define-thin-scenario (thin create lots-of-snaps) (pool (gig 10))
    "create lots of snapshots of a single volume"
    (create-thin pool 0)
    (upto (n 999)
          (create-snap pool (+ n 1) 0)))

  (define-thin-scenario (thin create lots-of-recursive-snaps) (pool (gig 10))
    "create lots of recursive snapshots"
    (create-thin pool 0)
    (upto (n 999)
          (create-snap pool (+ n 1) n)))

  (define-thin-scenario (thin create activate-thin-while-pool-suspended-fails) (pool (gig 10))
    "you can't activate a thin device while the pool is suspended"
    (create-thin pool 0)
    (pause-device pool
      (assert-raises
        (with-thin (thin pool 0 (gig 1))
          (fail "activate shouldn't work")))))

  (define-dm-scenario (thin create huge-block-size)
    "huge block sizes are possible"
    (let ((size (sectors 524288)))
     (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) size)
       (with-new-thin (thin pool 0 size)
                      (rand-write-and-verify thin)))))

  ;; FIXME: I thought we supported this?
  (define-dm-scenario (thin create non-power-2-block-size-fails)
    "The block size must be a power of 2"
    (assert-raises
      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 57))
                 #t)))

  (define-dm-scenario (thin create tiny-block-size-fails)
    "The block size must be at least 64k"
    (assert-raises
      (with-pool (pool (mk-fast-allocator) (mk-slow-allocator) (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 (mk-fast-allocator) (mk-slow-allocator) (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 (mk-fast-allocator) (mk-slow-allocator) (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-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
      (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-pool (pool (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
      (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 (mk-fast-allocator) (mk-slow-allocator) (gig 10) (kilo 64))
;;                 )))
)