HttpReply.hs

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

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

where

import           Data.ByteString       (ByteString)
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
      , compareBodys (hrBytes direct) (hrBytes proxied)
      , 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


compareBodys :: ByteString -> ByteString -> Maybe HttpReplyMismatch
compareBodys direct proxied =
  let direct' =  replaceAmznTraceId direct
      proxied' = replaceAmznTraceId proxied
      compare' a b
        | a == b = Nothing
        | otherwise = Just $ BodyMismatch a b
  in
    compare' direct' proxied'


replaceAmznTraceId :: ByteString -> ByteString
replaceAmznTraceId x =
  let asLines = C8.lines x
      checkTrace y = "X-Amzn-Trace-Id" `C8.isInfixOf` y
      dropTrace y = if checkTrace y then Nothing else Just y
  in C8.unlines $ catMaybes $ dropTrace <$> asLines