231 lines
10 KiB
Haskell
231 lines
10 KiB
Haskell
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
|
|
mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do
|
|
-- Manual migrations to go to InitialVersion below:
|
|
migrateEnableExtension "citext"
|
|
|
|
migrateDBVersioning
|
|
|
|
appliedMigrations <- map entityKey <$> selectList [] []
|
|
let
|
|
missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
|
doCustomMigration acc desc migration = acc <* do
|
|
let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
|
|
appliedMigrationTime <- liftIO getCurrentTime
|
|
_ <- migration
|
|
insert AppliedMigration{..}
|
|
-- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
|
|
Map.foldlWithKey doCustomMigration (return ()) missingMigrations
|
|
|
|
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');
|
|
|]
|
|
)
|
|
]
|
|
|
|
|
|
|
|
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
|
|
|