{-# LANGUAGE OverloadedStrings, TupleSections, CPP #-}
-- | Utilities for validating and inspecting Selda tables.
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)

-- | Are the given types compatible?
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

-- | Validate a table schema, and check it for consistency against the current
--   database.
--   Throws a 'ValidationError' if the schema does not validate, or if
--   inconsistencies were found.
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
      ]

-- | Ensure that the schema of the given table is valid.
--   Does not ensure consistency with the current database.
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 ()

-- | A description of the difference between a schema and its corresponding
--   database table.
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

-- | A description of the difference between a column in a Selda table and its
--   corresponding database column.
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

-- | Pretty-print a table diff.
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"
      ]

-- | Pretty-print a column diff.
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"]

-- | Get a description of the table by the given name currently in the database.
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)

-- | Check the given table for consistency with the current database, returning
--   a description of all inconsistencies found.
--   The table schema itself is not validated beforehand.
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

-- | Compute the difference between the two given tables.
--   The first table is considered to be the schema, and the second the database.
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)

-- | Compute the difference between the columns of two tables.
--   The first table is considered to be the schema, and the second the database.
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))