{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ module Snap.Internal.Http.Types.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Parallel.Strategies (rdeepseq, using) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S (concat) import Data.ByteString.Lazy.Char8 () import Data.List (sort) import qualified Data.Map as Map (empty, insert, lookup) import Data.Time.Calendar (Day (ModifiedJulianDay)) import Data.Time.Clock (UTCTime (UTCTime)) import Snap.Internal.Http.Types (Cookie (Cookie), HasHeaders (headers, updateHeaders), Method (CONNECT, DELETE, GET, HEAD, Method, OPTIONS, PATCH, POST, PUT, TRACE), Request (rqCookies, rqIsSecure, rqContentLength, rqParams), Response (rspContentLength, rspStatus, rspStatusReason), addHeader, addResponseCookie, cookieToBS, deleteResponseCookie, emptyResponse, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, rqModifyParams, rqParam, rqSetParam, setContentLength, setContentType, setResponseBody, setResponseCode, setResponseStatus) import Snap.Internal.Parsing (urlDecode) import qualified Snap.Test as Test (buildRequest, get, getResponseBody) import qualified Snap.Types.Headers as H (lookup, set) import qualified System.IO.Streams as Streams (write) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertBool, assertEqual) import Text.Regex.Posix ((=~)) ------------------------------------------------------------------------------ tests :: [Test] tests = [ testTypes , testCookies , testCookieToBS , testUrlDecode , testFormatLogTime , testAddHeader , testHeaderOrd ] ------------------------------------------------------------------------------ mkRq :: IO Request mkRq = Test.buildRequest $ Test.get "/" Map.empty ------------------------------------------------------------------------------ testHeaderOrd :: Test testHeaderOrd = testCase "httpTypes/methodOrd" $ do let methods = [GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH, Method "Foo"] mapM_ (\m -> assertEqual "method" (compare m m) EQ) methods mapM_ (\m -> assertEqual "ord" (compare GET m) LT) $ tail methods assertEqual "ord2" LT (compare (Method "a") (Method "b")) ------------------------------------------------------------------------------ testFormatLogTime :: Test testFormatLogTime = testCase "httpTypes/formatLogTime" $ do b <- formatLogTime 3804938 let re = S.concat [ "^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}" , ":[0-9]{2} (-|\\+)[0-9]{4}$" ] assertBool "formatLogTime" $ b =~ re ------------------------------------------------------------------------------ testAddHeader :: Test testAddHeader = testCase "httpTypes/addHeader" $ do defReq <- mkRq let req = addHeader "foo" "bar" $ addHeader "foo" "baz" defReq let x = getHeader "foo" req assertEqual "addHeader x 2" (Just "baz,bar") x assertEqual "listHeaders" [ ("foo","baz,bar") , ("Host", "localhost") ] $ sort $ listHeaders req let hdrs = updateHeaders (H.set "zzz" "bbb") $ headers req assertEqual "listHeaders 2" [ ("foo", "baz,bar") , ("Host", "localhost") , ("zzz", "bbb") ] (sort (listHeaders $ headers hdrs)) ------------------------------------------------------------------------------ testUrlDecode :: Test testUrlDecode = testCase "httpTypes/urlDecode" $ do assertEqual "bad hex" Nothing $ urlDecode "%qq" ------------------------------------------------------------------------------ testTypes :: Test testTypes = testCase "httpTypes/show" $ do defReq <- mkRq let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $ updateHeaders (H.set "zzz" "bbb") $ rqSetParam "foo" ["bar"] $ defReq let req2 = (addHeader "zomg" "1234" req) { rqCookies = [ cook, cook2 ] , rqIsSecure = True , rqContentLength = Just 10 } let !a = show req `using` rdeepseq let !_ = show req2 `using` rdeepseq -- we don't care about the show instance really, we're just trying to shut -- up hpc assertBool "show" $ a /= b assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req) assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req) assertEqual "lookup 2" (Just "bbb") (H.lookup "zzz" $ headers req) assertEqual "response status" 555 $ rspStatus resp assertEqual "response status reason" "bogus" $ rspStatusReason resp assertEqual "content-length" (Just 4) $ rspContentLength resp bd <- Test.getResponseBody resp assertEqual "response body" "PING" $ bd let !_ = show GET let !_ = GET == POST let !_ = headers $ headers defReq let !_ = show resp2 `using` rdeepseq assertEqual "999" "Unknown" (rspStatusReason resp3) where enum os = Streams.write (Just $ byteString "PING") os >> return os resp = addResponseCookie cook $ setContentLength 4 $ modifyResponseBody id $ setResponseBody enum $ setContentType "text/plain" $ setResponseStatus 555 "bogus" $ emptyResponse !b = show resp `using` rdeepseq resp2 = addResponseCookie cook2 resp resp3 = setResponseCode 999 resp2 utc = UTCTime (ModifiedJulianDay 55226) 0 cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") False False ------------------------------------------------------------------------------ testCookieToBS :: Test testCookieToBS = testCase "httpTypes/cookieToBS" $ do let [b0, b1, b2] = map cookieToBS [cookie0, cookie1, cookie2] assertEqual "cookie0" "foo=bar; HttpOnly" b0 assertEqual "cookie1" "foo=bar; Secure" b1 assertEqual "cookie2" "foo=bar; path=/; expires=Sat, 30 Jan 2010 00:00:00 GMT; domain=.foo.com; HttpOnly" b2 where utc = UTCTime (ModifiedJulianDay 55226) 0 cookie0 = Cookie "foo" "bar" Nothing Nothing Nothing False True cookie1 = Cookie "foo" "bar" Nothing Nothing Nothing True False cookie2 = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True testCookies :: Test testCookies = testCase "httpTypes/cookies" $ do assertEqual "cookie" (Just cook) rCook assertEqual "cookie2" (Just cook2) rCook2 assertEqual "cookie3" (Just cook3) rCook3 assertEqual "empty response cookie3" (Just cook3) rCook3e assertEqual "removed cookie" Nothing nilCook assertEqual "multiple cookies" [cook, cook2] cks assertEqual "cookie modification" (Just cook3) rCook3Mod assertEqual "modify nothing" Nothing (getResponseCookie "boo" resp5) return () where resp = addResponseCookie cook $ setContentType "text/plain" $ emptyResponse f !_ = cook3 resp' = deleteResponseCookie "foo" resp resp'' = modifyResponseCookie "foo" f resp resp2 = addResponseCookie cook2 resp resp3 = addResponseCookie cook3 resp2 resp4 = addResponseCookie cook3 emptyResponse resp5 = modifyResponseCookie "boo" id emptyResponse utc = UTCTime (ModifiedJulianDay 55226) 0 cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") True False cook3 = Cookie "boo" "baz" Nothing Nothing Nothing False False rCook = getResponseCookie "foo" resp nilCook = getResponseCookie "foo" resp' rCook2 = getResponseCookie "zoo" resp2 rCook3 = getResponseCookie "boo" resp3 rCook3e = getResponseCookie "boo" resp4 rCook3Mod = getResponseCookie "boo" resp'' cks = getResponseCookies resp2