fradrive-old/src/Model/Migration/Definitions.hs

-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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