gansito05/lime
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Lime window manager

Browse Source
This commit is contained in:
Adan
2026-10-02 14:14:47 -05:00
commit 785c2e8968
103 changed files with 27259 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

215
test/persistence.lisp Normal file
View File

@@ -0,0 +1,215 @@
(defpackage #:lime.persistence.test
(:use #:cl #:fiveam #:lime.core #:lime.persistence)
(:export #:run-tests))
(in-package #:lime.persistence.test)
(def-suite persistence-suite)
(in-suite persistence-suite)
(defun fixture ()
(let ((world (make-world)))
(dolist (head '("left" "right")) (create-head world head))
(create-activity world "work" "Lime 日本語")
(create-activity world "game" "Game")
(dolist (id '("editor" "terminal" "browser" "hidden"))
(create-client world id "work" :name id :metadata '(:note "plain data")))
(create-view world "code" "work" "Code"
(mapcar (lambda (id) (make-placement :client-id id)) '("editor" "terminal"))
:layout-mode :master-stack :layout-options '(:master-ratio 2/3)
:focus-client-id "terminal")
(create-view world "docs" "work" "Docs"
(mapcar (lambda (id) (make-placement :client-id id)) '("browser" "editor"))
:layout-mode :monocle :focus-client-id "browser")
(activate-view-strictly world "left" "code")
(activate-view-partially world "right" "docs")
(let ((p (current-presentation world "left")))
(set-client-tile-weight world (presentation-id p) "editor" 3/2)
(toggle-client-floating world (presentation-id p) "terminal"
:data '(:x 1/4 :y 1/3 :width 1/2 :height 1/2)))
;; Make a cached draft as well as the active checkpoint realizations.
(open-activity-draft world "left" "game")
(activate-view-strictly world "left" "code")
(create-viewset world "desk" "Desk" (list (make-viewset-entry :head-id "left" :view-id "code")
(make-viewset-entry :head-id "right" :view-id "docs")))
world))
(test deleted-activity-and-associated-library-stay-deleted-after-restore
(let ((world (fixture)))
(create-view world "game/empty" "game" "Empty" nil)
(create-viewset world "obsolete" "Obsolete" (list (make-viewset-entry :head-id "left" :view-id "game/empty")))
(delete-activity world "game")
(let ((restored (restore-world (snapshot-world world))))
(is (equalp (snapshot-world world) (snapshot-world restored)))
(signals unknown-entity (find-activity restored "game"))
(signals unknown-entity (find-view restored "game/empty"))
(signals unknown-entity (find-viewset restored "obsolete"))
(is-true (validate-world restored)))))
(test sharing-and-moved-drafts-survive-roundtrip
(let ((world (fixture)))
(set-client-shared world "terminal" t)
(open-activity-draft world "left" "game")
(show-client-on-presentation world "terminal" (presentation-id (current-presentation world "left")))
(move-client-to-activity world "browser" "game" :target-head-id "right")
(let ((restored (restore-world (snapshot-world world))))
(is (equalp (snapshot-world world) (snapshot-world restored)))
(is-true (client-shared-p (find-client restored "terminal")))
(is (equal "work" (client-activity-id (find-client restored "terminal"))))
(is (equal "game" (presentation-activity-id
(find-presentation restored (lease-presentation-id (lease-for-client restored "terminal"))))))
(is (equal '("browser") (presentation-client-ids (activity-draft-for-head restored "game" "right")))))
(let ((data (snapshot-world world)))
(setf (getf (first (getf data :clients)) :shared) :invalid)
(signals error (restore-world data)))))
(test version-one-snapshots-upgrade-to-private-clients
(let* ((world (fixture)) (data (snapshot-world world)))
(setf (getf data :version) 1)
(dolist (row (getf data :clients)) (remf row :shared))
(let ((restored (restore-world data)))
(is (equalp (snapshot-world world) (snapshot-world restored)))
(is-false (client-shared-p (find-client restored "terminal"))))))
(test lossless-model-roundtrip-and-independent-objects
(let* ((world (fixture)) (data (snapshot-world world)) (restored (restore-world data)))
(is (equalp data (snapshot-world restored)))
(is-true (validate-world restored))
(is (equal '("hidden")
(set-difference (activity-client-ids (find-activity restored "work"))
'("editor" "terminal" "browser") :test #'equal)))
(is-false (presentation-unavailable-client-ids (current-presentation restored "right")))
(is (= 3 (hash-table-count (lime.core::world-leases restored))))
(setf (client-metadata (find-client restored "editor")) '(:changed t))
(is (equal '(:note "plain data") (client-metadata (find-client world "editor"))))
(let ((old (hash-table-count (lime.core::world-presentations restored))))
(open-activity-draft restored "right" "game")
(is (= (1+ old) (hash-table-count (lime.core::world-presentations restored)))))))
(test checkpoints-and-dirty-drafts-are-distinct
(let* ((world (fixture)) (p (current-presentation world "left")))
(hide-client-from-presentation world "terminal" (presentation-id p))
(let* ((restored (restore-world (snapshot-world world))) (p2 (current-presentation restored "left")))
(is-true (presentation-dirty-p p2))
(is (equal '("editor") (presentation-client-ids p2)))
(is (= 2 (length (view-placements (find-view restored "code")))))
(is (member "terminal" (presentation-hidden-client-ids restored p2) :test #'equal)))))
(test manual-tree-and-empty-library-roundtrip
(let* ((world (fixture)) (p (current-presentation world "left")))
(set-presentation-manual-layout world (presentation-id p))
(set-presentation-layout-root world (presentation-id p)
(make-layout-split :orientation :vertical :ratio 2/5
:first (make-layout-leaf :client-id "editor")
:second (make-layout-leaf :client-id "terminal")))
(is (equalp (snapshot-world world) (snapshot-world (restore-world (snapshot-world world))))))
(let ((world (make-world)))
(create-head world "one") (create-activity world "plain" "Plain")
(open-activity-draft world "one" "plain")
(let ((restored (restore-world (snapshot-world world))))
(is-false (activity-view-ids (find-activity restored "plain")))
(is-false (presentation-source-view-id (current-presentation restored "one")))
(is-true (validate-world restored)))))
(test displays-have-independent-default-stores
(is (not (equal (default-session-path ":0") (default-session-path ":99"))))
(is (not (equal (default-session-path ":0") (default-session-path "_3A0")))))
(test malformed-snapshots-are-rejected-before-a-world-is-returned
(let ((data (snapshot-world (fixture))))
(flet ((reject (function)
(let ((copy (copy-tree data))) (funcall function copy) (signals error (restore-world copy)))))
(reject (lambda (x) (setf (getf x :version) 99)))
(reject (lambda (x) (setf (getf (first (getf x :activities)) :clients) '("bogus"))))
(reject (lambda (x) (setf (getf (first (getf x :clients)) :activity) "missing")))
(reject (lambda (x) (setf (getf (first (getf x :heads)) :active) "missing")))
(reject (lambda (x) (setf (getf (first (getf x :presentations)) :layout) :bogus)))
(reject (lambda (x) (setf (getf (first (getf x :presentations)) :dirty) 12)))
(reject (lambda (x)
;; Give a second live arrangement an actual duplicate client.
(let ((right (find "right" (getf x :presentations) :key (lambda (p) (getf p :head)) :test #'equal)))
(push '(:client "editor" :kind :float :data (:x 0 :y 0 :width 1 :height 1))
(getf right :placements)))))
(reject (lambda (x) (push (first (getf x :views)) (getf x :views)))))))
(test plain-data-only
(is-true (check-data (make-list 10000 :initial-element :wide)))
(signals error (check-data (list :callback #'identity)))
(signals error (check-data (make-world)))
(let ((cycle (list :cycle)))
(setf (cdr cycle) cycle)
(signals error (check-data cycle)))
(signals error (check-data (loop repeat 140 for x = '(:end) then (list x) finally (return x)))))
(test legacy-arrangements-consolidate-without-touching-windows-or-checkpoints
(let* ((world (fixture)) (ignored (create-head world "third"))
(data (snapshot-world world))
(active (find "left" (getf data :heads) :key (lambda (h) (getf h :id)) :test #'equal))
(row (find (getf active :active) (getf data :presentations) :key (lambda (p) (getf p :id)) :test #'equal))
(duplicate (copy-tree row)) (stale (copy-tree row)))
(declare (ignore ignored))
(setf (getf duplicate :id) "presentation-900"
(getf stale :id) "presentation-901" (getf stale :head) "third")
(push duplicate (getf data :presentations))
(push stale (getf data :presentations))
;; Version 3 rejects duplicates instead of silently repairing corruption.
(signals error (restore-world data))
(setf (getf data :version) 2)
(let* ((restored (restore-world data)) (after (snapshot-world restored)))
(dolist (key '(:clients :activities :views :viewsets :heads))
(is (equalp (getf data key) (getf after key))))
(is (equalp row (find (getf row :id) (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal)))
(signals unknown-entity (find-presentation restored "presentation-900"))
(is-false (presentation-client-ids (find-presentation restored "presentation-901")))
(is-false (presentation-source-view-id (find-presentation restored "presentation-901")))
(normalize-activity-arrangements restored)
(is (equalp after (snapshot-world restored)))
(is-true (validate-world restored)))))
(test worker-copy-does-not-share-mutable-strings
(let* ((text (copy-seq "Original")) (data (list :name text :pair (cons :label text)))
(copy (copy-data data)))
(setf (char text 0) #\X)
(is (string= "Original" (getf copy :name)))
(is (string= "Original" (cdr (getf copy :pair))))))
(defmacro with-store ((store path) &body body)
`(uiop:with-temporary-file (:pathname ,path :prefix "lime-persistence-test-")
(delete-file ,path)
(let ((,store (open-session-store ,path)))
(unwind-protect (progn ,@body)
(close-session-store ,store)
(let ((lock (pathname (concatenate 'string (namestring ,path) ".lock"))))
(when (probe-file lock) (delete-file lock)))))))
(test atomic-private-storage-and-writer-exclusion
(with-store (store path)
(is-false (read-session-store store))
(signals error (open-session-store path))
(is (= 1 (logand 1 (cffi:foreign-funcall "fcntl" :int (lime.persistence::session-store-descriptor store) :int 1 :int))))
(let ((data (snapshot-world (fixture))))
(write-session-store store data)
(is (equalp data (read-session-store store)))
(is (string= "600" (string-trim '(#\Newline) (uiop:run-program (list "stat" "-c" "%a" (namestring path)) :output :string))))
(let ((original (symbol-function 'lime.persistence::%sync-path)))
(unwind-protect
(progn
(setf (symbol-function 'lime.persistence::%sync-path)
(lambda (path) (declare (ignore path)) (error "Injected disk failure")))
(signals error (write-session-store store '(:replacement t))))
(setf (symbol-function 'lime.persistence::%sync-path) original)))
(is (equalp data (read-session-store store))))
(close-session-store store)
(let ((again (open-session-store path)))
(is-true again) (close-session-store again))))
(defvar *read-executed* nil)
(test reader-does-not-evaluate-or-accept-trailing-truncated-or-circular-data
(with-store (store path)
(dolist (text '("#.(setf lime.persistence.test::*read-executed* t)"
"#S(LIME.CORE::WORLD)" "#1=(:cycle . #1#)" "(:one 1) (:two 2)"
"(:missing" "" "(:text \"unterminated)"))
(with-open-file (stream path :direction :output :if-exists :supersede)
(write-string text stream))
(signals error (read-session-store store)))
(is-false *read-executed*)))
(defun run-tests () (unless (run! 'persistence-suite) (error "Persistence tests failed.")))