module Model.Migration
  ( migrateAll
  ) where

import ClassyPrelude.Yesod

import Utils (lastMaybe)

import Model
import Model.Migration.Version
import qualified Model.Migration.Types as Legacy
import Data.Map (Map)
import qualified Data.Map as Map

import Data.Set ()
import qualified Data.Set as Set

import Database.Persist.Sql
import Database.Persist.Postgresql

import Text.Read (readMaybe)
import Data.CaseInsensitive (CI)

import Text.Shakespeare.Text (st)

-- Database versions must follow https://pvp.haskell.org:
--   - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
--   - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)

-- Note that only one automatic migration is done (after all manual migrations).
-- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion)
-- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system

-- Database versions must be marked with git tags:
--   The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x
--   Tags should be annotated with a description of the changes affecting the database.
--
--   Example:
--     $ git tag -a db0.0.0 -m "Simplified format of UserTheme"
--
--   Doing so creates sort of parallel commit history tracking changes to the database schema

  
share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
  [persistLowerCase|
    AppliedMigration json
      from MigrationVersion
      to Version
      time UTCTime
      UniqueAppliedMigration from
      Primary from to
      deriving Show Eq Ord
  |]

migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
migrateAll = do
  $logDebugS "Migration" "Initial migration"
  mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do
    -- Manual migrations to go to InitialVersion below:
    migrateEnableExtension "citext"

    migrateDBVersioning

  $logDebugS "Migration" "Retrieve applied migrations"
  appliedMigrations <- selectKeysList [] []
  let
    missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
    doCustomMigration acc desc migration = acc <* do
      let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
      $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|]
      appliedMigrationTime <- liftIO getCurrentTime
      _ <- migration
      insert AppliedMigration{..} 
  -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
  $logDebugS "Migration" "Apply missing migrations"
  Map.foldlWithKey doCustomMigration (return ()) missingMigrations 
  
  $logDebugS "Migration" "Persistent automatic migration"
  mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'

{-
  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 :: MonadIO 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 $ Upload True)
                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
          [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
    )
  ]



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

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
  
