;;;; Isolated X + fake MPD protocol peer. Never changes the user's audio/player. (require :asdf) (asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) (asdf:load-system "lime/x11") (let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") :output :stream :error-output :interactive)) (backend nil) (checks 0) (listener nil) (peer nil) (peer-thread nil) (peer-error nil) (gate (bt:make-lock)) (signal (bt:make-condition-variable)) (phase 0) (allow-change nil) (requests 0)) (unwind-protect (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) (display-name (format nil ":~D" number))) (labels ((check (truth label) (assert truth () "Status: ~A" label) (incf checks)) (await (predicate &optional (seconds 3)) (let ((deadline (+ (get-internal-real-time) (* seconds internal-time-units-per-second)))) (loop until (funcall predicate) do (when (> (get-internal-real-time) deadline) (error "Status test timed out: ~A" peer-error)) (sleep 0.005)))) (cached (id) (getf (find id (lime.x11:backend-status-provider-report backend) :key (lambda (entry) (getf entry :id))) :text)) (snapshot (id) (getf (find id (lime.x11:backend-status-provider-report backend) :key (lambda (entry) (getf entry :id))) :value)) (pump () (xlib:event-case ((lime.x11::x11-backend-display backend) :timeout 1 :discard-p t) (:client-message (window type) (lime.x11::%handle-status-notification backend window type) t) (otherwise () t)))) (setf backend (lime.x11:start-lime :display-name display-name :head-discovery :none)) (let ((revision (lime.core:world-revision (lime.x11:x11-backend-world backend)))) ;; Fake MPD retains a change occurring between snapshot and idle. (setf listener (usocket:socket-listen "127.0.0.1" 0 :reuse-address t :element-type '(unsigned-byte 8))) (setf peer-thread (bt:make-thread (lambda () (handler-case (progn (setf peer (usocket:socket-accept listener :element-type '(unsigned-byte 8))) (let ((stream (usocket:socket-stream peer))) (lime.x11::%mpd-send stream "OK MPD 0.24.0") (loop for command = (lime.x11::%mpd-line stream) do (incf requests) (cond ((string= command "status") (lime.x11::%mpd-send stream (if (zerop phase) "state: play" "state: pause")) (lime.x11::%mpd-send stream "OK")) ((string= command "currentsong") (lime.x11::%mpd-send stream "Title: 日本語 music") (lime.x11::%mpd-send stream "OK")) ((string= command "idle player playlist") (bt:with-lock-held (gate) (loop until allow-change do (bt:condition-wait signal gate)) (setf allow-change nil)) (incf phase) (lime.x11::%mpd-send stream "changed: player") (lime.x11::%mpd-send stream "OK")) (t (error "Unexpected MPD request: ~A" command)))))) (error (condition) (setf peer-error condition)))) :name "Fake MPD")) (let* ((music (lime.x11:make-music-status-provider :mpd-port (usocket:get-local-port listener))) (clock (lime.x11:make-clock-status-provider)) (config (lime.x11:make-lime-configuration :status-providers (list music clock) :status-providers-supplied-p t))) (lime.x11:apply-lime-configuration backend config) (await (lambda () (and (cached :music) (cached :clock)))) (check (string= " 日本語 music" (cached :music)) "UTF-8 native MPD initial snapshot") (check (equal '(:state :playing :title "日本語 music" :source :mpd) (snapshot :music)) "MPD publishes data, not icons") (check (search "" (cached :clock)) "initial clock") (check (= 2 (length (lime.x11::status-runtime-workers (lime.x11::x11-backend-status-runtime backend)))) "one worker per provider, not per Head") (await (lambda () (>= requests 3))) (let ((count requests)) (sleep 0.08) (check (= count requests) "idle causes zero repeat MPD queries")) ;; Drain initial exposures and the initial coalesced publication. (loop while (xlib:event-listen (lime.x11::x11-backend-display backend)) do (pump)) (let ((runtime (lime.x11::x11-backend-status-runtime backend))) (check (not (lime.x11::status-runtime-dirty-p runtime)) "initial notification consumed") (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal)) (let ((start (get-internal-real-time))) ;; This waits for an actual X event, not a polling refresh. (pump) (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 0.75) "publication wakes an idle X wait immediately")) (check (string= " 日本語 music" (cached :music)) "pause event, no user input needed") ;; Presentation changes consume the cache on the X thread; ;; there is no new query, source restart, or source mutation. (let* ((formatter (lime.x11:status-provider-formatter music)) (workers (copy-list (lime.x11::status-runtime-workers runtime))) (before (snapshot :music)) (count requests)) (unwind-protect (progn (setf (lime.x11:status-provider-formatter music) (lambda (data) (lime.x11:make-head-bar-segment :text (format nil "Track: ~A" (getf data :title)) :foreground "#55aa66"))) (lime.x11:apply-lime-configuration backend config) (check (string= "Track: 日本語 music" (cached :music)) "configured label replaces default icons") (check (equal before (snapshot :music)) "formatting leaves source data intact") (check (equal workers (lime.x11::status-runtime-workers runtime)) "style reload keeps existing workers") (check (= count requests) "style change does not query MPD") (let* ((bar (gethash (first (lime.x11:backend-head-ids backend)) (lime.x11::x11-backend-head-bars backend))) (pixels (lime.x11::ui-canvas-pixels (lime.x11::x11-head-bar-canvas bar)))) (check (loop for i below (array-total-size pixels) thereis (= #x55aa66 (logand #xffffff (row-major-aref pixels i)))) "custom widget color actually painted")) (setf (lime.x11:status-provider-formatter music) (lambda (data) (declare (ignore data)) (error "broken fixture formatter"))) (lime.x11::render-head-bars backend) (check (typep (lime.x11:backend-last-command-error backend) 'error) "formatter error isolated") (check (cached :clock) "other widget survives formatter failure") (check (equal before (snapshot :music)) "formatter failure preserves data") (check (every (lambda (worker) (bt:thread-alive-p (lime.x11::status-worker-thread worker))) workers) "formatter failure does not kill workers")) (setf (lime.x11:status-provider-formatter music) formatter) (lime.x11::render-head-bars backend))) (let ((worker (find music (lime.x11::status-runtime-workers runtime) :key #'lime.x11::status-worker-provider))) (lime.x11:status-publish worker (snapshot :music)) (check (not (lime.x11::status-runtime-dirty-p runtime)) "identical data does not enqueue a redraw") (lime.x11:status-publish worker '(:state :paused :title "burst one" :source :mpd)) (lime.x11:status-publish worker '(:state :paused :title "burst two" :source :mpd)) (pump) (check (string= " burst two" (cached :music)) "coalesced notification paints latest value")) (check (= revision (lime.core:world-revision (lime.x11:x11-backend-world backend))) "status never changes model state") (let ((workers (copy-list (lime.x11::status-runtime-workers runtime)))) (lime.x11:apply-lime-configuration backend config) (check (equal workers (lime.x11::status-runtime-workers runtime)) "same provider objects are not duplicated on reload")) ;; Failed reload must restore old providers with live workers. (handler-case (lime.x11:apply-lime-configuration backend (lime.x11:make-lime-configuration :status-providers (list (lime.x11:make-clock-status-provider :id :replacement)) :status-providers-supplied-p t :startup-hooks (list (lambda (ignored) (declare (ignore ignored)) (error "test rollback")))) :run-startup-hooks-p t) (error ())) (check (eq config (lime.x11:x11-backend-configuration backend)) "configuration rolled back") (check (equal (sort (mapcar (lambda (entry) (getf entry :id)) (lime.x11:backend-status-provider-report backend)) #'string< :key #'symbol-name) '(:clock :music)) "old provider set restored") ;; Stop while the clock sleeps and MPD is blocked in idle. (let ((workers (copy-list (lime.x11::status-runtime-workers runtime))) (start (get-internal-real-time))) (lime.x11:backend-set-head-bar-status-providers backend nil) (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 4) "bounded cancellation") (check (every (lambda (worker) (not (bt:thread-alive-p (lime.x11::status-worker-thread worker)))) workers) "all removed workers joined") (check (null (lime.x11::x11-backend-status-runtime backend)) "last removal closes notifier")))) ;; A failed source is isolated and retries while other widgets run. (let* ((attempts 0) (failed (lime.x11:make-status-provider :id :test-retry :run (lambda (worker) (incf attempts) (if (= attempts 1) (error "fixture unavailable") (progn (lime.x11:status-publish worker "reconnected") (lime.x11:status-wait worker 60)))))) (clock (lime.x11:make-clock-status-provider))) (lime.x11:backend-set-head-bar-status-providers backend (list failed clock)) (await (lambda () (and (cached :clock) (cached :test-retry)))) (check (= 2 attempts) "source failure retries with backoff") (check (string= "reconnected" (cached :test-retry)) "other providers survive failure")) ;; A blocked subprocess is killed/reaped, not left after reload. (let ((provider (lime.x11:make-status-provider :id :blocked-helper :run (lambda (worker) (lime.x11::%call-with-status-process worker '("sleep" "60") (lambda (stream process) (declare (ignore process)) (lime.x11::%status-read-line stream))))))) (lime.x11:backend-set-head-bar-status-providers backend (list provider)) (let* ((runtime (lime.x11::x11-backend-status-runtime backend)) (worker (first (lime.x11::status-runtime-workers runtime)))) (await (lambda () (bt:with-lock-held ((lime.x11::status-worker-lock worker)) (lime.x11::status-worker-cancel-functions worker)))) (let ((start (get-internal-real-time))) (lime.x11:backend-set-head-bar-status-providers backend nil) (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 1) "blocked helper cancellation is immediate") (check (not (bt:thread-alive-p (lime.x11::status-worker-thread worker))) "helper reader joined")))) (format t "~&Status live-X smoke: ~D checks passed.~%" checks)))) (when backend (lime.x11:stop-backend backend)) (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal)) (when peer (ignore-errors (usocket:socket-shutdown peer :io))) (when listener (ignore-errors (usocket:socket-close listener))) (when peer-thread (bt:join-thread peer-thread)) (when peer (ignore-errors (usocket:socket-close peer))) (uiop:terminate-process server) (uiop:wait-process server)))