HttpReply.hs

{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.HttpReply
  ( HttpReply(..)
  , HttpReplyMismatch(..)
  , compareHttpReplies
  , assertHttpRepliesAreEq
  , assertHttpRepliesDiffer
  )

where

import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as C8
import           Data.List             (intercalate)
import           Data.Maybe            (catMaybes, isJust, isNothing)
import           Network.HTTP.Types    (Header, HeaderName)

import           Data.CaseInsensitive  (original)

data HttpReply =
  HttpReply
  { hrSecure  :: !Bool
  , hrStatus  :: !Int
  , hrHeaders :: ![Header]
  , hrBytes   :: !BS.ByteString
  }

instance Show HttpReply where
  show r = intercalate "\n" $
    [ "Status: " ++ (show . hrStatus) r
    , "Body:"
    , C8.unpack $ hrBytes r
    ] <> (map (show . concatHeader) $ hrHeaders r)
    where
      concatHeader (f, v) = BS.concat [ "  ", original f , ": " , v]

data HttpReplyMismatch
  = StatusMismatch Int Int
  | HeaderMismatch HeaderName (Maybe C8.ByteString) (Maybe C8.ByteString)
  | BodyMismatch BS.ByteString BS.ByteString
  | MissingViaHeader
  | UnexpectedViaHeader
  deriving (Eq)

instance Show HttpReplyMismatch where
  show (StatusMismatch x y)= "HTTP status codes don't match : " ++ show x ++ " /= " ++ show y
  show (HeaderMismatch name x y) = "Header field '" ++ show name ++ "' doesn't match : '" ++ show x ++ "' /= '" ++ show y
  show (BodyMismatch x y) = "HTTP response bodies are different :\n" ++ C8.unpack x ++ "\n-----------\n" ++ C8.unpack y
  show MissingViaHeader = "Error: Proxy connection should contain 'X-Via-Proxy' header."
  show UnexpectedViaHeader = "Error: Direct connection should not contain 'X-Via-Proxy' header."

assertHttpRepliesAreEq :: HttpReply -> HttpReply -> IO ()
assertHttpRepliesAreEq direct proxied = do
  let assertNoMismatches [] = return ()
      assertNoMismatches xs = error $ intercalate "\n" $ map show xs
  assertNoMismatches $ compareHttpReplies direct proxied

assertHttpRepliesDiffer :: HttpReply -> HttpReply -> IO ()
assertHttpRepliesDiffer direct proxied = do
  let assertHasMismatches [] = error "Responses should be different!"
      assertHasMismatches _ = return ()
  assertHasMismatches $ compareHttpReplies direct proxied

compareHttpReplies :: HttpReply -> HttpReply -> [HttpReplyMismatch]
compareHttpReplies direct proxied = catMaybes mbMismatches
  where
    mbMismatches =
      [ compare' hrStatus StatusMismatch
      , compare' hrBytes BodyMismatch
      , missingViaHeader
      , unexpectedViaHeader
      , mismatchedHeader "server"
      , mismatchedHeader "content-type"
      , mismatchedHeader "content-length"
      ]
    wantSecure = hrSecure direct
    maybeHeader n r = lookup n $ hrHeaders r
    compare' f g
      | f direct == f proxied = Nothing
      | otherwise = Just $ g (f direct) (f proxied)
    missingViaHeader
      | not wantSecure && (isJust $ maybeHeader "X-Via-Proxy" direct) = Just UnexpectedViaHeader
      | otherwise = Nothing
    unexpectedViaHeader
      | not wantSecure && (isNothing $ maybeHeader "X-Via-Proxy" proxied) = Just MissingViaHeader
      | otherwise = Nothing
    mismatchedHeader name
      | x' /= y' = Just $ HeaderMismatch name x' y'
      | otherwise = Nothing
        where x' = maybeHeader name direct
              y' = maybeHeader name proxied