content: {-# LANGUAGE LambdaCase #-}
  
  module Simplex.Messaging.Agent.Store.Migrations
    ( Migration (..),
      MigrationsToRun (..),
      DownMigration (..),
      DBMigrate (..),
      sharedMigrateSchema,
      -- for tests
      migrationsToRun,
      toDownMigration,
    )
  where
  
  import Control.Monad
  import Data.Char (toLower)
  import Data.Functor (($>))
  import Data.Maybe (isJust, isNothing, mapMaybe)
  import Simplex.Messaging.Agent.Store.Shared
  import System.Exit (exitFailure)
  import System.IO (hFlush, stdout)
  
  migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun
  migrationsToRun [] [] = Right MTRNone
  migrationsToRun appMs [] = Right $ MTRUp appMs
  migrationsToRun [] dbMs
    | length dms == length dbMs = Right $ MTRDown dms
    | otherwise = Left $ MTRENoDown $ mapMaybe nameNoDown dbMs
    where
      dms = mapMaybe toDownMigration dbMs
      nameNoDown m = if isNothing (down m) then Just $ name m else Nothing
  migrationsToRun (a : as) (d : ds)
    | name a == name d = migrationsToRun as ds
    | otherwise = Left $ MTREDifferent (name a) (name d)
  
  data DBMigrate = DBMigrate
    { initialize :: IO (),
      getCurrent :: IO [Migration],
      run :: MigrationsToRun -> IO (),
      backup :: Maybe (IO ())
    }
  
  sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
  sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
    initialize dbm
    currentMs <- getCurrent dbm
    case migrationsToRun migrations currentMs of
      Left e -> do
        when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
        pure . Left $ MigrationError e
      Right MTRNone -> pure $ Right ()
      Right ms@(MTRUp ums)
        | dbNew' -> run dbm ms $> Right ()
        | otherwise -> case confirmMigrations of
            MCYesUp -> runWithBackup ms
            MCYesUpDown -> runWithBackup ms
            MCConsole -> confirm' err >> runWithBackup ms
            MCError -> pure $ Left err
        where
          err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
      Right ms@(MTRDown dms) -> case confirmMigrations of
        MCYesUpDown -> runWithBackup ms
        MCConsole -> confirm' err >> runWithBackup ms
        MCYesUp -> pure $ Left err
        MCError -> pure $ Left err
        where
          err = MEDowngrade $ map downName dms
    where
      runWithBackup ms = sequence (backup dbm) >> run dbm ms $> Right ()
      confirm' err = confirmOrExit $ migrationErrorDescription (isJust $ backup dbm) err
  
  confirmOrExit :: String -> IO ()
  confirmOrExit s = do
    putStrLn s
    putStr "Continue (y/N): "
    hFlush stdout
    ok <- getLine
    when (map toLower ok /= "y") exitFailure
  