packages/slate-cli/test/test-agent-t1.sgl

1;;; T1 turn-control contract: durable delivery state and cooperative interrupt.

3(import (sigil test)

4 (sigil core)

5 (sigil fs)

6 (sigil path)

7 (slate-cli agent provider)

8 (slate-cli agent transcript)

9 (slate-cli agent loop))

11(define (session-at dir)

12 (transcript-create!

13 dir #{ workspace: dir provider: "fake" model: "m"

14 grants: #{ exec: #f } persona: #{} drafts: '() }))

16(define (delivery id sequence actor mode text)

17 #{ id: id sequence: sequence actor: actor source-kind: "controller"

18 deliver-as: mode text: text state: "queued" created: 1 })

20(define (event-types dir)

21 (map (lambda (entry) (dict-ref entry type: ""))

22 (dict-ref (transcript-load dir) entries: '())))

24(define (position-of value values)

25 (let loop ((rest values) (position 0))

26 (cond ((null? rest) #f)

27 ((string=? (car rest) value) position)

28 (else (loop (cdr rest) (+ position 1))))))

30(define (tool-boundary-run name arguments)

31 (let* ((dir (make-temp-directory))

32 (cancel (vector #f ""))

33 (round (vector 0))

34 (provider (make-provider "fake" chat-completions: "http://fake" #{} '("m")))

35 (complete

36 (lambda (_provider _model _messages _tools _turn _timeout)

37 (let ((n (vector-ref round 0)))

38 (vector-set! round 0 (+ n 1))

39 (if (= n 0)

40 (begin

41 ;; A steer becomes pending at the provider/tool boundary.

42 ;; The tool still reaches a terminal record before the

43 ;; next provider call observes cancellation.

44 (vector-set! cancel 1 "steer")

45 (vector-set! cancel 0 #t)

46 (make-assistant-message ""

47 (list (make-tool-call "boundary-call" name arguments))

48 (make-usage 1 1 0 2)))

49 (agent-error 'cancelled "cancelled" #{}))))))

50 (session-at dir)

51 (list dir

52 (run-agent-turn! dir dir provider "m" "boundary" "next-turn" "web:a"

53 complete (lambda (_) #t) cancel-state: cancel))))

55(test-group "T1 durable delivery journal"

56 (test "queued intent survives reload and transitions exactly once"

57 (let ((dir (make-temp-directory)))

58 (session-at dir)

59 (transcript-enqueue-delivery! dir (delivery "q-1" 1 "web:a" "next-turn" "one"))

60 (transcript-enqueue-delivery! dir (delivery "q-2" 2 "web:b" "follow-up" "two"))

61 (transcript-update-delivery! dir "q-1" "claimed" #{ turn-id: "turn-1" })

62 (transcript-update-delivery! dir "q-1" "consumed" #{ consumed: 2 })

63 (let ((loaded (transcript-deliveries dir)))

64 (assert-equal (length loaded) 2)

65 (assert-equal (dict-ref (car loaded) id: "") "q-1")

66 (assert-equal (dict-ref (car loaded) state: "") "consumed")

67 (assert-equal (dict-ref (cadr loaded) actor: "") "web:b")

68 (assert-equal (dict-ref (cadr loaded) sequence: 0) 2))))

70 (test "a torn or malformed delivery record is a loud typed error"

71 (let ((dir (make-temp-directory)))

72 (session-at dir)

73 (write-file-string (delivery-path dir) "{broken\n")

74 (assert-true (transcript-error? (transcript-deliveries dir))))))

76(test-group "T1 cooperative cancellation"

77 (test "provider cancellation closes the partial message and interrupts the turn"

78 (let* ((dir (make-temp-directory))

79 (cancel (vector #f ""))

80 (events '())

81 (provider (make-provider "fake" chat-completions: "http://fake" #{} '("m")))

82 (complete

83 (lambda (_provider _model _messages _tools _turn _timeout)

84 (agent-delta! "partial")

85 (vector-set! cancel 1 "steer")

86 (vector-set! cancel 0 #t)

87 (agent-error 'cancelled "cancelled" #{}))))

88 (session-at dir)

89 (let ((result (run-agent-turn! dir dir provider "m" "first" "next-turn" "web:a"

90 complete

91 (lambda (event) (set! events (cons event events)))

92 cancel-state: cancel)))

93 (assert-true (dict-ref result interrupted: #f))

94 (assert-equal (dict-ref result reason: "") "steer")

95 (assert-true (member "message-end" (event-types dir)))

96 (assert-true (member "turn-interrupted" (event-types dir)))

97 (assert-true (member "turn-end" (event-types dir)))

98 (assert-false (member "agent-settled" (event-types dir))))))

100 (test "ordinary completion still reaches the settled boundary"

101 (let* ((dir (make-temp-directory))

102 (provider (make-provider "fake" chat-completions: "http://fake" #{} '("m")))

103 (complete

104 (lambda (_provider _model _messages _tools _turn _timeout)

105 (make-assistant-message "done" '() (make-usage 1 1 0 2)))))

106 (session-at dir)

107 (run-agent-turn! dir dir provider "m" "first" "next-turn" "web:a"

108 complete (lambda (_) #t))

109 (assert-true (member "agent-settled" (event-types dir)))))

110

111 (test "a queued steer waits for a read-only tool terminal boundary"

112 (let* ((run (tool-boundary-run "read" #{ path: "./" }))

113 (dir (car run))

114 (result (cadr run))

115 (types (event-types dir)))

116 (assert-true (dict-ref result interrupted: #f))

117 (assert-true (member "tool-execution-end" types))

118 (assert-true (< (position-of "tool-execution-end" types)

119 (position-of "turn-interrupted" types)))))

120

121 (test "a queued steer never cancels an atomic mutating tool"

122 (let* ((run (tool-boundary-run "write"

123 #{ path: "boundary.txt" content: "committed" }))

124 (dir (car run))

125 (result (cadr run)))

126 (assert-true (dict-ref result interrupted: #f))

127 (assert-equal (read-file-string (path-join dir "boundary.txt")) "committed")

128 (assert-true (member "file-change" (event-types dir)))

129 (assert-true (member "tool-execution-end" (event-types dir))))))