diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 81d39e603..ea88dbbdc 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -7,74 +7,86 @@ module Model.Migration import Import.NoModel hiding (Max(..), Last(..)) import Model -import Settings import Foundation.Type -import Jobs.Types -import Audit.Types -import Model.Migration.Version +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.HashMap.Strict as HashMap - -import qualified Data.Text as Text import qualified Data.Conduit.List as C -import Data.Semigroup (Max(..), Last(..)) - - import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ import Database.Persist.Postgresql -import Text.Read (readMaybe) +import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..)) -import Utils.Lens (_NoUpload) - -import Network.IP.Addr - -import qualified Data.Char as Char -import qualified Data.CaseInsensitive as CI - -import qualified Data.Aeson as Aeson import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) -import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) +import qualified Control.Monad.State.Class as State -import Data.Time.Format.ISO8601 (iso8601Show) -import qualified Data.Time.Zones as TZ - --- 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 +_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 - from MigrationVersion - to Version + migration ManualMigration time UTCTime - UniqueAppliedMigration from - Primary from to + Primary migration deriving Show Eq Ord |] @@ -97,9 +109,8 @@ migrateAll = do missingMigrations <- getMissingMigrations let - doCustomMigration acc desc migration = acc <* do - let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc - $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|] + doCustomMigration acc appliedMigrationMigration migration = acc <* do + $logInfoS "Migration" $ toPathPiece appliedMigrationMigration appliedMigrationTime <- liftIO getCurrentTime _ <- migration insert AppliedMigration{..} @@ -142,6 +153,22 @@ 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'. @@ -150,949 +177,10 @@ getMissingMigrations :: forall m m'. , MonadResource m' , MonadReader UniWorX m' ) - => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ())) + => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ())) getMissingMigrations = do $logDebugS "Migration" "Retrieve applied migrations" - appliedMigrations <- selectKeysList [] [] + 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 - - -migrateManual :: Migration -migrateManual = do - mapM_ (uncurry addIndex) - [ ("course_application_file_content", "CREATE INDEX course_application_file_content ON course_application_file (content)" ) - , ("material_file_content", "CREATE INDEX material_file_content ON material_file (content)" ) - , ("course_news_file_content", "CREATE INDEX course_news_file_content ON course_news_file (content)" ) - , ("sheet_file_content", "CREATE INDEX sheet_file_content ON sheet_file (content)" ) - , ("course_app_instruction_file_content", "CREATE INDEX course_app_instruction_file_content ON course_app_instruction_file (content)") - , ("allocation_matching_log", "CREATE INDEX allocation_matching_log ON allocation_matching (log)" ) - , ("submission_file_content", "CREATE INDEX submission_file_content ON submission_file (content)" ) - , ("session_file_content", "CREATE INDEX session_file_content ON session_file (content)" ) - , ("file_lock_content", "CREATE INDEX file_lock_content ON file_lock (content)" ) - , ("user_lower_display_email", "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))" ) - , ("user_lower_email", "CREATE INDEX user_lower_email ON \"user\" (lower(email))" ) - , ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" ) - , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) - , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) - , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) - , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) - , ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL") - , ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL") - ] - where - addIndex :: Text -> Sql -> Migration - addIndex ixName ixDef = do - res <- lift $ lift [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] - alreadyDefined <- case res of - [Single e] -> return e - _other -> return True - unless alreadyDefined $ addMigration False ixDef - -migrateAlwaysSafe :: Migration --- | Part of `migrateAll` but not checked in `requiresMigration` -migrateAlwaysSafe = do - recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] [] - let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' - where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] - unless (null missingChangelogItems) $ do - today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - addMigration False $ do - let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] - vals = Text.intercalate ", " $ do - item <- missingChangelogItems - let itemDay = Map.findWithDefault today item changelogItemDays - return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] - in sql - -{- - 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 - , MonadReader UniWorX 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 True) - ( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True) - [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 = #{IPv4 loopbackIP4 :: IP} OR remote = #{IPv6 loopbackIP6 :: IP} - |] - - [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 :: Int64)] = - [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"; - |] - ) - , ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|] - , whenM (tableExists "exam") - [executeQQ| - UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL; - ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL; - |] - ) - , ( AppliedMigrationKey [migrationVersion|30.0.0|] [version|31.0.0|] - , whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do - queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|] - forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) -> - let res' :: ExamResultPassedGrade - res' = Left . view passingGrade <$> res - in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|] - ) - , ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|] - , whenM (tableExists "exam") - [executeQQ| - ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying; - UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades"; - UPDATE "exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; - ALTER TABLE "exam" DROP COLUMN "show_grades"; - ALTER TABLE "exam" ALTER COLUMN "grading_mode" SET NOT NULL; - |] - ) - , ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|] - , whenM (tableExists "external_exam") - [executeQQ| - ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying; - UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades"; - UPDATE "external_exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; - ALTER TABLE "external_exam" DROP COLUMN "show_grades"; - ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL; - |] - ) - , ( AppliedMigrationKey [migrationVersion|33.0.0|] [version|34.0.0|] - , whenM (tableExists "allocation_matching") $ - tableDropEmpty "allocation_matching" - ) - , ( AppliedMigrationKey [migrationVersion|34.0.0|] [version|35.0.0|] - , do - whenM (tableExists "submission_group") $ - tableDropEmpty "submission_group" - whenM (tableExists "submission_group_edit") $ - tableDropEmpty "submission_group_edit" - ) - , ( AppliedMigrationKey [migrationVersion|35.0.0|] [version|36.0.0|] - , whenM (tableExists "course_participant") $ do - [executeQQ| - ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active'; - ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT; - |] - let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] [] - ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m () - ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do - let toAllocated :: [[PersistValue]] -> Maybe AllocationId - toAllocated = either (const Nothing) Just . fromPersistValue <=< listToMaybe <=< listToMaybe - allocated <- toAllocated <$> sourceToList [queryQQ|SELECT "allocation_course".allocation FROM "allocation_deregister" INNER JOIN "allocation_course" ON "allocation_course".course = "allocation_deregister".course WHERE "user" = #{transactionUser} AND "allocation_course"."course" = #{transactionCourse} LIMIT 1;|] - whenM (existsKey transactionCourse `and2M` existsKey transactionUser) - [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state", "allocated") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}, #{allocated}) ON CONFLICT DO NOTHING;|] - ensureParticipant _ = return () - runConduit $ getAuditLog .| C.mapM_ ensureParticipant - ) - , ( AppliedMigrationKey [migrationVersion|36.0.0|] [version|37.0.0|] - , whenM (tableExists "session_file") $ - tableDropEmpty "session_file" - ) - , ( AppliedMigrationKey [migrationVersion|37.0.0|] [version|38.0.0|] - , whenM (tableExists "file") $ do - [executeQQ| - ALTER TABLE "file" ADD COLUMN "hash" BYTEA; - UPDATE "file" SET "hash" = digest("content", 'sha3-512'); - |] - - let - migrateFromFile :: forall fRef. - ( HasFileReference fRef - , PersistRecordBackend fRef SqlBackend - ) - => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef)) - -> (Entity fRef -> ReaderT SqlBackend m ()) - -> [PersistValue] - -> ReaderT SqlBackend m () - migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do - let (fRefKey, residual) = toResidual rest - fileDat <- [sqlQQ| - SELECT "file".title, "file".modified, "file".hash FROM "file" WHERE "id" = #{fId}; - |] - forM_ fileDat $ \case - (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do - let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual) - candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ] - where (fName, ext) = splitExtension fileReferenceTitle' - validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles - case validTitles of - fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle - _other -> error "Could not make validTitle" - _other -> return () - migrateFromFile _ _ _ = return () - - whenM (tableExists "submission_file") $ do - [executeQQ| - ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file"; - ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update"); - |] - let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right sfId - , fromPersistValue -> Right submissionFileResidualSubmission - , fromPersistValue -> Right submissionFileResidualIsUpdate - , fromPersistValue -> Right submissionFileResidualIsDeletion - ] - = (sfId, SubmissionFileResidual{..}) - toResidual _ = error "Could not convert SubmissionFile to residual" - runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "submission_file" DROP COLUMN "file"; - |] - - whenM (tableExists "sheet_file") $ do - [executeQQ| - ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file"; - ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title"); - |] - let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right shfId - , fromPersistValue -> Right sheetFileResidualSheet - , fromPersistValue -> Right sheetFileResidualType - ] - = (shfId, SheetFileResidual{..}) - toResidual _ = error "Could not convert SheetFile to residual" - runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "sheet_file" DROP COLUMN "file"; - |] - - whenM (tableExists "course_app_instruction_file") $ do - [executeQQ| - ALTER TABLE "course_app_instruction_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "course_app_instruction_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "course_app_instruction_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "course_app_instruction_file" DROP CONSTRAINT "unique_course_app_instruction_file"; - ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course", "title"); - |] - let getCourseAppInstructionFiles = [queryQQ|SELECT "file", "course_app_instruction_file"."id", "course" FROM "course_app_instruction_file" LEFT OUTER JOIN "file" ON "course_app_instruction_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right caifId - , fromPersistValue -> Right courseAppInstructionFileResidualCourse - ] - = (caifId, CourseAppInstructionFileResidual{..}) - toResidual _ = error "Could not convert CourseAppInstructionFile to residual" - runConduit $ getCourseAppInstructionFiles .| C.mapM_ (migrateFromFile @CourseAppInstructionFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "course_app_instruction_file" DROP COLUMN "file"; - |] - - whenM (tableExists "course_news_file") $ do - [executeQQ| - ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file"; - ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title"); - |] - let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right cnfId - , fromPersistValue -> Right courseNewsFileResidualNews - ] - = (cnfId, CourseNewsFileResidual{..}) - toResidual _ = error "Could not convert CourseNewsFile to residual" - runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "course_news_file" DROP COLUMN "file"; - |] - - whenM (tableExists "material_file") $ do - [executeQQ| - ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file"; - ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title"); - |] - let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right shfId - , fromPersistValue -> Right materialFileResidualMaterial - ] - = (shfId, MaterialFileResidual{..}) - toResidual _ = error "Could not convert MaterialFile to residual" - runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "material_file" DROP COLUMN "file"; - |] - - whenM (tableExists "course_application_file") $ do - [executeQQ| - ALTER TABLE "course_application_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "course_application_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "course_application_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "course_application_file" DROP CONSTRAINT "unique_application_file"; - ALTER TABLE "course_application_file" ADD CONSTRAINT "unique_course_application_file" UNIQUE("application", "title"); - |] - let getCourseApplicationFiles = [queryQQ|SELECT "file", "course_application_file"."id", "application" FROM "course_application_file" LEFT OUTER JOIN "file" ON "course_application_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right cnfId - , fromPersistValue -> Right courseApplicationFileResidualApplication - ] - = (cnfId, CourseApplicationFileResidual{..}) - toResidual _ = error "Could not convert CourseApplicationFile to residual" - runConduit $ getCourseApplicationFiles .| C.mapM_ (migrateFromFile @CourseApplicationFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "course_application_file" DROP COLUMN "file"; - |] - - whenM (tableExists "allocation_matching") $ do - [executeQQ| - ALTER TABLE "allocation_matching" ADD COLUMN "log_ref" BYTEA; - UPDATE "allocation_matching" SET "log_ref" = (SELECT "hash" FROM "file" WHERE "file".id = "log"); - ALTER TABLE "allocation_matching" DROP COLUMN "log"; - ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log"; - |] - - whenM (tableExists "session_file") - [executeQQ| - ALTER TABLE "session_file" ADD COLUMN "content" BYTEA; - UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file"); - ALTER TABLE "session_file" DROP COLUMN "file"; - |] - - [executeQQ| - ALTER TABLE "file" RENAME TO "file_content"; - DELETE FROM "file_content" WHERE "content" IS NULL OR "hash" IS NULL; - |] - [executeQQ| - DELETE FROM "file_content" - WHERE "id" IN ( - SELECT - "id" - FROM ( - SELECT - "id", - ROW_NUMBER() OVER w AS rnum - FROM "file_content" - WINDOW w AS ( - PARTITION BY "hash" - ORDER BY "id" - ) - ) as t - WHERE t.rnum > 1); - |] - [executeQQ| - ALTER TABLE "file_content" DROP COLUMN "title"; - ALTER TABLE "file_content" DROP COLUMN "modified"; - ALTER TABLE "file_content" DROP COLUMN "id"; - |] - ) - , ( AppliedMigrationKey [migrationVersion|38.0.0|] [version|39.0.0|] - , whenM (and2M (tableExists "cron_last_exec") (tableExists "allocation")) $ do - let - allocationTimes :: EntityField Allocation (Maybe UTCTime) - -> ReaderT SqlBackend m (MergeHashMap UTCTime (Set AllocationId, Max UTCTime, Last InstanceId)) - allocationTimes aField = do - ress <- [sqlQQ|SELECT ^{Allocation}.@{AllocationId},^{Allocation}.@{aField},^{CronLastExec}.@{CronLastExecTime},^{CronLastExec}.@{CronLastExecInstance} FROM ^{Allocation} INNER JOIN ^{CronLastExec} ON ^{CronLastExec}.@{CronLastExecJob}->'job' = '"queue-notification"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'notification' = '"allocation-staff-register"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'allocation' = (^{Allocation}.@{AllocationId} :: text) :: jsonb ORDER BY ^{Allocation}.@{aField} ASC;|] - return . flip foldMap ress $ \(Single allocId, Single allocTime, Single execTime, Single execInstance) - -> _MergeHashMap # HashMap.singleton allocTime (Set.singleton allocId, Max execTime, Last execInstance) - - staffRegisterFroms <- allocationTimes AllocationStaffRegisterFrom - forM_ staffRegisterFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> - insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationStaffRegister{..}, .. } - - registerFroms <- allocationTimes AllocationRegisterFrom - forM_ registerFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> - insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationRegister{..}, .. } - - staffAllocationFroms <- allocationTimes AllocationStaffAllocationFrom - forM_ staffAllocationFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> - insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationAllocation{..}, .. } - - registerTos <- allocationTimes AllocationRegisterTo - forM_ registerTos $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> - insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationUnratedApplications{..}, .. } - - ) - , ( AppliedMigrationKey [migrationVersion|39.0.0|] [version|40.0.0|] - , whenM (tableExists "study_features") - [executeQQ| - ALTER TABLE study_features RENAME updated TO last_observed; - ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone; - UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1); - |] - ) - , ( AppliedMigrationKey [migrationVersion|40.0.0|] [version|41.0.0|] - , whenM (tableExists "file_content") $ do - chunkingParams <- lift $ view _appFileChunkingParams - - [executeQQ| - ALTER TABLE file_content RENAME TO file_content_chunk; - ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey; - - CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL); - INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL)); - ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since; - - ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false; - UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams}; - - CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); - INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk); - |] - ) - , ( AppliedMigrationKey [migrationVersion|41.0.0|] [version|42.0.0|] - , do - whenM (tableExists "exam") - [executeQQ| - ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing}; - |] - whenM (tableExists "school") - [executeQQ| - ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse}; - |] - ) - , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|] - , return () -- Unused; used to create and fill `ChangelogItemFirstSeen` - ) - , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|43.1.0|] - , whenM (tableExists "school") $ do - schools <- [sqlQQ| SELECT "shorthand", "exam_discouraged_modes" FROM "school"; |] - forM_ schools $ \(sid, Single edModes) -> update sid [SchoolExamDiscouragedModes =. Legacy.examModeDNF edModes] - ) - , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|] - , [executeQQ| - SET client_min_messages TO WARNING; - ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseApplicationsInstructions} TYPE jsonb USING (CASE WHEN @{CourseApplicationsInstructions} IS NOT NULL THEN to_json(@{CourseApplicationsInstructions}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); - SET client_min_messages TO NOTICE; - |] - ) - , ( AppliedMigrationKey [migrationVersion|44.0.0|] [version|45.0.0|] - , do - whenM (tableExists "exam_occurrence") $ do - [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|] - let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|] - migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|] - migrateExamOccurrence _ = return () - in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence - [executeQQ| - ALTER TABLE "exam_occurrence" DROP COLUMN "room"; - ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "tutorial") $ do - [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|] - let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|] - migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|] - migrateTutorial _ = return () - in runConduit $ getTutorials .| C.mapM_ migrateTutorial - [executeQQ| - ALTER TABLE "tutorial" DROP COLUMN "room"; - ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "course_event") $ do - [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|] - let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|] - migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|] - migrateCourseEvent _ = return () - in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent - [executeQQ| - ALTER TABLE "course_event" DROP COLUMN "room"; - ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "course") $ do - let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|] - migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ] - | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|] - | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|] - migrateCourse _ = return () - in runConduit $ getCourses .| C.mapM_ migrateCourse - ) - ] - - - -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 - diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs new file mode 100644 index 000000000..27b11df1c --- /dev/null +++ b/src/Model/Migration/Definitions.hs @@ -0,0 +1,995 @@ +module Model.Migration.Definitions + ( ManualMigration(..) + , migrateManual + , migrateAlwaysSafe + , customMigrations + , columnExists + ) where + +import Import.NoModel hiding (Max(..), Last(..)) +import Model +import Model.Types.TH.PathPiece +import Settings +import Foundation.Type +import Jobs.Types +import Audit.Types +import qualified Model.Migration.Types as Legacy +import qualified Data.Map as Map + +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap + +import qualified Data.Text as Text + +import qualified Data.Conduit.List as C + +import Data.Semigroup (Max(..), Last(..)) + + +import Database.Persist.Sql +import Database.Persist.Sql.Raw.QQ + +import Text.Read (readMaybe) + +import Utils.Lens (_NoUpload) + +import Network.IP.Addr + +import qualified Data.Char as Char +import qualified Data.CaseInsensitive as CI + +import qualified Data.Aeson as Aeson + +import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) + +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Time.Format + +import qualified Data.Time.Zones as TZ + + +data ManualMigration + = Migration20180813SimplifyUserTheme + | Migration20180813SheetJSONB + | Migration20180823SchoolShorthandPrimaryKey + | Migration20180918SheetCorrectorLoadJSON + | Migration20180918UserSurnames + | Migration20180918SheetUploadMode + | Migration20180928UserAuthentication + | Migration20181011UserNotificationSettings + | Migration20181031SheetTypeRefactor + | Migration20181129EncodedSecretBoxes + | Migration20181130SheetTypeRefactor + | Migration20190319CourseParticipantField + | Migration20190320BetterStudyShorthands + | Migration20190421MixedSheetSubmissions + | Migration20190429Tutorials + | Migration20190515Exams + | Migration20190715ExamOccurrenceName + | Migration20190726UserFirstNamesTitles + | Migration20190806TransactionLogIds + | Migration20190809AllocationIndependentApplication + | Migration20190813Allocations + | Migration20190828UserFunction + | Migration20190912UserDisplayEmail + | Migration20190916ExamPartNumber + | Migration20190918ExamRulesRefactor + | Migration20190919ExamBonusRounding + | Migration20191002FavouriteReason + | Migration20191003CourseParticipantAllocatedId + | Migration20191013AllocationMatching + | Migration20191125UserLanguages + | Migration20191126ExamPartCorrector + | Migration20191128StudyFeaturesSuperField + | Migration20200111ExamOccurrenceRuleRefactor + | Migration20200218ExamResultPassedGrade + | Migration20200218ExamGradingModeMixed + | Migration20200218ExternalExamGradingModeMixed + | Migration20200311AllocationMatching + | Migration20200424SubmissionGroups + | Migration20200504CourseParticipantState + | Migration20200506SessionFile + | Migration20200627FileRefactor + | Migration20200824AllocationNotifications + | Migration20200825StudyFeaturesFirstObserved + | Migration20200902FileChunking + | Migration20200916ExamMode + | Migration20201106StoredMarkup + | Migration20201119RoomTypes + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ManualMigration $ \t@(splitCamel -> verbs) -> case verbs of + ("Migration" : dVerb : vs) + | Just (d :: Day) <- parseTimeM False defaultTimeLocale "%Y%m%d" (unpack dVerb) + -> pack (formatTime defaultTimeLocale "%Y-%m-%d" d) <> "--" <> intercalate "-" (map toLower vs) + _other + -> terror $ "Could not parse: “" <> t <> "” → " <> tshow verbs +pathPieceJSON ''ManualMigration +pathPieceJSONKey ''ManualMigration +pathPieceHttpApiData ''ManualMigration +derivePersistFieldPathPiece ''ManualMigration + + + + +migrateManual :: Migration +migrateManual = do + mapM_ (uncurry addIndex) + [ ("course_application_file_content", "CREATE INDEX course_application_file_content ON course_application_file (content)" ) + , ("material_file_content", "CREATE INDEX material_file_content ON material_file (content)" ) + , ("course_news_file_content", "CREATE INDEX course_news_file_content ON course_news_file (content)" ) + , ("sheet_file_content", "CREATE INDEX sheet_file_content ON sheet_file (content)" ) + , ("course_app_instruction_file_content", "CREATE INDEX course_app_instruction_file_content ON course_app_instruction_file (content)") + , ("allocation_matching_log", "CREATE INDEX allocation_matching_log ON allocation_matching (log)" ) + , ("submission_file_content", "CREATE INDEX submission_file_content ON submission_file (content)" ) + , ("session_file_content", "CREATE INDEX session_file_content ON session_file (content)" ) + , ("file_lock_content", "CREATE INDEX file_lock_content ON file_lock (content)" ) + , ("user_lower_display_email", "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))" ) + , ("user_lower_email", "CREATE INDEX user_lower_email ON \"user\" (lower(email))" ) + , ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" ) + , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) + , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) + , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) + , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) + , ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL") + , ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL") + ] + where + addIndex :: Text -> Sql -> Migration + addIndex ixName ixDef = do + res <- lift $ lift [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] + alreadyDefined <- case res of + [Single e] -> return e + _other -> return True + unless alreadyDefined $ addMigration False ixDef + +migrateAlwaysSafe :: Migration +-- | Part of `migrateAll` but not checked in `requiresMigration` +migrateAlwaysSafe = do + recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] [] + let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' + where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] + unless (null missingChangelogItems) $ do + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + addMigration False $ do + let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] + vals = Text.intercalate ", " $ do + item <- missingChangelogItems + let itemDay = Map.findWithDefault today item changelogItemDays + return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] + in sql + +{- + 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 + , MonadReader UniWorX m + ) + => Map ManualMigration (ReaderT SqlBackend m ()) +customMigrations = mapF $ \case + Migration20180813SimplifyUserTheme -> 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 + + Migration20180813SheetJSONB -> 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; + |] + + Migration20180823SchoolShorthandPrimaryKey -> 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); + |] + + Migration20180918SheetCorrectorLoadJSON -> 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; + |] + + Migration20180918UserSurnames -> 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" + + Migration20180918SheetUploadMode -> whenM (tableExists "sheet") + [executeQQ| + ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; + |] + + Migration20180928UserAuthentication -> 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"'; + |] + + Migration20181011UserNotificationSettings -> whenM (tableExists "user") + [executeQQ| + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; + |] + + Migration20181031SheetTypeRefactor -> whenM (tableExists "sheet") $ do + sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |] + forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] + + Migration20181129EncodedSecretBoxes -> whenM (tableExists "cluster_config") + [executeQQ| + UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; + |] + + Migration20181130SheetTypeRefactor -> 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'); + |] + + Migration20190319CourseParticipantField -> 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; |] + + Migration20190320BetterStudyShorthands -> 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" = '' |] + + Migration20190421MixedSheetSubmissions -> 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 True) + ( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True) + [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |] + + Migration20190429Tutorials -> whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before + tableDropEmpty "tutorial" + tableDropEmpty "tutorial_user" + + Migration20190515Exams -> whenM (tableExists "exam") $ -- Exams were an unused stub before + tableDropEmpty "exam" + + Migration20190715ExamOccurrenceName -> 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; + |] + + Migration20190726UserFirstNamesTitles -> 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 + + Migration20190806TransactionLogIds -> whenM (tableExists "transaction_log") $ do + [executeQQ| + UPDATE transaction_log SET remote = null WHERE remote = #{IPv4 loopbackIP4 :: IP} OR remote = #{IPv6 loopbackIP6 :: IP} + |] + + [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 + + Migration20190809AllocationIndependentApplication -> 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 :: Int64)] = + [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" + + Migration20190813Allocations -> 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;|] + + Migration20190828UserFunction -> 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"'; + |] + + Migration20190912UserDisplayEmail -> 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; + |] + + Migration20190916ExamPartNumber -> 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 + + Migration20190918ExamRulesRefactor -> 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"); + |] + + Migration20190919ExamBonusRounding -> whenM (tableExists "exam") + [executeQQ| + UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; + |] + + Migration20191002FavouriteReason -> 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; + |] + + Migration20191003CourseParticipantAllocatedId -> 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" + + Migration20191013AllocationMatching -> 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"; + |] + + Migration20191125UserLanguages -> 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"; + |] + + Migration20191126ExamPartCorrector -> whenM (tableExists "exam_part_corrector") $ + tableDropEmpty "exam_part_corrector" + + Migration20191128StudyFeaturesSuperField -> 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"; + |] + + Migration20200111ExamOccurrenceRuleRefactor -> whenM (tableExists "exam") + [executeQQ| + UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL; + ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL; + |] + + Migration20200218ExamResultPassedGrade -> whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do + queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|] + forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) -> + let res' :: ExamResultPassedGrade + res' = Left . view passingGrade <$> res + in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|] + + Migration20200218ExamGradingModeMixed -> whenM (tableExists "exam") + [executeQQ| + ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying; + UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades"; + UPDATE "exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; + ALTER TABLE "exam" DROP COLUMN "show_grades"; + ALTER TABLE "exam" ALTER COLUMN "grading_mode" SET NOT NULL; + |] + + Migration20200218ExternalExamGradingModeMixed -> whenM (tableExists "external_exam") + [executeQQ| + ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying; + UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades"; + UPDATE "external_exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; + ALTER TABLE "external_exam" DROP COLUMN "show_grades"; + ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL; + |] + + Migration20200311AllocationMatching -> whenM (tableExists "allocation_matching") $ + tableDropEmpty "allocation_matching" + + Migration20200424SubmissionGroups -> do + whenM (tableExists "submission_group") $ + tableDropEmpty "submission_group" + whenM (tableExists "submission_group_edit") $ + tableDropEmpty "submission_group_edit" + + Migration20200504CourseParticipantState -> whenM (tableExists "course_participant") $ do + [executeQQ| + ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active'; + ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT; + |] + let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] [] + ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m () + ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do + let toAllocated :: [[PersistValue]] -> Maybe AllocationId + toAllocated = either (const Nothing) Just . fromPersistValue <=< listToMaybe <=< listToMaybe + allocated <- toAllocated <$> sourceToList [queryQQ|SELECT "allocation_course".allocation FROM "allocation_deregister" INNER JOIN "allocation_course" ON "allocation_course".course = "allocation_deregister".course WHERE "user" = #{transactionUser} AND "allocation_course"."course" = #{transactionCourse} LIMIT 1;|] + whenM (existsKey transactionCourse `and2M` existsKey transactionUser) + [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state", "allocated") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}, #{allocated}) ON CONFLICT DO NOTHING;|] + ensureParticipant _ = return () + runConduit $ getAuditLog .| C.mapM_ ensureParticipant + + Migration20200506SessionFile -> whenM (tableExists "session_file") $ + tableDropEmpty "session_file" + + Migration20200627FileRefactor -> whenM (tableExists "file") $ do + [executeQQ| + ALTER TABLE "file" ADD COLUMN "hash" BYTEA; + UPDATE "file" SET "hash" = digest("content", 'sha3-512'); + |] + + let + migrateFromFile :: forall fRef. + ( HasFileReference fRef + , PersistRecordBackend fRef SqlBackend + ) + => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef)) + -> (Entity fRef -> ReaderT SqlBackend m ()) + -> [PersistValue] + -> ReaderT SqlBackend m () + migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do + let (fRefKey, residual) = toResidual rest + fileDat <- [sqlQQ| + SELECT "file".title, "file".modified, "file".hash FROM "file" WHERE "id" = #{fId}; + |] + forM_ fileDat $ \case + (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do + let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual) + candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ] + where (fName, ext) = splitExtension fileReferenceTitle' + validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles + case validTitles of + fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle + _other -> error "Could not make validTitle" + _other -> return () + migrateFromFile _ _ _ = return () + + whenM (tableExists "submission_file") $ do + [executeQQ| + ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file"; + ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update"); + |] + let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right sfId + , fromPersistValue -> Right submissionFileResidualSubmission + , fromPersistValue -> Right submissionFileResidualIsUpdate + , fromPersistValue -> Right submissionFileResidualIsDeletion + ] + = (sfId, SubmissionFileResidual{..}) + toResidual _ = error "Could not convert SubmissionFile to residual" + runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "submission_file" DROP COLUMN "file"; + |] + + whenM (tableExists "sheet_file") $ do + [executeQQ| + ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file"; + ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title"); + |] + let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right shfId + , fromPersistValue -> Right sheetFileResidualSheet + , fromPersistValue -> Right sheetFileResidualType + ] + = (shfId, SheetFileResidual{..}) + toResidual _ = error "Could not convert SheetFile to residual" + runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "sheet_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_app_instruction_file") $ do + [executeQQ| + ALTER TABLE "course_app_instruction_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_app_instruction_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_app_instruction_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_app_instruction_file" DROP CONSTRAINT "unique_course_app_instruction_file"; + ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course", "title"); + |] + let getCourseAppInstructionFiles = [queryQQ|SELECT "file", "course_app_instruction_file"."id", "course" FROM "course_app_instruction_file" LEFT OUTER JOIN "file" ON "course_app_instruction_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right caifId + , fromPersistValue -> Right courseAppInstructionFileResidualCourse + ] + = (caifId, CourseAppInstructionFileResidual{..}) + toResidual _ = error "Could not convert CourseAppInstructionFile to residual" + runConduit $ getCourseAppInstructionFiles .| C.mapM_ (migrateFromFile @CourseAppInstructionFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_app_instruction_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_news_file") $ do + [executeQQ| + ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file"; + ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title"); + |] + let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right cnfId + , fromPersistValue -> Right courseNewsFileResidualNews + ] + = (cnfId, CourseNewsFileResidual{..}) + toResidual _ = error "Could not convert CourseNewsFile to residual" + runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_news_file" DROP COLUMN "file"; + |] + + whenM (tableExists "material_file") $ do + [executeQQ| + ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file"; + ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title"); + |] + let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right shfId + , fromPersistValue -> Right materialFileResidualMaterial + ] + = (shfId, MaterialFileResidual{..}) + toResidual _ = error "Could not convert MaterialFile to residual" + runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "material_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_application_file") $ do + [executeQQ| + ALTER TABLE "course_application_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_application_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_application_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_application_file" DROP CONSTRAINT "unique_application_file"; + ALTER TABLE "course_application_file" ADD CONSTRAINT "unique_course_application_file" UNIQUE("application", "title"); + |] + let getCourseApplicationFiles = [queryQQ|SELECT "file", "course_application_file"."id", "application" FROM "course_application_file" LEFT OUTER JOIN "file" ON "course_application_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right cnfId + , fromPersistValue -> Right courseApplicationFileResidualApplication + ] + = (cnfId, CourseApplicationFileResidual{..}) + toResidual _ = error "Could not convert CourseApplicationFile to residual" + runConduit $ getCourseApplicationFiles .| C.mapM_ (migrateFromFile @CourseApplicationFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_application_file" DROP COLUMN "file"; + |] + + whenM (tableExists "allocation_matching") $ do + [executeQQ| + ALTER TABLE "allocation_matching" ADD COLUMN "log_ref" BYTEA; + UPDATE "allocation_matching" SET "log_ref" = (SELECT "hash" FROM "file" WHERE "file".id = "log"); + ALTER TABLE "allocation_matching" DROP COLUMN "log"; + ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log"; + |] + + whenM (tableExists "session_file") + [executeQQ| + ALTER TABLE "session_file" ADD COLUMN "content" BYTEA; + UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file"); + ALTER TABLE "session_file" DROP COLUMN "file"; + |] + + [executeQQ| + ALTER TABLE "file" RENAME TO "file_content"; + DELETE FROM "file_content" WHERE "content" IS NULL OR "hash" IS NULL; + |] + [executeQQ| + DELETE FROM "file_content" + WHERE "id" IN ( + SELECT + "id" + FROM ( + SELECT + "id", + ROW_NUMBER() OVER w AS rnum + FROM "file_content" + WINDOW w AS ( + PARTITION BY "hash" + ORDER BY "id" + ) + ) as t + WHERE t.rnum > 1); + |] + [executeQQ| + ALTER TABLE "file_content" DROP COLUMN "title"; + ALTER TABLE "file_content" DROP COLUMN "modified"; + ALTER TABLE "file_content" DROP COLUMN "id"; + |] + + Migration20200824AllocationNotifications -> whenM (and2M (tableExists "cron_last_exec") (tableExists "allocation")) $ do + let + allocationTimes :: EntityField Allocation (Maybe UTCTime) + -> ReaderT SqlBackend m (MergeHashMap UTCTime (Set AllocationId, Max UTCTime, Last InstanceId)) + allocationTimes aField = do + ress <- [sqlQQ|SELECT ^{Allocation}.@{AllocationId},^{Allocation}.@{aField},^{CronLastExec}.@{CronLastExecTime},^{CronLastExec}.@{CronLastExecInstance} FROM ^{Allocation} INNER JOIN ^{CronLastExec} ON ^{CronLastExec}.@{CronLastExecJob}->'job' = '"queue-notification"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'notification' = '"allocation-staff-register"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'allocation' = (^{Allocation}.@{AllocationId} :: text) :: jsonb ORDER BY ^{Allocation}.@{aField} ASC;|] + return . flip foldMap ress $ \(Single allocId, Single allocTime, Single execTime, Single execInstance) + -> _MergeHashMap # HashMap.singleton allocTime (Set.singleton allocId, Max execTime, Last execInstance) + + staffRegisterFroms <- allocationTimes AllocationStaffRegisterFrom + forM_ staffRegisterFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> + insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationStaffRegister{..}, .. } + + registerFroms <- allocationTimes AllocationRegisterFrom + forM_ registerFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> + insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationRegister{..}, .. } + + staffAllocationFroms <- allocationTimes AllocationStaffAllocationFrom + forM_ staffAllocationFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> + insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationAllocation{..}, .. } + + registerTos <- allocationTimes AllocationRegisterTo + forM_ registerTos $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) -> + insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationUnratedApplications{..}, .. } + + Migration20200825StudyFeaturesFirstObserved -> whenM (tableExists "study_features") + [executeQQ| + ALTER TABLE study_features RENAME updated TO last_observed; + ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone; + UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1); + |] + + Migration20200902FileChunking -> whenM (tableExists "file_content") $ do + chunkingParams <- lift $ view _appFileChunkingParams + + [executeQQ| + ALTER TABLE file_content RENAME TO file_content_chunk; + ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey; + + CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL); + INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL)); + ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since; + + ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false; + UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams}; + + CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); + INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk); + |] + + Migration20200916ExamMode -> do + whenM (tableExists "exam") + [executeQQ| + ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing}; + |] + whenM (tableExists "school") + [executeQQ| + ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse}; + |] + + Migration20201106StoredMarkup -> + [executeQQ| + SET client_min_messages TO WARNING; + ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseApplicationsInstructions} TYPE jsonb USING (CASE WHEN @{CourseApplicationsInstructions} IS NOT NULL THEN to_json(@{CourseApplicationsInstructions}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); + SET client_min_messages TO NOTICE; + |] + + Migration20201119RoomTypes -> do + whenM (tableExists "exam_occurrence") $ do + [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|] + let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|] + migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|] + migrateExamOccurrence _ = return () + in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence + [executeQQ| + ALTER TABLE "exam_occurrence" DROP COLUMN "room"; + ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "tutorial") $ do + [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|] + let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|] + migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|] + migrateTutorial _ = return () + in runConduit $ getTutorials .| C.mapM_ migrateTutorial + [executeQQ| + ALTER TABLE "tutorial" DROP COLUMN "room"; + ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "course_event") $ do + [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|] + let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|] + migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|] + migrateCourseEvent _ = return () + in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent + [executeQQ| + ALTER TABLE "course_event" DROP COLUMN "room"; + ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "course") $ do + let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|] + migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ] + | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|] + | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|] + migrateCourse _ = return () + in runConduit $ getCourses .| C.mapM_ migrateCourse + + +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 diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 9847c93d4..0c185750e 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE UndecidableInstances #-} -module Model.Migration.Types where +module Model.Migration.Types + ( module Model.Migration.Types + ) where import ClassyPrelude.Yesod import Data.Aeson @@ -16,6 +18,8 @@ import Data.Universe.TH import qualified Data.Set as Set +import Model.Migration.Version as Model.Migration.Types + data SheetType = Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs index c5239e4bb..ab60b06b9 100644 --- a/src/Model/Migration/Version.hs +++ b/src/Model/Migration/Version.hs @@ -16,12 +16,15 @@ import Data.Version import Data.Aeson.TH +import Language.Haskell.TH.Lib (viewP) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (Lift) import qualified Language.Haskell.TH.Syntax as TH (lift) import Data.Data (Data) +import Utils (assertM') + deriving instance Lift Version @@ -64,25 +67,31 @@ instance PersistFieldSql Version where version, migrationVersion :: QuasiQuoter -version = undefinedQuote{quoteExp} +version = undefinedQuote{quoteExp, quotePat} where - quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of - [x] -> TH.lift x + withP f v = case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> f x [] -> error "No parse" _ -> error "Ambiguous parse" -migrationVersion = undefinedQuote{quoteExp} + + quoteExp = withP TH.lift + quotePat = withP $ \p -> viewP [e|assertM' (== $(TH.lift p))|] [p|Just _|] +migrationVersion = undefinedQuote{quoteExp, quotePat} where - quoteExp "initial" = TH.lift InitialVersion - quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of - [x] -> TH.lift $ MigrationVersion x + withP f "initial" = f InitialVersion + withP f v = case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> f $ MigrationVersion x [] -> error "No parse" _ -> error "Ambiguous parse" + + quoteExp = withP TH.lift + quotePat = withP $ \p -> viewP [e|assertM' (== $(TH.lift p))|] [p|Just _|] undefinedQuote :: QuasiQuoter undefinedQuote = QuasiQuoter{..} where - quoteExp = error "version cannot be used as expression" - quotePat = error "version cannot be used as pattern" - quoteType = error "version cannot be used as type" - quoteDec = error "version cannot be used as declaration" + quoteExp = error "qq cannot be used as expression" + quotePat = error "qq cannot be used as pattern" + quoteType = error "qq cannot be used as type" + quoteDec = error "qq cannot be used as declaration" diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 1d466b689..c47419799 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -156,7 +156,7 @@ splitCamel = map fromList . reverse . helper (error "hasChange undefined at star helper _hadChange items [] (c:cs) = helper True items [c] cs helper hadChange items ws@(w:ws') (c:cs) | sameCategory w c - , null ws' = helper (Char.isLower w) items (c:ws) cs + , null ws' = helper (Char.isLower w || Char.isDigit w) items (c:ws) cs | sameCategory w c = helper hadChange items (c:ws) cs | Char.isLower w , Char.isUpper c = helper True (reverse ws :items) [c] cs