{-# LANGUAGE MultiWayIf #-}

module Unison.Codebase.SqliteCodebase.Migrations where

import Control.Concurrent.MVar
import Control.Concurrent.STM (TVar)
import Control.Monad.Reader
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (getPOSIXTime)
import System.Console.Regions qualified as Region
import System.FilePath ((</>))
import Text.Printf (printf)
import U.Codebase.Reference qualified as C.Reference
import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase (CodebasePath)
import Unison.Codebase.Init (BackupStrategy (..), VacuumStrategy (..))
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (OpenCodebaseUnknownSchemaVersion))
import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 (migrateSchema7To8)
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2
import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath)
import Unison.Codebase.Type (LocalOrRemote (..))
import Unison.ConstructorType qualified as CT
import Unison.Debug qualified as Debug
import Unison.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import Unison.Sqlite.Connection qualified as Sqlite.Connection
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty qualified as Pretty
import UnliftIO qualified

-- | Mapping from schema version to the migration required to get there.
-- E.g. The migration at index 2 must be run on a codebase at version 1.
migrations ::
  (MVar Region.ConsoleRegion) ->
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
  TVar (Map Hash Ops2.TermBufferEntry) ->
  TVar (Map Hash Ops2.DeclBufferEntry) ->
  CodebasePath ->
  Map SchemaVersion (Sqlite.Connection -> IO ())
migrations :: MVar ConsoleRegion
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> String
-> Map SchemaVersion (Connection -> IO ())
migrations MVar ConsoleRegion
regionVar Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer String
rootCodebasePath =
  [(SchemaVersion, Connection -> IO ())]
-> Map SchemaVersion (Connection -> IO ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (SchemaVersion
2, Transaction () -> Connection -> IO ()
runT (Transaction () -> Connection -> IO ())
-> Transaction () -> Connection -> IO ()
forall a b. (a -> b) -> a -> b
$ (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Transaction ()
migrateSchema1To2 Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer),
      -- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this
      -- caused an issue:
      --
      -- The migration would detect causals whose value hash did not have a corresponding branch
      -- object, this was caused by a race-condition in sync which could end up in a partial sync.
      -- When a branch object was determined to be missing, the migration would replace it with the
      -- empty branch. This worked well, but led to a situation where related parent or successors
      -- of that causal would have their hash objects mapped to the new v2 object which contained
      -- the empty branch in place of missing branches. This is fine, but, if a different codebase
      -- migrated the same branch and wasn't missing the branch in question it would migrate
      -- successfully and each database now have the same v1 hash object mapped to two distinct v2
      -- objects, which rightfully causes a crash when syncing.
      --
      -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects
      -- weren't being used for anything anyways.
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
3 (HashVersion -> Transaction ()
Q.removeHashObjectsByHashingVersion (Word64 -> HashVersion
HashVersion Word64
1)),
      (SchemaVersion
4, Transaction () -> Connection -> IO ()
runT (Transaction ()
migrateSchema3To4 Transaction () -> Transaction () -> Transaction ()
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> MVar ConsoleRegion -> Transaction ()
runIntegrityChecks MVar ConsoleRegion
regionVar)),
      -- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
5 Transaction ()
Q.addTempEntityTables,
      (SchemaVersion
6, Transaction () -> Connection -> IO ()
runT (Transaction () -> Connection -> IO ())
-> Transaction () -> Connection -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Transaction ()
migrateSchema5To6 String
rootCodebasePath),
      (SchemaVersion
7, Transaction () -> Connection -> IO ()
runT (Transaction ()
migrateSchema6To7 Transaction () -> Transaction () -> Transaction ()
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> MVar ConsoleRegion -> Transaction ()
runIntegrityChecks MVar ConsoleRegion
regionVar)),
      (SchemaVersion
8, Transaction () -> Connection -> IO ()
runT Transaction ()
migrateSchema7To8),
      -- Recreates the name lookup tables because the primary key was missing the root hash id.
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
9 Transaction ()
Q.fixScopedNameLookupTables,
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
10 Transaction ()
Q.addProjectTables,
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
11 Transaction ()
Q.addMostRecentBranchTable,
      (SchemaVersion
12, Transaction () -> Connection -> IO ()
runT Transaction ()
migrateSchema11To12),
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
13 Transaction ()
Q.addMostRecentNamespaceTable,
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
14 Transaction ()
Q.addSquashResultTable,
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
15 Transaction ()
Q.addSquashResultTableIfNotExists,
      SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
16 Transaction ()
Q.cdToProjectRoot,
      (SchemaVersion
17 {- This migration takes a raw sqlite connection -}, \Connection
conn -> Connection -> IO ()
migrateSchema16To17 Connection
conn)
    ]
  where
    runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()
    runT :: Transaction () -> Connection -> IO ()
runT Transaction ()
t Connection
conn = Connection -> ((forall x. Transaction x -> IO x) -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
Sqlite.runWriteTransaction Connection
conn (\forall x. Transaction x -> IO x
run -> Transaction () -> IO ()
forall x. Transaction x -> IO x
run Transaction ()
t)
    sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ())
    sqlMigration :: SchemaVersion
-> Transaction () -> (SchemaVersion, Connection -> IO ())
sqlMigration SchemaVersion
ver Transaction ()
migration =
      ( SchemaVersion
ver,
        \Connection
conn -> Connection -> ((forall x. Transaction x -> IO x) -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
Sqlite.runWriteTransaction Connection
conn \forall x. Transaction x -> IO x
run -> Transaction () -> IO ()
forall x. Transaction x -> IO x
run
          do
            SchemaVersion -> Transaction ()
Q.expectSchemaVersion (SchemaVersion
ver SchemaVersion -> SchemaVersion -> SchemaVersion
forall a. Num a => a -> a -> a
- SchemaVersion
1)
            Transaction ()
migration
            SchemaVersion -> Transaction ()
Q.setSchemaVersion SchemaVersion
ver
      )

data CodebaseVersionStatus
  = CodebaseUpToDate
  | CodebaseUnknownSchemaVersion SchemaVersion
  | CodebaseRequiresMigration
      -- Current version
      SchemaVersion
      -- Required version
      SchemaVersion
  deriving stock (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
(CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> Eq CodebaseVersionStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
== :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
$c/= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
/= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
Eq, Eq CodebaseVersionStatus
Eq CodebaseVersionStatus =>
(CodebaseVersionStatus -> CodebaseVersionStatus -> Ordering)
-> (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> (CodebaseVersionStatus -> CodebaseVersionStatus -> Bool)
-> (CodebaseVersionStatus
    -> CodebaseVersionStatus -> CodebaseVersionStatus)
-> (CodebaseVersionStatus
    -> CodebaseVersionStatus -> CodebaseVersionStatus)
-> Ord CodebaseVersionStatus
CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
CodebaseVersionStatus -> CodebaseVersionStatus -> Ordering
CodebaseVersionStatus
-> CodebaseVersionStatus -> CodebaseVersionStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodebaseVersionStatus -> CodebaseVersionStatus -> Ordering
compare :: CodebaseVersionStatus -> CodebaseVersionStatus -> Ordering
$c< :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
< :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
$c<= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
<= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
$c> :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
> :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
$c>= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
>= :: CodebaseVersionStatus -> CodebaseVersionStatus -> Bool
$cmax :: CodebaseVersionStatus
-> CodebaseVersionStatus -> CodebaseVersionStatus
max :: CodebaseVersionStatus
-> CodebaseVersionStatus -> CodebaseVersionStatus
$cmin :: CodebaseVersionStatus
-> CodebaseVersionStatus -> CodebaseVersionStatus
min :: CodebaseVersionStatus
-> CodebaseVersionStatus -> CodebaseVersionStatus
Ord, Int -> CodebaseVersionStatus -> ShowS
[CodebaseVersionStatus] -> ShowS
CodebaseVersionStatus -> String
(Int -> CodebaseVersionStatus -> ShowS)
-> (CodebaseVersionStatus -> String)
-> ([CodebaseVersionStatus] -> ShowS)
-> Show CodebaseVersionStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodebaseVersionStatus -> ShowS
showsPrec :: Int -> CodebaseVersionStatus -> ShowS
$cshow :: CodebaseVersionStatus -> String
show :: CodebaseVersionStatus -> String
$cshowList :: [CodebaseVersionStatus] -> ShowS
showList :: [CodebaseVersionStatus] -> ShowS
Show)

checkCodebaseIsUpToDate :: Sqlite.Transaction CodebaseVersionStatus
checkCodebaseIsUpToDate :: Transaction CodebaseVersionStatus
checkCodebaseIsUpToDate = do
  SchemaVersion
schemaVersion <- Transaction SchemaVersion
Q.schemaVersion
  -- The highest schema that this ucm knows how to migrate to.
  pure $
    if
      | SchemaVersion
schemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SchemaVersion
Q.currentSchemaVersion -> CodebaseVersionStatus
CodebaseUpToDate
      | SchemaVersion
schemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
< SchemaVersion
Q.currentSchemaVersion -> SchemaVersion -> SchemaVersion -> CodebaseVersionStatus
CodebaseRequiresMigration SchemaVersion
schemaVersion SchemaVersion
Q.currentSchemaVersion
      | Bool
otherwise -> SchemaVersion -> CodebaseVersionStatus
CodebaseUnknownSchemaVersion SchemaVersion
schemaVersion

-- | Migrates a codebase up to the most recent version known to ucm.
-- This is a No-op if it's up to date
-- Returns an error if the schema version is newer than this ucm knows about.
ensureCodebaseIsUpToDate ::
  (MonadIO m) =>
  LocalOrRemote ->
  CodebasePath ->
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
  TVar (Map Hash Ops2.TermBufferEntry) ->
  TVar (Map Hash Ops2.DeclBufferEntry) ->
  Bool ->
  BackupStrategy ->
  VacuumStrategy ->
  Sqlite.Connection ->
  m (Either Codebase.OpenCodebaseError ())
ensureCodebaseIsUpToDate :: forall (m :: * -> *).
MonadIO m =>
LocalOrRemote
-> String
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
ensureCodebaseIsUpToDate LocalOrRemote
localOrRemote String
root Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Bool
shouldPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy Connection
conn =
  (IO (Either OpenCodebaseError ()) -> m (Either OpenCodebaseError ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either OpenCodebaseError ())
 -> m (Either OpenCodebaseError ()))
-> (IO () -> IO (Either OpenCodebaseError ()))
-> IO ()
-> m (Either OpenCodebaseError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either OpenCodebaseError ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try) do
    MVar ConsoleRegion
regionVar <- IO (MVar ConsoleRegion)
forall a. IO (MVar a)
newEmptyMVar
    let finalizeRegion :: IO ()
        finalizeRegion :: IO ()
finalizeRegion =
          IO (Maybe ConsoleRegion) -> (ConsoleRegion -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (MVar ConsoleRegion -> IO (Maybe ConsoleRegion)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ConsoleRegion
regionVar) \ConsoleRegion
region -> do
            Text
content <- ConsoleRegion -> IO Text
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m Text
Region.getConsoleRegion ConsoleRegion
region
            ConsoleRegion -> Text -> IO ()
forall v (m :: * -> *).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Region.finishConsoleRegion ConsoleRegion
region Text
content

    IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
Region.displayConsoleRegions do
      (IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` IO ()
finalizeRegion) do
        let migs :: Map SchemaVersion (Connection -> IO ())
migs = MVar ConsoleRegion
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> String
-> Map SchemaVersion (Connection -> IO ())
migrations MVar ConsoleRegion
regionVar Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer String
root
        -- The highest schema that this ucm knows how to migrate to.
        let highestKnownSchemaVersion :: SchemaVersion
highestKnownSchemaVersion = (SchemaVersion, Connection -> IO ()) -> SchemaVersion
forall a b. (a, b) -> a
fst ((SchemaVersion, Connection -> IO ()) -> SchemaVersion)
-> ([(SchemaVersion, Connection -> IO ())]
    -> (SchemaVersion, Connection -> IO ()))
-> [(SchemaVersion, Connection -> IO ())]
-> SchemaVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SchemaVersion, Connection -> IO ())]
-> (SchemaVersion, Connection -> IO ())
forall a. HasCallStack => [a] -> a
head ([(SchemaVersion, Connection -> IO ())] -> SchemaVersion)
-> [(SchemaVersion, Connection -> IO ())] -> SchemaVersion
forall a b. (a -> b) -> a -> b
$ Map SchemaVersion (Connection -> IO ())
-> [(SchemaVersion, Connection -> IO ())]
forall k a. Map k a -> [(k, a)]
Map.toDescList Map SchemaVersion (Connection -> IO ())
migs
        SchemaVersion
currentSchemaVersion <- Connection -> Transaction SchemaVersion -> IO SchemaVersion
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Connection -> Transaction a -> m a
Sqlite.runTransaction Connection
conn Transaction SchemaVersion
Q.schemaVersion
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SchemaVersion
currentSchemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
> SchemaVersion
highestKnownSchemaVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenCodebaseError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (OpenCodebaseError -> IO ()) -> OpenCodebaseError -> IO ()
forall a b. (a -> b) -> a -> b
$ SchemaVersion -> OpenCodebaseError
OpenCodebaseUnknownSchemaVersion (SchemaVersion -> SchemaVersion
forall a b. (Integral a, Num b) => a -> b
fromIntegral SchemaVersion
currentSchemaVersion)
        BackupStrategy
-> LocalOrRemote
-> Connection
-> SchemaVersion
-> SchemaVersion
-> String
-> IO ()
backupCodebaseIfNecessary BackupStrategy
backupStrategy LocalOrRemote
localOrRemote Connection
conn SchemaVersion
currentSchemaVersion SchemaVersion
highestKnownSchemaVersion String
root
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldPrompt do
          String -> IO ()
putStrLn String
"Press <enter> to start the migration once all other ucm processes are shutdown..."
          IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO String
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getLine
        Bool
ranMigrations <- do
          SchemaVersion
currentSchemaVersion <- Connection -> Transaction SchemaVersion -> IO SchemaVersion
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Connection -> Transaction a -> m a
Sqlite.runTransaction Connection
conn (Transaction SchemaVersion -> IO SchemaVersion)
-> Transaction SchemaVersion -> IO SchemaVersion
forall a b. (a -> b) -> a -> b
$ do
            -- Get the schema version again now that we're in a transaction.
            Transaction SchemaVersion
Q.schemaVersion
            -- This is a bit of a hack, hopefully we can remove this when we have a more
            -- reliable way to freeze old migration code in time.
            -- The problem is that 'saveObject' has been changed to flush temp entity tables,
            -- but old schema versions still use 'saveObject', but don't have the tables!
            -- We can create the tables no matter what, there won't be anything to flush, so
            -- everything still works as expected.
            --
            -- Hopefully we can remove this once we've got better methods of freezing migration
            -- code in time.
            Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SchemaVersion
currentSchemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
< SchemaVersion
5) Transaction ()
Q.addTempEntityTables
            Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SchemaVersion
currentSchemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
< SchemaVersion
6) Transaction ()
Q.addNamespaceStatsTables
            pure SchemaVersion
currentSchemaVersion
          let migrationsToRun :: Map SchemaVersion (Connection -> IO ())
migrationsToRun = (SchemaVersion -> (Connection -> IO ()) -> Bool)
-> Map SchemaVersion (Connection -> IO ())
-> Map SchemaVersion (Connection -> IO ())
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\SchemaVersion
v Connection -> IO ()
_ -> SchemaVersion
v SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
> SchemaVersion
currentSchemaVersion) Map SchemaVersion (Connection -> IO ())
migs
          [(SchemaVersion, Connection -> IO ())]
-> ((SchemaVersion, Connection -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map SchemaVersion (Connection -> IO ())
-> [(SchemaVersion, Connection -> IO ())]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map SchemaVersion (Connection -> IO ())
migrationsToRun) (((SchemaVersion, Connection -> IO ()) -> IO ()) -> IO ())
-> ((SchemaVersion, Connection -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SchemaVersion Word64
v, Connection -> IO ()
migration) -> do
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"🔨 Migrating codebase to version " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..."
            Connection -> IO ()
migration Connection
conn
          let ranMigrations :: Bool
ranMigrations = Bool -> Bool
not (Map SchemaVersion (Connection -> IO ()) -> Bool
forall a. Map SchemaVersion a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map SchemaVersion (Connection -> IO ())
migrationsToRun)
          pure Bool
ranMigrations
        DebugFlag -> String -> IO ()
forall (m :: * -> *). Monad m => DebugFlag -> String -> m ()
Debug.debugLogM DebugFlag
Debug.Migration String
"Migrations complete"
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ranMigrations do
          ConsoleRegion
region <-
            IO ConsoleRegion -> IO ConsoleRegion
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
UnliftIO.mask_ do
              ConsoleRegion
region <- RegionLayout -> IO ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Region.openConsoleRegion RegionLayout
Region.Linear
              MVar ConsoleRegion -> ConsoleRegion -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConsoleRegion
regionVar ConsoleRegion
region
              pure ConsoleRegion
region
          -- Vacuum once now that any migrations have taken place.
          ConsoleRegion -> Text -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Region.setConsoleRegion ConsoleRegion
region (Text
"✅ All good, cleaning up..." :: Text)
          case VacuumStrategy
vacuumStrategy of
            VacuumStrategy
Vacuum -> do
              DebugFlag -> String -> IO ()
forall (m :: * -> *). Monad m => DebugFlag -> String -> m ()
Debug.debugLogM DebugFlag
Debug.Migration String
"About to VACUUM"
              IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO Bool
Sqlite.Connection.vacuum Connection
conn
              DebugFlag -> String -> IO ()
forall (m :: * -> *). Monad m => DebugFlag -> String -> m ()
Debug.debugLogM DebugFlag
Debug.Migration String
"Done VACUUM"
            VacuumStrategy
NoVacuum -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ConsoleRegion -> Text -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Region.setConsoleRegion ConsoleRegion
region (Text
"🏁 Migrations complete 🏁" :: Text)

-- | If we need to make a backup,  then copy the sqlite database to a new file with a unique name based on current time.
backupCodebaseIfNecessary :: BackupStrategy -> LocalOrRemote -> Sqlite.Connection -> SchemaVersion -> SchemaVersion -> CodebasePath -> IO ()
backupCodebaseIfNecessary :: BackupStrategy
-> LocalOrRemote
-> Connection
-> SchemaVersion
-> SchemaVersion
-> String
-> IO ()
backupCodebaseIfNecessary BackupStrategy
backupStrategy LocalOrRemote
localOrRemote Connection
conn SchemaVersion
currentSchemaVersion SchemaVersion
highestKnownSchemaVersion String
root = do
  case (BackupStrategy
backupStrategy, LocalOrRemote
localOrRemote) of
    (BackupStrategy
NoBackup, LocalOrRemote
_) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (BackupStrategy
_, LocalOrRemote
Remote) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (BackupStrategy
Backup, LocalOrRemote
Local)
      | (SchemaVersion
currentSchemaVersion SchemaVersion -> SchemaVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= SchemaVersion
highestKnownSchemaVersion) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> do
          String
backupPath <- IO POSIXTime
getPOSIXTime IO POSIXTime -> (POSIXTime -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\POSIXTime
t -> String
root String -> ShowS
</> SchemaVersion -> POSIXTime -> String
backupCodebasePath SchemaVersion
currentSchemaVersion POSIXTime
t)
          Connection -> String -> IO ()
Sqlite.vacuumInto Connection
conn String
backupPath
          -- vacuum-into clears the journal mode, so we need to set it again.
          String -> String -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (Connection -> m a) -> m a
Sqlite.withConnection String
"backup" String
backupPath \Connection
backupConn -> do
            Connection -> JournalMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
Connection -> JournalMode -> m ()
Sqlite.trySetJournalMode Connection
backupConn JournalMode
Sqlite.JournalMode'WAL
          String -> IO ()
putStrLn (String
"📋 I backed up your codebase to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String
root String -> ShowS
</> String
backupPath))
          String -> IO ()
putStrLn String
"⚠️  Please close all other ucm processes and wait for the migration to complete before interacting with your codebase."

runIntegrityChecks ::
  (MVar Region.ConsoleRegion) ->
  Sqlite.Transaction ()
runIntegrityChecks :: MVar ConsoleRegion -> Transaction ()
runIntegrityChecks MVar ConsoleRegion
regionVar = do
  ConsoleRegion
region <- IO ConsoleRegion -> Transaction ConsoleRegion
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO ConsoleRegion -> Transaction ConsoleRegion)
-> (IO ConsoleRegion -> IO ConsoleRegion)
-> IO ConsoleRegion
-> Transaction ConsoleRegion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ConsoleRegion -> IO ConsoleRegion
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
UnliftIO.mask_ (IO ConsoleRegion -> Transaction ConsoleRegion)
-> IO ConsoleRegion -> Transaction ConsoleRegion
forall a b. (a -> b) -> a -> b
$ do
    ConsoleRegion
region <- RegionLayout -> IO ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Region.openConsoleRegion RegionLayout
Region.Linear
    MVar ConsoleRegion -> ConsoleRegion -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConsoleRegion
regionVar ConsoleRegion
region
    pure ConsoleRegion
region
  IntegrityResult
result <- do
    -- Ideally we'd check everything here, but certain codebases are known to have objects
    -- with missing Hash Objects, we'll want to clean that up in a future migration.
    -- integrityCheckAllHashObjects,
    let checks :: [Transaction IntegrityResult]
checks =
          [ Transaction IntegrityResult
integrityCheckAllBranches,
            Transaction IntegrityResult
integrityCheckAllCausals
          ]

    [Int]
-> [Transaction IntegrityResult]
-> [(Int, Transaction IntegrityResult)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [Transaction IntegrityResult]
checks [(Int, Transaction IntegrityResult)]
-> ([(Int, Transaction IntegrityResult)]
    -> Transaction IntegrityResult)
-> Transaction IntegrityResult
forall a b. a -> (a -> b) -> b
& ((Int, Transaction IntegrityResult) -> Transaction IntegrityResult)
-> [(Int, Transaction IntegrityResult)]
-> Transaction IntegrityResult
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM \(Int
i, Transaction IntegrityResult
check) -> do
      IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ()) -> IO () -> Transaction ()
forall a b. (a -> b) -> a -> b
$
        ConsoleRegion -> Text -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Region.setConsoleRegion
          ConsoleRegion
region
          (String -> Text
Text.pack (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"🕵️  Checking codebase integrity (step %d of %d)..." Int
i ([Transaction IntegrityResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Transaction IntegrityResult]
checks)))
      Transaction IntegrityResult
check
  case IntegrityResult
result of
    IntegrityResult
NoIntegrityErrors -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    IntegrityErrorDetected NESet IntegrityError
errs -> do
      let msg :: Pretty ColorText
msg = NESet IntegrityError -> Pretty ColorText
forall (f :: * -> *).
Foldable f =>
f IntegrityError -> Pretty ColorText
prettyPrintIntegrityErrors NESet IntegrityError
errs
      let rendered :: String
rendered = Width -> Pretty ColorText -> String
Pretty.toPlain Width
80 (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty ColorText
msg)
      IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ()) -> IO () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ ConsoleRegion -> Text -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Region.setConsoleRegion ConsoleRegion
region (String -> Text
Text.pack String
rendered)
      (String -> Transaction ()
forall a. String -> Transaction a
abortMigration String
"Codebase integrity error detected.")