{-# 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