test/output-batch.sgl

1(import (sigil async) (sigil io) (sigil process) (sigil ffi) (sigil wm host))

2(define host (start-host! protocols: 128))

3(define outputs '())

4(define stage 'initial)

5(define token #f)

6(define before #f)

7(define errors '())

8(define rollback-failure? (and (getenv "SIGIL_WM_TEST_ROLLBACK_FAILURE") #t))

9(define partial-commits (c-function (c-library #f) "wm_test_partial_commits" '() ffi/int))

10(define (require condition message)

11 (unless condition (error message)))

12(define (settings width height)

13 (map (lambda (id index)

14 (dict id: id enabled: #t x: (* index width) y: 0 scale: 1 transform: 0

15 mode: -1 width: width height: height refresh: 60000))

16 outputs (iota (length outputs))))

17(define (current) (dict-ref (host-snapshot host) outputs:))

18(define (size? width height)

19 (every (lambda (output)

20 (and (= (dict-ref output width:) width) (= (dict-ref output height:) height)))

21 (current)))

22(on-event! host

23 (lambda (event)

24 (guard (exception

25 (#t (set! errors (cons exception errors)) (write exception) (newline) (stop-host! host)))

26 (case (event-type event)

27 ((output-added) (set! outputs (append outputs (list (event-ref event id:)))))

28 ((ready)

29 (require (= (length outputs) 2) "output batch requires two outputs")

30 (set! token (configure-outputs! host (settings 960 640))))

31 ((configuration-result)

32 (when (= (event-ref event id:) token)

33 (case stage

34 ((initial)

35 (require (event-ref event success?:) "initial output batch failed")

36 (require (size? 960 640) "initial output facts are wrong")

37 (set! before (host-snapshot host))

38 (set! stage 'test)

39 (set! token (configure-outputs! host (settings 800 600) test?: #t)))

40 ((test)

41 (require (event-ref event success?:) "output test was refused")

42 (require (size? 960 640) "test-only output batch changed state")

43 (set! stage 'fault)

44 (set! token (configure-outputs! host (settings 800 600))))

45 ((fault)

46 (require (not (event-ref event success?:)) "injected partial commit succeeded")

47 (require (= (partial-commits) 1) "partial commit interposer did not run")

48 (require (= (event-ref event rollback:) (if rollback-failure? 2 1)) "wrong rollback outcome")

49 (if rollback-failure?

50 (require (and (find (lambda (output) (= (dict-ref output width:) 800)) (current))

51 (find (lambda (output) (= (dict-ref output width:) 960)) (current)))

52 "failed rollback did not publish actual partial hardware state")

53 (require (size? 960 640) "rollback did not restore both outputs"))

54 (require (every (lambda (output) (= (dict-ref output width:) 960))

55 (dict-ref before outputs:)) "prior snapshot was mutated")

56 (set! stage 'retry)

57 (set! token (configure-outputs! host (settings 800 600))))

58 ((retry)

59 (require (event-ref event success?:) "output retry failed")

60 (require (size? 800 600) "output retry facts are wrong")

61 (set! stage 'complete)

62 (stop-host! host)))))))))

63(with-async (run-host! host))

64(unless (and (null? errors) (eq? stage 'complete)

65 (= (host-statistic host 1) 0) (= (host-statistic host 2) 0)

66 (= (host-statistic host 3) 0) (= (host-statistic host 4) 0))

67 (error "output batch fixture failed" stage errors))

68(display "OUTPUT_BATCH=PASS test-only partial commit rollback actual-state retry immutable snapshots\n")