From d4f0d69428a4f7fc887cb6854cb59e3dea83b9bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 12 Dec 2023 12:33:21 +0100 Subject: [PATCH 001/140] fix(migration): fix #133 by removing old outdated migrations irrelevant to FRADrive --- src/Jobs/Crontab.hs | 42 +- src/Model/Migration.hs | 59 +-- src/Model/Migration/Definitions.hs | 749 +---------------------------- 3 files changed, 41 insertions(+), 809 deletions(-) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 093c5cbde..72ae6a7c4 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -445,28 +445,26 @@ determineCrontab = execWriterT $ do ) .| C.fold collateSubmissionsByCorrector Map.empty - submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification - whenIsJust submissionRatedNotificationsSince $ \notifySince - -> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.where_ $ sqlSubmissionRatingDone submission - E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince - return (submission, sheet E.^. SheetType) - submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do - examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do - ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId - Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam - return examFinished - notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime - tell $ HashMap.singleton - (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) - Cron - { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime - , cronRepeat = CronRepeatNever - , cronRateLimit = appNotificationRateLimit - , cronNotAfter = Left appNotificationExpiration - } - in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs + let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.where_ $ sqlSubmissionRatingDone submission + E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal (toMidnight $ fromGregorian 2024 1 1) -- no submissions used in FRADrive as of this date, previously cut off by an old legacy migration + return (submission, sheet E.^. SheetType) + submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do + examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do + ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId + Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam + return examFinished + notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime + tell $ HashMap.singleton + (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } + runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs let examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index c04bf03ee..34626fd7d 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -31,53 +31,14 @@ import Control.Monad.Except (MonadError(..)) import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) -import qualified Control.Monad.State.Class as State +-- import qualified Control.Monad.State.Class as State -_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|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|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|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|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 +-- _manualMigration :: Fold (Legacy.MigrationVersion, Legacy.Version) ManualMigration +-- _manualMigration = folding $ \case +-- ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme +-- ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes +-- _other -> Nothing share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] @@ -99,7 +60,7 @@ migrateAll' = sequence_ migrateAll :: ( MonadLogger m , MonadResource m , MonadUnliftIO m - , MonadReader UniWorX m + -- , MonadReader UniWorX m ) => ReaderT SqlBackend m () migrateAll = do @@ -154,9 +115,9 @@ 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 + 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) + -- State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV) migrateAppliedMigration _ = return () insertMigrations ms = do [executeQQ| @@ -174,7 +135,7 @@ getMissingMigrations :: forall m m'. ( MonadLogger m , MonadIO m , MonadResource m' - , MonadReader UniWorX m' + -- , MonadReader UniWorX m' ) => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ())) getMissingMigrations = do diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index fd2e9c810..8e458ac47 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + module Model.Migration.Definitions ( ManualMigration(..) , migrateManual @@ -14,8 +16,8 @@ import Import.NoModel hiding (Max(..), Last(..)) import Model import Model.Types.TH.PathPiece import Settings -import Foundation.Type -import Audit.Types +-- import Foundation.Type +-- import Audit.Types import qualified Model.Migration.Types as Legacy import qualified Data.Map as Map @@ -28,16 +30,14 @@ import qualified Data.Conduit.List as C import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ -import Text.Read (readMaybe) +-- import Text.Read (readMaybe) -import Network.IP.Addr +-- import Network.IP.Addr -import qualified Data.Char as Char -import qualified Data.CaseInsensitive as CI +-- 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 qualified Data.Aeson as Aeson import Data.Time.Format.ISO8601 (iso8601Show) import Data.Time.Format @@ -47,52 +47,7 @@ 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 - | Migration20190828UserFunction - | Migration20190912UserDisplayEmail - | Migration20190916ExamPartNumber - | Migration20190918ExamRulesRefactor - | Migration20190919ExamBonusRounding - | Migration20191002FavouriteReason - | Migration20191125UserLanguages - | Migration20191126ExamPartCorrector - | Migration20191128StudyFeaturesSuperField - | Migration20200111ExamOccurrenceRuleRefactor - | Migration20200218ExamResultPassedGrade - | Migration20200218ExamGradingModeMixed - | Migration20200218ExternalExamGradingModeMixed - | Migration20200424SubmissionGroups - | Migration20200504CourseParticipantState - | Migration20200506SessionFile - | Migration20200627FileRefactor - | Migration20200825StudyFeaturesFirstObserved - | Migration20200902FileChunking - | Migration20200916ExamMode - | Migration20201106StoredMarkup - | Migration20201119RoomTypes - | Migration20210115ExamPartsFrom - | Migration20210208StudyFeaturesRelevanceCachedUUIDs - | Migration20210318CrontabSubmissionRatedNotification - | Migration20210608SeparateTermActive - | Migration20230524QualificationUserBlock + = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -179,692 +134,10 @@ migrateAlwaysSafe = do customMigrations :: forall m. ( MonadResource m - , MonadReader UniWorX 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 - - 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; - |] - - 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; - |] - - 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 - whenM (existsKey transactionCourse `and2M` existsKey transactionUser) - [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}) 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_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 "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"; - |] - - 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 ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) 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 - - Migration20210115ExamPartsFrom -> do - whenM (tableExists "exam") $ do - [executeQQ|ALTER TABLE "exam" ADD COLUMN "parts_from" timestamp with time zone|] - let getExam = [queryQQ|SELECT "id", "finished" FROM "exam"|] - migrateExam [ fromPersistValue -> Right (eId :: ExamId), fromPersistValue -> Right (finished :: Maybe UTCTime) ] = [executeQQ|UPDATE "exam" SET "parts_from" = #{finished} WHERE "id" = #{eId}|] - migrateExam _ = return () - in runConduit $ getExam .| C.mapM_ migrateExam - - Migration20210208StudyFeaturesRelevanceCachedUUIDs -> - whenM (tableExists "study_features") $ do - [executeQQ| - ALTER TABLE "study_features" ADD COLUMN "relevance_cached_uuid" uuid - |] - - let getStudyFeatures = [queryQQ|SELECT "id" FROM "study_features" WHERE relevance_cached|] - migrateStudyFeatures genUUID lift' [ fromPersistValue -> Right (sfId :: StudyFeaturesId) ] = do - uuid <- genUUID - lift' [executeQQ|UPDATE "study_features" SET "relevance_cached_uuid" = #{uuid} WHERE "id" = #{sfId}|] - migrateStudyFeatures _ _ _ = return () - in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift') - - [executeQQ| - ALTER TABLE "study_features" DROP COLUMN "relevance_cached"; - ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached"; - |] - - -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected - Migration20210318CrontabSubmissionRatedNotification -> return () - - Migration20210608SeparateTermActive -> do - now <- liftIO getCurrentTime - - whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do - [executeQQ| - CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL) - |] - - let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|] - migrateTerms [ fromPersistValue -> Right (tid :: TermId), fromPersistValue -> Right (isActive :: Bool) ] = when isActive - [executeQQ|INSERT INTO term_active (term, "from") VALUES (#{tid}, #{now})|] - migrateTerms _ = return () - in runConduit $ getTerms .| C.mapM_ migrateTerms - - [executeQQ| - ALTER TABLE "term" DROP COLUMN "active"; - |] Migration20230524QualificationUserBlock -> whenM (andM [ not <$> tableExists "qualification_user_block" -- 2.39.2 From db77850c4f4cd1d68bfd38e02e0ae24584e1e556 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 12 Dec 2023 18:23:52 +0100 Subject: [PATCH 002/140] fix(firm): supervisor filter performance --- src/Handler/Firm.hs | 63 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 56 insertions(+), 7 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 53914269e..b50539d87 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -517,7 +517,48 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + -- THIS WAS WAY TOO SLOW: + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + -- (usr :& usrCmp) <- E.from $ E.table @User + -- `E.leftJoin` E.table @UserCompany + -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + -- E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- E.&&. E.exists (do + -- usrSub <- E.from $ E.table @UserCompany + -- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) + -- ) + -- ) + -- ) , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + usr <- E.from $ E.table @User + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. (E.exists (do + usrCmp <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + E.&&. usrCmp E.^. UserCompanySupervisor + E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + ) + ) + ) + , single ("is-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) @@ -526,16 +567,22 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) E.||. E.exists (do - usrSpr <- E.from $ E.table @UserSupervisor + (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser) E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. E.exists (do - usrSub <- E.from $ E.table @UserCompany - E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - ) + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId ) ) ) + , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.innerJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. usrCmp E.^. UserCompanySupervisor + E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor @@ -570,8 +617,10 @@ mkFirmAllTable isAdmin uid = do dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) - , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-supervisor2") mPrev $ aopt textField (fslI MsgTableSupervisor) -- TODO: remove either one variant which works worse + , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] -- 2.39.2 From ce45d26a21a2a6cce505c43892af6cd90f21fb5a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 13 Dec 2023 16:20:17 +0100 Subject: [PATCH 003/140] chore(error): revert 54a956dc3663b6d3fe0540d75983a1845074f21f ff since it did not help towards #40 --- src/Foundation/Yesod/ErrorHandler.hs | 76 ++++++++++++++-------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 769f65faf..6d11826dc 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler import Import.NoFoundation hiding (errorHandler) import Foundation.Type --- import Foundation.I18n +import Foundation.I18n import Foundation.Authorization --- import Foundation.SiteLayout +import Foundation.SiteLayout import Foundation.Routes import Foundation.DB @@ -20,15 +20,15 @@ import qualified Data.Text as Text import qualified Network.Wai as W --- import System.Exit -- DEBUG: just for testing --- import System.Posix.Process -- DEBUG: just for testing +import System.Exit -- DEBUG: just for testing +import System.Posix.Process -- DEBUG: just for testing errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) - -- , MonadSecretBox (WidgetFor UniWorX) + , MonadSecretBox (WidgetFor UniWorX) , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX)) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX - -- , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do @@ -72,39 +72,39 @@ errorHandler err = do setSessionJson SessionError sessErr selectRep $ do - -- provideRep $ do - -- mr <- getMessageRender - -- let - -- encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX () - -- encrypted plaintextJson plaintext = do - -- let displayEncrypted ciphertext = - -- [whamlet| - -- $newline never - --

_{MsgErrorResponseEncrypted} - -- 

-    --                 #{ciphertext}
-    --             |]
-    --       if
-    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-    --         | otherwise -> plaintext
+    provideRep $ do
+      mr <- getMessageRender
+      let
+        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted plaintextJson plaintext = do
+          let displayEncrypted ciphertext = 
+                [whamlet|
+                  $newline never
+                  
_{MsgErrorResponseEncrypted}
+                  
+                    #{ciphertext}
+                |]
+          if
+            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+            | otherwise -> plaintext
 
-    --     errPage = case err of
-    --       NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|]
-    --       InternalError err'
-    --         | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-    --         | otherwise -> encrypted err' [whamlet|
#{fromMaybe err' decrypted}|]
-    --       InvalidArgs errs -> [whamlet|
-    --