-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 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 Audit.Types import qualified Model.Migration.Types as Legacy import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ -- import Text.Read (readMaybe) -- import Network.IP.Addr -- import qualified Data.Char as Char -- import qualified Data.CaseInsensitive as CI -- import qualified Data.Aeson as Aeson import Data.Time.Format.ISO8601 (iso8601Show) import Data.Time.Format import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values | Migration20240224UniquenessCompanyAvsNr deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) 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) -- NOTE: Indices are automatically created for primary keys and unique columns; manually create them frequent filter conditions that small results for speed up [ ("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)" ) , ("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") , ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)") , ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" ) , ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" ) , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) , ("idx_qualification_user_first_held" ,"CREATE INDEX idx_qualification_user_first_held ON \"qualification_user\" (\"first_held\")") , ("idx_qualification_user_valid_until" ,"CREATE INDEX idx_qualification_user_valid_until ON \"qualification_user\" (\"valid_until\")") , ("idx_qualification_user_block_quser" ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")") , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] 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 Migration20230524QualificationUserBlock -> whenM (andM [ not <$> tableExists "qualification_user_block" , tableExists "qualification_user" , columnExists "qualification_user" "blocked_due" ] ) $ do [executeQQ| CREATE TABLE "qualification_user_block" ( "id" SERIAL8 PRIMARY KEY UNIQUE , "qualification_user" bigint NOT NULL , "unblock" boolean NOT NULL , "from" timestamp with time zone NOT NULL , "reason" character varying NOT NULL , "blocker" bigint , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) ); |] let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] = [executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "unblock", "from", "reason") VALUES (#{quid}, FALSE, #{qualificationBlockedDay}, #{qualificationBlockedReason})|] migrateBlocks _ = return () in runConduit $ getBlocks .| C.mapM_ migrateBlocks [executeQQ| ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; |] Migration20230703LmsUserStatus -> whenM (columnNotExists "lms_user" "status_day") $ do [executeQQ| ALTER TABLE "lms_user" ADD COLUMN "status_day" date; UPDATE "lms_user" SET "status_day" = CAST("status"->>'day' AS date) , "status" = "status"->'lms-status' ; |] Migration20240212InitInterfaceHealth -> unlessM (tableExists "interface_health") $ do -- fill health table with some defaults [executeQQ| CREATE TABLE "interface_health" ( id BIGSERIAL NOT NULL , interface CHARACTER VARYING NOT NULL , subtype CHARACTER VARYING , write BOOLEAN , hours BIGINT NOT NULL , PRIMARY KEY(id) , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) ); INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") VALUES ('Printer', 'Acknowledge', True, 168) , ('AVS' , 'Synch' , True , 96) ON CONFLICT DO NOTHING; |] Migration20240224UniquenessCompanyAvsNr -> whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade [executeQQ| DELETE FROM "company" WHERE avs_id = 0; ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand"; |] 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 -- BEWARE: use tablesExist beforehand!!! 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 -- | equivalent to andM [ tableExists, not <$> columnExists] columnNotExists :: MonadIO m => Text -- ^ Table -> Text -- ^ Column -> ReaderT SqlBackend m Bool columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column) indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool indexExists ixName = do res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] return $ case res of [Single e] -> e _other -> True