;;;; 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))))))