thin-provisioning-tools/functional-tests/thin-xml.scm
2017-08-02 13:42:37 +01:00

105 lines
2.9 KiB
Scheme

(library
(thin-xml)
(export generate-xml to-attribute-name)
(import (rnrs)
(list-utils)
(fmt fmt)
(only (srfi s1 lists) iota)
(srfi s27 random-bits))
;;;----------------------------------------
(define (make-const-generator n)
(lambda () n))
(define (make-uniform-generator low hi)
(assert (<= low hi))
(let ((range (- hi low)))
(lambda ()
(+ low (random-integer range)))))
;;;----------------------------------------
(define (dquote doc)
(cat (dsp #\") doc (dsp #\")))
(define (to-attribute-name sym)
(define (to-underscore c)
(if (eq? #\- c) #\_ c))
(list->string (map to-underscore (string->list (symbol->string sym)))))
(define (attribute dotted-pair)
(let ((key (to-attribute-name (car dotted-pair)))
(val (cdr dotted-pair)))
(cat (dsp key)
(dsp "=")
(dquote ((if (string? val) dsp wrt) val)))))
(define (%open-tag sym attrs end)
(cat (dsp "<")
(dsp sym)
(dsp " ")
(apply cat (intersperse (dsp " ")
(map attribute attrs)))
(dsp end)))
(define (open-tag sym attrs)
(%open-tag sym attrs ">"))
(define (simple-tag sym attrs)
(%open-tag sym attrs "/>"))
(define (close-tag sym)
(cat (dsp "</")
(dsp sym)
(dsp ">")))
(define (tag sym attrs . body)
(if (null? body)
(simple-tag sym attrs)
(begin
(cat (open-tag sym attrs)
nl
(apply cat body)
nl
(close-tag sym)))))
(define (vcat docs)
(apply cat (intersperse nl docs)))
;;;----------------------------------------
(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))))))))