{-# 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 = 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] }

-- | 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]
..} =
  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)

-- | Log all messages in a 'ValidationResult', and fail if any of them
-- were errors.
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
")."
          ]

-- | 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 ()))
_                  -> 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
": "