640 lines
32 KiB
Haskell
640 lines
32 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Model.Migration
|
|
( migrateAll
|
|
, requiresMigration
|
|
) where
|
|
|
|
import Utils (lastMaybe)
|
|
|
|
import Import.NoModel
|
|
import Model
|
|
import Audit.Types
|
|
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 qualified Data.Text as Text
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import Database.Persist.Sql
|
|
import Database.Persist.Sql.Raw.QQ
|
|
import Database.Persist.Postgresql
|
|
|
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
|
|
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, allM, whenIsJust, guardM)
|
|
import Utils.Lens (_NoUpload)
|
|
import Utils.DB (getKeyBy)
|
|
|
|
import qualified Net.IP as IP
|
|
import qualified Net.IPv4 as IPv4
|
|
import qualified Net.IPv6 as IPv6
|
|
|
|
import Data.Aeson (toJSON)
|
|
|
|
import qualified Data.Char as Char
|
|
import qualified Data.CaseInsensitive as 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
|
|
, MonadResource m
|
|
, MonadUnliftIO 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
|
|
, MonadResource 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 <- mapReaderT lift $ 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
|
|
mapM_ migrateEnableExtension ["citext", "pgcrypto"]
|
|
migrateDBVersioning
|
|
|
|
getMissingMigrations :: forall m m'.
|
|
( MonadLogger m
|
|
, MonadIO m
|
|
, MonadResource 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 :: forall m.
|
|
MonadResource 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"
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|12.0.0|] [version|13.0.0|]
|
|
, whenM (tableExists "exam") $ -- Exams were an unused stub before
|
|
tableDropEmpty "exam"
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|13.0.0|] [version|14.0.0|]
|
|
, whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do
|
|
examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |]
|
|
[executeQQ|
|
|
ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null;
|
|
|]
|
|
forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do
|
|
let name = [st|occ-#{tshow n}|]
|
|
[executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |]
|
|
[executeQQ|
|
|
ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT;
|
|
ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|14.0.0|] [version|15.0.0|]
|
|
, whenM (tableExists "user") $ do
|
|
[executeQQ|
|
|
ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
|
|
ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
|
|
|]
|
|
let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
|
|
updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
|
|
splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
|
|
splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
|
|
| Just givenName <- Text.stripSuffix surname displayName
|
|
<|> Text.stripPrefix surname displayName
|
|
-> Text.strip givenName
|
|
| otherwise
|
|
-> Text.replace surname "…" displayName
|
|
splitFirstName _ = Nothing
|
|
runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|15.0.0|] [version|16.0.0|]
|
|
, whenM (tableExists "transaction_log") $ do
|
|
[executeQQ|
|
|
UPDATE transaction_log SET remote = null WHERE remote = #{IP.fromIPv4 IPv4.loopback} OR remote = #{IP.fromIPv6 IPv6.loopback}
|
|
|]
|
|
|
|
[executeQQ|
|
|
ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
|
|
|]
|
|
|
|
whenM (tableExists "user") $
|
|
[executeQQ|
|
|
UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
|
|
|]
|
|
|
|
[executeQQ|
|
|
ALTER TABLE transaction_log DROP COLUMN initiator;
|
|
ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator;
|
|
ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT;
|
|
|]
|
|
|
|
let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] []
|
|
updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do
|
|
newT <- case oldT of
|
|
Legacy.TransactionTermEdit tid
|
|
-> return . Just . TransactionTermEdit $ TermKey tid
|
|
Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
|
|
-> runMaybeT $ do
|
|
guardM . lift $ tablesExist ["user", "exam", "course"]
|
|
|
|
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
eid <- MaybeT . getKeyBy $ UniqueExam cid examn
|
|
uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
|
|
return $ TransactionExamRegister eid uid
|
|
Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
|
|
-> runMaybeT $ do
|
|
guardM . lift $ tablesExist ["user", "exam", "course"]
|
|
|
|
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
eid <- MaybeT . getKeyBy $ UniqueExam cid examn
|
|
uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
|
|
return $ TransactionExamRegister eid uid
|
|
whenIsJust newT $ \newT' ->
|
|
update lid [ TransactionLogInfo =. toJSON newT' ]
|
|
updateTransactionInfo _ = return ()
|
|
runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|16.0.0|] [version|17.0.0|]
|
|
, do
|
|
whenM (tableExists "allocation_course") $ do
|
|
vals <- [sqlQQ| SELECT "course", "instructions", "application_text", "application_files", "ratings_visible" FROM "allocation_course"; |]
|
|
|
|
whenM (tableExists "course") $ do
|
|
[executeQQ|
|
|
ALTER TABLE "course" ADD COLUMN "applications_required" boolean not null default #{False}, ADD COLUMN "applications_instructions" varchar null, ADD COLUMN "applications_text" boolean not null default #{False}, ADD COLUMN "applications_files" jsonb not null default #{NoUpload}, ADD COLUMN "applications_ratings_visible" boolean not null default #{False};
|
|
ALTER TABLE "course" ALTER COLUMN "applications_required" DROP DEFAULT, ALTER COLUMN "applications_text" DROP DEFAULT, ALTER COLUMN "applications_files" DROP DEFAULT, ALTER COLUMN "applications_ratings_visible" DROP DEFAULT;
|
|
|]
|
|
|
|
forM_ vals $ \(cid :: CourseId, Single applicationsInstructions :: Single (Maybe Html), Single applicationsText :: Single Bool, Single applicationsFiles :: Single UploadMode, Single applicationsRatingsVisible :: Single Bool) -> do
|
|
let appRequired = applicationsText || isn't _NoUpload applicationsFiles
|
|
[executeQQ|
|
|
UPDATE "course" SET ("applications_required", "applications_instructions", "applications_text", "applications_files", "applications_ratings_visible") = (#{appRequired}, #{applicationsInstructions}, #{applicationsText}, #{applicationsFiles}, #{applicationsRatingsVisible}) WHERE "id" = #{cid};
|
|
|]
|
|
|
|
[executeQQ|
|
|
ALTER TABLE "allocation_course" DROP COLUMN "instructions", DROP COLUMN "application_text", DROP COLUMN "application_files", DROP COLUMN "ratings_visible";
|
|
|]
|
|
|
|
whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do
|
|
[executeQQ|
|
|
CREATe TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL);
|
|
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file");
|
|
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id");
|
|
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id");
|
|
|]
|
|
|
|
let getFileEntries = rawQuery [st|SELECT "allocation_course_file"."id", "allocation_course"."course", "allocation_course_file"."file" FROM "allocation_course_file" INNER JOIN "allocation_course" ON "allocation_course"."id" = "allocation_course_file"."allocation_course"|] []
|
|
moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: FileId)] =
|
|
[executeQQ|
|
|
INSERT INTO "course_app_instruction_file" ("course", "file") VALUES (#{cid}, #{fid});
|
|
DELETE FROM "allocation_course_file" WHERE "id" = #{acfId};
|
|
|]
|
|
moveFileEntry _ = return ()
|
|
runConduit $ getFileEntries .| C.mapM_ moveFileEntry
|
|
tableDropEmpty "allocation_course_file"
|
|
|
|
whenM (tableExists "allocation_application") $
|
|
tableDropEmpty "allocation_application"
|
|
whenM (tableExists "allocation_application_file") $
|
|
tableDropEmpty "allocation_application_file"
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|17.0.0|] [version|18.0.0|]
|
|
, do
|
|
whenM (tableExists "allocation") $ do
|
|
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS capacity;|]
|
|
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS link_external;|]
|
|
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS register_secret;|]
|
|
whenM (tableExists "allocation_deregister") $ do
|
|
[executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|18.0.0|] [version|19.0.0|]
|
|
, do
|
|
[executeQQ|
|
|
CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
|
|
|]
|
|
|
|
whenM (tableExists "user_admin") $ do
|
|
let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] []
|
|
moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
|
|
[executeQQ|
|
|
INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin});
|
|
DELETE FROM "user_admin" WHERE "id" = #{eId};
|
|
|]
|
|
moveAdminEntry _ = return ()
|
|
runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry
|
|
tableDropEmpty "user_admin"
|
|
whenM (tableExists "user_lecturer") $ do
|
|
let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] []
|
|
moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
|
|
[executeQQ|
|
|
INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer});
|
|
DELETE FROM "user_lecturer" WHERE "id" = #{eId};
|
|
|]
|
|
moveLecturerEntry _ = return ()
|
|
runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry
|
|
tableDropEmpty "user_lecturer"
|
|
whenM (tableExists "invitation") $ do
|
|
[executeQQ|
|
|
DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"';
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|19.0.0|] [version|20.0.0|]
|
|
, whenM (tableExists "user") $ do
|
|
[executeQQ|
|
|
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "display_email" citext;
|
|
UPDATE "user" SET "display_email" = "email" WHERE "display_email" IS NULL;
|
|
ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL;
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|20.0.0|] [version|21.0.0|]
|
|
, whenM (tableExists "exam_part") $ do
|
|
[executeQQ|
|
|
ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext;
|
|
|]
|
|
|
|
let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] []
|
|
renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do
|
|
partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|]
|
|
let
|
|
partNames :: [(ExamPartId, ExamPartName)]
|
|
partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames'
|
|
|
|
partsSorted = partNames
|
|
& sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer))
|
|
. groupBy ((==) `on` Char.isDigit)
|
|
. CI.foldedCase
|
|
. snd
|
|
)
|
|
& map fst
|
|
forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) ->
|
|
[executeQQ|
|
|
UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId};
|
|
|]
|
|
renameExamParts _ = return ()
|
|
runConduit $ getExamEntries .| C.mapM_ renameExamParts
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|21.0.0|] [version|22.0.0|]
|
|
, whenM (tableExists "exam") $ do
|
|
oldVersion <- columnExists "exam" "grading_key"
|
|
if
|
|
| oldVersion -> do
|
|
-- Major changes happend to the structure of exams without appropriate
|
|
-- migration, try to remedy that here
|
|
tableDropEmpty "exam_part_corrector"
|
|
tableDropEmpty "exam_corrector"
|
|
tableDropEmpty "exam_result"
|
|
tableDropEmpty "exam_registration"
|
|
tableDropEmpty "exam_occurrence"
|
|
tableDropEmpty "exam_part"
|
|
tableDropEmpty "exam"
|
|
| otherwise ->
|
|
[executeQQ|
|
|
ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL;
|
|
ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL;
|
|
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL;
|
|
|
|
UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual';
|
|
UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus';
|
|
UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"';
|
|
|
|
UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule");
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
|
|
, whenM (tableExists "exam") $
|
|
[executeQQ|
|
|
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
|
, whenM (tableExists "course_favourite") $
|
|
[executeQQ|
|
|
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
|
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|24.0.0|] [version|25.0.0|]
|
|
, whenM (tableExists "course_participant") $ do
|
|
queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|]
|
|
case queryRes of
|
|
[Single False] ->
|
|
[executeQQ|
|
|
ALTER TABLE "course_participant" DROP COLUMN "allocated";
|
|
ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint;
|
|
|]
|
|
_other -> error "Cannot reconstruct course_participant.allocated"
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
|
|
, whenM (tableExists "allocation") $
|
|
[executeQQ|
|
|
CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
|
|
INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
|
|
ALTER TABLE "allocation" DROP COLUMN "fingerprint";
|
|
ALTER TABLE "allocation" DROP COLUMN "matching_log";
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
|
|
, whenM (tableExists "user") $
|
|
[executeQQ|
|
|
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
|
|
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
|
|
ALTER TABLE "user" DROP COLUMN "mail_languages";
|
|
|]
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|27.0.0|] [version|28.0.0|]
|
|
, whenM (tableExists "exam_part_corrector") $
|
|
tableDropEmpty "exam_part_corrector"
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
|
|
, whenM (tableExists "study_features") $
|
|
[executeQQ|
|
|
ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
|
|
UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
|
|
ALTER TABLE "study_features" DROP COLUMN "sub_field";
|
|
|]
|
|
)
|
|
]
|
|
|
|
|
|
|
|
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
|
|
|
|
tablesExist :: MonadIO m => [Text] -> ReaderT SqlBackend m Bool
|
|
tablesExist = flip allM tableExists
|
|
|
|
tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
|
tableIsEmpty table = do
|
|
res <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []
|
|
return $ case res of
|
|
[unSingle -> rows] -> rows == (0 :: Int64)
|
|
_other -> error "tableIsEmpty din't return exactly one result"
|
|
|
|
tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m ()
|
|
tableDropEmpty table = whenM (tableExists table) $ do
|
|
isEmpty <- tableIsEmpty table
|
|
if
|
|
| isEmpty -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] []
|
|
| otherwise -> error $ "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
|
|
|