    {-# LANGUAGE ViewPatterns #-}
    module Test.Hspec.Wai.Matcher (
      ResponseMatcher(..)
    , MatchHeader(..)
    , MatchBody(..)
    , Body
    , (<:>)
    , bodyEquals
    , match
    ) where

    import           Prelude ()
    import           Prelude.Compat

    import           Control.Monad
    import           Data.Maybe
    import           Data.String
    import           Data.Text.Lazy.Encoding (encodeUtf8)
    import qualified Data.Text.Lazy as T
    import           Data.ByteString (ByteString)
    import qualified Data.ByteString.Lazy as LB
    import           Network.HTTP.Types
    import           Network.Wai.Test

    import           Test.Hspec.Wai.Util

    type Body = LB.ByteString

    data ResponseMatcher = ResponseMatcher {
      matchStatus :: Int
    , matchHeaders :: [MatchHeader]
    , matchBody :: MatchBody
    }

    data MatchHeader = MatchHeader ([Header] -> Body -> Maybe String)

    data MatchBody = MatchBody ([Header] -> Body -> Maybe String)

    bodyEquals :: Body -> MatchBody
    bodyEquals body = MatchBody (\_ actual -> bodyMatcher actual body)
      where
        bodyMatcher :: Body -> Body -> Maybe String
        bodyMatcher (toStrict -> actual) (toStrict -> expected) = actualExpected "body mismatch:" actual_ expected_ <$ guard (actual /= expected)
          where
            (actual_, expected_) = case (safeToString actual, safeToString expected) of
              (Just x, Just y) -> (x, y)
              _ -> (show actual, show expected)

    matchAny :: MatchBody
    matchAny = MatchBody (\_ _ -> Nothing)

    instance IsString MatchBody where
      fromString = bodyEquals . encodeUtf8 . T.pack

    instance IsString ResponseMatcher where
      fromString = ResponseMatcher 200 [] . fromString

    instance Num ResponseMatcher where
      fromInteger n = ResponseMatcher (fromInteger n) [] matchAny
      (+) =    error "ResponseMatcher does not support (+)"
      (-) =    error "ResponseMatcher does not support (-)"
      (*) =    error "ResponseMatcher does not support (*)"
      abs =    error "ResponseMatcher does not support `abs`"
      signum = error "ResponseMatcher does not support `signum`"

    match :: SResponse -> ResponseMatcher -> Maybe String
    match (SResponse (Status status _) headers body) (ResponseMatcher expectedStatus expectedHeaders (MatchBody bodyMatcher)) = mconcat [
        actualExpected "status mismatch:" (show status) (show expectedStatus) <$ guard (status /= expectedStatus)
      , checkHeaders headers body expectedHeaders
      , bodyMatcher headers body
      ]

    actualExpected :: String -> String -> String -> String
    actualExpected message actual expected = unlines [
        message
      , "  expected: " ++ expected
      , "  but got:  " ++ actual
      ]

    checkHeaders :: [Header] -> Body -> [MatchHeader] -> Maybe String
    checkHeaders headers body m = case go m of
        [] -> Nothing
        xs -> Just (mconcat xs ++ "the actual headers were:\n" ++ unlines (map formatHeader headers))
      where
        go = catMaybes . map (\(MatchHeader p) -> p headers body)

    (<:>) :: HeaderName -> ByteString -> MatchHeader
    name <:> value = MatchHeader $ \headers _body -> guard (header `notElem` headers) >> (Just . unlines) [
        "missing header:"
      , formatHeader header
      ]
      where
        header = (name, value)