    {-# LANGUAGE ViewPatterns #-}
    module Test.Hspec.Wai.Matcher (
      ResponseMatcher(..)
    , MatchHeader(..)
    , MatchBody(..)
    , Body
    , (<:>)
    , bodyEquals
    , match
    , formatHeader
    ) 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 {
      ResponseMatcher -> Int
    matchStatus :: Int
    , ResponseMatcher -> [MatchHeader]
    matchHeaders :: [MatchHeader]
    , ResponseMatcher -> MatchBody
    matchBody :: MatchBody
    }

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

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

    bodyEquals :: Body -> MatchBody
    bodyEquals :: Body -> MatchBody
    bodyEquals Body
    body = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchBody
    MatchBody (\[(HeaderName, ByteString)]
    _ Body
    actual -> Body -> Body -> Maybe [Char]
    bodyMatcher Body
    actual Body
    body)
      where
        bodyMatcher :: Body -> Body -> Maybe String
        bodyMatcher :: Body -> Body -> Maybe [Char]
    bodyMatcher (Body -> ByteString
    toStrict -> ByteString
    actual) (Body -> ByteString
    toStrict -> ByteString
    expected) = [Char] -> [Char] -> [Char] -> [Char]
    actualExpected [Char]
    "body mismatch:" [Char]
    actual_ [Char]
    expected_ [Char] -> Maybe () -> Maybe [Char]
    forall a b. a -> Maybe b -> Maybe a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (ByteString
    actual ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString
    expected)
          where
            ([Char]
    actual_, [Char]
    expected_) = case (ByteString -> Maybe [Char]
    safeToString ByteString
    actual, ByteString -> Maybe [Char]
    safeToString ByteString
    expected) of
              (Just [Char]
    x, Just [Char]
    y) -> ([Char]
    x, [Char]
    y)
              (Maybe [Char], Maybe [Char])
    _ -> (ByteString -> [Char]
    forall a. Show a => a -> [Char]
    show ByteString
    actual, ByteString -> [Char]
    forall a. Show a => a -> [Char]
    show ByteString
    expected)

    matchAny :: MatchBody
    matchAny :: MatchBody
    matchAny = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchBody
    MatchBody (\[(HeaderName, ByteString)]
    _ Body
    _ -> Maybe [Char]
    forall a. Maybe a
    Nothing)

    instance IsString MatchBody where
      fromString :: [Char] -> MatchBody
    fromString = Body -> MatchBody
    bodyEquals (Body -> MatchBody) -> ([Char] -> Body) -> [Char] -> MatchBody
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Body
    encodeUtf8 (Text -> Body) -> ([Char] -> Text) -> [Char] -> Body
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> Text
    T.pack

    instance IsString ResponseMatcher where
      fromString :: [Char] -> ResponseMatcher
    fromString = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
    ResponseMatcher Int
    200 [] (MatchBody -> ResponseMatcher)
    -> ([Char] -> MatchBody) -> [Char] -> ResponseMatcher
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> MatchBody
    forall a. IsString a => [Char] -> a
    fromString

    instance Num ResponseMatcher where
      fromInteger :: Integer -> ResponseMatcher
    fromInteger Integer
    n = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
    ResponseMatcher (Integer -> Int
    forall a. Num a => Integer -> a
    fromInteger Integer
    n) [] MatchBody
    matchAny
      + :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
    (+) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "ResponseMatcher does not support (+)"
      (-) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "ResponseMatcher does not support (-)"
      * :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
    (*) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "ResponseMatcher does not support (*)"
      abs :: ResponseMatcher -> ResponseMatcher
    abs =    [Char] -> ResponseMatcher -> ResponseMatcher
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "ResponseMatcher does not support `abs`"
      signum :: ResponseMatcher -> ResponseMatcher
    signum = [Char] -> ResponseMatcher -> ResponseMatcher
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "ResponseMatcher does not support `signum`"

    match :: SResponse -> ResponseMatcher -> Maybe String
    match :: SResponse -> ResponseMatcher -> Maybe [Char]
    match (SResponse (Status Int
    status ByteString
    _) [(HeaderName, ByteString)]
    headers Body
    body) (ResponseMatcher Int
    expectedStatus [MatchHeader]
    expectedHeaders (MatchBody [(HeaderName, ByteString)] -> Body -> Maybe [Char]
    bodyMatcher)) = [Maybe [Char]] -> Maybe [Char]
    forall a. Monoid a => [a] -> a
    mconcat [
        [Char] -> [Char] -> [Char] -> [Char]
    actualExpected [Char]
    "status mismatch:" (Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    status) (Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    expectedStatus) [Char] -> Maybe () -> Maybe [Char]
    forall a b. a -> Maybe b -> Maybe a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Int
    status Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Int
    expectedStatus)
      , [(HeaderName, ByteString)] -> Body -> [MatchHeader] -> Maybe [Char]
    checkHeaders [(HeaderName, ByteString)]
    headers Body
    body [MatchHeader]
    expectedHeaders
      , [(HeaderName, ByteString)] -> Body -> Maybe [Char]
    bodyMatcher [(HeaderName, ByteString)]
    headers Body
    body
      ]

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

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

    (<:>) :: HeaderName -> ByteString -> MatchHeader
    HeaderName
    name <:> :: HeaderName -> ByteString -> MatchHeader
    <:> ByteString
    value = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchHeader
    MatchHeader (([(HeaderName, ByteString)] -> Body -> Maybe [Char])
     -> MatchHeader)
    -> ([(HeaderName, ByteString)] -> Body -> Maybe [Char])
    -> MatchHeader
    forall a b. (a -> b) -> a -> b
    $ \[(HeaderName, ByteString)]
    headers Body
    _body -> Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard ((HeaderName, ByteString)
    header (HeaderName, ByteString) -> [(HeaderName, ByteString)] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [(HeaderName, ByteString)]
    headers) Maybe () -> Maybe [Char] -> Maybe [Char]
    forall a b. Maybe a -> Maybe b -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ([Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just ([Char] -> Maybe [Char])
    -> ([[Char]] -> [Char]) -> [[Char]] -> Maybe [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [[Char]] -> [Char]
    unlines) [
        [Char]
    "missing header:"
      , (HeaderName, ByteString) -> [Char]
    formatHeader (HeaderName, ByteString)
    header
      ]
      where
        header :: (HeaderName, ByteString)
    header = (HeaderName
    name, ByteString
    value)