(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.")))