302 lines
21 KiB
Common Lisp
302 lines
21 KiB
Common Lisp
;;;; Fault injection against an owned Xvfb and a real supervised developer loop.
|
|
;;;; Does not connect to the user's DISPLAY, REPL, or application processes.
|
|
(require :asdf)
|
|
(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
|
|
(asdf:load-system "lime/dev")
|
|
|
|
(handler-case
|
|
(let* ((directory (uiop:ensure-directory-pathname
|
|
(string-trim '(#\Newline) (uiop:run-program '("mktemp" "-d" "/tmp/lime-resilience-XXXXXX")
|
|
:output :string))))
|
|
(log-path (merge-pathnames "fault.log" directory))
|
|
(server (uiop:launch-program
|
|
'("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp")
|
|
:output :stream :error-output :interactive))
|
|
(session nil) (supervisor nil) (client-display nil) (checks 0)
|
|
(supervisor-error nil)
|
|
(original-configure (symbol-function 'lime.x11::%handle-configure-request))
|
|
(original-adopt (symbol-function 'lime.x11::icccm-adopt-client))
|
|
(original-shutdown-bars (symbol-function 'lime.x11::shutdown-head-bars))
|
|
(cleanup-count 0)
|
|
(original-start (symbol-function 'lime.x11:start-lime)))
|
|
(unwind-protect
|
|
(let* ((number (parse-integer (read-line (uiop:process-info-output server))))
|
|
(display-name (format nil ":~D" number))
|
|
(port-socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t))
|
|
(port (usocket:get-local-port port-socket)))
|
|
(usocket:socket-close port-socket)
|
|
(setf client-display (xlib:open-default-display display-name))
|
|
(let* ((root (xlib:screen-root (xlib:display-default-screen client-display)))
|
|
(windows (loop repeat 2 collect (xlib:create-window :parent root :x 0 :y 0
|
|
:width 100 :height 100)))
|
|
(original-world nil) (view-id "keep-this"))
|
|
(labels ((check (truth label)
|
|
(assert truth () "Resilience: ~A" label) (incf checks))
|
|
(await (predicate label)
|
|
(loop repeat 500 when (funcall predicate) return t
|
|
do (sleep 0.01)
|
|
finally
|
|
(error "Timed out: ~A (supervisor: ~A; running: ~S; paused: ~S; event: ~S; fault: ~S)"
|
|
label supervisor-error
|
|
(and session (lime.dev::development-session-running-p session))
|
|
(and session (paused))
|
|
(and session (lime.x11::x11-backend-event-context
|
|
(lime.dev:development-session-backend session)))
|
|
(and session (lime.dev::development-session-event-loop-condition session)))))
|
|
(owner (function)
|
|
(lime.dev:call-in-development-session function :session session))
|
|
(paused () (lime.dev::development-session-paused-p session))
|
|
(status () (lime.dev:development-status session))
|
|
(repl-alive ()
|
|
(let ((socket (usocket:socket-connect "127.0.0.1" port :timeout 1)))
|
|
(usocket:socket-close socket) t))
|
|
(client-exists (window)
|
|
(find (xlib:window-id window) (xlib:query-tree root) :key #'xlib:window-id))
|
|
(new-window ()
|
|
(let ((window (xlib:create-window :parent root :x 0 :y 0 :width 80 :height 80)))
|
|
(xlib:display-finish-output client-display) window))
|
|
(request-configure ()
|
|
(setf (xlib:drawable-width (first windows)) 321)
|
|
(xlib:display-finish-output client-display))
|
|
(inject-failure ()
|
|
(setf (symbol-function 'lime.x11::%handle-configure-request)
|
|
(lambda (&rest args) (declare (ignore args))
|
|
(error "Injected configure failure")))
|
|
(request-configure)
|
|
(await #'paused "fault pauses event handling")))
|
|
(dolist (window windows) (xlib:map-window window))
|
|
(xlib:display-finish-output client-display)
|
|
(setf supervisor
|
|
(bt:make-thread
|
|
(lambda ()
|
|
(handler-case
|
|
(lime.dev:run-development-session
|
|
:display-name display-name :head-discovery :none :session-file nil
|
|
:event-timeout 0.01 :diagnostic-file log-path :repl-port port)
|
|
(error (condition) (setf supervisor-error condition))))
|
|
:name "Owned resilience supervisor"))
|
|
(await (lambda () lime.dev:*development-session*) "session startup")
|
|
(setf session lime.dev:*development-session*)
|
|
;; Slynk installs debugger hooks; batch test failures must still
|
|
;; exit nonzero rather than falling into an EOF-driven REPL.
|
|
#+sbcl (sb-ext:disable-debugger)
|
|
(check (repl-alive) "private Slynk endpoint available")
|
|
(owner (lambda (backend)
|
|
(setf original-world (lime.x11:x11-backend-world backend))
|
|
(lime.x11:backend-save-view backend view-id "Keep this")
|
|
(lime.x11:backend-activate-view backend view-id)))
|
|
;; BadWindow may arrive BEFORE DestroyNotify has retired the client.
|
|
(let ((window (new-window)))
|
|
(owner (lambda (backend)
|
|
(let* ((display (lime.x11::x11-backend-display backend))
|
|
(managed (xlib::lookup-window display (xlib:window-id window))))
|
|
(lime.x11:manage-window backend managed)
|
|
(xlib:display-finish-output display)
|
|
(xlib:destroy-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(setf (xlib:drawable-x managed) 17)
|
|
(xlib:display-finish-output display))))
|
|
(check (not (paused)) "async destroyed-client configure is harmless"))
|
|
;; A query on a vanished, unregistered client must unwind, not hang.
|
|
(let ((window (new-window)))
|
|
(xlib:destroy-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(let ((before (lime.x11::x11-backend-expected-x-error-count
|
|
(lime.dev:development-session-backend session))))
|
|
(owner (lambda (backend)
|
|
(let ((display (lime.x11::x11-backend-display backend)))
|
|
(xlib:queue-event display :map-request :append-p t
|
|
:parent (lime.x11::x11-backend-root backend)
|
|
:window (xlib::lookup-window display (xlib:window-id window))))))
|
|
(await (lambda () (> (lime.x11::x11-backend-expected-x-error-count
|
|
(lime.dev:development-session-backend session)) before))
|
|
"stale MapRequest processed"))
|
|
(check (not (paused)) "stale MapRequest survives synchronous BadWindow"))
|
|
;; Mid-adoption death: registered in the adapter, not yet in the core.
|
|
(let ((window (new-window)) (destroyed-p nil))
|
|
(setf (symbol-function 'lime.x11::icccm-adopt-client)
|
|
(lambda (backend client-id managed)
|
|
(when (= (xlib:window-id managed) (xlib:window-id window))
|
|
(xlib:destroy-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(setf destroyed-p t))
|
|
(funcall original-adopt backend client-id managed)))
|
|
(xlib:map-window window)
|
|
(xlib:display-finish-output client-display)
|
|
;; Do not concurrently query the client connection while the
|
|
;; injected owner-thread hook is using that same CLX display.
|
|
(await (lambda () destroyed-p) "adoption victim gone")
|
|
(owner (lambda (backend)
|
|
(check (lime.core:validate-world (lime.x11:x11-backend-world backend))
|
|
"partial adoption does not corrupt core")))
|
|
(setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt)
|
|
(check (not (paused)) "mid-adoption death is harmless"))
|
|
;; Focus of an existing but unmapped window produces real BadMatch.
|
|
(let ((window (new-window)))
|
|
(owner (lambda (backend)
|
|
(let ((display (lime.x11::x11-backend-display backend)))
|
|
(xlib:set-input-focus display (xlib::lookup-window display (xlib:window-id window))
|
|
:pointer-root)
|
|
(xlib:display-finish-output display))))
|
|
(xlib:destroy-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(check (not (paused)) "unviewable focus is harmless"))
|
|
(check (>= (getf (getf (getf (status) :backend-status) :diagnostics) :expected-x-errors) 4)
|
|
"expected races are counted")
|
|
;; Root ownership conflicts must remain fatal to the attempted WM.
|
|
(check (handler-case
|
|
(progn (lime.x11:start-backend :display-name display-name :head-discovery :none) nil)
|
|
(xlib:access-error () t))
|
|
"second WM cannot silently claim root")
|
|
(check (not (paused)) "original WM unaffected by second WM")
|
|
;; Leave active grabs installed, then fail a real event handler.
|
|
(owner (lambda (backend)
|
|
(let ((wm-root (lime.x11::x11-backend-root backend)))
|
|
(check (eq :success (xlib:grab-keyboard wm-root)) "test keyboard grab")
|
|
(check (eq :success (xlib:grab-pointer wm-root '(:button-press :button-release)))
|
|
"test pointer grab")
|
|
(xlib:display-finish-output (lime.x11::x11-backend-display backend)))))
|
|
(inject-failure)
|
|
(let* ((snapshot (status))
|
|
(report (getf snapshot :last-error-report)))
|
|
(check (getf snapshot :running-p) "control session remains running")
|
|
(check (getf snapshot :event-thread-alive-p) "owner thread services paused mailbox")
|
|
(check (eq :configure-request (getf (getf report :event) :kind)) "diagnostic has event context")
|
|
(check (search "Injected configure failure" (getf report :message)) "diagnostic has original failure")
|
|
(check (search "%DISPATCH-NEXT-EVENT" (getf report :backtrace)) "backtrace captured before unwind")
|
|
(check (probe-file log-path) "fault diagnostic written")
|
|
(check (search "Injected configure failure" (uiop:read-file-string log-path)) "fault survives in log")
|
|
(check (string= "600" (string-trim '(#\Newline)
|
|
(uiop:run-program (list "stat" "-c" "%a" (namestring log-path))
|
|
:output :string))) "log is private")
|
|
(check (bt:thread-alive-p supervisor) "supervisor did not exit after event fault")
|
|
(check (repl-alive) "Slynk still accepts connections"))
|
|
(check (eq :success (xlib:grab-keyboard root)) "fault released keyboard grab")
|
|
(xlib:ungrab-keyboard client-display)
|
|
(check (eq :success (xlib:grab-pointer root '(:button-press))) "fault released pointer grab")
|
|
(xlib:ungrab-pointer client-display)
|
|
(xlib:display-finish-output client-display)
|
|
(check (every #'client-exists windows) "application windows survive pause")
|
|
;; Deliberately invalid model: recovery must refuse, not reset it.
|
|
(let ((presentation nil) (old-focus nil))
|
|
(owner (lambda (backend)
|
|
(setf presentation (lime.core:current-presentation
|
|
(lime.x11:x11-backend-world backend)
|
|
(lime.x11:x11-backend-focused-head-id backend))
|
|
old-focus (lime.core:presentation-focus-client-id presentation)
|
|
(lime.core:presentation-focus-client-id presentation) "missing-client")))
|
|
(check (handler-case (progn (lime.dev:resume-development-session session) nil)
|
|
(error () t)) "invalid model blocks resume")
|
|
(check (paused) "failed resume stays paused")
|
|
(owner (lambda (backend) (declare (ignore backend))
|
|
(setf (lime.core:presentation-focus-client-id presentation) old-focus))))
|
|
;; A core-valid but partially lost adapter mapping is not safe either.
|
|
(let ((id nil) (managed nil))
|
|
(owner (lambda (backend)
|
|
(setf id (lime.x11::%backend-client-id backend (first windows))
|
|
managed (gethash id (lime.x11::x11-backend-client-windows backend)))
|
|
(remhash id (lime.x11::x11-backend-client-windows backend))))
|
|
(check (handler-case (progn (lime.dev:resume-development-session session) nil)
|
|
(error () t)) "inconsistent adapter registration blocks resume")
|
|
(check (paused) "adapter validation failure stays paused")
|
|
(owner (lambda (backend)
|
|
(setf (gethash id (lime.x11::x11-backend-client-windows backend)) managed))))
|
|
(setf (symbol-function 'lime.x11::%handle-configure-request) original-configure)
|
|
(lime.dev:resume-development-session session)
|
|
(check (not (paused)) "explicit resume succeeds after repair")
|
|
(owner (lambda (backend)
|
|
(check (eq original-world (lime.x11:x11-backend-world backend)) "resume keeps same world")
|
|
(check (lime.core:find-view original-world view-id) "resume keeps saved checkpoint")
|
|
(check (lime.core:validate-world original-world) "resumed world valid")))
|
|
;; A surviving client whose adoption was interrupted can be finished
|
|
;; deliberately on resume, without replaying unrelated events.
|
|
(let ((window (new-window)))
|
|
(setf (symbol-function 'lime.x11::icccm-adopt-client)
|
|
(lambda (backend id managed)
|
|
(funcall original-adopt backend id managed)
|
|
(when (= (xlib:window-id managed) (xlib:window-id window))
|
|
(error "Injected partial adoption failure"))))
|
|
(xlib:map-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(await #'paused "interrupted live adoption pauses")
|
|
(setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt)
|
|
(lime.dev:resume-development-session session)
|
|
(owner (lambda (backend)
|
|
(check (lime.core:find-client original-world
|
|
(lime.x11::%backend-client-id backend window))
|
|
"resume finishes the interrupted adoption")
|
|
(check (lime.x11::%validate-client-registrations backend)
|
|
"repaired adoption has consistent registrations")))
|
|
(xlib:destroy-window window)
|
|
(xlib:display-finish-output client-display)
|
|
(await (lambda () (owner (lambda (backend)
|
|
(null (lime.x11::%backend-client-id backend window)))))
|
|
"recovered client retires normally"))
|
|
;; Logging itself must never cause the session to exit.
|
|
(owner (lambda (backend) (declare (ignore backend))
|
|
(setf (lime.dev::development-session-diagnostic-file session)
|
|
(merge-pathnames "fault.log/impossible" directory))))
|
|
(inject-failure)
|
|
(check (getf (status) :diagnostic-write-error) "log write failure remains inspectable")
|
|
(check (repl-alive) "failed log write does not take down control server")
|
|
(setf (symbol-function 'lime.x11::%handle-configure-request) original-configure)
|
|
(owner (lambda (backend) (declare (ignore backend))
|
|
(setf (lime.dev::development-session-diagnostic-file session) log-path)))
|
|
(lime.dev:resume-development-session session)
|
|
;; A slow failing restart lasts longer than the xinit supervisor poll.
|
|
(setf (symbol-function 'lime.x11:start-lime)
|
|
(lambda (&rest args) (declare (ignore args))
|
|
(sleep 1.2) (error "Injected restart failure")))
|
|
(check (handler-case (progn (lime.dev:restart-development-session session) nil)
|
|
(error () t)) "restart failure is reported to caller")
|
|
(check (bt:thread-alive-p supervisor) "slow failed restart retains xinit supervisor")
|
|
(check (paused) "failed restart leaves paused control session")
|
|
(check (repl-alive) "failed restart retains same Slynk endpoint")
|
|
(check (every #'client-exists windows) "applications survive failed restart")
|
|
(setf (symbol-function 'lime.x11:start-lime) original-start)
|
|
(lime.dev:restart-development-session session)
|
|
(check (not (paused)) "explicit retry can restart")
|
|
(check (repl-alive) "successful restart retains Slynk")
|
|
(owner (lambda (backend)
|
|
(check (not (eq original-world (lime.x11:x11-backend-world backend)))
|
|
"restart honestly makes a new world")
|
|
(check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend)))
|
|
"restart readopts surviving clients")))
|
|
;; A deliberate quit still exits the supervisor, even while paused.
|
|
(inject-failure)
|
|
;; A failed UI cleanup must not skip client restoration or CLX close.
|
|
(setf (symbol-function 'lime.x11::shutdown-head-bars)
|
|
(lambda (backend) (declare (ignore backend))
|
|
(incf cleanup-count)
|
|
;; Let the supervisor notice quit while a second caller
|
|
;; is already stopping. Cleanup must not run concurrently.
|
|
(sleep 1.2)
|
|
(error "Injected bar cleanup failure")))
|
|
(owner #'lime.x11:backend-request-quit)
|
|
(lime.dev:stop-development-session session)
|
|
(await (lambda () (not (bt:thread-alive-p supervisor))) "intentional quit exits supervisor")
|
|
(bt:join-thread supervisor)
|
|
(check (null supervisor-error) "supervisor returned normally")
|
|
(check (null lime.dev:*development-session*) "intentional quit clears current session")
|
|
(check (every #'client-exists windows) "graceful stop did not destroy client windows")
|
|
(check (= 1 cleanup-count) "concurrent explicit/supervised stop cleans up only once")
|
|
(check (null (lime.x11::x11-backend-display (lime.dev:development-session-backend session)))
|
|
"failed bar cleanup still closes CLX")
|
|
(check (find :cleanup (getf (lime.x11:backend-diagnostics
|
|
(lime.dev:development-session-backend session)) :reports)
|
|
:key (lambda (report) (getf report :source)))
|
|
"cleanup failure retained in diagnostics")
|
|
(format t "~&Live X11 resilience: ~D checks passed. Diagnostics: ~A~%" checks directory))))
|
|
(setf (symbol-function 'lime.x11::%handle-configure-request) original-configure
|
|
(symbol-function 'lime.x11::icccm-adopt-client) original-adopt
|
|
(symbol-function 'lime.x11::shutdown-head-bars) original-shutdown-bars
|
|
(symbol-function 'lime.x11:start-lime) original-start)
|
|
(when lime.dev:*development-session* (lime.dev:stop-development-session))
|
|
(when supervisor (bt:join-thread supervisor))
|
|
(when client-display (xlib:close-display client-display))
|
|
(uiop:terminate-process server)
|
|
(uiop:wait-process server)))
|
|
(error (condition)
|
|
(format *error-output* "~&Resilience smoke failed: ~A~%" condition)
|
|
(uiop:quit 1)))
|