{-# LANGUAGE CPP #-}
module Database.PostgreSQL.PQTypes.Checks.Util (
ValidationResult,
validationError,
validationInfo,
mapValidationResult,
validationErrorsToInfos,
resultCheck,
topMessage,
tblNameText,
tblNameString,
checkEquality,
checkNames,
checkPKPresence,
objectHasLess,
objectHasMore,
arrListTable
) where
import Control.Monad.Catch
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import Data.Monoid.Utils
import Data.Text (Text)
import Log
import TextShow
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Semigroup as SG
import Database.PostgreSQL.PQTypes.Model
import Database.PostgreSQL.PQTypes
data ValidationResult = ValidationResult
{ ValidationResult -> [Text]
vrInfos :: [Text]
, ValidationResult -> [Text]
vrErrors :: [Text]
}
validationError :: Text -> ValidationResult
validationError :: Text -> ValidationResult
validationError Text
err = ValidationResult
forall a. Monoid a => a
mempty { vrErrors :: [Text]
vrErrors = [Text
err] }
validationInfo :: Text -> ValidationResult
validationInfo :: Text -> ValidationResult
validationInfo Text
msg = ValidationResult
forall a. Monoid a => a
mempty { vrInfos :: [Text]
vrInfos = [Text
msg] }
validationErrorsToInfos :: ValidationResult -> ValidationResult
validationErrorsToInfos :: ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} =
ValidationResult
forall a. Monoid a => a
mempty { vrInfos :: [Text]
vrInfos = [Text]
vrInfos [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
vrErrors }
mapValidationResult ::
([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult :: ([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult [Text] -> [Text]
mapInfos [Text] -> [Text]
mapErrs ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} =
ValidationResult
forall a. Monoid a => a
mempty { vrInfos :: [Text]
vrInfos = [Text] -> [Text]
mapInfos [Text]
vrInfos, vrErrors :: [Text]
vrErrors = [Text] -> [Text]
mapErrs [Text]
vrErrors }
instance SG.Semigroup ValidationResult where
(ValidationResult [Text]
infos0 [Text]
errs0) <> :: ValidationResult -> ValidationResult -> ValidationResult
<> (ValidationResult [Text]
infos1 [Text]
errs1)
= [Text] -> [Text] -> ValidationResult
ValidationResult ([Text]
infos0 [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
infos1) ([Text]
errs0 [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
errs1)
instance Monoid ValidationResult where
mempty :: ValidationResult
mempty = [Text] -> [Text] -> ValidationResult
ValidationResult [] []
mappend :: ValidationResult -> ValidationResult -> ValidationResult
mappend = ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
(SG.<>)
topMessage :: Text -> Text -> ValidationResult -> ValidationResult
topMessage :: Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
objtype Text
objname vr :: ValidationResult
vr@ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} =
case [Text]
vrErrors of
[] -> ValidationResult
vr
[Text]
es -> [Text] -> [Text] -> ValidationResult
ValidationResult [Text]
vrInfos
(Text
"There are problems with the" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+>
Text
objtype Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
es)
resultCheck
:: (MonadLog m, MonadThrow m)
=> ValidationResult
-> m ()
resultCheck :: ValidationResult -> m ()
resultCheck ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} = do
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ [Text]
vrInfos
case [Text]
vrErrors of
[] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Text]
msgs -> do
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logAttention_ [Text]
msgs
[Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"resultCheck: validation failed"
tblNameText :: Table -> Text
tblNameText :: Table -> Text
tblNameText = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName
tblNameString :: Table -> String
tblNameString :: Table -> [Char]
tblNameString = Text -> [Char]
T.unpack (Text -> [Char]) -> (Table -> Text) -> Table -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> Text
tblNameText
checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality :: Text -> [t] -> [t] -> ValidationResult
checkEquality Text
pname [t]
defs [t]
props = case ([t]
defs [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
props, [t]
props [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
defs) of
([], []) -> ValidationResult
forall a. Monoid a => a
mempty
([t]
def_diff, [t]
db_diff) -> Text -> ValidationResult
validationError (Text -> ValidationResult)
-> ([Text] -> Text) -> [Text] -> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> ValidationResult) -> [Text] -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [
Text
"Table and its definition have diverged and have "
, Int -> Text
forall a. TextShow a => a -> Text
showt (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [t] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
db_diff
, Text
" and "
, Int -> Text
forall a. TextShow a => a -> Text
showt (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [t] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
def_diff
, Text
" different "
, Text
pname
, Text
" each, respectively (table: "
, [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [t] -> [Char]
forall a. Show a => a -> [Char]
show [t]
db_diff
, Text
", definition: "
, [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [t] -> [Char]
forall a. Show a => a -> [Char]
show [t]
def_diff
, Text
")."
]
checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames :: (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames t -> RawSQL ()
prop_name = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> ([(t, RawSQL ())] -> [ValidationResult])
-> [(t, RawSQL ())]
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, RawSQL ()) -> ValidationResult)
-> [(t, RawSQL ())] -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
map (t, RawSQL ()) -> ValidationResult
check
where
check :: (t, RawSQL ()) -> ValidationResult
check (t
prop, RawSQL ()
name) = case t -> RawSQL ()
prop_name t
prop of
RawSQL ()
pname
| RawSQL ()
pname RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== RawSQL ()
name -> ValidationResult
forall a. Monoid a => a
mempty
| Bool
otherwise -> Text -> ValidationResult
validationError (Text -> ValidationResult)
-> ([Text] -> Text) -> [Text] -> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> ValidationResult) -> [Text] -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [
Text
"Property "
, [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ t -> [Char]
forall a. Show a => a -> [Char]
show t
prop
, Text
" has invalid name (expected: "
, RawSQL () -> Text
unRawSQL RawSQL ()
pname
, Text
", given: "
, RawSQL () -> Text
unRawSQL RawSQL ()
name
, Text
")."
]
checkPKPresence :: RawSQL ()
-> Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ())
-> ValidationResult
checkPKPresence :: RawSQL ()
-> Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ())
-> ValidationResult
checkPKPresence RawSQL ()
tableName Maybe PrimaryKey
mdef Maybe (PrimaryKey, RawSQL ())
mpk =
case (Maybe PrimaryKey
mdef, Maybe (PrimaryKey, RawSQL ())
mpk) of
(Maybe PrimaryKey
Nothing, Maybe (PrimaryKey, RawSQL ())
Nothing) -> [Text] -> ValidationResult
valRes [Text
noSrc, Text
noTbl]
(Maybe PrimaryKey
Nothing, Just (PrimaryKey, RawSQL ())
_) -> [Text] -> ValidationResult
valRes [Text
noSrc]
(Just PrimaryKey
_, Maybe (PrimaryKey, RawSQL ())
Nothing) -> [Text] -> ValidationResult
valRes [Text
noTbl]
(Maybe PrimaryKey, Maybe (PrimaryKey, RawSQL ()))
_ -> ValidationResult
forall a. Monoid a => a
mempty
where
noSrc :: Text
noSrc = Text
"no source definition"
noTbl :: Text
noTbl = Text
"no table definition"
valRes :: [Text] -> ValidationResult
valRes [Text]
msgs =
Text -> ValidationResult
validationError (Text -> ValidationResult)
-> ([Text] -> Text) -> [Text] -> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> ValidationResult) -> [Text] -> ValidationResult
forall a b. (a -> b) -> a -> b
$
[ Text
"Table ", RawSQL () -> Text
unRawSQL RawSQL ()
tableName
, Text
" has no primary key defined "
, Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
forall m. Monoid m => m -> [m] -> m
mintercalate Text
", " [Text]
msgs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"]
objectHasLess :: Show t => Text -> Text -> t -> Text
objectHasLess :: Text -> Text -> t -> Text
objectHasLess Text
otype Text
ptype t
missing =
Text
otype Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"in the database has *less*" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
ptype Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+>
Text
"than its definition (missing:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> [Char] -> Text
T.pack (t -> [Char]
forall a. Show a => a -> [Char]
show t
missing) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
objectHasMore :: Show t => Text -> Text -> t -> Text
objectHasMore :: Text -> Text -> t -> Text
objectHasMore Text
otype Text
ptype t
extra =
Text
otype Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"in the database has *more*" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
ptype Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+>
Text
"than its definition (extra:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> [Char] -> Text
T.pack (t -> [Char]
forall a. Show a => a -> [Char]
show t
extra) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
arrListTable :: RawSQL () -> Text
arrListTable :: RawSQL () -> Text
arrListTable RawSQL ()
tableName = Text
" ->" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "