mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-25 11:14:33 +00:00
94 lines
3.0 KiB
Haskell
94 lines
3.0 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Simplex.Messaging.Agent.Store.Shared
|
|
( Migration (..),
|
|
MigrationsToRun (..),
|
|
DownMigration (..),
|
|
MTRError (..),
|
|
mtrErrorDescription,
|
|
MigrationConfirmation (..),
|
|
MigrationError (..),
|
|
UpMigration (..),
|
|
migrationErrorDescription,
|
|
-- for tests
|
|
toDownMigration,
|
|
upMigration,
|
|
)
|
|
where
|
|
|
|
import qualified Data.Aeson.TH as J
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
import Data.List (intercalate)
|
|
import Data.Maybe (isJust)
|
|
import Data.Text (Text)
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
|
|
|
|
data Migration = Migration {name :: String, up :: Text, down :: Maybe Text}
|
|
deriving (Eq, Show)
|
|
|
|
data DownMigration = DownMigration {downName :: String, downQuery :: Text}
|
|
deriving (Eq, Show)
|
|
|
|
toDownMigration :: Migration -> Maybe DownMigration
|
|
toDownMigration Migration {name, down} = DownMigration name <$> down
|
|
|
|
data MigrationsToRun = MTRUp [Migration] | MTRDown [DownMigration] | MTRNone
|
|
deriving (Eq, Show)
|
|
|
|
data MTRError
|
|
= MTRENoDown {dbMigrations :: [String]}
|
|
| MTREDifferent {appMigration :: String, dbMigration :: String}
|
|
deriving (Eq, Show)
|
|
|
|
mtrErrorDescription :: MTRError -> String
|
|
mtrErrorDescription = \case
|
|
MTRENoDown ms -> "database version is newer than the app, but no down migration for: " <> intercalate ", " ms
|
|
MTREDifferent a d -> "different migration in the app/database: " <> a <> " / " <> d
|
|
|
|
data MigrationError
|
|
= MEUpgrade {upMigrations :: [UpMigration]}
|
|
| MEDowngrade {downMigrations :: [String]}
|
|
| MigrationError {mtrError :: MTRError}
|
|
deriving (Eq, Show)
|
|
|
|
migrationErrorDescription :: MigrationError -> String
|
|
migrationErrorDescription = \case
|
|
MEUpgrade ums ->
|
|
"The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
|
|
MEDowngrade dms ->
|
|
"Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms
|
|
MigrationError err -> mtrErrorDescription err
|
|
|
|
data UpMigration = UpMigration {upName :: String, withDown :: Bool}
|
|
deriving (Eq, Show)
|
|
|
|
upMigration :: Migration -> UpMigration
|
|
upMigration Migration {name, down} = UpMigration name $ isJust down
|
|
|
|
data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError
|
|
deriving (Eq, Show)
|
|
|
|
instance StrEncoding MigrationConfirmation where
|
|
strEncode = \case
|
|
MCYesUp -> "yesUp"
|
|
MCYesUpDown -> "yesUpDown"
|
|
MCConsole -> "console"
|
|
MCError -> "error"
|
|
strP =
|
|
A.takeByteString >>= \case
|
|
"yesUp" -> pure MCYesUp
|
|
"yesUpDown" -> pure MCYesUpDown
|
|
"console" -> pure MCConsole
|
|
"error" -> pure MCError
|
|
_ -> fail "invalid MigrationConfirmation"
|
|
|
|
$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError)
|
|
|
|
$(J.deriveJSON defaultJSON ''UpMigration)
|
|
|
|
$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError)
|