{-# 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

-- | A (potentially empty) list of info/error messages.
data ValidationResult = ValidationResult
  { ValidationResult -> [Text]
vrInfos  :: [Text]
  , ValidationResult -> [Text]
vrErrors :: [Text]
  }

validationError :: Text -> ValidationResult
validationError :: Text -> ValidationResult
validationError Text
err = forall a. Monoid a => a
mempty { vrErrors :: [Text]
vrErrors = [Text
err] }

validationInfo :: Text -> ValidationResult
validationInfo :: Text -> ValidationResult
validationInfo Text
msg  = forall a. Monoid a => a
mempty { vrInfos :: [Text]
vrInfos = [Text
msg] }

-- | Downgrade all error messages in a ValidationResult to info messages.
validationErrorsToInfos :: ValidationResult -> ValidationResult
validationErrorsToInfos :: ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} =
  forall a. Monoid a => a
mempty { vrInfos :: [Text]
vrInfos = [Text]
vrInfos 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]
..} =
  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 forall a. Semigroup a => a -> a -> a
<> [Text]
infos1) ([Text]
errs0 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 = 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" forall m. (IsString m, Monoid m) => m -> m -> m
<+>
            Text
objtype forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
objname forall a. Semigroup a => a -> a -> a
<> Text
"'" forall a. a -> [a] -> [a]
: [Text]
es)

-- | Log all messages in a 'ValidationResult', and fail if any of them
-- were errors.
resultCheck
  :: (MonadLog m, MonadThrow m)
  => ValidationResult
  -> m ()
resultCheck :: forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck ValidationResult{[Text]
vrErrors :: [Text]
vrInfos :: [Text]
vrErrors :: ValidationResult -> [Text]
vrInfos :: ValidationResult -> [Text]
..} = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ [Text]
vrInfos
  case [Text]
vrErrors of
    []   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [Text]
msgs -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadLog m => Text -> m ()
logAttention_ [Text]
msgs
      forall a. HasCallStack => [Char] -> a
error [Char]
"resultCheck: validation failed"

----------------------------------------

tblNameText :: Table -> Text
tblNameText :: Table -> Text
tblNameText = RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName

tblNameString :: Table -> String
tblNameString :: Table -> [Char]
tblNameString = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> Text
tblNameText

checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality :: forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
pname [t]
defs [t]
props = case ([t]
defs forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
props, [t]
props forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
defs) of
  ([], []) -> forall a. Monoid a => a
mempty
  ([t]
def_diff, [t]
db_diff) -> Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
      Text
"Table and its definition have diverged and have "
    , forall a. TextShow a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
db_diff
    , Text
" and "
    , forall a. TextShow a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
def_diff
    , Text
" different "
    , Text
pname
    , Text
" each, respectively:\n"
    , Text
"  ● table:"
    , [t] -> Text
showDiff [t]
db_diff
    , Text
"\n  ● definition:"
    , [t] -> Text
showDiff [t]
def_diff
    ]
  where
    showDiff :: [t] -> Text
showDiff = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Text
"\n    ○ " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show)

checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames :: forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames t -> RawSQL ()
prop_name = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== RawSQL ()
name -> forall a. Monoid a => a
mempty
        | Bool
otherwise     -> Text -> ValidationResult
validationError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ [
            Text
"Property "
          , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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
")."
          ]

-- | Check presence of primary key on the named table. We cover all the cases so
-- this could be used standalone, but note that the those where the table source
-- definition and the table in the database differ in this respect is also
-- covered by @checkEquality@.
checkPKPresence :: RawSQL ()
                -- ^ The name of the table to check for presence of primary key
              -> Maybe PrimaryKey
                -- ^ A possible primary key gotten from the table data structure
              -> Maybe (PrimaryKey, RawSQL ())
                -- ^ A possible primary key as retrieved from database along
                -- with its name
              -> 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 ()))
_                  -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        [ Text
"Table ", RawSQL () -> Text
unRawSQL RawSQL ()
tableName
        , Text
" has no primary key defined "
        , Text
" (" forall a. Semigroup a => a -> a -> a
<> (forall m. Monoid m => m -> [m] -> m
mintercalate Text
", " [Text]
msgs) forall a. Semigroup a => a -> a -> a
<> Text
")"]

objectHasLess :: Show t => Text -> Text -> t -> Text
objectHasLess :: forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
otype Text
ptype t
missing =
  Text
otype forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"in the database has *less*" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
ptype forall m. (IsString m, Monoid m) => m -> m -> m
<+>
  Text
"than its definition (missing:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show t
missing) forall a. Semigroup a => a -> a -> a
<> Text
")"

objectHasMore :: Show t => Text -> Text -> t -> Text
objectHasMore :: forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
otype Text
ptype t
extra =
  Text
otype forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"in the database has *more*" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
ptype forall m. (IsString m, Monoid m) => m -> m -> m
<+>
  Text
"than its definition (extra:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show t
extra) forall a. Semigroup a => a -> a -> a
<> Text
")"

arrListTable :: RawSQL () -> Text
arrListTable :: RawSQL () -> Text
arrListTable RawSQL ()
tableName = Text
" ->" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
tableName forall a. Semigroup a => a -> a -> a
<> Text
": "