{-# 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 :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun
migrationsToRun [] [] = MigrationsToRun -> Either MTRError MigrationsToRun
forall a b. b -> Either a b
Right MigrationsToRun
MTRNone
migrationsToRun [Migration]
appMs [] = MigrationsToRun -> Either MTRError MigrationsToRun
forall a b. b -> Either a b
Right (MigrationsToRun -> Either MTRError MigrationsToRun)
-> MigrationsToRun -> Either MTRError MigrationsToRun
forall a b. (a -> b) -> a -> b
$ [Migration] -> MigrationsToRun
MTRUp [Migration]
appMs
migrationsToRun [] [Migration]
dbMs
  | [DownMigration] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DownMigration]
dms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Migration] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Migration]
dbMs = MigrationsToRun -> Either MTRError MigrationsToRun
forall a b. b -> Either a b
Right (MigrationsToRun -> Either MTRError MigrationsToRun)
-> MigrationsToRun -> Either MTRError MigrationsToRun
forall a b. (a -> b) -> a -> b
$ [DownMigration] -> MigrationsToRun
MTRDown [DownMigration]
dms
  | Bool
otherwise = MTRError -> Either MTRError MigrationsToRun
forall a b. a -> Either a b
Left (MTRError -> Either MTRError MigrationsToRun)
-> MTRError -> Either MTRError MigrationsToRun
forall a b. (a -> b) -> a -> b
$ [[Char]] -> MTRError
MTRENoDown ([[Char]] -> MTRError) -> [[Char]] -> MTRError
forall a b. (a -> b) -> a -> b
$ (Migration -> Maybe [Char]) -> [Migration] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Migration -> Maybe [Char]
nameNoDown [Migration]
dbMs
  where
    dms :: [DownMigration]
dms = (Migration -> Maybe DownMigration)
-> [Migration] -> [DownMigration]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Migration -> Maybe DownMigration
toDownMigration [Migration]
dbMs
    nameNoDown :: Migration -> Maybe [Char]
nameNoDown Migration
m = if Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Migration -> Maybe Text
down Migration
m) then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Migration -> [Char]
name Migration
m else Maybe [Char]
forall a. Maybe a
Nothing
migrationsToRun (Migration
a : [Migration]
as) (Migration
d : [Migration]
ds)
  | Migration -> [Char]
name Migration
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Migration -> [Char]
name Migration
d = [Migration] -> [Migration] -> Either MTRError MigrationsToRun
migrationsToRun [Migration]
as [Migration]
ds
  | Bool
otherwise = MTRError -> Either MTRError MigrationsToRun
forall a b. a -> Either a b
Left (MTRError -> Either MTRError MigrationsToRun)
-> MTRError -> Either MTRError MigrationsToRun
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> MTRError
MTREDifferent (Migration -> [Char]
name Migration
a) (Migration -> [Char]
name Migration
d)

data DBMigrate = DBMigrate
  { DBMigrate -> IO ()
initialize :: IO (),
    DBMigrate -> IO [Migration]
getCurrent :: IO [Migration],
    DBMigrate -> MigrationsToRun -> IO ()
run :: MigrationsToRun -> IO (),
    DBMigrate -> Maybe (IO ())
backup :: Maybe (IO ())
  }

sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
sharedMigrateSchema :: DBMigrate
-> Bool
-> [Migration]
-> MigrationConfirmation
-> IO (Either MigrationError ())
sharedMigrateSchema DBMigrate
dbm Bool
dbNew' [Migration]
migrations MigrationConfirmation
confirmMigrations = do
  DBMigrate -> IO ()
initialize DBMigrate
dbm
  [Migration]
currentMs <- DBMigrate -> IO [Migration]
getCurrent DBMigrate
dbm
  case [Migration] -> [Migration] -> Either MTRError MigrationsToRun
migrationsToRun [Migration]
migrations [Migration]
currentMs of
    Left MTRError
e -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationConfirmation
confirmMigrations MigrationConfirmation -> MigrationConfirmation -> Bool
forall a. Eq a => a -> a -> Bool
== MigrationConfirmation
MCConsole) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
confirmOrExit ([Char]
"Database state error: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MTRError -> [Char]
mtrErrorDescription MTRError
e)
      Either MigrationError () -> IO (Either MigrationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError () -> IO (Either MigrationError ()))
-> (MigrationError -> Either MigrationError ())
-> MigrationError
-> IO (Either MigrationError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationError -> Either MigrationError ()
forall a b. a -> Either a b
Left (MigrationError -> IO (Either MigrationError ()))
-> MigrationError -> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ MTRError -> MigrationError
MigrationError MTRError
e
    Right MigrationsToRun
MTRNone -> Either MigrationError () -> IO (Either MigrationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError () -> IO (Either MigrationError ()))
-> Either MigrationError () -> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ () -> Either MigrationError ()
forall a b. b -> Either a b
Right ()
    Right ms :: MigrationsToRun
ms@(MTRUp [Migration]
ums)
      | Bool
dbNew' -> DBMigrate -> MigrationsToRun -> IO ()
run DBMigrate
dbm MigrationsToRun
ms IO () -> Either MigrationError () -> IO (Either MigrationError ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () -> Either MigrationError ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> case MigrationConfirmation
confirmMigrations of
          MigrationConfirmation
MCYesUp -> MigrationsToRun -> IO (Either MigrationError ())
forall {a}. MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms
          MigrationConfirmation
MCYesUpDown -> MigrationsToRun -> IO (Either MigrationError ())
forall {a}. MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms
          MigrationConfirmation
MCConsole -> MigrationError -> IO ()
confirm' MigrationError
err IO ()
-> IO (Either MigrationError ()) -> IO (Either MigrationError ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MigrationsToRun -> IO (Either MigrationError ())
forall {a}. MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms
          MigrationConfirmation
MCError -> Either MigrationError () -> IO (Either MigrationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError () -> IO (Either MigrationError ()))
-> Either MigrationError () -> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ MigrationError -> Either MigrationError ()
forall a b. a -> Either a b
Left MigrationError
err
      where
        err :: MigrationError
err = [UpMigration] -> MigrationError
MEUpgrade ([UpMigration] -> MigrationError)
-> [UpMigration] -> MigrationError
forall a b. (a -> b) -> a -> b
$ (Migration -> UpMigration) -> [Migration] -> [UpMigration]
forall a b. (a -> b) -> [a] -> [b]
map Migration -> UpMigration
upMigration [Migration]
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 :: MigrationsToRun
ms@(MTRDown [DownMigration]
dms) -> case MigrationConfirmation
confirmMigrations of
      MigrationConfirmation
MCYesUpDown -> MigrationsToRun -> IO (Either MigrationError ())
forall {a}. MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms
      MigrationConfirmation
MCConsole -> MigrationError -> IO ()
confirm' MigrationError
err IO ()
-> IO (Either MigrationError ()) -> IO (Either MigrationError ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MigrationsToRun -> IO (Either MigrationError ())
forall {a}. MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms
      MigrationConfirmation
MCYesUp -> Either MigrationError () -> IO (Either MigrationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError () -> IO (Either MigrationError ()))
-> Either MigrationError () -> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ MigrationError -> Either MigrationError ()
forall a b. a -> Either a b
Left MigrationError
err
      MigrationConfirmation
MCError -> Either MigrationError () -> IO (Either MigrationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError () -> IO (Either MigrationError ()))
-> Either MigrationError () -> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ MigrationError -> Either MigrationError ()
forall a b. a -> Either a b
Left MigrationError
err
      where
        err :: MigrationError
err = [[Char]] -> MigrationError
MEDowngrade ([[Char]] -> MigrationError) -> [[Char]] -> MigrationError
forall a b. (a -> b) -> a -> b
$ (DownMigration -> [Char]) -> [DownMigration] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DownMigration -> [Char]
downName [DownMigration]
dms
  where
    runWithBackup :: MigrationsToRun -> IO (Either a ())
runWithBackup MigrationsToRun
ms = Maybe (IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Maybe (m a) -> m (Maybe a)
sequence (DBMigrate -> Maybe (IO ())
backup DBMigrate
dbm) IO (Maybe ()) -> IO (Either a ()) -> IO (Either a ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DBMigrate -> MigrationsToRun -> IO ()
run DBMigrate
dbm MigrationsToRun
ms IO () -> Either a () -> IO (Either a ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () -> Either a ()
forall a b. b -> Either a b
Right ()
    confirm' :: MigrationError -> IO ()
confirm' MigrationError
err = [Char] -> IO ()
confirmOrExit ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> MigrationError -> [Char]
migrationErrorDescription (Maybe (IO ()) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (IO ()) -> Bool) -> Maybe (IO ()) -> Bool
forall a b. (a -> b) -> a -> b
$ DBMigrate -> Maybe (IO ())
backup DBMigrate
dbm) MigrationError
err

confirmOrExit :: String -> IO ()
confirmOrExit :: [Char] -> IO ()
confirmOrExit [Char]
s = do
  [Char] -> IO ()
putStrLn [Char]
s
  [Char] -> IO ()
putStr [Char]
"Continue (y/N): "
  Handle -> IO ()
hFlush Handle
stdout
  [Char]
ok <- IO [Char]
getLine
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
ok [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"y") IO ()
forall a. IO a
exitFailure