wai-extra-3.1.15: test/WaiExtraSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module WaiExtraSpec (spec, toRequest) where
import Codec.Compression.GZip (decompress)
import Control.Applicative ((<|>))
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.IORef as I
import Data.Maybe (fromMaybe)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mempty, mappend)
#endif
#endif
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as T
import Network.HTTP.Types (
Header,
RequestHeaders,
ResponseHeaders,
hContentEncoding,
hContentLength,
hContentType,
partialContent206,
status200,
)
import Network.HTTP.Types.Header (hAcceptEncoding, hVary)
import Network.Wai
import System.Directory (listDirectory)
import System.IO.Temp (withSystemTempDirectory)
import System.Log.FastLogger (fromLogStr)
import Test.HUnit (Assertion, assertBool, assertEqual, (@?=))
import Test.Hspec
import Network.Wai.Header (parseQValueList)
import Network.Wai.Middleware.AcceptOverride (acceptOverride)
import Network.Wai.Middleware.Autohead (autohead)
import Network.Wai.Middleware.Gzip (
GzipFiles (..),
GzipSettings (..),
def,
defaultCheckMime,
gzip,
)
import Network.Wai.Middleware.Jsonp (jsonp)
import Network.Wai.Middleware.MethodOverride (methodOverride)
import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.StreamFile (streamFile)
import Network.Wai.Middleware.Vhost (vhost)
import Network.Wai.Test
import Network.Wai.UrlMap (mapUrls, mount, mountRoot)
spec :: Spec
spec = do
describe "Network.Wai.UrlMap" $ do
mapM_ (uncurry it) casesUrlMap
describe "Network.Wai" $ do
{-
, it "findBound" caseFindBound
, it "sinkTillBound" caseSinkTillBound
, it "killCR" caseKillCR
, it "killCRLF" caseKillCRLF
, it "takeLine" caseTakeLine
-}
it "jsonp" caseJsonp
describe "gzip" $ do
it "gzip" caseGzip
it "more gzip" caseGzip2
it "gzip not on partial content" caseGzipPartial
it "gzip removes length header" caseGzipLength
it "gzip not for MSIE" caseGzipMSIE
it "gzip bypass when precompressed" caseGzipBypassPre
it "defaultCheckMime" caseDefaultCheckMime
it "gzip checking of files" caseGzipFiles
it "vhost" caseVhost
it "autohead" caseAutohead
it "method override" caseMethodOverride
it "method override post" caseMethodOverridePost
it "accept override" caseAcceptOverride
it "debug request body" caseDebugRequestBody
it "stream file" caseStreamFile
it "stream LBS" caseStreamLBS
it "can modify POST params before logging" caseModifyPostParamsInLogs
it "can filter requests in logs" caseFilterRequestsInLogs
it "can parse Q values" caseQValues
toRequest :: S8.ByteString -> S8.ByteString -> SRequest
toRequest ctype content =
SRequest
defaultRequest
{ requestHeaders = [("Content-Type", ctype)]
, requestMethod = "POST"
, rawPathInfo = "/"
, rawQueryString = ""
, queryString = []
}
(L.fromChunks [content])
{-
caseFindBound :: Assertion
caseFindBound = do
findBound "def" "abcdefghi" @?=
FoundBound "abc" "ghi"
findBound "def" "ABC" @?= NoBound
findBound "def" "abcd" @?= PartialBound
findBound "def" "abcdE" @?= NoBound
findBound "def" "abcdEdef" @?=
FoundBound "abcdE" ""
caseSinkTillBound :: Assertion
caseSinkTillBound = do
let iter () _ = return ()
let src = "this is some text"
bound1 = "some"
bound2 = "some!"
let enum = enumList 1 [src]
let helper _ _ = return ()
(_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
res1 @?= True
(_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
res2 @?= False
caseKillCR :: Assertion
caseKillCR = do
"foo" @=? killCR "foo"
"foo" @=? killCR "foo\r"
"foo\r\n" @=? killCR "foo\r\n"
"foo\r'" @=? killCR "foo\r'"
caseKillCRLF :: Assertion
caseKillCRLF = do
"foo" @=? killCRLF "foo"
"foo\r" @=? killCRLF "foo\r"
"foo" @=? killCRLF "foo\r\n"
"foo\r'" @=? killCRLF "foo\r'"
"foo" @=? killCRLF "foo\n"
caseTakeLine :: Assertion
caseTakeLine = do
helper "foo\nbar\nbaz" "foo"
helper "foo\r\nbar\nbaz" "foo"
helper "foo\nbar\r\nbaz" "foo"
helper "foo\rbar\r\nbaz" "foo\rbar"
where
helper haystack needle = do
x <- run_ $ enumList 1 [haystack] $$ takeLine
Just needle @=? x
-}
jsonpApp :: Application
jsonpApp = jsonp $ \_ f ->
f $
responseLBS
status200
[("Content-Type", "application/json")]
"{\"foo\":\"bar\"}"
caseJsonp :: Assertion
caseJsonp = withSession jsonpApp $ do
sres1 <-
request
defaultRequest
{ queryString = [("callback", Just "test")]
, requestHeaders = [("Accept", "text/javascript")]
}
assertContentType "text/javascript" sres1
assertBody "test({\"foo\":\"bar\"})" sres1
sres2 <-
request
defaultRequest
{ queryString = [("call_back", Just "test")]
, requestHeaders = [("Accept", "text/javascript")]
}
assertContentType "application/json" sres2
assertBody "{\"foo\":\"bar\"}" sres2
sres3 <-
request
defaultRequest
{ queryString = [("callback", Just "test")]
, requestHeaders = [("Accept", "text/html")]
}
assertContentType "application/json" sres3
assertBody "{\"foo\":\"bar\"}" sres3
gzipApp :: Application
gzipApp = gzipApp' id
gzipApp' :: (Response -> Response) -> Application
gzipApp' changeRes =
gzip def $ \_ f ->
f . changeRes $
responseLBS
status200
[("Content-Type", "text/plain")]
"test"
gzipAppWithHeaders :: ResponseHeaders -> Application
gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders (hdrs ++)
gzipFileApp :: GzipSettings -> Application
gzipFileApp = flip gzipFileApp' id
gzipJSONFile, gzipNoPreCompressFile :: FilePath
gzipJSONFile = "test/json"
gzipNoPreCompressFile = "test/noprecompress"
gzipJSONBody, gzipNocompressBody :: L.ByteString
#if WINDOWS
gzipJSONBody = "{\"data\":\"this is some data\"}\r\n"
gzipNocompressBody = "noprecompress\r\n"
#else
gzipJSONBody = "{\"data\":\"this is some data\"}\n"
gzipNocompressBody = "noprecompress\n"
#endif
-- | Use 'changeRes' to make r
gzipFileApp' :: GzipSettings -> (Response -> Response) -> Application
gzipFileApp' set changeRes =
gzip set $ \_ f ->
f . changeRes $
responseFile status200 [(hContentType, "application/json")] gzipJSONFile Nothing
acceptGzip :: Header
acceptGzip = (hAcceptEncoding, "gzip")
doesEncodeGzip :: RequestHeaders -> Session SResponse
doesEncodeGzip = doesEncodeGzip' "test"
doesEncodeGzipJSON :: RequestHeaders -> Session SResponse
doesEncodeGzipJSON = doesEncodeGzip' gzipJSONBody
doesEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse
doesEncodeGzipNoPreCompress = doesEncodeGzip' gzipNocompressBody
doesEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse
doesEncodeGzip' body hdrs = do
sres <-
request
defaultRequest
{ requestHeaders = hdrs
}
assertHeader hContentEncoding "gzip" sres
assertHeader hVary "Accept-Encoding" sres
liftIO $ decompress (simpleBody sres) @?= body
pure sres
doesNotEncodeGzip :: RequestHeaders -> Session SResponse
doesNotEncodeGzip = doesNotEncodeGzip' "test"
doesNotEncodeGzipJSON :: RequestHeaders -> Session SResponse
doesNotEncodeGzipJSON = doesNotEncodeGzip' gzipJSONBody
doesNotEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse
doesNotEncodeGzipNoPreCompress = doesNotEncodeGzip' gzipNocompressBody
doesNotEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse
doesNotEncodeGzip' body hdrs = do
sres <-
request
defaultRequest
{ requestHeaders = hdrs
}
assertNoHeader hContentEncoding sres
assertHeader hVary "Accept-Encoding" sres
assertBody body sres
pure sres
caseGzip :: Assertion
caseGzip = do
withSession gzipApp $ do
_ <- doesEncodeGzip [acceptGzip]
_ <- doesNotEncodeGzip []
_ <- doesEncodeGzip [(hAcceptEncoding, "compress , gzip ; q=0.8")]
pure ()
withSession (gzipAppWithHeaders [(hContentLength, "200")]) $ do
sres4 <- doesNotEncodeGzip [acceptGzip]
assertHeader hContentLength "200" sres4
caseGzipLength :: Assertion
caseGzipLength = do
withSession (gzipAppWithHeaders [(hContentLength, "4000")]) $ do
sres <- doesEncodeGzip [acceptGzip]
assertNoHeader hContentLength sres
caseGzipPartial :: Assertion
caseGzipPartial =
withSession partialApp $ do
_ <- doesNotEncodeGzip [acceptGzip]
pure ()
where
partialApp = gzipApp' $ mapResponseStatus $ const partialContent206
-- | Checking that it doesn't compress when already compressed AND
-- doesn't replace already set "Vary" header.
caseGzip2 :: Assertion
caseGzip2 =
withSession gzipVariantApp $ do
sres1 <-
request
defaultRequest
{ requestHeaders = [(hAcceptEncoding, "compress, gzip")]
}
assertHeader hContentEncoding "compress" sres1
assertHeader hVary "Accept-Encoding, foobar" sres1
where
gzipVariantApp =
gzipAppWithHeaders
[ ("Content-Encoding", "compress")
, ("Vary", "foobar")
]
-- | Testing of the GzipSettings's 'GzipFiles' setting
-- with 'ResponseFile' responses.
caseGzipFiles :: Assertion
caseGzipFiles = do
-- Default GzipSettings ignore compressing files
withSession (gzipFileApp def) $ do
_ <- doesNotEncodeGzipJSON [acceptGzip]
_ <- doesNotEncodeGzipJSON []
pure ()
-- Just compresses the file
withSession (gzipFileApp def{gzipFiles = GzipCompress}) $ do
_ <- doesEncodeGzipJSON [acceptGzip]
_ <- doesNotEncodeGzipJSON []
pure ()
-- Checks for a "filename.gz" file in the same folder
withSession (gzipFileApp def{gzipFiles = GzipPreCompressed GzipIgnore}) $ do
sres <-
request
defaultRequest
{ requestHeaders = [acceptGzip]
}
assertHeader hContentEncoding "gzip" sres
assertHeader hVary "Accept-Encoding" sres
-- json.gz has body "test\n"
assertBody
#if WINDOWS
"test\r\n"
#else
"test\n"
#endif
sres
doesNotEncodeGzipJSON [] >> pure ()
-- If no "filename.gz" file is in the same folder, just ignore
withSession (noPreCompressApp $ GzipPreCompressed GzipIgnore) $ do
_ <- doesNotEncodeGzipNoPreCompress [acceptGzip]
_ <- doesNotEncodeGzipNoPreCompress []
pure ()
-- If no "filename.gz" file is in the same folder, just compress
withSession (noPreCompressApp $ GzipPreCompressed GzipCompress) $ do
_ <- doesEncodeGzipNoPreCompress [acceptGzip]
_ <- doesNotEncodeGzipNoPreCompress []
pure ()
-- Using a caching directory
withSystemTempDirectory "gziptest" $ \path -> do
let checkTempDir n s = do
fs <- listDirectory path
assertBool s $ length fs == n
checkTempDir 0 "temp directory should be empty"
-- Respond with "test/json" file
withSession (gzipFileApp def{gzipFiles = GzipCacheFolder path}) $ do
_ <- doesEncodeGzipJSON [acceptGzip]
liftIO $ checkTempDir 1 "should have one file"
_ <- doesEncodeGzipJSON [acceptGzip]
liftIO $ checkTempDir 1 "should still have only one file"
_ <- doesNotEncodeGzipJSON []
liftIO $ checkTempDir 1 "should not have done anything"
-- Respond with "test/noprecompress" file
withSession (noPreCompressApp $ GzipCacheFolder path) $ do
_ <- doesEncodeGzipNoPreCompress [acceptGzip]
liftIO $ checkTempDir 2 "should now have 2 files"
_ <- doesEncodeGzipNoPreCompress [acceptGzip]
liftIO $ checkTempDir 2 "should still only have 2 files"
_ <- doesNotEncodeGzipNoPreCompress []
liftIO $ checkTempDir 2 "again should not have done anything"
-- try "test/json" again, just to make sure it isn't a weird Session bug
withSession (gzipFileApp def{gzipFiles = GzipCacheFolder path}) $ do
_ <- doesEncodeGzipJSON [acceptGzip]
liftIO $ checkTempDir 2 "just to make sure it isn't a fluke"
where
noPreCompressApp set =
gzipFileApp'
def{gzipFiles = set}
$ const
$ responseFile
status200
[(hContentType, "text/plain")]
gzipNoPreCompressFile
Nothing
caseDefaultCheckMime :: Assertion
caseDefaultCheckMime = do
let go x y = (x, defaultCheckMime x) `shouldBe` (x, y)
go "application/json" True
go "application/javascript" True
go "application/something" False
go "text/something" True
go "foo/bar" False
go "application/json; charset=utf-8" True
caseGzipMSIE :: Assertion
caseGzipMSIE = withSession gzipApp $ do
sres1 <-
doesNotEncodeGzip
[ acceptGzip
, ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
]
assertHeader "Vary" "Accept-Encoding" sres1
caseGzipBypassPre :: Assertion
caseGzipBypassPre =
-- Lie a little and don't compress the body. This way we test
-- that the compression is skipped based on the presence of
-- the Content-Encoding header.
withSession (gzipAppWithHeaders [(hContentEncoding, "gzip")]) $ do
sres1 <- request defaultRequest{requestHeaders = [acceptGzip]}
assertHeader "Content-Encoding" "gzip" sres1
assertHeader "Vary" "Accept-Encoding" sres1
assertBody "test" sres1 -- the body is not actually compressed
vhostApp1, vhostApp2, vhostApp :: Application
vhostApp1 _ f = f $ responseLBS status200 [] "app1"
vhostApp2 _ f = f $ responseLBS status200 [] "app2"
vhostApp =
vhost
[ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)
]
vhostApp2
caseVhost :: Assertion
caseVhost = withSession vhostApp $ do
sres1 <-
request
defaultRequest
{ requestHeaders = [("Host", "foo.com")]
}
assertBody "app1" sres1
sres2 <-
request
defaultRequest
{ requestHeaders = [("Host", "bar.com")]
}
assertBody "app2" sres2
autoheadApp :: Application
autoheadApp = autohead $ \_ f ->
f $
responseLBS
status200
[("Foo", "Bar")]
"body"
caseAutohead :: Assertion
caseAutohead = withSession autoheadApp $ do
sres1 <-
request
defaultRequest
{ requestMethod = "GET"
}
assertHeader "Foo" "Bar" sres1
assertBody "body" sres1
sres2 <-
request
defaultRequest
{ requestMethod = "HEAD"
}
assertHeader "Foo" "Bar" sres2
assertBody "" sres2
moApp :: Application
moApp = methodOverride $ \req f ->
f $
responseLBS
status200
[("Method", requestMethod req)]
""
caseMethodOverride :: Assertion
caseMethodOverride = withSession moApp $ do
sres1 <-
request
defaultRequest
{ requestMethod = "GET"
, queryString = []
}
assertHeader "Method" "GET" sres1
sres2 <-
request
defaultRequest
{ requestMethod = "POST"
, queryString = []
}
assertHeader "Method" "POST" sres2
sres3 <-
request
defaultRequest
{ requestMethod = "POST"
, queryString = [("_method", Just "PUT")]
}
assertHeader "Method" "PUT" sres3
mopApp :: Application
mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] ""
caseMethodOverridePost :: Assertion
caseMethodOverridePost = withSession mopApp $ do
-- Get Request are unmodified
sres1 <-
let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
s = simpleRequest r
m = s{requestMethod = "GET"}
b = r{simpleRequest = m}
in srequest b
assertHeader "Method" "GET" sres1
-- Post requests are modified if _method comes first
sres2 <-
srequest $
toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
assertHeader "Method" "PUT" sres2
-- Post requests are unmodified if _method doesn't come first
sres3 <-
srequest $
toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
assertHeader "Method" "POST" sres3
-- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
sres4 <-
srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
assertHeader "Method" "POST" sres4
aoApp :: Application
aoApp = acceptOverride $ \req f ->
f $
responseLBS
status200
[("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)]
""
caseAcceptOverride :: Assertion
caseAcceptOverride = withSession aoApp $ do
sres1 <-
request
defaultRequest
{ queryString = []
, requestHeaders = [("Accept", "foo")]
}
assertHeader "Accept" "foo" sres1
sres2 <-
request
defaultRequest
{ queryString = []
, requestHeaders = [("Accept", "bar")]
}
assertHeader "Accept" "bar" sres2
sres3 <-
request
defaultRequest
{ queryString = [("_accept", Just "baz")]
, requestHeaders = [("Accept", "bar")]
}
assertHeader "Accept" "baz" sres3
caseDebugRequestBody :: Assertion
caseDebugRequestBody = do
withSession (debugApp postOutput) $ do
let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
res <- srequest req
assertStatus 200 res
let qs = "?foo=bar&baz=bin"
withSession (debugApp $ getOutput params) $ do
assertStatus 200
=<< request
defaultRequest
{ requestMethod = "GET"
, queryString = map (\(k, v) -> (k, Just v)) params
, rawQueryString = qs
, requestHeaders = []
, rawPathInfo = "/location"
}
where
params = [("foo", "bar"), ("baz", "bin")]
-- the time cannot be known, so match around it
postOutput = (T.pack $ "POST /\n Params: " ++ show params, "s\n")
getOutput params' =
( "GET /location\n Params: "
<> T.pack (show params')
<> "\n Accept: \n Status: 200 OK 0"
, "s\n"
)
debugApp (beginning, ending) req send = do
iactual <- I.newIORef mempty
middleware <-
mkRequestLogger
def
{ destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)
, outputFormat = Detailed False
}
res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send
actual <- logToBs <$> I.readIORef iactual
actual `shouldSatisfy` S.isPrefixOf begin
actual `shouldSatisfy` S.isSuffixOf end
return res
where
begin = TE.encodeUtf8 $ T.toStrict beginning
end = TE.encodeUtf8 $ T.toStrict ending
logToBs = fromLogStr
{-debugApp = debug $ \req -> do-}
{-return $ responseLBS status200 [ ] ""-}
urlMapTestApp :: Application
urlMapTestApp =
mapUrls $
mount "bugs" bugsApp
<|> mount "helpdesk" helpdeskApp
<|> mount
"api"
( mount "v1" apiV1
<|> mount "v2" apiV2
)
<|> mountRoot mainApp
where
trivialApp :: S.ByteString -> Application
trivialApp name req f =
f $
responseLBS
status200
[ ("content-type", "text/plain")
, ("X-pathInfo", S8.pack . show . pathInfo $ req)
, ("X-rawPathInfo", rawPathInfo req)
, ("X-appName", name)
]
""
bugsApp = trivialApp "bugs"
helpdeskApp = trivialApp "helpdesk"
apiV1 = trivialApp "apiv1"
apiV2 = trivialApp "apiv2"
mainApp = trivialApp "main"
casesUrlMap :: [(String, Assertion)]
casesUrlMap = [pair1, pair2, pair3, pair4]
where
makePair name session = (name, runSession session urlMapTestApp)
get reqPath = request $ setPath defaultRequest reqPath
s = S8.pack . show :: [TS.Text] -> S.ByteString
pair1 = makePair "should mount root" $ do
res1 <- get "/"
assertStatus 200 res1
assertHeader "X-rawPathInfo" "/" res1
assertHeader "X-pathInfo" (s []) res1
assertHeader "X-appName" "main" res1
pair2 = makePair "should mount apps" $ do
res2 <- get "/bugs"
assertStatus 200 res2
assertHeader "X-rawPathInfo" "/" res2
assertHeader "X-pathInfo" (s []) res2
assertHeader "X-appName" "bugs" res2
pair3 = makePair "should preserve extra path info" $ do
res3 <- get "/helpdesk/issues/11"
assertStatus 200 res3
assertHeader "X-rawPathInfo" "/issues/11" res3
assertHeader "X-pathInfo" (s ["issues", "11"]) res3
pair4 = makePair "should 404 if none match" $ do
res4 <- get "/api/v3"
assertStatus 404 res4
testFile :: FilePath
testFile = "test/WaiExtraSpec.hs"
streamFileApp :: Application
streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing
caseStreamFile :: Assertion
caseStreamFile = withSession streamFileApp $ do
sres <- request defaultRequest
assertStatus 200 sres
assertBodyContains "caseStreamFile" sres
assertNoHeader "Transfer-Encoding" sres
streamLBSApp :: Application
streamLBSApp = streamFile $ \_ f ->
f $
responseLBS
status200
[("Content-Type", "text/plain")]
"test"
caseStreamLBS :: Assertion
caseStreamLBS = withSession streamLBSApp $ do
sres <- request defaultRequest
assertStatus 200 sres
assertBody "test" sres
caseModifyPostParamsInLogs :: Assertion
caseModifyPostParamsInLogs = do
let formatUnredacted = DetailedWithSettings $ DetailedSettings False Nothing Nothing False
outputUnredacted = [("username", "some_user"), ("password", "dont_show_me")]
formatRedacted =
DetailedWithSettings $ DetailedSettings False (Just hidePasswords) Nothing False
hidePasswords p@(k, _) = Just $ if k == "password" then (k, "***REDACTED***") else p
outputRedacted = [("username", "some_user"), ("password", "***REDACTED***")]
testLogs formatUnredacted outputUnredacted
testLogs formatRedacted outputRedacted
where
testLogs :: OutputFormat -> [(String, String)] -> Assertion
testLogs format output = withSession (debugApp format output) $ do
let req =
toRequest
"application/x-www-form-urlencoded"
"username=some_user&password=dont_show_me"
res <- srequest req
assertStatus 200 res
postOutputStart params = TE.encodeUtf8 $ T.toStrict $ "POST /\n Params: " <> (T.pack . show $ params)
postOutputEnd = TE.encodeUtf8 $ T.toStrict "s\n"
debugApp format output req send = do
iactual <- I.newIORef mempty
middleware <-
mkRequestLogger
def
{ destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)
, outputFormat = format
}
res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send
actual <- fromLogStr <$> I.readIORef iactual
actual `shouldSatisfy` S.isPrefixOf (postOutputStart output)
actual `shouldSatisfy` S.isSuffixOf postOutputEnd
return res
caseFilterRequestsInLogs :: Assertion
caseFilterRequestsInLogs = do
let formatUnfiltered = DetailedWithSettings $ DetailedSettings False Nothing Nothing False
formatFiltered =
DetailedWithSettings $
DetailedSettings False Nothing (Just hideHealthCheck) False
pathHidden = "/health-check"
pathNotHidden = "/foobar"
-- filter is off
testLogs formatUnfiltered pathNotHidden True
testLogs formatUnfiltered pathHidden True
-- filter is on, path does not match
testLogs formatFiltered pathNotHidden True
-- filter is on, path matches
testLogs formatFiltered pathHidden False
where
testLogs :: OutputFormat -> S8.ByteString -> Bool -> Assertion
testLogs format rpath haslogs = withSession (debugApp format rpath haslogs) $ do
let req = flip SRequest "" $ setPath defaultRequest rpath
res <- srequest req
assertStatus 200 res
hideHealthCheck req _res = pathInfo req /= ["health-check"]
debugApp format rpath haslogs req send = do
iactual <- I.newIORef mempty
middleware <-
mkRequestLogger
def
{ destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)
, outputFormat = format
}
res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send
actual <- fromLogStr <$> I.readIORef iactual
if haslogs
then do
actual `shouldSatisfy` S.isPrefixOf ("GET " <> rpath <> "\n")
actual `shouldSatisfy` S.isSuffixOf "s\n"
else actual `shouldBe` ""
return res
-- | Unit test to make sure 'parseQValueList' works correctly
caseQValues :: Assertion
caseQValues = do
let encodings =
mconcat
-- This has weird white space on purpose, because this
-- should be acceptable according to RFC 7231
[ "deflate, compress; q=0.813 ,gzip ; q=0.9, * ;q=0, "
, "notq;charset=bar, "
, "noq;q=, "
, "toolong;q=0.0023, "
, "toohigh ;q=1.1"
]
qList = parseQValueList encodings
expected =
[ ("deflate", Just 1000)
, ("compress", Just 813)
, ("gzip", Just 900)
, ("*", Just 0)
, ("notq", Nothing)
, ("noq", Nothing)
, ("toolong", Nothing)
, ("toohigh", Nothing)
]
assertEqual "invalid Q values" expected qList