Initial Lime window manager

work/upgrade-live-arrangements.lisp

@@ -0,0 +1,110 @@
+;;;; One-time, owner-thread upgrade. No structure changes or X window moves.
+(in-package #:cl-user)
+
+(defun lime-upgrade-live-arrangements ()
+  (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process."))
+  (lime.dev:with-development-backend (backend)
+    (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*)
+                 (not (lime.dev::development-session-paused-p lime.dev:*development-session*)))
+      (error "Lime is not running normally."))
+    (when (or (lime.x11::x11-backend-pointer-drag backend)
+              (lime.x11::x11-backend-ui-session backend))
+      (error "Close the menu or finish the drag before upgrading."))
+    (let* ((world (lime.x11::x11-backend-world backend))
+           (session (lime.x11::%session-snapshot backend))
+           (before (getf session :world))
+           (nav (gethash backend lime.x11::*backend-navigation-states*))
+           (old-nav (and nav (lime.x11::copy-navigation-state nav)))
+           (preferred (mapcar #'third (getf (getf session :navigation) :resume)))
+           (slots (lime.x11:backend-navigation-slots backend))
+           (config (lime.x11::x11-backend-configuration backend))
+           (revision (lime.core:world-revision world))
+           (records (loop for p being the hash-values of (lime.core::world-presentations world)
+                          collect (cons p (lime.core::copy-presentation p))))
+           (manifest
+             '((:lime.core "src/operations.lisp"
+                "PREFLIGHT-PRESENTATION-RESUME" "ACTIVITY-DRAFT-FOR-HEAD" "PREFLIGHT-ACTIVITY-DRAFT"
+                "%TRANSFER-AWAY-FROM-INCUMBENT" "%REMOVE-LIVE-PLACEMENT" "%CLAIM-LIVE-LOCATIONS"
+                "COMMIT-ACTIVATION-PLAN" "OPEN-ACTIVITY-DRAFT" "TRANSFER-CLIENT-LEASE"
+                "RECLAIM-AVAILABLE-SLOTS" "SHOW-CLIENT-ON-PRESENTATION"
+                "NORMALIZE-ACTIVITY-ARRANGEMENTS" "VALIDATE-WORLD")
+               (:lime.core "src/membership.lisp" "MOVE-CLIENT-TO-ACTIVITY")
+               (:lime.core "src/viewset.lisp" "%INSTALL-VIEWSET-ENTRY")
+               (:lime.core "src/topology.lisp" "COMMIT-HEAD-TOPOLOGY-RECONCILIATION-PLAN")
+               (:lime.persistence "src/persistence/model.lisp" "SNAPSHOT-WORLD" "RESTORE-WORLD")
+               (:lime.x11 "src/x11/commands.lisp" "BACKEND-ACTIVATE-ACTIVITY" "BACKEND-ATTEND-CLIENT")
+               (:lime.x11 "src/x11/navigation.lisp" "%NAVIGATION-RESUME-TARGET")
+               (:lime.x11 "src/x11/ui.lisp" "%UI-REQUEST-ACTIVITY-ACTIVATION")
+               (:lime.x11 "src/x11/persistence.lisp" "%VALIDATE-SESSION-ENVELOPE" "%PREPARE-SESSION-PERSISTENCE")))
+           (old-functions nil) (definitions nil) (migration nil))
+      ;; An exact, current session backup using the normal private atomic writer.
+      (when (probe-file #p"/home/adan/.local/state/lime/pre-arrangements-Om1oWG/live-before.sexp")
+        (error "The pre-upgrade backup already exists; refusing to overwrite it."))
+      (let ((store (lime.persistence:open-session-store
+                    #p"/home/adan/.local/state/lime/pre-arrangements-Om1oWG/live-before.sexp")))
+        (unwind-protect (lime.persistence:write-session-store store session)
+          (lime.persistence:close-session-store store)))
+      (export 'lime.core::normalize-activity-arrangements :lime.core)
+      (dolist (entry manifest)
+        (destructuring-bind (package file &rest names) entry
+          (let* ((*package* (find-package package)) (*read-eval* nil)
+                 (symbols (mapcar (lambda (name) (intern name *package*)) names))
+                 (found nil))
+            (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/"))
+              (loop for form = (read in nil :eof) until (eq form :eof)
+                    when (and (consp form) (eq (first form) 'defun) (member (second form) symbols))
+                    do (push form found)))
+            (assert (= (length symbols) (length found)))
+            (dolist (name symbols)
+              (assert (find name found :key #'second))
+              (push (cons name (and (fboundp name) (fdefinition name))) old-functions))
+            (setf definitions (append definitions (nreverse found))))))
+      (handler-case
+          (progn
+            (dolist (form definitions) (eval form))
+            ;; Recheck a fresh copy of this precise live state, not just the
+            ;; earlier disk backup. All tests below are read-only on the desk.
+            (let* ((candidate (lime.persistence:restore-world before :normalize-arrangements-p nil))
+                   (candidate-migration
+                     (lime.core::normalize-activity-arrangements candidate :preferred-presentation-ids preferred))
+                   (after (lime.persistence:snapshot-world candidate)))
+              (dolist (key '(:clients :activities :views :viewsets :heads))
+                (assert (equalp (getf before key) (getf after key))))
+              (dolist (h (getf before :heads))
+                (let ((id (getf h :active)))
+                  (assert (equalp (find id (getf before :presentations) :key (lambda (p) (getf p :id)) :test #'equal)
+                                  (find id (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal)))))
+              (dolist (h (getf after :heads))
+                (dolist (a (getf after :activities))
+                  (assert (lime.core:activation-report-ready-p
+                           (lime.core:preflight-activity-draft candidate (getf h :id) (getf a :id))))))
+              ;; Apply only after the copy has passed. Preserve world and
+              ;; surviving Presentation identities held by REPL clients.
+              (setf migration (lime.core::normalize-activity-arrangements
+                               world :preferred-presentation-ids preferred))
+              (assert (equal migration candidate-migration))
+              (assert (equalp after (lime.persistence:snapshot-world world))))
+            (assert (eq config (lime.x11::x11-backend-configuration backend)))
+            (assert (equal slots (lime.x11:backend-navigation-slots backend)))
+            (lime.x11::render-head-bars backend)
+            (xlib:display-finish-output (lime.x11::x11-backend-display backend))
+            (list :upgraded t :active-arrangements-unchanged t :saved-views-unchanged t
+                  :configuration-unchanged t :slots-unchanged t
+                  :retired-records (length (getf migration :retired-arrangements))
+                  :removed-old-locations (length (getf migration :removed-old-locations))
+                  :function-count (length definitions)))
+        (error (condition)
+          ;; Restore original objects and function definitions, not a restart.
+          (dolist (entry old-functions)
+            (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry))))
+          (clrhash (lime.core::world-presentations world))
+          (dolist (record records)
+            (let ((p (car record)) (old (cdr record)))
+              (dolist (slot '(lime.core::placements lime.core::layout-root lime.core::focus-client-id
+                             lime.core::unavailable-client-ids lime.core::dirty-p lime.core::source-view-id))
+                (setf (slot-value p slot) (slot-value old slot)))
+              (setf (gethash (lime.core:presentation-id p) (lime.core::world-presentations world)) p)))
+          (setf (lime.core:world-revision world) revision)
+          (when old-nav (setf (gethash backend lime.x11::*backend-navigation-states*) old-nav))
+          (ignore-errors (lime.x11::render-head-bars backend))
+          (error condition))))))