{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Testing.CurlRunnings.Types
( AssertionFailure(..)
, Authentication(..)
, CaseResult(..)
, CurlCase(..)
, CurlRunningsState(..)
, CurlSuite(..)
, FullQueryText
, Header(..)
, HeaderMatcher(..)
, Headers(..)
, HttpMethod(..)
, Index(..)
, InterpolatedQuery(..)
, JsonMatcher(..)
, JsonSubExpr(..)
, KeyValuePair(..)
, KeyValuePairs(..)
, PartialHeaderMatcher(..)
, Payload(..)
, Query(..)
, QueryError(..)
, SingleQueryText
, StatusCodeMatcher(..)
, TLSCheckType(..)
, isFailing
, isPassing
, logger
, unsafeLogger
) where
import Data.Aeson
import Data.Aeson.Types
import qualified Data.Char as C
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as H
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics
import Testing.CurlRunnings.Internal
import Testing.CurlRunnings.Internal.Headers
import Testing.CurlRunnings.Internal.KeyValuePairs
import Testing.CurlRunnings.Internal.Payload
import Text.Printf
data HttpMethod
= GET
| POST
| PUT
| PATCH
| DELETE
deriving (Show, Generic)
instance FromJSON HttpMethod
instance ToJSON HttpMethod
data JsonMatcher
= Exactly Value
| Contains [JsonSubExpr]
| NotContains [JsonSubExpr]
| MixedContains [JsonMatcher]
deriving (Show, Generic)
instance ToJSON JsonMatcher
instance FromJSON JsonMatcher where
parseJSON (Object v)
| justAndNotEmpty "exactly" v = Exactly <$> v .: "exactly"
| justAndNotEmpty "contains" v && justAndNotEmpty "notContains" v = do
c <- Contains <$> v .: "contains"
n <- NotContains <$> v .: "notContains"
return $ MixedContains [c, n]
| justAndNotEmpty "contains" v = Contains <$> v .: "contains"
| justAndNotEmpty "notContains" v = NotContains <$> v .: "notContains"
parseJSON invalid = typeMismatch "JsonMatcher" invalid
justAndNotEmpty :: (Eq k, Hashable k) => k -> H.HashMap k Value -> Bool
justAndNotEmpty key obj =
(isJust $ H.lookup key obj) && (H.lookup key obj /= Just Null)
isContains :: JsonMatcher -> Bool
isContains (Contains _) = True
isContains _ = False
isNotContains :: JsonMatcher -> Bool
isNotContains (NotContains _) = True
isNotContains _ = False
data PartialHeaderMatcher =
PartialHeaderMatcher (Maybe T.Text)
(Maybe T.Text)
deriving (Show, Generic)
instance ToJSON PartialHeaderMatcher
data HeaderMatcher =
HeaderMatcher [PartialHeaderMatcher]
deriving (Show, Generic)
instance ToJSON HeaderMatcher
data QueryError
= QueryParseError T.Text
T.Text
| QueryTypeMismatch T.Text
Value
| QueryValidationError T.Text
| NullPointer T.Text
T.Text
deriving (Generic)
instance Show QueryError where
show (QueryParseError t q) = printf "error parsing query %s: %s" q $ T.unpack t
show (NullPointer full part) = printf "null pointer in %s at %s" (T.unpack full) $ T.unpack part
show (QueryTypeMismatch message val) = printf "type error: %s %s" message $ show val
show (QueryValidationError message) = printf "invalid query: %s" message
instance ToJSON QueryError
instance FromJSON HeaderMatcher where
parseJSON o@(String v) =
either
(\s -> typeMismatch ("HeaderMatcher: " ++ T.unpack s) o)
(\(HeaderSet parsed) ->
return . HeaderMatcher $
map
(\(Header key val) -> PartialHeaderMatcher (Just key) (Just val))
parsed)
(parseHeaders v)
parseJSON (Object v) = do
partial <- PartialHeaderMatcher <$> v .:? "key" <*> v .:? "value"
return $ HeaderMatcher [partial]
parseJSON (Array v) = mconcat . V.toList $ V.map parseJSON v
parseJSON invalid = typeMismatch "HeaderMatcher" invalid
data JsonSubExpr
= ValueMatch Value
| KeyMatch T.Text
| KeyValueMatch { matchKey :: T.Text
, matchValue :: Value }
deriving (Show, Generic)
instance FromJSON JsonSubExpr where
parseJSON (Object v)
| justAndNotEmpty "keyValueMatch" v =
let toParse = fromJust $ H.lookup "keyValueMatch" v
in case toParse of
Object o -> KeyValueMatch <$> o .: "key" <*> o .: "value"
_ -> typeMismatch "JsonSubExpr" toParse
| justAndNotEmpty "keyMatch" v =
let toParse = fromJust $ H.lookup "keyMatch" v
in case toParse of
String s -> return $ KeyMatch s
_ -> typeMismatch "JsonSubExpr" toParse
| justAndNotEmpty "valueMatch" v = ValueMatch <$> v .: "valueMatch"
parseJSON invalid = typeMismatch "JsonSubExpr" invalid
instance ToJSON JsonSubExpr
data StatusCodeMatcher
= ExactCode Int
| AnyCodeIn [Int]
deriving (Show, Generic)
instance ToJSON StatusCodeMatcher
instance FromJSON StatusCodeMatcher where
parseJSON obj@(Number _) = ExactCode <$> parseJSON obj
parseJSON obj@(Array _) = AnyCodeIn <$> parseJSON obj
parseJSON invalid = typeMismatch "StatusCodeMatcher" invalid
data Authentication =
BasicAuthentication T.Text T.Text
deriving (Show, Generic)
instance FromJSON Authentication where
parseJSON (Object o) = BasicAuthentication <$> (o .: "basic" >>= (.: "username")) <*> (o .: "basic" >>= (.: "password"))
parseJSON invalid = typeMismatch "Authentication" invalid
instance ToJSON Authentication
data CurlCase = CurlCase
{ name :: T.Text
, url :: T.Text
, requestMethod :: HttpMethod
, requestData :: Maybe Payload
, queryParameters :: Maybe KeyValuePairs
, headers :: Maybe Headers
, auth :: Maybe Authentication
, expectData :: Maybe JsonMatcher
, expectStatus :: StatusCodeMatcher
, expectHeaders :: Maybe HeaderMatcher
, allowedRedirects :: Maybe Int
} deriving (Show, Generic)
instance FromJSON CurlCase
instance ToJSON CurlCase
data AssertionFailure
= DataFailure CurlCase
JsonMatcher
(Maybe Value)
| StatusFailure CurlCase
Int
| HeaderFailure CurlCase
HeaderMatcher
Headers
| QueryFailure CurlCase
QueryError
| UnexpectedFailure deriving (Generic)
instance ToJSON AssertionFailure
colorizeExpects :: String -> String
colorizeExpects t =
let expectedColor = makeRed "Expected:"
actualColor = makeRed "Actual:"
replacedExpected = T.replace "Expected:" expectedColor (T.pack t)
in T.unpack $ T.replace "Actual:" actualColor replacedExpected
instance Show AssertionFailure where
show (StatusFailure c receivedCode) =
case expectStatus c of
ExactCode code ->
colorizeExpects $
printf
"[%s] Incorrect status code from %s. Expected: %s. Actual: %s"
(name c)
(url c)
(show code)
(show receivedCode)
AnyCodeIn codes ->
colorizeExpects $
printf
"[%s] Incorrect status code from %s. Expected: %s. Actual: %s"
(name c)
(url c)
(show codes)
(show receivedCode)
show (DataFailure curlCase expected receivedVal) =
case expected of
Exactly expectedVal ->
colorizeExpects $
printf
"[%s] JSON response from %s didn't match spec. Expected: %s. Actual: %s"
(name curlCase)
(url curlCase)
(T.unpack (pShow expectedVal))
(T.unpack (pShow receivedVal))
(Contains expectedVals) ->
colorizeExpects $
printf
"[%s] JSON response from %s didn't contain the matcher. Expected: %s to each be subvalues in: %s"
(name curlCase)
(url curlCase)
(T.unpack (pShow expectedVals))
(T.unpack (pShow receivedVal))
(NotContains expectedVals) ->
colorizeExpects $
printf
"[%s] JSON response from %s did contain the matcher. Expected: %s not to be subvalues in: %s"
(name curlCase)
(url curlCase)
(T.unpack (pShow expectedVals))
(T.unpack (pShow receivedVal))
(MixedContains expectedVals) ->
colorizeExpects $
printf
"[%s] JSON response from %s didn't satisfy the matcher. Expected: %s to each be subvalues and %s not to be subvalues in: %s"
(name curlCase)
(url curlCase)
(T.unpack (pShow (filter isContains expectedVals)))
(T.unpack (pShow (filter isNotContains expectedVals)))
(T.unpack (pShow receivedVal))
show (HeaderFailure curlCase expected receivedHeaders) =
colorizeExpects $
printf
"[%s] Headers from %s didn't contain expected headers. Expected: %s. Actual: %s"
(name curlCase)
(url curlCase)
(show expected)
(show receivedHeaders)
show (QueryFailure curlCase queryErr) =
colorizeExpects $
printf "JSON query error in spec %s: %s" (name curlCase) (show queryErr)
show UnexpectedFailure = "Unexpected Error D:"
data CaseResult
= CasePass
{ curlCase :: CurlCase
, caseResponseHeaders :: Maybe Headers
, caseResponseValue :: Maybe Value
, elapsedTime :: Integer
}
| CaseFail
{ curlCase :: CurlCase
, caseResponseHeaders :: Maybe Headers
, caseResponseValue :: Maybe Value
, failures :: [AssertionFailure]
, elapsedTime :: Integer
} deriving (Generic)
instance Show CaseResult where
show CasePass{curlCase, elapsedTime} = T.unpack . makeGreen $ "[PASS] " <> (T.pack $ printf "%s (%0.2f seconds)" (name curlCase) (millisToS elapsedTime))
show CaseFail{curlCase, failures, elapsedTime} =
T.unpack $ makeRed "[FAIL] " <>
name curlCase <>
(T.pack $ printf " (%0.2f seconds) " (millisToS elapsedTime)) <>
"\n" <>
mconcat (map ((\s -> "\nAssertion failed: " <> s) . (<> "\n") . (T.pack . show)) failures)
instance ToJSON CaseResult where
toJSON CasePass {curlCase, caseResponseHeaders, caseResponseValue, elapsedTime} =
object
[ "testPassed" .= (Bool True)
, "case" .= curlCase
, "responseHeaders" .= caseResponseHeaders
, "responseValue" .= caseResponseValue
, "elapsedTimeSeconds" .= millisToS elapsedTime
]
toJSON CaseFail {curlCase, caseResponseHeaders, caseResponseValue, elapsedTime, failures} =
object
[ "testPassed" .= (Bool False)
, "case" .= curlCase
, "responseHeaders" .= caseResponseHeaders
, "responseValue" .= caseResponseValue
, "elapsedTimeSeconds" .= millisToS elapsedTime
, "failures" .= failures
]
data CurlSuite = CurlSuite
{ suiteCases :: [CurlCase]
, suiteCaseFilter :: Maybe T.Text
} deriving (Show, Generic)
noFilterSuite :: [CurlCase] -> CurlSuite
noFilterSuite = flip CurlSuite Nothing
instance ToJSON CurlSuite
instance FromJSON CurlSuite where
parseJSON (Object v) = noFilterSuite <$> v .: "cases"
parseJSON a@(Array _) = noFilterSuite <$> parseJSON a
parseJSON invalid = typeMismatch "JsonMatcher" invalid
isPassing :: CaseResult -> Bool
isPassing CasePass {} = True
isPassing CaseFail {} = False
isFailing :: CaseResult -> Bool
isFailing = not . isPassing
type Environment = H.HashMap T.Text T.Text
data TLSCheckType = SkipTLSCheck | DoTLSCheck deriving (Show, Eq)
data CurlRunningsState = CurlRunningsState Environment [CaseResult] LogLevel TLSCheckType
logger :: CurlRunningsState -> CurlRunningsLogger
logger (CurlRunningsState _ _ l _) = makeLogger l
unsafeLogger :: Show a => CurlRunningsState -> CurlRunningsUnsafeLogger a
unsafeLogger (CurlRunningsState _ _ l _) = makeUnsafeLogger l
data Index
= CaseResultIndex Integer
| KeyIndex T.Text
| ArrayIndex Integer
deriving (Show)
printOriginalQuery :: Index -> String
printOriginalQuery (CaseResultIndex t) = "RESPONSES[" ++ show t ++ "]"
printOriginalQuery (KeyIndex key) = "." ++ T.unpack key
printOriginalQuery (ArrayIndex i) = printf "[%d]" i
data Query =
Query [Index] |
EnvironmentVariable T.Text
deriving (Show)
data InterpolatedQuery
= LiteralText T.Text
| InterpolatedQuery T.Text
Query
| NonInterpolatedQuery Query
deriving (Show)
printQueryString :: InterpolatedQuery -> String
printQueryString (LiteralText t) = show t
printQueryString (InterpolatedQuery raw (Query indexes)) =
printf "%s$<%s>" raw $ concatMap show indexes
printQueryString (NonInterpolatedQuery (Query indexes)) = printf "$<%s>" (concatMap show indexes)
type FullQueryText = T.Text
type SingleQueryText = T.Text