module Sqel.Migration.Consistency where

import qualified Control.Exception as Base
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT, throwE, withExceptT)
import qualified Data.Aeson as Aeson
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LByteString
import Data.List.Extra (zipWithLongest)
import qualified Data.Map.Strict as Map
import Exon (exon)
import Generics.SOP (NP (Nil, (:*)))
import Lens.Micro ((.~), (^.))
import Path (Abs, Dir, File, Path, parseRelFile, toFilePath, (</>))
import Path.IO (createDirIfMissing, doesFileExist)
import qualified Sqel.Data.Migration as Migration
import Sqel.Data.Migration (Migration (Migration), Migrations (Migrations))
import qualified Sqel.Data.PgType as PgType
import Sqel.Data.PgType (
  ColumnType (ColumnComp, ColumnPrim),
  PgColumn (PgColumn),
  PgColumns (PgColumns),
  PgComposite (PgComposite),
  PgPrimName (PgPrimName),
  PgTable (PgTable),
  PgTypeRef (PgTypeRef),
  )
import Sqel.Data.PgTypeName (PgTableName, pattern PgTypeName)
import Sqel.Data.Sql (Sql)
import qualified Sqel.Sql.Type as Sql
import Sqel.Text.Quote (squote)
import System.IO.Error (IOError)

import Sqel.Migration.Statement (migrationStatementSql, migrationStatements)

tryIO :: MonadIO m => IO a -> m (Either Text a)
tryIO :: forall (m :: * -> *) a. MonadIO m => IO a -> m (Either Text a)
tryIO =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall b a. (Show a, IsString b) => a -> b
show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
Base.try @IOError

data MigrationMetadata =
  MigrationMetadata {
    MigrationMetadata -> PgTableName
name :: PgTableName,
    MigrationMetadata -> PgColumns
table :: PgColumns,
    MigrationMetadata -> [PgComposite]
types :: [PgComposite],
    MigrationMetadata -> [Sql]
statementsTable :: [Sql],
    MigrationMetadata -> [Sql]
statementsMigration :: [Sql]
  }
  deriving stock (MigrationMetadata -> MigrationMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationMetadata -> MigrationMetadata -> Bool
$c/= :: MigrationMetadata -> MigrationMetadata -> Bool
== :: MigrationMetadata -> MigrationMetadata -> Bool
$c== :: MigrationMetadata -> MigrationMetadata -> Bool
Eq, Int -> MigrationMetadata -> ShowS
[MigrationMetadata] -> ShowS
MigrationMetadata -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationMetadata] -> ShowS
$cshowList :: [MigrationMetadata] -> ShowS
show :: MigrationMetadata -> String
$cshow :: MigrationMetadata -> String
showsPrec :: Int -> MigrationMetadata -> ShowS
$cshowsPrec :: Int -> MigrationMetadata -> ShowS
Show, forall x. Rep MigrationMetadata x -> MigrationMetadata
forall x. MigrationMetadata -> Rep MigrationMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MigrationMetadata x -> MigrationMetadata
$cfrom :: forall x. MigrationMetadata -> Rep MigrationMetadata x
Generic)
  deriving anyclass ([MigrationMetadata] -> Encoding
[MigrationMetadata] -> Value
MigrationMetadata -> Encoding
MigrationMetadata -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MigrationMetadata] -> Encoding
$ctoEncodingList :: [MigrationMetadata] -> Encoding
toJSONList :: [MigrationMetadata] -> Value
$ctoJSONList :: [MigrationMetadata] -> Value
toEncoding :: MigrationMetadata -> Encoding
$ctoEncoding :: MigrationMetadata -> Encoding
toJSON :: MigrationMetadata -> Value
$ctoJSON :: MigrationMetadata -> Value
ToJSON, Value -> Parser [MigrationMetadata]
Value -> Parser MigrationMetadata
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MigrationMetadata]
$cparseJSONList :: Value -> Parser [MigrationMetadata]
parseJSON :: Value -> Parser MigrationMetadata
$cparseJSON :: Value -> Parser MigrationMetadata
FromJSON)

tableStatements :: PgTable a -> [Sql]
tableStatements :: forall {k} (a :: k). PgTable a -> [Sql]
tableStatements PgTable a
table =
  forall {k} (a :: k). PgTable a -> Sql
Sql.createTable PgTable a
table forall a. a -> [a] -> [a]
: (PgComposite -> Sql
Sql.createProdType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgComposite]
types)
  where
    types :: [PgComposite]
types = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toAscList (PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "types" a => a
#types)

tableMetadata :: PgTable a -> MigrationMetadata
tableMetadata :: forall {k} (a :: k). PgTable a -> MigrationMetadata
tableMetadata PgTable a
table =
  MigrationMetadata {
    $sel:name:MigrationMetadata :: PgTableName
name = PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name,
    $sel:table:MigrationMetadata :: PgColumns
table = PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "columns" a => a
#columns,
    [PgComposite]
types :: [PgComposite]
$sel:types:MigrationMetadata :: [PgComposite]
types,
    $sel:statementsTable:MigrationMetadata :: [Sql]
statementsTable = forall {k} (a :: k). PgTable a -> [Sql]
tableStatements PgTable a
table,
    $sel:statementsMigration:MigrationMetadata :: [Sql]
statementsMigration = []
  }
  where
    types :: [PgComposite]
types = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toAscList (PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "types" a => a
#types)

migrationMetadata :: Migration mig -> MigrationMetadata
migrationMetadata :: forall (mig :: Mig). Migration mig -> MigrationMetadata
migrationMetadata Migration {PgTable from
$sel:tableFrom:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable from
tableFrom :: PgTable from
tableFrom, MigrationActions ext
$sel:actions:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> MigrationActions ext
actions :: MigrationActions ext
actions} =
  forall {k} (a :: k). PgTable a -> MigrationMetadata
tableMetadata PgTable from
tableFrom forall a b. a -> (a -> b) -> b
& forall a. IsLabel "statementsMigration" a => a
#statementsMigration forall s t a b. ASetter s t a b -> b -> s -> t
.~
  (MigrationStatement -> Sql
migrationStatementSql forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ext.
PgTableName -> MigrationActions ext -> [MigrationStatement]
migrationStatements (PgTable from
tableFrom forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name) MigrationActions ext
actions)

currentMetadata :: Migration mig -> MigrationMetadata
currentMetadata :: forall (mig :: Mig). Migration mig -> MigrationMetadata
currentMetadata Migration {PgTable to
$sel:tableTo:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable to
tableTo :: PgTable to
tableTo} =
  forall {k} (a :: k). PgTable a -> MigrationMetadata
tableMetadata PgTable to
tableTo

migrationMetadatas :: NP Migration migs -> [MigrationMetadata]
migrationMetadatas :: forall (migs :: [Mig]). NP Migration migs -> [MigrationMetadata]
migrationMetadatas = \case
  NP Migration migs
Nil -> []
  Migration x
m :* NP Migration xs
ms -> forall (mig :: Mig). Migration mig -> MigrationMetadata
migrationMetadata Migration x
m forall a. a -> [a] -> [a]
: forall (migs :: [Mig]). NP Migration migs -> [MigrationMetadata]
migrationMetadatas NP Migration xs
ms

headMigrationMetadata :: NP Migration migs -> Maybe MigrationMetadata
headMigrationMetadata :: forall (migs :: [Mig]).
NP Migration migs -> Maybe MigrationMetadata
headMigrationMetadata = \case
  NP Migration migs
Nil -> forall a. Maybe a
Nothing
  Migration x
mig :* NP Migration xs
_ -> forall a. a -> Maybe a
Just (forall (mig :: Mig). Migration mig -> MigrationMetadata
currentMetadata Migration x
mig)

migrationsMetadata :: Migrations m migs -> [MigrationMetadata]
migrationsMetadata :: forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> [MigrationMetadata]
migrationsMetadata (Migrations NP Migration migs
migs) =
  forall a. [a] -> [a]
reverse (forall a. Maybe a -> [a]
maybeToList (forall (migs :: [Mig]).
NP Migration migs -> Maybe MigrationMetadata
headMigrationMetadata NP Migration migs
migs) forall a. Semigroup a => a -> a -> a
<> forall (migs :: [Mig]). NP Migration migs -> [MigrationMetadata]
migrationMetadatas NP Migration migs
migs)

jsonFile :: PgTable a -> String
jsonFile :: forall {k} (a :: k). PgTable a -> String
jsonFile PgTable {$sel:name:PgTable :: forall {k} (a :: k). PgTable a -> PgTableName
name = PgTypeName Text
name} =
  [exon|##{name}.json|]

jsonPath ::
  Monad m =>
  Path Abs Dir ->
  PgTable a ->
  ExceptT Text m (Path Abs File)
jsonPath :: forall {k} (m :: * -> *) (a :: k).
Monad m =>
Path Abs Dir -> PgTable a -> ExceptT Text m (Path Abs File)
jsonPath Path Abs Dir
dir PgTable a
table = do
  Path Rel File
name <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> Text
pathError (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (forall {k} (a :: k). PgTable a -> String
jsonFile PgTable a
table))))
  pure (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
name)
  where
    pathError :: SomeException -> Text
pathError SomeException
_ = [exon|Table name couldn't be converted to a path: #{toText tname}|]
    tname :: String
tname = forall {k} (a :: k). PgTable a -> String
jsonFile PgTable a
table

writeMigrationMetadata ::
  MonadIO m =>
  Path Abs Dir ->
  Migrations m migs ->
  ExceptT Text m ()
writeMigrationMetadata :: forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir -> Migrations m migs -> ExceptT Text m ()
writeMigrationMetadata Path Abs Dir
dir migs :: Migrations m migs
migs@(Migrations (Migration {PgTable from
tableFrom :: PgTable from
$sel:tableFrom:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable from
tableFrom} :* NP Migration xs
_)) = do
  Path Abs File
path <- forall {k} (m :: * -> *) (a :: k).
Monad m =>
Path Abs Dir -> PgTable a -> ExceptT Text m (Path Abs File)
jsonPath Path Abs Dir
dir PgTable from
tableFrom
  let
    write :: IO ()
write = String -> ByteString -> IO ()
LByteString.writeFile (forall b t. Path b t -> String
toFilePath Path Abs File
path) (forall a. ToJSON a => a -> ByteString
Aeson.encode (forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> [MigrationMetadata]
migrationsMetadata Migrations m migs
migs))
    writeError :: Text -> Text
writeError Text
e = [exon|Couldn't write migration metadata to '#{show path}': #{e}|]
  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
writeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m (Either Text a)
tryIO (forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True Path Abs Dir
dir))
  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
writeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m (Either Text a)
tryIO IO ()
write)
writeMigrationMetadata Path Abs Dir
_ (Migrations NP Migration migs
Nil) =
  forall (f :: * -> *). Applicative f => f ()
unit

readError :: Path Abs File -> Text -> Text
readError :: Path Abs File -> Text -> Text
readError Path Abs File
path Text
e =
  [exon|Couldn't read migration metadata from #{show path}: #{e}|]

decodeError :: Path Abs File -> String -> Text
decodeError :: Path Abs File -> String -> Text
decodeError Path Abs File
path String
e =
  [exon|Migration metadata in '#{show path}' has invalid json format: ##{e}|]

readMigrationMetadata ::
  MonadIO m =>
  Path Abs Dir ->
  Migrations m migs ->
  ExceptT Text m (Maybe [MigrationMetadata])
readMigrationMetadata :: forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir
-> Migrations m migs -> ExceptT Text m (Maybe [MigrationMetadata])
readMigrationMetadata Path Abs Dir
dir (Migrations (Migration {PgTable from
tableFrom :: PgTable from
$sel:tableFrom:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable from
tableFrom} :* NP Migration xs
_)) = do
  Path Abs File
path <- forall {k} (m :: * -> *) (a :: k).
Monad m =>
Path Abs Dir -> PgTable a -> ExceptT Text m (Path Abs File)
jsonPath Path Abs Dir
dir PgTable from
tableFrom
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall b a. b -> Either a b -> b
fromRight Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m (Either Text a)
tryIO (forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Bool
True -> do
      ByteString
j <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Path Abs File -> Text -> Text
readError Path Abs File
path) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m (Either Text a)
tryIO (String -> IO ByteString
ByteString.readFile (forall b t. Path b t -> String
toFilePath Path Abs File
path)))
      forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Path Abs File -> String -> Text
decodeError Path Abs File
path) (forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
j)))
readMigrationMetadata Path Abs Dir
_ (Migrations NP Migration migs
Nil) =
  forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"Cannot test empty migrations"

indent ::
  Functor t =>
  t Text ->
  t Text
indent :: forall (t :: * -> *). Functor t => t Text -> t Text
indent =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" • " forall a. Semigroup a => a -> a -> a
<>)

showType :: ColumnType -> Text
showType :: ColumnType -> Text
showType =
  forall a. Exon a => a -> a
squote forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    ColumnPrim {$sel:name:ColumnPrim :: ColumnType -> PgPrimName
name = PgPrimName Text
name} -> Text
name
    ColumnComp { $sel:pgType:ColumnPrim :: ColumnType -> PgTypeRef
pgType = PgTypeRef Text
name } -> Text
name

columnMismatch :: Maybe PgColumn -> Maybe PgColumn -> Text
columnMismatch :: Maybe PgColumn -> Maybe PgColumn -> Text
columnMismatch Maybe PgColumn
Nothing (Just (PgColumn PgColumnName
name ColumnType
tpe)) =
  [exon|A column '##{name}' with type #{showType tpe} was added.|]
columnMismatch (Just (PgColumn PgColumnName
name ColumnType
tpe)) Maybe PgColumn
Nothing =
  [exon|The column '##{name}' with type #{showType tpe} was removed.|]
columnMismatch (Just (PgColumn PgColumnName
gname ColumnType
gtpe)) (Just (PgColumn PgColumnName
cname ColumnType
ctpe))
  | PgColumnName
gname forall a. Eq a => a -> a -> Bool
== PgColumnName
cname =
    [exon|The type of the column '##{gname}' was changed from #{showType gtpe} to #{showType ctpe}.|]
  | Bool
otherwise =
    [exon|The column '##{gname}' with type #{showType gtpe} was replaced with the column '##{cname}' with type #{showType ctpe}.|]
columnMismatch Maybe PgColumn
Nothing Maybe PgColumn
Nothing =
  Text
"Internal error"

compareType :: Text -> PgColumns -> PgColumns -> Maybe (NonEmpty Text)
compareType :: Text -> PgColumns -> PgColumns -> Maybe (NonEmpty Text)
compareType Text
desc (PgColumns [PgColumn]
golden) (PgColumns [PgColumn]
current) =
  NonEmpty (Maybe PgColumn, Maybe PgColumn) -> NonEmpty Text
mismatches forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(/=)) (forall a b c. (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c]
zipWithLongest (,) [PgColumn]
golden [PgColumn]
current))
  where
    mismatches :: NonEmpty (Maybe PgColumn, Maybe PgColumn) -> NonEmpty Text
mismatches NonEmpty (Maybe PgColumn, Maybe PgColumn)
cols = [exon|#{desc} has mismatched columns:|] forall a. a -> [a] -> NonEmpty a
:| (forall (t :: * -> *). Functor t => t Text -> t Text
indent (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe PgColumn -> Maybe PgColumn -> Text
columnMismatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Maybe PgColumn, Maybe PgColumn)
cols))

compareComp :: Maybe PgComposite -> Maybe PgComposite -> Maybe (NonEmpty Text)
compareComp :: Maybe PgComposite -> Maybe PgComposite -> Maybe (NonEmpty Text)
compareComp Maybe PgComposite
Nothing Maybe PgComposite
Nothing =
  forall a. Maybe a
Nothing
compareComp Maybe PgComposite
Nothing (Just (PgComposite (PgTypeName Text
name) PgColumns
_)) =
  forall a. a -> Maybe a
Just [[exon|The type '#{name}' was added.|]]
compareComp (Just (PgComposite (PgTypeName Text
name) PgColumns
_)) Maybe PgComposite
Nothing =
  forall a. a -> Maybe a
Just [[exon|The type '#{name}' was removed.|]]
compareComp (Just (PgComposite (PgTypeName Text
gname) PgColumns
gcols)) (Just (PgComposite (PgTypeName Text
cname) PgColumns
ccols))
  | Text
gname forall a. Eq a => a -> a -> Bool
== Text
cname =
    Text -> PgColumns -> PgColumns -> Maybe (NonEmpty Text)
compareType [exon|The composite type '#{gname}'|] PgColumns
gcols PgColumns
ccols
  | Bool
otherwise =
    forall a. a -> Maybe a
Just [[exon|The type '#{gname}' was replaced with a type named '#{cname}'.|]]

compareStep :: MigrationMetadata -> MigrationMetadata -> Maybe (NonEmpty Text)
compareStep :: MigrationMetadata -> MigrationMetadata -> Maybe (NonEmpty Text)
compareStep MigrationMetadata
golden MigrationMetadata
current =
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. [Maybe a] -> [a]
catMaybes [Maybe (NonEmpty Text)]
mismatches)
  where
    mismatches :: [Maybe (NonEmpty Text)]
mismatches =
      Text -> PgColumns -> PgColumns -> Maybe (NonEmpty Text)
compareType [exon|The migration table '#{name}'|] (MigrationMetadata
golden forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "table" a => a
#table) (MigrationMetadata
current forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "table" a => a
#table) forall a. a -> [a] -> [a]
:
      forall a b c. (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c]
zipWithLongest (Maybe PgComposite -> Maybe PgComposite -> Maybe (NonEmpty Text)
compareComp) (MigrationMetadata
golden forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "types" a => a
#types) (MigrationMetadata
current forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "types" a => a
#types)
    PgTypeName Text
name = MigrationMetadata
golden forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name

checkStep :: Maybe MigrationMetadata -> Maybe MigrationMetadata -> Maybe (NonEmpty Text)
checkStep :: Maybe MigrationMetadata
-> Maybe MigrationMetadata -> Maybe (NonEmpty Text)
checkStep Maybe MigrationMetadata
Nothing Maybe MigrationMetadata
_ =
  forall a. Maybe a
Nothing
checkStep (Just MigrationMetadata
golden) Maybe MigrationMetadata
Nothing =
  let (PgTypeName Text
name) = MigrationMetadata
golden forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name
  in forall a. a -> Maybe a
Just (forall (f :: * -> *) a. Applicative f => a -> f a
pure [exon|A migration for #{name} was removed.|])
checkStep (Just MigrationMetadata
golden) (Just MigrationMetadata
current) =
  MigrationMetadata -> MigrationMetadata -> Maybe (NonEmpty Text)
compareStep MigrationMetadata
golden MigrationMetadata
current

checkMigrationConsistency :: [MigrationMetadata] -> [MigrationMetadata] -> Either (NonEmpty Text) ()
checkMigrationConsistency :: [MigrationMetadata]
-> [MigrationMetadata] -> Either (NonEmpty Text) ()
checkMigrationConsistency [MigrationMetadata]
golden [MigrationMetadata]
current =
  forall r l. r -> Maybe l -> Either l r
maybeToLeft () (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. [Maybe a] -> [a]
catMaybes (forall a b c. (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c]
zipWithLongest Maybe MigrationMetadata
-> Maybe MigrationMetadata -> Maybe (NonEmpty Text)
checkStep [MigrationMetadata]
golden [MigrationMetadata]
current))))

single ::
  Functor m =>
  ExceptT Text m a ->
  ExceptT (NonEmpty Text) m a
single :: forall (m :: * -> *) a.
Functor m =>
ExceptT Text m a -> ExceptT (NonEmpty Text) m a
single =
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT forall (f :: * -> *) a. Applicative f => a -> f a
pure

result ::
  Functor m =>
  ExceptT e m () ->
  m (Maybe e)
result :: forall (m :: * -> *) e. Functor m => ExceptT e m () -> m (Maybe e)
result =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
    Left e
e -> forall a. a -> Maybe a
Just e
e
    Right () -> forall a. Maybe a
Nothing

migrationConsistency ::
  MonadIO m =>
  Path Abs Dir ->
  Migrations m migs ->
  Bool ->
  m (Maybe (NonEmpty Text))
migrationConsistency :: forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir
-> Migrations m migs -> Bool -> m (Maybe (NonEmpty Text))
migrationConsistency Path Abs Dir
dir Migrations m migs
migs =
  forall (m :: * -> *) e. Functor m => ExceptT e m () -> m (Maybe e)
result forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Bool
True ->
      forall (m :: * -> *) a.
Functor m =>
ExceptT Text m a -> ExceptT (NonEmpty Text) m a
single (forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir -> Migrations m migs -> ExceptT Text m ()
writeMigrationMetadata Path Abs Dir
dir Migrations m migs
migs)
    Bool
False ->
      forall (m :: * -> *) a.
Functor m =>
ExceptT Text m a -> ExceptT (NonEmpty Text) m a
single (forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir
-> Migrations m migs -> ExceptT Text m (Maybe [MigrationMetadata])
readMigrationMetadata Path Abs Dir
dir Migrations m migs
migs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just [MigrationMetadata]
golden ->
          forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([MigrationMetadata]
-> [MigrationMetadata] -> Either (NonEmpty Text) ()
checkMigrationConsistency [MigrationMetadata]
golden (forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> [MigrationMetadata]
migrationsMetadata Migrations m migs
migs)))
        Maybe [MigrationMetadata]
Nothing -> forall (m :: * -> *) a.
Functor m =>
ExceptT Text m a -> ExceptT (NonEmpty Text) m a
single (forall (m :: * -> *) (migs :: [Mig]).
MonadIO m =>
Path Abs Dir -> Migrations m migs -> ExceptT Text m ()
writeMigrationMetadata Path Abs Dir
dir Migrations m migs
migs)