196 lines
11 KiB
Haskell
196 lines
11 KiB
Haskell
{-# 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
|
||
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.MigrationVersion, Legacy.Version) ManualMigration
|
||
_manualMigration = folding $ \case
|
||
([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme
|
||
([Legacy.migrationVersion|0.0.0|], [Legacy.version|1.0.0|]) -> Just Migration20180813SheetJSONB
|
||
([Legacy.migrationVersion|1.0.0|], [Legacy.version|2.0.0|]) -> Just Migration20180823SchoolShorthandPrimaryKey
|
||
([Legacy.migrationVersion|2.0.0|], [Legacy.version|3.0.0|]) -> Just Migration20180918SheetCorrectorLoadJSON
|
||
([Legacy.migrationVersion|3.0.0|], [Legacy.version|3.1.0|]) -> Just Migration20180918UserSurnames
|
||
([Legacy.migrationVersion|3.1.0|], [Legacy.version|3.2.0|]) -> Just Migration20180918SheetUploadMode
|
||
([Legacy.migrationVersion|3.2.0|], [Legacy.version|4.0.0|]) -> Just Migration20180928UserAuthentication
|
||
([Legacy.migrationVersion|4.0.0|], [Legacy.version|5.0.0|]) -> Just Migration20181011UserNotificationSettings
|
||
([Legacy.migrationVersion|5.0.0|], [Legacy.version|6.0.0|]) -> Just Migration20181031SheetTypeRefactor
|
||
([Legacy.migrationVersion|6.0.0|], [Legacy.version|7.0.0|]) -> Just Migration20181129EncodedSecretBoxes
|
||
([Legacy.migrationVersion|7.0.0|], [Legacy.version|8.0.0|]) -> Just Migration20181130SheetTypeRefactor
|
||
([Legacy.migrationVersion|8.0.0|], [Legacy.version|9.0.0|]) -> Just Migration20190319CourseParticipantField
|
||
([Legacy.migrationVersion|9.0.0|], [Legacy.version|10.0.0|]) -> Just Migration20190320BetterStudyShorthands
|
||
([Legacy.migrationVersion|10.0.0|], [Legacy.version|11.0.0|]) -> Just Migration20190421MixedSheetSubmissions
|
||
([Legacy.migrationVersion|11.0.0|], [Legacy.version|12.0.0|]) -> Just Migration20190429Tutorials
|
||
([Legacy.migrationVersion|12.0.0|], [Legacy.version|13.0.0|]) -> Just Migration20190515Exams
|
||
([Legacy.migrationVersion|13.0.0|], [Legacy.version|14.0.0|]) -> Just Migration20190715ExamOccurrenceName
|
||
([Legacy.migrationVersion|14.0.0|], [Legacy.version|15.0.0|]) -> Just Migration20190726UserFirstNamesTitles
|
||
([Legacy.migrationVersion|15.0.0|], [Legacy.version|16.0.0|]) -> Just Migration20190806TransactionLogIds
|
||
([Legacy.migrationVersion|16.0.0|], [Legacy.version|17.0.0|]) -> Just Migration20190809AllocationIndependentApplication
|
||
([Legacy.migrationVersion|17.0.0|], [Legacy.version|18.0.0|]) -> Just Migration20190813Allocations
|
||
([Legacy.migrationVersion|18.0.0|], [Legacy.version|19.0.0|]) -> Just Migration20190828UserFunction
|
||
([Legacy.migrationVersion|19.0.0|], [Legacy.version|20.0.0|]) -> Just Migration20190912UserDisplayEmail
|
||
([Legacy.migrationVersion|20.0.0|], [Legacy.version|21.0.0|]) -> Just Migration20190916ExamPartNumber
|
||
([Legacy.migrationVersion|21.0.0|], [Legacy.version|22.0.0|]) -> Just Migration20190918ExamRulesRefactor
|
||
([Legacy.migrationVersion|22.0.0|], [Legacy.version|23.0.0|]) -> Just Migration20190919ExamBonusRounding
|
||
([Legacy.migrationVersion|23.0.0|], [Legacy.version|24.0.0|]) -> Just Migration20191002FavouriteReason
|
||
([Legacy.migrationVersion|24.0.0|], [Legacy.version|25.0.0|]) -> Just Migration20191003CourseParticipantAllocatedId
|
||
([Legacy.migrationVersion|25.0.0|], [Legacy.version|26.0.0|]) -> Just Migration20191013AllocationMatching
|
||
([Legacy.migrationVersion|26.0.0|], [Legacy.version|27.0.0|]) -> Just Migration20191125UserLanguages
|
||
([Legacy.migrationVersion|27.0.0|], [Legacy.version|28.0.0|]) -> Just Migration20191126ExamPartCorrector
|
||
([Legacy.migrationVersion|28.0.0|], [Legacy.version|29.0.0|]) -> Just Migration20191128StudyFeaturesSuperField
|
||
([Legacy.migrationVersion|29.0.0|], [Legacy.version|30.0.0|]) -> Just Migration20200111ExamOccurrenceRuleRefactor
|
||
([Legacy.migrationVersion|30.0.0|], [Legacy.version|31.0.0|]) -> Just Migration20200218ExamResultPassedGrade
|
||
([Legacy.migrationVersion|31.0.0|], [Legacy.version|32.0.0|]) -> Just Migration20200218ExamGradingModeMixed
|
||
([Legacy.migrationVersion|32.0.0|], [Legacy.version|33.0.0|]) -> Just Migration20200218ExternalExamGradingModeMixed
|
||
([Legacy.migrationVersion|33.0.0|], [Legacy.version|34.0.0|]) -> Just Migration20200311AllocationMatching
|
||
([Legacy.migrationVersion|34.0.0|], [Legacy.version|35.0.0|]) -> Just Migration20200424SubmissionGroups
|
||
([Legacy.migrationVersion|35.0.0|], [Legacy.version|36.0.0|]) -> Just Migration20200504CourseParticipantState
|
||
([Legacy.migrationVersion|36.0.0|], [Legacy.version|37.0.0|]) -> Just Migration20200506SessionFile
|
||
([Legacy.migrationVersion|37.0.0|], [Legacy.version|38.0.0|]) -> Just Migration20200627FileRefactor
|
||
([Legacy.migrationVersion|38.0.0|], [Legacy.version|39.0.0|]) -> Just Migration20200824AllocationNotifications
|
||
([Legacy.migrationVersion|39.0.0|], [Legacy.version|40.0.0|]) -> Just Migration20200825StudyFeaturesFirstObserved
|
||
([Legacy.migrationVersion|40.0.0|], [Legacy.version|41.0.0|]) -> Just Migration20200902FileChunking
|
||
([Legacy.migrationVersion|41.0.0|], [Legacy.version|42.0.0|]) -> Just Migration20200916ExamMode
|
||
([Legacy.migrationVersion|43.0.0|], [Legacy.version|44.0.0|]) -> Just Migration20201106StoredMarkup
|
||
([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
|
||
_other -> Nothing
|
||
|
||
|
||
share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
|
||
[persistLowerCase|
|
||
AppliedMigration json
|
||
migration ManualMigration
|
||
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 appliedMigrationMigration migration = acc <* do
|
||
$logInfoS "Migration" $ toPathPiece 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
|
||
E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF
|
||
return $ appliedMigration E.^. AppliedMigrationMigration
|
||
return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
||
|
||
getMigrationTime :: ( MonadIO m
|
||
, BaseBackend backend ~ SqlBackend
|
||
, PersistStoreRead backend
|
||
)
|
||
=> ManualMigration
|
||
-> ReaderT backend m (Maybe UTCTime)
|
||
getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey
|