-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-}

module Model.Migration
  ( migrateAll
  , requiresMigration
  , ManualMigration(..), getMigrationTime
  ) where

import Import.NoModel hiding (Max(..), Last(..))
import Model
import Foundation.Type
import Model.Migration.Definitions                 -- SEE HERE: this module contains the actual migration code
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.Legacy 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.Migration Version, 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

-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause)
share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
  [persistLowerCase|
    AppliedMigration json
      migration Text
      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 manualMigration migration = acc <* do
      let appliedMigrationMigration = toPathPiece manualMigration
      $logInfoS "Migration" 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    
    return $ appliedMigration E.^. AppliedMigrationMigration
  let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations
  return $ Map.filterWithKey migNotDone customMigrations
    

getMigrationTime :: ( MonadIO m
                    , BaseBackend backend ~ SqlBackend
                    , PersistStoreRead backend
                    )
                 => ManualMigration
                 -> ReaderT backend m (Maybe UTCTime)
getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece