-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Sarah Vaupel ,Steffen Jost -- -- 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.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|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|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|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|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