157 lines
6.4 KiB
Haskell
157 lines
6.4 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||
--
|
||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||
|
||
{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-}
|
||
|
||
module Model.Migration
|
||
( migrateAll
|
||
, requiresMigration
|
||
, ManualMigration(..), getMigrationTime
|
||
) where
|
||
|
||
import Import.NoModel hiding (Max(..), Last(..))
|
||
import Model
|
||
import Foundation.Type
|
||
import Model.Migration.Definitions -- SEE HERE: this module contains the actual migration code
|
||
import qualified Model.Migration.Types as Legacy
|
||
import qualified Data.Map as Map
|
||
|
||
import qualified Data.Set as Set
|
||
|
||
import qualified Data.Conduit.List as C
|
||
|
||
import Database.Persist.Sql
|
||
import Database.Persist.Sql.Raw.QQ
|
||
import Database.Persist.Postgresql
|
||
|
||
import qualified Database.Esqueleto.Legacy as E
|
||
|
||
import Control.Monad.Except (MonadError(..))
|
||
|
||
import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
|
||
|
||
-- import qualified Control.Monad.State.Class as State
|
||
|
||
|
||
-- _manualMigration :: Fold (Legacy.Migration Version, Legacy.Version) ManualMigration
|
||
-- _manualMigration = folding $ \case
|
||
-- ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme
|
||
-- ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
|
||
-- _other -> Nothing
|
||
|
||
-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause)
|
||
share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
|
||
[persistLowerCase|
|
||
AppliedMigration json
|
||
migration Text
|
||
time UTCTime
|
||
Primary migration
|
||
deriving Show Eq Ord
|
||
|]
|
||
|
||
migrateAll' :: Migration
|
||
migrateAll' = sequence_
|
||
[ migrateUniWorX
|
||
, migrateMemcachedSqlStorage
|
||
, migrateManual
|
||
]
|
||
|
||
migrateAll :: ( MonadLogger m
|
||
, MonadResource m
|
||
, MonadUnliftIO m
|
||
-- , MonadReader UniWorX m
|
||
)
|
||
=> ReaderT SqlBackend m ()
|
||
migrateAll = do
|
||
$logDebugS "Migration" "Initial migration"
|
||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
|
||
|
||
missingMigrations <- getMissingMigrations
|
||
let
|
||
doCustomMigration acc manualMigration migration = acc <* do
|
||
let appliedMigrationMigration = toPathPiece manualMigration
|
||
$logInfoS "Migration" appliedMigrationMigration
|
||
appliedMigrationTime <- liftIO getCurrentTime
|
||
_ <- migration
|
||
insert AppliedMigration{..}
|
||
-- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
|
||
$logDebugS "Migration" "Apply missing migrations"
|
||
Map.foldlWithKey doCustomMigration (return ()) missingMigrations
|
||
|
||
$logDebugS "Migration" "Persistent automatic migration"
|
||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
|
||
|
||
$logDebugS "Migration" "Migrations marked as ‘always safe’"
|
||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAlwaysSafe
|
||
|
||
requiresMigration :: forall m.
|
||
( MonadLogger m
|
||
, MonadResource m
|
||
)
|
||
=> ReaderT SqlBackend m Bool
|
||
requiresMigration = mapReaderT (exceptT return return) $ do
|
||
initial <- either id (map snd) <$> parseMigration initialMigration
|
||
unless (null initial) $ do
|
||
$logInfoS "Migration" $ intercalate "; " initial
|
||
throwError True
|
||
|
||
customs <- mapReaderT lift $ getMissingMigrations @_ @(ReaderT UniWorX m)
|
||
unless (Map.null customs) $ do
|
||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||
throwError True
|
||
|
||
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
||
unless (null automatic) $ do
|
||
$logInfoS "Migration" $ intercalate "; " automatic
|
||
throwError True
|
||
|
||
-- Does not consider `migrateAlwaysSafe`
|
||
|
||
return False
|
||
|
||
initialMigration :: Migration
|
||
-- ^ Manual migrations to go to InitialVersion below:
|
||
initialMigration = do
|
||
mapM_ migrateEnableExtension ["citext", "pgcrypto"]
|
||
lift . lift . hoist runResourceT . whenM (columnExists "applied_migration" "from") $ do
|
||
let getAppliedMigrations = [queryQQ|SELECT "from", "to", "time" FROM "applied_migration"|]
|
||
migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (_time :: UTCTime) ] = do
|
||
lift [executeQQ|DELETE FROM "applied_migration" WHERE "from" = #{fromV} AND "to" = #{toV}|]
|
||
-- State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
|
||
migrateAppliedMigration _ = return ()
|
||
insertMigrations ms = do
|
||
[executeQQ|
|
||
ALTER TABLE "applied_migration" DROP CONSTRAINT "applied_migration_pkey";
|
||
ALTER TABLE "applied_migration" DROP CONSTRAINT "unique_applied_migration";
|
||
ALTER TABLE "applied_migration" DROP COLUMN "from";
|
||
ALTER TABLE "applied_migration" DROP COLUMN "to";
|
||
ALTER TABLE "applied_migration" ADD COLUMN "migration" text NOT NULL CONSTRAINT "applied_migration_pkey" PRIMARY KEY;
|
||
|]
|
||
iforM_ ms $ \appliedMigrationMigration appliedMigrationTime -> insert AppliedMigration{..}
|
||
in runConduit $ getAppliedMigrations .| execStateC Map.empty (C.mapM_ migrateAppliedMigration) >>= lift . insertMigrations
|
||
migrateDBVersioning
|
||
|
||
getMissingMigrations :: forall m m'.
|
||
( MonadLogger m
|
||
, MonadIO m
|
||
, MonadResource m'
|
||
-- , MonadReader UniWorX m'
|
||
)
|
||
=> ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ()))
|
||
getMissingMigrations = do
|
||
$logDebugS "Migration" "Retrieve applied migrations"
|
||
appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do
|
||
return $ appliedMigration E.^. AppliedMigrationMigration
|
||
let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations
|
||
return $ Map.filterWithKey migNotDone customMigrations
|
||
|
||
|
||
getMigrationTime :: ( MonadIO m
|
||
, BaseBackend backend ~ SqlBackend
|
||
, PersistStoreRead backend
|
||
)
|
||
=> ManualMigration
|
||
-> ReaderT backend m (Maybe UTCTime)
|
||
getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece
|