{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances, FieldSelectors #-}

module Conduit.Validation
  ( Validation(..)
  , NotBlank(..)
  , ValErrs(..)
  , parseJsonBody
  , inErrMsgObj
  , (<?!<)
  , (<!<)
  ) where

import Conduit.Utils (InObj(..), (.-))
import Data.Aeson (FromJSON(..), ToJSON(..), Value, eitherDecode, object, (.=))
import Data.Aeson.Types (Parser)
import Data.Map.Strict (fromAscList)
import Data.Text qualified as T
import Network.HTTP.Types (status422)
import Relude.Unsafe as Unsafe ((!!))
import UnliftIO (MonadUnliftIO)
import Web.Scotty.Trans (ActionT, body, finish, json, status)

newtype Assurance property a = Assurance { forall {k} (property :: k) a. Assurance property a -> a
getAssured :: a}
  deriving Int -> Assurance property a -> ShowS
[Assurance property a] -> ShowS
Assurance property a -> String
(Int -> Assurance property a -> ShowS)
-> (Assurance property a -> String)
-> ([Assurance property a] -> ShowS)
-> Show (Assurance property a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (property :: k) a.
Show a =>
Int -> Assurance property a -> ShowS
forall k (property :: k) a.
Show a =>
[Assurance property a] -> ShowS
forall k (property :: k) a.
Show a =>
Assurance property a -> String
$cshowsPrec :: forall k (property :: k) a.
Show a =>
Int -> Assurance property a -> ShowS
showsPrec :: Int -> Assurance property a -> ShowS
$cshow :: forall k (property :: k) a.
Show a =>
Assurance property a -> String
show :: Assurance property a -> String
$cshowList :: forall k (property :: k) a.
Show a =>
[Assurance property a] -> ShowS
showList :: [Assurance property a] -> ShowS
Show

instance (Validation prop on, FromJSON on) => FromJSON (Assurance prop on) where
  parseJSON :: Value -> Parser (Assurance prop on)
parseJSON Value
v = do
    on
val <- Value -> Parser on
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    if forall (property :: k) on. Validation property on => on -> Bool
forall {k} (property :: k) on. Validation property on => on -> Bool
validate @prop on
val
      then Assurance prop on -> Parser (Assurance prop on)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Assurance prop on -> Parser (Assurance prop on))
-> Assurance prop on -> Parser (Assurance prop on)
forall a b. (a -> b) -> a -> b
$ on -> Assurance prop on
forall {k} (property :: k) a. a -> Assurance property a
Assurance on
val 
      else String -> Parser (Assurance prop on)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Assurance prop on))
-> String -> Parser (Assurance prop on)
forall a b. (a -> b) -> a -> b
$ forall (property :: k) on. Validation property on => String
forall {k} (property :: k) on. Validation property on => String
errMsg @prop @on

-- | A simple validation class using typeclass-metaprogramming (TMP) to help catch and generate Conduit-spec-abiding validation errors
--   Intended for use on Aeson Parsers (in manual FromJSON instances)
--   See also: 'NotBlank' (example), '(<!<)', and '(<?!<)'
-- 
-- > data IsRed = IsRed
-- >
-- > instance Validation IsRed Text where
-- >   validate = (== "red")
-- >   errMsg = "must be red"
-- 
-- > newtype Test = Test Text
-- >
-- > instance FromJSON Test where
-- >   parseJSON = withObject "Test" $ \v -> Test
-- >     <$> v .: "test" <!< IsRed <!< NotBlank -- assurances are evaluated R->L
--
-- >>> eitherDecode @Test "{ \"test\": \"\" }"
-- Left "Error in $.test: can't be blank"
--
-- >>> eitherDecode @Test "{ \"test\": \"abc\" }"
-- Left "Error in $.test: must be red"
class Validation property on where
  validate :: on -> Bool
  errMsg :: String

-- | Validates an optional json field *if it exists*.
(<?!<) :: Parser (Maybe (Assurance prop on)) -> prop -> Parser (Maybe on)
Parser (Maybe (Assurance prop on))
p <?!< :: forall prop on.
Parser (Maybe (Assurance prop on)) -> prop -> Parser (Maybe on)
<?!< prop
_ = (Assurance prop on -> on) -> Maybe (Assurance prop on) -> Maybe on
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Assurance prop on -> on
forall {k} (property :: k) a. Assurance property a -> a
getAssured (Maybe (Assurance prop on) -> Maybe on)
-> Parser (Maybe (Assurance prop on)) -> Parser (Maybe on)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe (Assurance prop on))
p

-- | Validates a json field.
(<!<) :: Parser (Assurance prop on) -> prop -> Parser on
Parser (Assurance prop on)
p <!< :: forall prop on. Parser (Assurance prop on) -> prop -> Parser on
<!< prop
_ = Assurance prop on -> on
forall {k} (property :: k) a. Assurance property a -> a
getAssured (Assurance prop on -> on)
-> Parser (Assurance prop on) -> Parser on
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Assurance prop on)
p

-- | A property ensuing that the given json field isn't blank (intended for String/Text-like objects).
data NotBlank = NotBlank

instance Validation NotBlank Text where
  validate :: Text -> Bool
validate = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null
  errMsg :: String
errMsg = String
"can't be blank"

-- | The instance that recursively evaluates assurances to allow multi-assurance validation.
instance (Validation prop on) => Validation prop (Assurance other on) where
  validate :: Assurance other on -> Bool
validate = Assurance other on -> on
forall {k} (property :: k) a. Assurance property a -> a
getAssured (Assurance other on -> on)
-> (on -> Bool) -> Assurance other on -> Bool
forall a b c. (a -> b) -> (b -> c) -> a -> c
.- forall (property :: k) on. Validation property on => on -> Bool
forall {k} (property :: k) on. Validation property on => on -> Bool
validate @prop
  errMsg :: String
errMsg = forall (property :: k) on. Validation property on => String
forall {k} (property :: k) on. Validation property on => String
errMsg @prop @on

-- | Represents errors as the [spec describes](https://realworld-docs.netlify.app/docs/specs/backend-specs/error-handling).
newtype ValErrs = ValErrs [(Text, Text)]
  deriving newtype (Int -> ValErrs -> ShowS
[ValErrs] -> ShowS
ValErrs -> String
(Int -> ValErrs -> ShowS)
-> (ValErrs -> String) -> ([ValErrs] -> ShowS) -> Show ValErrs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValErrs -> ShowS
showsPrec :: Int -> ValErrs -> ShowS
$cshow :: ValErrs -> String
show :: ValErrs -> String
$cshowList :: [ValErrs] -> ShowS
showList :: [ValErrs] -> ShowS
Show)

instance ToJSON ValErrs where
  toJSON :: ValErrs -> Value
  toJSON :: ValErrs -> Value
toJSON (ValErrs [(Text, Text)]
errs) = 
    [Pair] -> Value
object [Key
"errors" Key -> Map Text [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(Text, [Text])] -> Map Text [Text]
forall k a. Eq k => [(k, a)] -> Map k a
fromAscList ((Text -> [Text]) -> (Text, Text) -> (Text, [Text])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) ((Text, Text) -> (Text, [Text]))
-> [(Text, Text)] -> [(Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
errs)]

-- | Extracts and decodes an expected json body, intended for use with 'Validation's.
--   Returns the appropriate unprocessable errors the Conduit spec expects.
--   
-- > newtype Test = Test Text
-- >   deriving (Show)
-- >
-- > instance FromJSON Test where
-- >   parseJSON = withObject "Test" $ \v -> Test
-- >     <$> v .: "test" <!< NotBlank
-- >
-- > endpoint = post "/" $ do
-- >   result <- parseJsonBody @Test
-- >   print text
parseJsonBody :: ∀ a m. (MonadUnliftIO m, FromJSON a) => ActionT m a
parseJsonBody :: forall a (m :: * -> *).
(MonadUnliftIO m, FromJSON a) =>
ActionT m a
parseJsonBody = ActionT m ByteString
forall (m :: * -> *). MonadIO m => ActionT m ByteString
body ActionT m ByteString
-> (ByteString -> Either String (InObj a))
-> ActionT m (Either String (InObj a))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> Either String (InObj a)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ActionT m (Either String (InObj a))
-> (Either String (InObj a) -> ActionT m a) -> ActionT m a
forall a b. ActionT m a -> (a -> ActionT m b) -> ActionT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left String
msg -> do
    Status -> ActionT m ()
forall (m :: * -> *). MonadIO m => Status -> ActionT m ()
status Status
status422
    ValErrs -> ActionT m ()
forall a (m :: * -> *). (ToJSON a, MonadIO m) => a -> ActionT m ()
json (ValErrs -> ActionT m ()) -> ValErrs -> ActionT m ()
forall a b. (a -> b) -> a -> b
$ String -> ValErrs
msg2err String
msg
    ActionT m a
forall (m :: * -> *) a. Monad m => ActionT m a
finish
  Right (InObj Key
_ a
a) -> do
    a -> ActionT m a
forall a. a -> ActionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

msg2err :: String -> ValErrs
msg2err :: String -> ValErrs
msg2err (String -> Text
forall a. ToText a => a -> Text
toText -> Text
txt) = [(Text, Text)] -> ValErrs
ValErrs [[Text] -> (Text, Text)
go ([Text] -> (Text, Text)) -> [Text] -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
": " Text
txt] where 
  go :: [Text] -> (Text, Text)
go [Text
path, Text
err] = if HasCallStack => Text -> Char
Text -> Char
T.last Text
path Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$'
    then (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"key \"" Text
err [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
Unsafe.!! Int
1 Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'), Text
"can't be blank")
    else (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"Error in $." Text
path [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
Unsafe.!! Int
1, Text
err)
  go [Text]
split = Text -> (Text, Text)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Text]
split

inErrMsgObj :: obj -> InObj obj
inErrMsgObj :: forall obj. obj -> InObj obj
inErrMsgObj = Key -> obj -> InObj obj
forall obj. Key -> obj -> InObj obj
InObj Key
"message"