324 lines
16 KiB
Haskell
324 lines
16 KiB
Haskell
module Model.Migration
|
|
( migrateAll
|
|
, requiresMigration
|
|
) 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)
|
|
|
|
import Text.Shakespeare.Text (st)
|
|
|
|
import Control.Monad.Trans.Reader (mapReaderT)
|
|
import Control.Monad.Except (MonadError(..))
|
|
import Utils (exceptT)
|
|
|
|
-- 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 initialMigration
|
|
|
|
missingMigrations <- getMissingMigrations
|
|
let
|
|
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'
|
|
|
|
requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
|
|
requiresMigration = mapReaderT (exceptT return return) $ do
|
|
initial <- either id (map snd) <$> parseMigration initialMigration
|
|
when (not $ null initial) $ do
|
|
$logInfoS "Migration" $ intercalate "; " initial
|
|
throwError True
|
|
|
|
customs <- getMissingMigrations @_ @m
|
|
when (not $ Map.null customs) $ do
|
|
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
|
throwError True
|
|
|
|
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
|
when (not $ null automatic) $ do
|
|
$logInfoS "Migration" $ intercalate "; " automatic
|
|
throwError True
|
|
|
|
return False
|
|
|
|
initialMigration :: Migration
|
|
-- ^ Manual migrations to go to InitialVersion below:
|
|
initialMigration = do
|
|
migrateEnableExtension "citext"
|
|
migrateDBVersioning
|
|
|
|
getMissingMigrations :: forall m m'.
|
|
( MonadLogger m
|
|
, MonadBaseControl IO m
|
|
, MonadIO m
|
|
, MonadIO m'
|
|
)
|
|
=> ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
|
|
getMissingMigrations = do
|
|
$logDebugS "Migration" "Retrieve applied migrations"
|
|
appliedMigrations <- selectKeysList [] []
|
|
return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
|
|
|
{-
|
|
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 $ UploadAny True defaultExtensionRestriction)
|
|
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
|
|
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
|
|
, whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
|
|
tableDropEmpty "tutorial"
|
|
tableDropEmpty "tutorial_user"
|
|
)
|
|
]
|
|
|
|
|
|
|
|
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
|
|
|
|
tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
|
tableIsEmpty table = do
|
|
[rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []
|
|
return $ unSingle rows == (0 :: Int64)
|
|
|
|
tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m ()
|
|
tableDropEmpty table = do
|
|
isEmpty <- tableIsEmpty table
|
|
if
|
|
| isEmpty -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] []
|
|
| otherwise -> fail $ "Table " <> unpack table <> " is not empty"
|
|
|
|
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
|
|
|