{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-}

module Model.Migration
  ( migrateAll
  , requiresMigration
  ) where

import Import.NoModel hiding (Max(..), Last(..))
import Model
import Foundation.Type
import Model.Migration.Definitions
import qualified Model.Migration.Types as Legacy
import qualified Data.Map as Map

import qualified Data.Set as Set

import qualified Data.Conduit.List as C

import Database.Persist.Sql
import Database.Persist.Sql.Raw.QQ
import Database.Persist.Postgresql

import qualified Database.Esqueleto as E

import Control.Monad.Except (MonadError(..))

import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
  
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|16.0.0|],  [Legacy.version|17.0.0|]) -> Just Migration20190809AllocationIndependentApplication
  ([Legacy.migrationVersion|17.0.0|],  [Legacy.version|18.0.0|]) -> Just Migration20190813Allocations
  ([Legacy.migrationVersion|18.0.0|],  [Legacy.version|19.0.0|]) -> Just Migration20190828UserFunction
  ([Legacy.migrationVersion|19.0.0|],  [Legacy.version|20.0.0|]) -> Just Migration20190912UserDisplayEmail
  ([Legacy.migrationVersion|20.0.0|],  [Legacy.version|21.0.0|]) -> Just Migration20190916ExamPartNumber
  ([Legacy.migrationVersion|21.0.0|],  [Legacy.version|22.0.0|]) -> Just Migration20190918ExamRulesRefactor
  ([Legacy.migrationVersion|22.0.0|],  [Legacy.version|23.0.0|]) -> Just Migration20190919ExamBonusRounding
  ([Legacy.migrationVersion|23.0.0|],  [Legacy.version|24.0.0|]) -> Just Migration20191002FavouriteReason
  ([Legacy.migrationVersion|24.0.0|],  [Legacy.version|25.0.0|]) -> Just Migration20191003CourseParticipantAllocatedId
  ([Legacy.migrationVersion|25.0.0|],  [Legacy.version|26.0.0|]) -> Just Migration20191013AllocationMatching
  ([Legacy.migrationVersion|26.0.0|],  [Legacy.version|27.0.0|]) -> Just Migration20191125UserLanguages
  ([Legacy.migrationVersion|27.0.0|],  [Legacy.version|28.0.0|]) -> Just Migration20191126ExamPartCorrector
  ([Legacy.migrationVersion|28.0.0|],  [Legacy.version|29.0.0|]) -> Just Migration20191128StudyFeaturesSuperField
  ([Legacy.migrationVersion|29.0.0|],  [Legacy.version|30.0.0|]) -> Just Migration20200111ExamOccurrenceRuleRefactor
  ([Legacy.migrationVersion|30.0.0|],  [Legacy.version|31.0.0|]) -> Just Migration20200218ExamResultPassedGrade
  ([Legacy.migrationVersion|31.0.0|],  [Legacy.version|32.0.0|]) -> Just Migration20200218ExamGradingModeMixed
  ([Legacy.migrationVersion|32.0.0|],  [Legacy.version|33.0.0|]) -> Just Migration20200218ExternalExamGradingModeMixed
  ([Legacy.migrationVersion|33.0.0|],  [Legacy.version|34.0.0|]) -> Just Migration20200311AllocationMatching
  ([Legacy.migrationVersion|34.0.0|],  [Legacy.version|35.0.0|]) -> Just Migration20200424SubmissionGroups
  ([Legacy.migrationVersion|35.0.0|],  [Legacy.version|36.0.0|]) -> Just Migration20200504CourseParticipantState
  ([Legacy.migrationVersion|36.0.0|],  [Legacy.version|37.0.0|]) -> Just Migration20200506SessionFile
  ([Legacy.migrationVersion|37.0.0|],  [Legacy.version|38.0.0|]) -> Just Migration20200627FileRefactor
  ([Legacy.migrationVersion|38.0.0|],  [Legacy.version|39.0.0|]) -> Just Migration20200824AllocationNotifications
  ([Legacy.migrationVersion|39.0.0|],  [Legacy.version|40.0.0|]) -> Just Migration20200825StudyFeaturesFirstObserved
  ([Legacy.migrationVersion|40.0.0|],  [Legacy.version|41.0.0|]) -> Just Migration20200902FileChunking
  ([Legacy.migrationVersion|41.0.0|],  [Legacy.version|42.0.0|]) -> Just Migration20200916ExamMode
  ([Legacy.migrationVersion|43.0.0|],  [Legacy.version|44.0.0|]) -> Just Migration20201106StoredMarkup
  ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
  _other -> Nothing


share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
  [persistLowerCase|
    AppliedMigration json
      migration ManualMigration
      time UTCTime
      Primary migration
      deriving Show Eq Ord
  |]

migrateAll' :: Migration
migrateAll' = sequence_
  [ migrateUniWorX
  , migrateMemcachedSqlStorage
  , migrateManual
  ]

migrateAll :: ( MonadLogger m
              , MonadResource m
              , MonadUnliftIO m
              , MonadReader UniWorX m
              )
           => ReaderT SqlBackend m ()
migrateAll = do
  $logDebugS "Migration" "Initial migration"
  mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration

  missingMigrations <- getMissingMigrations
  let
    doCustomMigration acc appliedMigrationMigration migration = acc <* do
      $logInfoS "Migration" $ toPathPiece appliedMigrationMigration
      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'

  $logDebugS "Migration" "Migrations marked as ‘always safe’"
  mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAlwaysSafe

requiresMigration :: forall m.
                     ( MonadLogger m
                     , MonadResource m
                     )
                  => ReaderT SqlBackend m Bool
requiresMigration = mapReaderT (exceptT return return) $ do
  initial <- either id (map snd) <$> parseMigration initialMigration
  unless (null initial) $ do
    $logInfoS "Migration" $ intercalate "; " initial
    throwError True

  customs <- mapReaderT lift $ getMissingMigrations @_ @(ReaderT UniWorX m)
  unless (Map.null customs) $ do
    $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
    throwError True

  automatic <- either id (map snd) <$> parseMigration migrateAll'
  unless (null automatic) $ do
    $logInfoS "Migration" $ intercalate "; " automatic
    throwError True

  -- Does not consider `migrateAlwaysSafe`

  return False

initialMigration :: Migration
-- ^ Manual migrations to go to InitialVersion below:
initialMigration = do
  mapM_ migrateEnableExtension ["citext", "pgcrypto"]
  lift . lift . hoist runResourceT . whenM (columnExists "applied_migration" "from") $ do
    let getAppliedMigrations = [queryQQ|SELECT "from", "to", "time" FROM "applied_migration"|]
        migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (time :: UTCTime) ] = do
          lift [executeQQ|DELETE FROM "applied_migration" WHERE "from" = #{fromV} AND "to" = #{toV}|]
          State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
        migrateAppliedMigration _ = return ()
        insertMigrations ms = do
          [executeQQ|
            ALTER TABLE "applied_migration" DROP CONSTRAINT "applied_migration_pkey";
            ALTER TABLE "applied_migration" DROP CONSTRAINT "unique_applied_migration";
            ALTER TABLE "applied_migration" DROP COLUMN "from";
            ALTER TABLE "applied_migration" DROP COLUMN "to";
            ALTER TABLE "applied_migration" ADD COLUMN "migration" text NOT NULL CONSTRAINT "applied_migration_pkey" PRIMARY KEY;
          |]
          iforM_ ms $ \appliedMigrationMigration appliedMigrationTime -> insert AppliedMigration{..}
     in runConduit $ getAppliedMigrations .| execStateC Map.empty (C.mapM_ migrateAppliedMigration) >>= lift . insertMigrations
  migrateDBVersioning

getMissingMigrations :: forall m m'.
                        ( MonadLogger m
                        , MonadIO m
                        , MonadResource m'
                        , MonadReader UniWorX m'
                        )
                     => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ()))
getMissingMigrations = do
  $logDebugS "Migration" "Retrieve applied migrations"
  appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do
    E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF
    return $ appliedMigration E.^. AppliedMigrationMigration
  return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
