121 lines
8.2 KiB
Common Lisp
121 lines
8.2 KiB
Common Lisp
;;;; Guarded function-only upgrade: preserve every live model object and XID.
|
|
(in-package #:cl-user)
|
|
(declaim (special lime.x11::*backend-activity-navigation-states*))
|
|
|
|
(defun lime-portable-definitions ()
|
|
(let ((manifest
|
|
'((:lime.core "src/membership.lisp" "%MOVE-CLIENT-MEMBERSHIP" "MOVE-CLIENT-TO-ACTIVITY")
|
|
(:lime.x11 "src/x11/navigation.lisp" "%FORGET-NAVIGATION-STATE"
|
|
"BACKEND-PREFLIGHT-ACTIVITY-SWITCH" "BACKEND-SWITCH-TO-ACTIVITY")
|
|
(:lime.x11 "src/x11/commands.lisp" "BACKEND-MOVE-CLIENT-TO-ACTIVITY"
|
|
"BACKEND-ACTIVATE-ACTIVITY" "BACKEND-PREFLIGHT-ACTIVITY-ACTIVATION"
|
|
"BACKEND-PREFLIGHT-VIEW-ACTIVATION" "BACKEND-ACTIVATE-VIEW")
|
|
(:lime.x11 "src/x11/ui.lisp" "%UI-ACTIVITY-CANDIDATES" "%UI-MOVE-CLIENT-RESULT"
|
|
"%UI-REQUEST-ACTIVITY-ACTIVATION" "%COMMAND-PALETTE-CANDIDATES" "%UI-KEY-PATH")
|
|
(:lime.x11 "src/x11/persistence.lisp" "%VALIDATE-SESSION-ENVELOPE"
|
|
"%PREPARE-SESSION-PERSISTENCE" "%SESSION-SIGNATURE" "%SESSION-SNAPSHOT")))
|
|
(definitions nil) (*read-eval* nil))
|
|
(dolist (entry manifest)
|
|
(destructuring-bind (package file &rest names) entry
|
|
(let* ((*package* (find-package package))
|
|
(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 (symbol symbols) (assert (find symbol found :key #'second)))
|
|
(setf definitions (append definitions (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols))))))
|
|
definitions))
|
|
|
|
(defun lime-upgrade-live-portable-activities ()
|
|
(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."))
|
|
(when (and (boundp 'lime.x11::*backend-activity-navigation-states*)
|
|
(gethash backend lime.x11::*backend-activity-navigation-states*))
|
|
(error "Portable navigation is already installed; do not repeat this migration."))
|
|
(let* ((world (lime.x11:x11-backend-world backend))
|
|
(before (lime.persistence:snapshot-world world))
|
|
(head (lime.x11:x11-backend-focused-head-id backend))
|
|
(display (lime.x11::x11-backend-display backend))
|
|
(focus (xlib:input-focus display))
|
|
(config (lime.x11::x11-backend-configuration backend))
|
|
(bindings (lime.x11:list-keybindings backend))
|
|
(leases (loop for id being the hash-keys of (lime.core::world-leases world)
|
|
using (hash-value lease) collect (cons id lease)))
|
|
(session (lime.x11:backend-save-session backend :wait-p t))
|
|
(old-data (lime.x11::%session-snapshot backend))
|
|
(backup-directory (uiop:ensure-directory-pathname
|
|
(string-trim '(#\Newline)
|
|
(uiop:run-program '("mktemp" "-d" "/home/adan/.local/state/lime/pre-portable-XXXXXX")
|
|
:output :string))))
|
|
(backup-file (merge-pathnames "session-v2.sexp" backup-directory)))
|
|
;; The owner thread cannot autosave a newer snapshot during this block.
|
|
;; Waiting above drains the writer before making this private backup.
|
|
(assert (= 2 (getf old-data :version)))
|
|
(uiop:copy-file (getf session :file) backup-file)
|
|
(uiop:run-program (list "chmod" "600" (namestring backup-file)))
|
|
(export (mapcar (lambda (name) (intern name :lime.core))
|
|
'("ACTIVITY-PRESENTATIONS" "PREFLIGHT-PRESENTATION-BRING" "BRING-PRESENTATION-TO-HEAD")) :lime.core)
|
|
(export (mapcar (lambda (name) (intern name :lime.x11))
|
|
'("BACKEND-ACTIVITY-NAVIGATION-MODE" "BACKEND-EXTEND-ACTIVITY-TO-HEAD"
|
|
"BACKEND-MAKE-ACTIVITY-PORTABLE")) :lime.x11)
|
|
(let* ((definitions (lime-portable-definitions))
|
|
(old-functions (mapcar (lambda (form) (cons (second form) (fdefinition (second form)))) definitions))
|
|
(copy-checks 0) (policies nil))
|
|
(handler-case
|
|
(progn
|
|
;; New modules only: no existing DEFSTRUCT layout is redefined.
|
|
(dolist (file '("src/presentation-navigation.lisp" "src/x11/activity-navigation.lisp"
|
|
"src/x11/activity-navigation-ui.lisp"))
|
|
(load (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")))
|
|
(dolist (definition definitions) (eval definition))
|
|
;; Test migration and actual bring/swap transitions on a detached
|
|
;; copy of this user's exact saved world before enabling policy.
|
|
(multiple-value-bind (candidate navigation footprint)
|
|
(lime.x11::%validate-session-envelope old-data)
|
|
(declare (ignore navigation))
|
|
(assert (equalp before (lime.persistence:snapshot-world candidate)))
|
|
(setf policies (copy-tree (lime.x11::activity-navigation-state-rows footprint)))
|
|
(dolist (row policies)
|
|
(when (and (eq :portable (second row)) (third row))
|
|
(dolist (destination (lime.x11:backend-head-ids backend))
|
|
(lime.core::bring-presentation-to-head candidate (third row) destination)
|
|
(assert (lime.core:validate-world candidate))
|
|
(incf copy-checks)))))
|
|
;; Hash-table iteration order need not survive snapshot/restore.
|
|
(let ((live-policies (lime.x11::%activity-navigation-snapshot backend)))
|
|
(assert (= (length policies) (length live-policies)))
|
|
(dolist (row policies)
|
|
(assert (equal row (assoc (first row) live-policies :test #'equal)))))
|
|
(assert (equalp before (lime.persistence:snapshot-world world)))
|
|
(assert (equal head (lime.x11:x11-backend-focused-head-id backend)))
|
|
(let ((after-focus (xlib:input-focus display)))
|
|
(assert (or (eql focus after-focus)
|
|
(and (typep focus 'xlib:window) (typep after-focus 'xlib:window)
|
|
(xlib:window-equal focus after-focus)))))
|
|
(assert (eq config (lime.x11::x11-backend-configuration backend)))
|
|
(assert (equal bindings (lime.x11:list-keybindings backend)))
|
|
(assert (= (length leases) (hash-table-count (lime.core::world-leases world))))
|
|
(dolist (entry leases) (assert (eq (cdr entry) (lime.core:lease-for-client world (car entry)))))
|
|
(assert (= 3 (getf (lime.x11::%session-snapshot backend) :version))))
|
|
(error (condition)
|
|
(dolist (entry old-functions) (setf (fdefinition (car entry)) (cdr entry)))
|
|
(when (boundp 'lime.x11::*backend-activity-navigation-states*)
|
|
(remhash backend lime.x11::*backend-activity-navigation-states*))
|
|
(error "Portable upgrade rolled back; backup ~A. ~A" backup-file condition)))
|
|
;; The code/model transaction has committed; a disk failure here must
|
|
;; keep the new running code, whose normal autosave retry can recover.
|
|
(let ((save (handler-case (lime.x11:backend-save-session backend :wait-p t)
|
|
(error (c) (list :error (princ-to-string c))))))
|
|
(list :upgraded t :functions (length definitions) :backup (namestring backup-file)
|
|
:world-unchanged t :focus-unchanged t :bindings-unchanged t :lease-objects-unchanged t
|
|
:migration-copy-swaps-tested copy-checks
|
|
:policies (mapcar (lambda (row) (subseq row 0 2)) policies)
|
|
:session-save save))))))
|