happstack-server-6.1.3: tests/Happstack/Server/Tests.hs
-- |HUnit tests and QuickQuick properties for Happstack.Server.*
module Happstack.Server.Tests (allTests) where
import qualified Codec.Compression.GZip as GZ
import qualified Codec.Compression.Zlib as Z
import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
import Control.Concurrent.MVar
import Control.Monad (msum)
import Control.Monad.Trans (liftIO)
import Data.ByteString.Lazy.Char8 (pack, unpack)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart(..), Headers(..), RqBody(Body), HttpVersion(..)
, ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength)
import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse)
import Happstack.Server.Cookie
import Happstack.Server.Internal.Compression
import Happstack.Server.Internal.Cookie
import Happstack.Server.Internal.Multipart
import Happstack.Server.Internal.MessageWrap
import Happstack.Server.SURI(ToSURI(..), SURI(..),path,query)
import Test.HUnit as HU (Test(..),(~:),(~?),(@?=),(@=?), assertEqual, assertFailure)
import Text.ParserCombinators.Parsec
-- |All of the tests for happstack-util should be listed here.
allTests :: Test
allTests =
"happstack-server tests" ~: [ cookieParserTest
, acceptEncodingParserTest
, splitMultipart
, compressFilterResponseTest
]
cookieParserTest :: Test
cookieParserTest =
"cookieParserTest" ~:
[parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"
@?= (Right [
Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False
, Cookie "1" "" "" "cookie2" "value2" False False
])
,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ "
@?= (Right [
Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False
])
,parseCookies " cookie1 = value1 "
@?= (Right [
Cookie "" "" "" "cookie1" "value1" False False
])
,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe "
@?= (Right [
Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False
])
, parseCookies "foo=\"\\\"bar\\\"\""
@?= (Right [
Cookie "" "" "" "foo" "\"bar\"" False False
])
]
acceptEncodingParserTest :: Test
acceptEncodingParserTest =
"acceptEncodingParserTest" ~:
map (\(string, result) -> either (Left . show) Right (parse encodings "" string) @?= (Right result)) acceptEncodings
where
acceptEncodings =
[ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])
, (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)])
, (" ", [])
, (" *", [("*", Nothing)])
, (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)])
, (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)])
, (" x-gzip",[("x-gzip", Nothing)])
]
splitMultipart :: Test
splitMultipart =
"split multipart" ~: assertFailure "update splitMultipart test"
{-
[ Just [pack "1"] @=?
splitParts (pack "boundary")
(pack "beg\r\n--boundary\r\n1\r\n--boundary--\r\nend")
, Just [pack "1\n"] @=?
splitParts (pack "boundary")
(pack "beg\r\n--boundary\r\n1\n\r\n--boundary--\r\nend")
, Just [pack "1\r\n"] @=?
splitParts (pack "boundary")
(pack "beg\r\n--boundary\r\n1\r\n\r\n--boundary--\r\nend")
, Just [pack "1\n\r"] @=?
splitParts (pack "boundary")
(pack "beg\r\n--boundary\r\n1\n\r\r\n--boundary--\r\nend")
, Just [pack "\r\n1\n\r"] @=?
splitParts (pack "boundary")
(pack "beg\r\n--boundary\r\n\r\n1\n\r\r\n--boundary--\r\nend")
]
-}
compressFilterResponseTest :: Test
compressFilterResponseTest =
"compressFilterResponseTest" ~:
[ uncompressedResponse
, uncompressedSendFile
, compressedResponseGZ
, compressedResponseZ
, compressedSendFile
, compressedSendFileNoIdentity
]
mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request
mkRequest method uri cookies headers body =
do let u = toSURI uri
ib <- newEmptyMVar
b <- newMVar (Body body)
return $ Request { rqMethod = method
, rqPaths = (pathEls (path u))
, rqUri = (path u)
, rqQuery = (query u)
, rqInputsQuery = (queryInput u)
, rqInputsBody = ib
, rqCookies = cookies
, rqVersion = HttpVersion 1 1
, rqHeaders = headers
, rqBody = b
, rqPeer = ("",0)
}
compressPart :: ServerPart Response
compressPart =
do compressedResponseFilter
composeFilter noContentLength
msum [ dir "response" $ ok (toResponse "compress Response")
, dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100)
]
uncompressedResponse :: Test
uncompressedResponse =
"uncompressedResponse" ~:
do req <- mkRequest GET "/response" [] Map.empty L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 200
assertEqual "body" (unpack (rsBody res)) "compress Response"
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing
uncompressedSendFile :: Test
uncompressedSendFile =
"uncompressedSendFile" ~:
do req <- mkRequest GET "/sendfile" [] Map.empty L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 200
assertEqual "filepath" (sfFilePath res) "/dev/null"
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing
compressedResponseGZ :: Test
compressedResponseGZ =
"compressedResponseGZ" ~:
do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 200
assertEqual "body" (unpack (GZ.decompress (rsBody res))) ("compress Response")
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"]))
compressedResponseZ :: Test
compressedResponseZ =
"compressedResponseZ" ~:
do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 200
assertEqual "body" (unpack (Z.decompress (rsBody res))) ("compress Response")
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"]))
compressedSendFile :: Test
compressedSendFile =
"compressedSendfile" ~:
do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 200
assertEqual "filepath" (sfFilePath res) "/dev/null"
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing
compressedSendFileNoIdentity :: Test
compressedSendFileNoIdentity =
"compressedSendFileNoIdentity" ~:
do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty
res <- simpleHTTP'' compressPart req
assertEqual "respone code" (rsCode res) 406
assertEqual "body" (unpack (rsBody res)) ""
assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing