{-# LANGUAGE OverloadedStrings, TupleSections, CPP #-}
module Database.Selda.Validation
( TableDiff (..), ColumnDiff (..)
, TableName, ColName, ColumnInfo, SqlTypeRep, tableInfo
, showTableDiff, showColumnDiff
, describeTable, diffTable, diffTables
, validateTable, validateSchema
) where
import Control.Monad.Catch ( MonadThrow(..) )
import Data.List ((\\))
import Data.Maybe (catMaybes)
import Data.Text (pack, unpack, intercalate)
import Database.Selda
( Text,
MonadIO(liftIO),
TableName,
ColName,
Table(..),
MonadSelda )
import Database.Selda.Backend.Internal
( SqlTypeRep(TInt64, TRowID),
SeldaBackend(getTableInfo),
ColumnInfo(colType, colIsAutoPrimary, colIsNullable, colHasIndex,
colFKs, colName),
TableInfo(tableColumnInfos, tableUniqueGroups, tablePrimaryKey),
tableInfo,
withBackend )
import Database.Selda.Types ( fromColName, fromTableName )
import Database.Selda.Table.Type (tableCols)
import Database.Selda.Table.Validation (ValidationError (..), validateOrThrow)
isCompatibleWith :: SqlTypeRep -> SqlTypeRep -> Bool
isCompatibleWith :: SqlTypeRep -> SqlTypeRep -> Bool
isCompatibleWith SqlTypeRep
TRowID SqlTypeRep
TInt64 = Bool
True
isCompatibleWith SqlTypeRep
TInt64 SqlTypeRep
TRowID = Bool
True
isCompatibleWith SqlTypeRep
a SqlTypeRep
b = SqlTypeRep
a forall a. Eq a => a -> a -> Bool
== SqlTypeRep
b
validateTable :: (MonadSelda m, MonadThrow m) => Table a -> m ()
validateTable :: forall (m :: * -> *) a.
(MonadSelda m, MonadThrow m) =>
Table a -> m ()
validateTable Table a
t = do
forall (m :: * -> *) a. MonadThrow m => Table a -> m ()
validateSchema Table a
t
TableDiff
diffs <- forall (m :: * -> *) a. MonadSelda m => Table a -> m TableDiff
diffTable Table a
t
case TableDiff
diffs of
TableDiff
TableOK -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TableDiff
errors -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> ValidationError
ValidationError forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"error validating table ", Text -> [Char]
unpack (TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table a
t)), [Char]
":\n"
, forall a. Show a => a -> [Char]
show TableDiff
errors
]
validateSchema :: MonadThrow m => Table a -> m ()
validateSchema :: forall (m :: * -> *) a. MonadThrow m => Table a -> m ()
validateSchema Table a
t = TableName -> [ColInfo] -> [ColInfo]
validateOrThrow (forall a. Table a -> TableName
tableName Table a
t) (forall a. Table a -> [ColInfo]
tableCols Table a
t) seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
data TableDiff
= TableOK
| TableMissing
| UniqueMissing [[ColName]]
| UniquePresent [[ColName]]
| PkMissing [ColName]
| PkPresent [ColName]
| InconsistentColumns [(ColName, [ColumnDiff])]
deriving TableDiff -> TableDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TableDiff -> TableDiff -> Bool
$c/= :: TableDiff -> TableDiff -> Bool
== :: TableDiff -> TableDiff -> Bool
$c== :: TableDiff -> TableDiff -> Bool
Eq
instance Show TableDiff where
show :: TableDiff -> [Char]
show = Text -> [Char]
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableDiff -> Text
showTableDiff
data ColumnDiff
= ColumnMissing
| ColumnPresent
| NameMismatch ColName
| UnknownType Text
| TypeMismatch SqlTypeRep SqlTypeRep
| AutoIncrementMismatch Bool
| NullableMismatch Bool
| ForeignKeyMissing TableName ColName
| ForeignKeyPresent TableName ColName
| IndexMismatch Bool
deriving ColumnDiff -> ColumnDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColumnDiff -> ColumnDiff -> Bool
$c/= :: ColumnDiff -> ColumnDiff -> Bool
== :: ColumnDiff -> ColumnDiff -> Bool
$c== :: ColumnDiff -> ColumnDiff -> Bool
Eq
instance Show ColumnDiff where
show :: ColumnDiff -> [Char]
show = Text -> [Char]
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnDiff -> Text
showColumnDiff
showTableDiff :: TableDiff -> Text
showTableDiff :: TableDiff -> Text
showTableDiff TableDiff
TableOK = Text
"no inconsistencies detected"
showTableDiff TableDiff
TableMissing = Text
"table does not exist"
showTableDiff (UniqueMissing [[ColName]]
cs) = forall a. Monoid a => [a] -> a
mconcat
[ Text
"table should have uniqueness constraints on the following column groups, "
, Text
"but doesn't in database:\n"
, Text -> [Text] -> Text
intercalate Text
", "
[ Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
constraintGroup) forall a. Semigroup a => a -> a -> a
<> Text
")"
| [ColName]
constraintGroup <- [[ColName]]
cs
]
]
showTableDiff (UniquePresent [[ColName]]
cs) = forall a. Monoid a => [a] -> a
mconcat
[ Text
"table shouldn't have uniqueness constraints on the following column groups, "
, Text
"but does in database:\n"
, Text -> [Text] -> Text
intercalate Text
", "
[ Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
constraintGroup) forall a. Semigroup a => a -> a -> a
<> Text
")"
| [ColName]
constraintGroup <- [[ColName]]
cs
]
]
showTableDiff (PkMissing [ColName]
cs) = forall a. Monoid a => [a] -> a
mconcat
[ Text
"table should have a primary key constraint on the following column group, "
, Text
"but doesn't in database:\n"
, Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
cs) forall a. Semigroup a => a -> a -> a
<> Text
")"
]
showTableDiff (PkPresent [ColName]
cs) = forall a. Monoid a => [a] -> a
mconcat
[ Text
"table shouldn't have a primary key constraint group, "
, Text
"but does in database:\n"
, Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
cs) forall a. Semigroup a => a -> a -> a
<> Text
")"
]
showTableDiff (InconsistentColumns [(ColName, [ColumnDiff])]
cols) = forall a. Monoid a => [a] -> a
mconcat
[ Text
"table has inconsistent columns:\n"
, forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (ColName, [ColumnDiff]) -> Text
showColDiffs [(ColName, [ColumnDiff])]
cols)
]
where
showColDiffs :: (ColName, [ColumnDiff]) -> Text
showColDiffs (ColName
col, [ColumnDiff]
diffs) = forall a. Monoid a => [a] -> a
mconcat
[ Text
" ", ColName -> Text
fromColName ColName
col, Text
":\n"
, forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ColumnDiff -> Text
showDiffs [ColumnDiff]
diffs)
]
showDiffs :: ColumnDiff -> Text
showDiffs ColumnDiff
diff = forall a. Monoid a => [a] -> a
mconcat
[ Text
" ", ColumnDiff -> Text
showColumnDiff ColumnDiff
diff, Text
"\n"
]
showColumnDiff :: ColumnDiff -> Text
showColumnDiff :: ColumnDiff -> Text
showColumnDiff ColumnDiff
ColumnMissing =
Text
"column does not exist in database"
showColumnDiff ColumnDiff
ColumnPresent =
Text
"column exists in database even though it shouldn't"
showColumnDiff (NameMismatch ColName
n) =
forall a. Monoid a => [a] -> a
mconcat [Text
"column is called ", ColName -> Text
fromColName ColName
n, Text
" in database"]
showColumnDiff (UnknownType Text
t) =
forall a. Monoid a => [a] -> a
mconcat [Text
"column has incompatible type \"", Text
t, Text
"\" in database"]
showColumnDiff (TypeMismatch SqlTypeRep
t1 SqlTypeRep
t2) =
forall a. Monoid a => [a] -> a
mconcat [ Text
"column should have type `", [Char] -> Text
pack (forall a. Show a => a -> [Char]
show SqlTypeRep
t1)
, Text
"', but actually has type `", [Char] -> Text
pack (forall a. Show a => a -> [Char]
show SqlTypeRep
t2)
, Text
"' in database"
]
showColumnDiff (ForeignKeyMissing TableName
tbl ColName
col) =
forall a. Monoid a => [a] -> a
mconcat [ Text
"column should be a foreign key referencing column "
, ColName -> Text
fromColName ColName
col, Text
" of table ", TableName -> Text
fromTableName TableName
tbl
, Text
"', but isn't a foreign key in database"
]
showColumnDiff (ForeignKeyPresent TableName
tbl ColName
col) =
forall a. Monoid a => [a] -> a
mconcat [ Text
"column is a foreign key referencing column "
, ColName -> Text
fromColName ColName
col, Text
" of table ", TableName -> Text
fromTableName TableName
tbl
, Text
", in database, even though it shouldn't be"
]
showColumnDiff (AutoIncrementMismatch Bool
dbval) =
Bool -> Text -> Text
showBoolDiff Bool
dbval Text
"auto-incrementing"
showColumnDiff (NullableMismatch Bool
dbval) =
Bool -> Text -> Text
showBoolDiff Bool
dbval Text
"nullable"
showColumnDiff (IndexMismatch Bool
dbval) =
Bool -> Text -> Text
showBoolDiff Bool
dbval Text
"indexed"
showBoolDiff :: Bool -> Text -> Text
showBoolDiff :: Bool -> Text -> Text
showBoolDiff Bool
True Text
what =
forall a. Monoid a => [a] -> a
mconcat [Text
"column is ", Text
what, Text
" in database, even though it shouldn't be"]
showBoolDiff Bool
False Text
what =
forall a. Monoid a => [a] -> a
mconcat [Text
"column is not ", Text
what, Text
" in database, even though it should be"]
describeTable :: MonadSelda m => TableName -> m TableInfo
describeTable :: forall (m :: * -> *). MonadSelda m => TableName -> m TableInfo
describeTable TableName
tbl = forall (m :: * -> *) a.
MonadSelda m =>
(SeldaBackend (Backend m) -> m a) -> m a
withBackend (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b. SeldaBackend b -> TableName -> IO TableInfo
getTableInfo TableName
tbl)
diffTable :: MonadSelda m => Table a -> m TableDiff
diffTable :: forall (m :: * -> *) a. MonadSelda m => Table a -> m TableDiff
diffTable Table a
tbl = do
TableInfo
dbInfos <- forall (m :: * -> *). MonadSelda m => TableName -> m TableInfo
describeTable (forall a. Table a -> TableName
tableName Table a
tbl)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TableInfo -> TableInfo -> TableDiff
diffColumns (forall a. Table a -> TableInfo
tableInfo Table a
tbl) TableInfo
dbInfos
diffTables :: Table a -> Table b -> TableDiff
diffTables :: forall a b. Table a -> Table b -> TableDiff
diffTables Table a
schema Table b
db = TableInfo -> TableInfo -> TableDiff
diffColumns (forall a. Table a -> TableInfo
tableInfo Table a
schema) (forall a. Table a -> TableInfo
tableInfo Table b
db)
diffColumns :: TableInfo -> TableInfo -> TableDiff
diffColumns :: TableInfo -> TableInfo -> TableDiff
diffColumns TableInfo
inschema TableInfo
indb =
case ( forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ColumnInfo -> ColumnInfo -> (ColName, [ColumnDiff])
diffColumn [ColumnInfo]
infos [ColumnInfo]
dbInfos
, forall a b. (a -> b) -> [a] -> [b]
map ColumnInfo -> ColName
colName [ColumnInfo]
infos forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map ColumnInfo -> ColName
colName [ColumnInfo]
dbInfos
, forall a b. (a -> b) -> [a] -> [b]
map ColumnInfo -> ColName
colName [ColumnInfo]
dbInfos forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map ColumnInfo -> ColName
colName [ColumnInfo]
infos
, TableInfo -> [[ColName]]
tableUniqueGroups TableInfo
inschema forall a. Eq a => [a] -> [a] -> [a]
\\ TableInfo -> [[ColName]]
tableUniqueGroups TableInfo
indb
, TableInfo -> [[ColName]]
tableUniqueGroups TableInfo
indb forall a. Eq a => [a] -> [a] -> [a]
\\ TableInfo -> [[ColName]]
tableUniqueGroups TableInfo
inschema
, TableInfo -> [ColName]
tablePrimaryKey TableInfo
inschema forall a. Eq a => [a] -> [a] -> [a]
\\ TableInfo -> [ColName]
tablePrimaryKey TableInfo
indb
, TableInfo -> [ColName]
tablePrimaryKey TableInfo
indb forall a. Eq a => [a] -> [a] -> [a]
\\ TableInfo -> [ColName]
tablePrimaryKey TableInfo
inschema) of
([], [ColName]
_, [ColName]
_, [[ColName]]
_, [[ColName]]
_, [ColName]
_, [ColName]
_) ->
TableDiff
TableMissing
([(ColName, [ColumnDiff])]
diffs, [], [], [], [], [], []) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {t :: * -> *} {a} {a}. Foldable t => (a, t a) -> Bool
consistent [(ColName, [ColumnDiff])]
diffs ->
TableDiff
TableOK
([(ColName, [ColumnDiff])]
diffs, [ColName]
missing, [ColName]
extras, [], [], [], []) ->
[(ColName, [ColumnDiff])] -> TableDiff
InconsistentColumns forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *} {a} {a}. Foldable t => (a, t a) -> Bool
consistent) [(ColName, [ColumnDiff])]
diffs
, forall a b. (a -> b) -> [a] -> [b]
map (, [ColumnDiff
ColumnMissing]) [ColName]
missing
, forall a b. (a -> b) -> [a] -> [b]
map (, [ColumnDiff
ColumnPresent]) [ColName]
extras
]
([(ColName, [ColumnDiff])]
_, [ColName]
_, [ColName]
_, [[ColName]]
schemaUniques, [], [], []) ->
[[ColName]] -> TableDiff
UniqueMissing [[ColName]]
schemaUniques
([(ColName, [ColumnDiff])]
_, [ColName]
_, [ColName]
_, [[ColName]]
_, [[ColName]]
dbUniques, [], []) ->
[[ColName]] -> TableDiff
UniquePresent [[ColName]]
dbUniques
([(ColName, [ColumnDiff])]
_, [ColName]
_, [ColName]
_, [[ColName]]
_, [[ColName]]
_, [ColName]
schemaPks, []) ->
[ColName] -> TableDiff
PkMissing [ColName]
schemaPks
([(ColName, [ColumnDiff])]
_, [ColName]
_, [ColName]
_, [[ColName]]
_, [[ColName]]
_, [ColName]
_, [ColName]
dbPks) ->
[ColName] -> TableDiff
PkPresent [ColName]
dbPks
where
infos :: [ColumnInfo]
infos = TableInfo -> [ColumnInfo]
tableColumnInfos TableInfo
inschema
dbInfos :: [ColumnInfo]
dbInfos = TableInfo -> [ColumnInfo]
tableColumnInfos TableInfo
indb
consistent :: (a, t a) -> Bool
consistent (a
_, t a
diffs) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
diffs
diffColumn :: ColumnInfo -> ColumnInfo -> (ColName, [ColumnDiff])
diffColumn ColumnInfo
schema ColumnInfo
db = (ColumnInfo -> ColName
colName ColumnInfo
schema, forall a. [Maybe a] -> [a]
catMaybes
([ forall a.
Eq a =>
(ColumnInfo -> a) -> (a -> ColumnDiff) -> Maybe ColumnDiff
check ColumnInfo -> ColName
colName ColName -> ColumnDiff
NameMismatch
, case ColumnInfo -> Either Text SqlTypeRep
colType ColumnInfo
db of
Left Text
typ ->
forall a. a -> Maybe a
Just (Text -> ColumnDiff
UnknownType Text
typ)
Right SqlTypeRep
t | Bool -> Bool
not (SqlTypeRep
t SqlTypeRep -> SqlTypeRep -> Bool
`isCompatibleWith` SqlTypeRep
schemaColType) ->
forall a. a -> Maybe a
Just (SqlTypeRep -> SqlTypeRep -> ColumnDiff
TypeMismatch SqlTypeRep
schemaColType SqlTypeRep
t)
Either Text SqlTypeRep
_ ->
forall a. Maybe a
Nothing
, forall a.
Eq a =>
(ColumnInfo -> a) -> (a -> ColumnDiff) -> Maybe ColumnDiff
check ColumnInfo -> Bool
colIsAutoPrimary Bool -> ColumnDiff
AutoIncrementMismatch
, forall a.
Eq a =>
(ColumnInfo -> a) -> (a -> ColumnDiff) -> Maybe ColumnDiff
check ColumnInfo -> Bool
colIsNullable Bool -> ColumnDiff
NullableMismatch
, forall a.
Eq a =>
(ColumnInfo -> a) -> (a -> ColumnDiff) -> Maybe ColumnDiff
check ColumnInfo -> Bool
colHasIndex Bool -> ColumnDiff
IndexMismatch
] forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => [a] -> a
mconcat
[ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TableName -> ColName -> ColumnDiff
ForeignKeyPresent)
(ColumnInfo -> [(TableName, ColName)]
colFKs ColumnInfo
schema forall a. Eq a => [a] -> [a] -> [a]
\\ ColumnInfo -> [(TableName, ColName)]
colFKs ColumnInfo
db)
, forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TableName -> ColName -> ColumnDiff
ForeignKeyMissing)
(ColumnInfo -> [(TableName, ColName)]
colFKs ColumnInfo
db forall a. Eq a => [a] -> [a] -> [a]
\\ ColumnInfo -> [(TableName, ColName)]
colFKs ColumnInfo
schema)
]))
where
schemaColType :: SqlTypeRep
schemaColType = case ColumnInfo -> Either Text SqlTypeRep
colType ColumnInfo
schema of
Right SqlTypeRep
t -> SqlTypeRep
t
Left Text
t -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Selda has no idea what to make of this type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t
check :: Eq a
=> (ColumnInfo -> a)
-> (a -> ColumnDiff)
-> Maybe ColumnDiff
check :: forall a.
Eq a =>
(ColumnInfo -> a) -> (a -> ColumnDiff) -> Maybe ColumnDiff
check ColumnInfo -> a
f a -> ColumnDiff
err
| ColumnInfo -> a
f ColumnInfo
schema forall a. Eq a => a -> a -> Bool
== ColumnInfo -> a
f ColumnInfo
db = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (a -> ColumnDiff
err (ColumnInfo -> a
f ColumnInfo
db))