snap-core-1.0.5.1: test/Snap/Test/Tests.hs
{-# LANGUAGE OverloadedStrings #-}
module Snap.Test.Tests
( tests
) where
------------------------------------------------------------------------------
import Control.Applicative (Applicative (..))
import Control.Exception (ErrorCall (..), evaluate)
import Control.Monad (MonadPlus (mzero), liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (lift)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.Functor (Functor (fmap, (<$)))
import qualified Data.Map as Map
import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Prelude (Bool (True, False), IO, Int, Maybe (Just, Nothing), Monad (..), Ord (..), const, fail, fromIntegral, return, seq, show, ($), ($!), (*), (.))
import Snap.Core (Cookie (Cookie, cookieExpires), Method (DELETE, GET, HEAD, Method, PATCH, POST, PUT), Request (rqContentLength, rqContextPath, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Snap, expireCookie, extendTimeout, getCookie, getHeader, getParam, logError, readCookie, redirect, runSnap, terminateConnection, writeBS)
import Snap.Internal.Http.Types (Request (..), Response (rspCookies))
import qualified Snap.Internal.Http.Types as T
import Snap.Internal.Test.RequestBuilder (FileData (FileData), MultipartParam (Files, FormData), RequestBuilder, RequestType (DeleteRequest, GetRequest, MultipartPostRequest, RequestWithRawBody, UrlEncodedPostRequest), addCookies, addHeader, buildRequest, delete, evalHandler, get, postMultipart, postRaw, postUrlEncoded, put, requestToString, responseToString, runHandler, setContentType, setHeader, setHttpVersion, setQueryStringRaw, setRequestPath, setRequestType, setSecure)
import Snap.Test (assert404, assertBodyContains, assertRedirect, assertRedirectTo, assertSuccess, getResponseBody)
import Snap.Test.Common (coverShowInstance, expectExceptionH)
import Snap.Util.FileUploads (defaultUploadPolicy, handleMultipart, partContentType, partFieldName, partFileName)
import qualified System.IO.Streams as Streams
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertBool, assertEqual)
import Text.Regex.Posix ((=~))
------------------------------------------------------------------------------
------------------------------------------------------------------------------
tests :: [Test]
tests = [ testDefaultBuild
, testRequestToString
, testSetRequestType
, testSetQueryString
, testSetQueryStringRaw
, testHeaders
, testMisc
, testMultipart
, testPost
, testFormEncoded
, testToString
, testAssert404
, testAssertBodyContains
, testAssertRedirect
, testCookies
, testTerminate
, testTrivials
, testHostName
]
------------------------------------------------------------------------------
testDefaultBuild :: Test
testDefaultBuild = testCase "test/requestBuilder/defaultBuild" $ do
req <- buildRequest $ setRequestType GetRequest
Streams.toList (rqBody req) >>= assertEqual "body" []
assertEqual "pathInfo" "" $ rqPathInfo req
assertEqual "ctx" "/" $ rqContextPath req
assertEqual "uri" "/" $ rqURI req
assertEqual "qs" "" $ rqQueryString req
assertEqual "p1" Map.empty $ rqParams req
assertEqual "p2" Map.empty $ rqQueryParams req
assertEqual "p3" Map.empty $ rqPostParams req
------------------------------------------------------------------------------
testFormEncoded :: Test
testFormEncoded = testCase "test/requestBuilder/postFormEncoded" $ do
req <- buildRequest $ postUrlEncoded "/foo/bar"
$ Map.fromList [("baz", ["qux"])]
assertEqual "post params" [("baz", ["qux"])] $ Map.toList $ rqPostParams req
------------------------------------------------------------------------------
testSetRequestType :: Test
testSetRequestType = testCase "test/requestBuilder/setRequestType" $ do
request1 <- buildRequest $ setRequestType GetRequest
assertEqual "setRequestType/1" GET (rqMethod request1)
request2 <- buildRequest $ setRequestType DeleteRequest
assertEqual "setRequestType/2" DELETE (rqMethod request2)
request3 <- buildRequest $ setRequestType $ RequestWithRawBody PUT "foo"
assertEqual "setRequestType/3/Method" PUT (rqMethod request3)
rqBody3 <- getRqBody request3
assertEqual "setRequestType/3/Body" "foo" rqBody3
request4 <- buildRequest $ setRequestType rt4
assertEqual "setRequestType/4/Method" POST (rqMethod request4)
-- will test correctness of multipart generation code in another test
request5 <- buildRequest $ setRequestType $
UrlEncodedPostRequest $ Map.fromList [("foo", ["foo"])]
assertEqual "setRequestType/5/Method" POST (rqMethod request5)
request6 <- buildRequest $ setRequestType $
RequestWithRawBody (Method "MOVE") "foo"
assertEqual "setRequestType/6/Method" (Method "MOVE") (rqMethod request6)
request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar"
assertEqual "setRequestType/7/Method" PATCH (rqMethod request7)
request8 <- buildRequest $ setRequestType $ RequestWithRawBody HEAD ""
assertEqual "setRequestType/8/Method" HEAD (rqMethod request8)
where
rt4 = MultipartPostRequest [ ("foo", FormData ["foo"])
, ("bar", Files [fd4])
]
fd4 = FileData "bar.txt" "text/plain" "bar"
------------------------------------------------------------------------------
testSetQueryString :: Test
testSetQueryString = testCase "test/requestBuilder/testSetQueryString" $ do
request <- buildRequest $ get "/" params
assertEqual "setQueryString" params $ rqParams request
assertEqual "queryString" "bar=bar&foo=foo&foo=foo2" $
rqQueryString request
where
params = Map.fromList [ ("foo", ["foo", "foo2"])
, ("bar", ["bar"]) ]
------------------------------------------------------------------------------
testSetQueryStringRaw :: Test
testSetQueryStringRaw = testCase "test/requestBuilder/testSetQueryStringRaw" $ do
request <- buildRequest $ do
postUrlEncoded "/" $ Map.fromList [("foo", ["foo0"])]
addCookies [c1, c2]
setQueryStringRaw "foo=foo&foo=foo2&bar=bar"
assertEqual "setQueryStringRaw" params $ rqParams request
assertEqual "cookie" (Just "k=v; k2=v2") $ getHeader "cookie" request
where
c1 = Cookie "k" "v" Nothing Nothing Nothing False False
c2 = Cookie "k2" "v2" Nothing Nothing Nothing False False
params = Map.fromList [ ("foo", ["foo0", "foo", "foo2"])
, ("bar", ["bar"]) ]
------------------------------------------------------------------------------
testHeaders :: Test
testHeaders = testCase "test/requestBuilder/testHeaders" $ do
request <- buildRequest $ do
get "/" Map.empty
setHeader "foo" "foo"
addHeader "bar" "bar"
addHeader "bar" "bar2"
setContentType "image/gif" -- this should get deleted
assertEqual "setHeader" (Just "foo") $ getHeader "foo" request
assertEqual "addHeader" (Just "bar,bar2") $ T.getHeader "bar" request
assertEqual "contentType" Nothing $ T.getHeader "Content-Type" request
assertEqual "contentLength" Nothing $ rqContentLength request
assertEqual "contentLengthHdr" Nothing $ getHeader "Content-Length" request
request2 <- buildRequest $ put "/" "text/zzz" "zzz"
assertEqual "contentType2" (Just "text/zzz") $
T.getHeader "Content-Type" request2
assertEqual "contentLength" (Just 3) $ rqContentLength request2
assertEqual "contentLengthHdr" (Just "3") $
getHeader "Content-Length" request2
------------------------------------------------------------------------------
testMisc :: Test
testMisc = testCase "test/requestBuilder/testMisc" $ do
request <- buildRequest $ do
get "/" Map.empty
setSecure True
setRequestPath "/foo/bar"
assertEqual "secure" True $ rqIsSecure request
assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request
assertEqual "rqURI" "/foo/bar" $ rqURI request
assertEqual "rqContextPath" "/" $ rqContextPath request
assertEqual "rqVersion" (1,1) $ rqVersion request
body <- getRqBody request
assertEqual "body" "" body
request2 <- buildRequest $ do
postRaw "/" "text/zzz" "zzz"
setHttpVersion (1,0)
body2 <- getRqBody request2
assertEqual "body2" "zzz" body2
assertEqual "contentType2" (Just "text/zzz") $
T.getHeader "Content-Type" request2
assertEqual "postRaw" POST $ rqMethod request2
assertEqual "rqVersion2" (1,0) $ rqVersion request2
request3 <- buildRequest $ do
delete "/" Map.empty
setSecure True
setRequestPath "/foo/bar"
assertEqual "secure" True $ rqIsSecure request3
assertEqual "method" DELETE $ rqMethod request3
assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request3
assertEqual "rqURI" "/foo/bar" $ rqURI request3
assertEqual "rqContextPath" "/" $ rqContextPath request3
assertEqual "rqVersion" (1,1) $ rqVersion request3
------------------------------------------------------------------------------
testMultipart :: Test
testMultipart = testCase "test/requestBuilder/testMultipart" $ do
request0 <- buildRequest rq
(request,rbody) <- peekRqBody request0
assertEqual "content-length" (Just (fromIntegral $ S.length rbody)) $
rqContentLength request
(_,response) <- runSnap handler (const $ return $! ())
(const $ return $! ())
request
body <- getResponseBody response
assertEqual "body" "OK" body
where
partHandler pinfo stream = do
let field = partFieldName pinfo
let fn = partFileName pinfo
let ct = partContentType pinfo
body <- liftM S.concat $ Streams.toList stream
return (field, fn, ct, body)
expectedParts = [ ("bar", Just "bar1.txt", "text/plain", "bar")
, ("bar", Just "bar2.txt", "text/zzz", "bar2")
, ("baz", Just "baz.gif", "text/gif", "baz") ]
handler = do
parts <- handleMultipart defaultUploadPolicy partHandler
fooParam <- getParam "foo"
liftIO $ assertEqual "param" (Just "oof") fooParam
quuxParams <- getParam "quux"
liftIO $ assertEqual "quux" (Just "quux1 quux2") quuxParams
liftIO $ assertEqual "parts" expectedParts parts
writeBS "OK"
rq = postMultipart "/" rt
rt = [ ("foo", FormData ["oof"])
, ("bar", Files [fb1, fb2])
, ("baz", Files [fz])
, ("zzz", Files [])
, ("zz0", FormData [])
, ("quux", FormData ["quux1", "quux2"])
]
fb1 = FileData "bar1.txt" "text/plain" "bar"
fb2 = FileData "bar2.txt" "text/zzz" "bar2"
fz = FileData "baz.gif" "text/gif" "baz"
------------------------------------------------------------------------------
testPost :: Test
testPost = testCase "test/requestBuilder/testPost" $ do
request <- buildRequest $ do
postUrlEncoded "/" $ Map.fromList [("foo", ["foo1", "foo2"])]
body <- getRqBody request
assertEqual "body" "foo=foo1&foo=foo2" body
assertEqual "len" (Just (fromIntegral $ S.length body))
(rqContentLength request)
assertEqual "contentType" (Just "application/x-www-form-urlencoded") $
getHeader "Content-Type" request
------------------------------------------------------------------------------
testToString :: Test
testToString = testCase "test/requestBuilder/testToString" $ do
rsp <- runHandler rq h
http <- responseToString rsp
body <- getResponseBody rsp
out2 <- evalHandler rq h
assertSuccess rsp
assertEqual "Close" (Just "close") $ getHeader "connection" rsp
assertEqual "HTTP body" "zzz" body
assertBool "HTTP header" $ http =~ headRE
assertBool "HTTP date" $ http =~ dateRE
assertEqual "monadic result" 42 out2
where
rq = do postRaw "/" "text/zzz" "zzz"
setHttpVersion (1,0)
h = do writeBS "zzz"
logError "zzz"
extendTimeout 5
return (42 :: Int)
headRE = "HTTP/1.1 200 OK" :: ByteString
dateRE = S.concat [ "date: [a-zA-Z]+, [0-9]+ [a-zA-Z]+ "
, "[0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT"
]
------------------------------------------------------------------------------
testRequestToString :: Test
testRequestToString = testCase "test/requestBuilder/reqToString" $ do
req1 <- buildRequest $ setRequestType GetRequest
s1 <- requestToString req1
assertBool "HTTP header" $ s1 =~ headRE
req2 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"
setHttpVersion (1,0)
s2 <- requestToString req2
assertBool "HTTP header2" $ s2 =~ postHeadRE
assertBool "HTTP cl" $ s2 =~ ("content-length: 3" :: ByteString)
req3 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"
setHeader "transfer-encoding" "chunked"
s3 <- requestToString req3
assertBool "HTTP chunked" $ "3\r\nzzz\r\n0\r\n\r\n" `S.isSuffixOf` s3
where
headRE = "^GET / HTTP/1.1\r\n" :: ByteString
postHeadRE = "^POST / HTTP/1.0\r\n" :: ByteString
------------------------------------------------------------------------------
testAssert404 :: Test
testAssert404 = testCase "test/requestBuilder/testAssert404" $ do
rsp <- runHandler (get "/" Map.empty) mzero
assert404 rsp
expectExceptionH $ assertSuccess rsp
expectExceptionH $ assertBodyContains "fjlkdja" rsp
expectExceptionH $ assertRedirectTo "/zzzzz" rsp
expectExceptionH $ assertRedirect rsp
rsp2 <- runHandler (get "/" Map.empty) (return ())
assertSuccess rsp2
expectExceptionH $ assert404 rsp2
------------------------------------------------------------------------------
testAssertBodyContains :: Test
testAssertBodyContains =
testCase "test/requestBuilder/testAssertBodyContains" $ do
rsp <- runHandler (get "/" Map.empty) $ do
writeBS "RESPONSE IS OK"
assertBodyContains "NSE IS" rsp
------------------------------------------------------------------------------
testAssertRedirect :: Test
testAssertRedirect = testCase "test/requestBuilder/testAssertRedirect" $ do
rsp <- runHandler (get "/" Map.empty) $ redirect "/bar"
assertRedirectTo "/bar" rsp
assertRedirect rsp
expectExceptionH $ assertRedirectTo "/zzzz" rsp
------------------------------------------------------------------------------
testCookies :: Test
testCookies = testCase "test/requestBuilder/cookies" $ do
evalHandler (get "/" Map.empty) (getCookie "foo")
>>= assertEqual "cookie1" Nothing
evalHandler (get "/" Map.empty >> addCookies [c1]) (getCookie "foo")
>>= assertEqual "cookie2" (Just c1)
evalHandler (get "/" Map.empty >> addCookies [c1]) (readCookie "foo")
>>= assertEqual "cookie3" ("bar" :: Text)
expectExceptionH $
evalHandler (get "/" Map.empty >> addCookies [c2])
((readCookie "foo") :: Snap Int)
expectExceptionH $
evalHandler (get "/" Map.empty >> addCookies [c2])
((readCookie "bar") :: Snap Int)
rsp <- runHandler (get "/" Map.empty) expire
let h = Map.lookup "foo" (rspCookies rsp)
assertBool "isJust" (isJust h)
now <- getCurrentTime
let tm = fromJust $ cookieExpires $ fromJust h
assertBool "time" (tm < now)
return $! show tm `seq` ()
-- FIXME(greg): the following test currently fails because we're rendering
-- the set-cookie headers in the server instead of in fixupResponse where
-- it should be happening
-- let h = getHeader "set-cookie" rsp
-- assertBool "isJust" (isJust h)
-- let (Just cookie) = h
-- assertEqual "cookie" "" cookie
where
c1 = Cookie "foo" "bar" Nothing Nothing Nothing False False
c2 = Cookie "foo" "zzzzz" Nothing Nothing Nothing False False
expire = expireCookie c1
------------------------------------------------------------------------------
testTerminate :: Test
testTerminate = testCase "test/requestBuilder/terminate" $
expectExceptionH $
evalHandler (return ()) (terminateConnection $ ErrorCall "foo")
------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "test/requestBuilder/trivials" $ do
coverShowInstance (FormData [])
coverShowInstance (Files [])
coverShowInstance (FileData "" "" "")
coverShowInstance GetRequest
z <- buildRequest $ do
(() <$ (pure () <* rb *> rb2)) >>= lift . evaluate
x <- fmap (*4) (return (3 :: Int))
lift $ assertEqual "fmap" 12 x
expectExceptionH $ buildRequest $ fail "foo"
z `seq` return ()
where
rb = (return ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()
rb2 = (pure ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()
------------------------------------------------------------------------------
testHostName :: Test
testHostName = testCase "test/requestBuilder/hostName" $ do
request <- buildRequest $ do
get "/" Map.empty
setHeader "Host" "just.an.example.com"
assertEqual "HostName" "just.an.example.com" $ rqHostName request
assertEqual "Host header" (Just "just.an.example.com") $ getHeader "host" request
------------------------------------------------------------------------------
getRqBody :: Request -> IO ByteString
getRqBody = liftM S.concat . Streams.toList . rqBody
peekRqBody :: Request -> IO (Request, ByteString)
peekRqBody rq = do
l <- Streams.toList $ rqBody rq
b <- Streams.fromList l
return (rq { rqBody = b }, S.concat l)