module Model.Migration ( migrateAll ) where import ClassyPrelude.Yesod import Utils (lastMaybe) import Model import Model.Migration.Version import qualified Model.Migration.Types as Legacy import Data.Map (Map) import qualified Data.Map as Map import Data.Set () import qualified Data.Set as Set import Database.Persist.Sql import Database.Persist.Postgresql import Text.Read (readMaybe) import Data.CaseInsensitive (CI) -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) -- Note that only one automatic migration is done (after all manual migrations). -- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion) -- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system -- Database versions must be marked with git tags: -- The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x -- Tags should be annotated with a description of the changes affecting the database. -- -- Example: -- $ git tag -a db0.0.0 -m "Simplified format of UserTheme" -- -- Doing so creates sort of parallel commit history tracking changes to the database schema share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] [persistLowerCase| AppliedMigration json from MigrationVersion to Version time UTCTime UniqueAppliedMigration from Primary from to deriving Show Eq Ord |] migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () migrateAll = do $logDebugS "Migration" "Initial migration" mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do -- Manual migrations to go to InitialVersion below: migrateEnableExtension "citext" migrateDBVersioning $logDebugS "Migration" "Retrieve applied migrations" appliedMigrations <- selectKeysList [] [] let missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations doCustomMigration acc desc migration = acc <* do let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|] 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' {- Confusion about quotes, from the PostgreSQL Manual: Single quotes for string constants, double quotes for table/column names. QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model); #{anything} (escaped as value); -} customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations = Map.fromListWith (>>) [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] , whenM (columnExists "user" "theme") $ do -- New theme format userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |] forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of Just v | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme] other -> error $ "Could not parse theme: " <> show other ) , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] , whenM (tableExists "sheet") $ -- Better JSON encoding [executeQQ| ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb; ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|] , whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now -- Read old table into memory schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |] let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed -- Convert columns containing SchoolId whenM (tableExists "user_admin") $ do [executeQQ| ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey"; ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext; |] forM_ schoolTable $ \(Single idnr, Single ssh) -> [executeQQ| UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; |] [executeQQ| ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey" FOREIGN KEY (school) REFERENCES school(shorthand); |] whenM (tableExists "user_lecturer") $ do [executeQQ| ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey"; ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext; |] forM_ schoolTable $ \(Single idnr, Single ssh) -> [executeQQ| UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; |] [executeQQ| ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey" FOREIGN KEY (school) REFERENCES school(shorthand); |] whenM (tableExists "course") $ do [executeQQ| ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey"; ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext; |] forM_ schoolTable $ \(Single idnr, Single ssh) -> [executeQQ| UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; |] [executeQQ| ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey" FOREIGN KEY (school) REFERENCES school(shorthand); |] [executeQQ| ALTER TABLE "school" DROP COLUMN "id"; ALTER TABLE "school" ADD PRIMARY KEY (shorthand); |] ) , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|] , whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now. correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |] forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of Just load -> update uid [SheetCorrectorLoad =. load] _other -> error $ "Could not parse Load: " <> show str [executeQQ| ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|] , whenM (tableExists "user") $ do userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |] [executeQQ| ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT ''; |] forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of Just name -> update uid [UserSurname =. name] _other -> error "Empty userDisplayName found" ) , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] , whenM (tableExists "sheet") $ [executeQQ| ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; |] ) , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] , whenM (columnExists "user" "plugin") $ -- <> is standard sql for /= [executeQQ| DELETE FROM "user" WHERE "plugin" <> 'LDAP'; ALTER TABLE "user" DROP COLUMN "plugin"; ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"'; |] ) , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] , whenM (tableExists "user") $ [executeQQ| ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; |] ) , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] , whenM (tableExists "sheet") $ do sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |] forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] ) , ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|] , whenM (tableExists "cluster_config") $ [executeQQ| UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; |] ) , ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|] , whenM (tableExists "sheet") $ [executeQQ| UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", ''); UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points'); UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points'); |] ) , ( AppliedMigrationKey [migrationVersion|8.0.0|] [version|9.0.0|] , whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do [executeQQ| ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id); ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true; |] users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |] forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |] ) , ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|] , do whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |] whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |] whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |] whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |] ) , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|] , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |] [executeQQ| ALTER TABLE "sheet" DROP COLUMN "upload_mode"; ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT; ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb; |] forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do let submissionMode' = case (submissionMode, uploadMode) of ( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing ( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing ( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload) ( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True) ( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False) [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |] ) ] tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |] case haveTable :: [Maybe (Single PersistValue)] of [Just _] -> return True _other -> return False columnExists :: MonadIO m => Text -- ^ Table -> Text -- ^ Column -> ReaderT SqlBackend m Bool columnExists table column = do haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|] case haveColumn :: [Single PersistValue] of [_] -> return True _other -> return False