module Test.Hspec.Wai.JSON (
json
, FromValue(..)
) where
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Aeson (Value, decode, encode)
import Data.Aeson.QQ
import Language.Haskell.TH.Quote
import Test.Hspec.Wai
import Test.Hspec.Wai.Matcher
json :: QuasiQuoter
json = QuasiQuoter {
quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|]
, quotePat = const $ error "No quotePat defined for Test.Hspec.Wai.JSON.json"
, quoteType = const $ error "No quoteType defined for Test.Hspec.Wai.JSON.json"
, quoteDec = const $ error "No quoteDec defined for Test.Hspec.Wai.JSON.json"
}
class FromValue a where
fromValue :: Value -> a
instance FromValue ResponseMatcher where
fromValue = ResponseMatcher 200 [matchHeader] . equalsJSON
where
matchHeader = MatchHeader $ \headers _body ->
case lookup "Content-Type" headers of
Just h | isJSON h -> Nothing
_ -> Just $ unlines [
"missing header:"
, formatHeader ("Content-Type", "application/json")
]
isJSON c = media == "application/json" && parameters `elem` ignoredParameters
where
(media, parameters) = let (m, p) = breakAt ';' c in (strip m, strip p)
ignoredParameters = ["", "charset=utf-8"]
breakAt c = fmap (B.drop 1) . B.break (== c)
strip = B.reverse . B.dropWhile isSpace . B.reverse . B.dropWhile isSpace
equalsJSON :: Value -> MatchBody
equalsJSON expected = MatchBody matcher
where
matcher headers actualBody = case decode actualBody of
Just actual | actual == expected -> Nothing
_ -> let MatchBody m = bodyEquals (encode expected) in m headers actualBody
instance FromValue ByteString where
fromValue = encode