snap-core-1.0.5.1: test/Snap/Util/FileServe/Tests.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Util.FileServe.Tests
( tests ) where
------------------------------------------------------------------------------
import Control.Applicative ((<|>))
import Control.Monad (forM_, liftM)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S (break, breakEnd, drop, isInfixOf, pack)
import qualified Data.HashMap.Strict as HashMap (empty, fromList, toList)
import qualified Data.Map as Map (empty)
import Data.Maybe (fromJust, isJust)
import qualified Data.Text as T (unpack)
import Snap.Internal.Core (Snap, fixupResponse, pass, runSnap, writeBS)
import Snap.Internal.Http.Types (Request, Response (rspContentLength, rspStatus), getHeader, setHeader)
import Snap.Internal.Util.FileServe (DirectoryConfig (..), decodeFilePath, defaultMimeTypes, fancyDirectoryConfig, serveDirectory, serveDirectoryWith, serveFile, simpleDirectoryConfig)
import qualified Snap.Test as Test (buildRequest, get, getResponseBody, setQueryStringRaw)
import Snap.Test.Common (expectExceptionH)
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertBool, assertEqual)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
------------------------------------------------------------------------------
------------------------------------------------------------------------------
tests :: [Test]
tests = [ testFooBin
, testFooTxt
, testFooHtml
, testFooBinBinBin
, testDirectoryPasses
, test404s
, testFsSingle
, testFsCfgA
, testFsCfgB
, testFsCfgC
, testFsCfgD
, testFsCfgFancy
, testRangeOK
, testRangeBad
, testMultiRange
, testIfRange
, testBadUrl
, testDecodeFilePath
]
------------------------------------------------------------------------------
expect404 :: IO Response -> IO ()
expect404 m = do
r <- m
assertBool "expected 404" (rspStatus r == 404)
------------------------------------------------------------------------------
expect302 :: ByteString -> IO Response -> IO ()
expect302 p m = do
r <- m
assertBool "expected 302" (rspStatus r == 302)
assertEqual "redir location"
(Just p)
(getHeader "location" r)
------------------------------------------------------------------------------
runIt :: Snap a -> Request -> IO (Request, Response)
runIt m rq = do
(rq', rsp) <- runSnap m d d rq
rsp' <- fixupResponse rq rsp
return (rq', rsp')
where
d = const $ return ()
------------------------------------------------------------------------------
go :: Snap a -> ByteString -> IO Response
go m s = do
rq <- mkRequest s
liftM snd (runIt m rq)
------------------------------------------------------------------------------
goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response
goIfModifiedSince m s lm = do
rq <- mkRequest s
let r = setHeader "if-modified-since" lm rq
liftM snd (runIt m r)
------------------------------------------------------------------------------
goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response
goIfRange m s (start,end) lm = do
rq <- mkRequest s
let r = setHeader "if-range" lm $
setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end)
rq
liftM snd (runIt m r)
------------------------------------------------------------------------------
goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response
goRange m s (start,end) = do
rq' <- mkRequest s
let rq = setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end)
rq'
liftM snd (runIt m rq)
------------------------------------------------------------------------------
goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response
goMultiRange m s (start,end) (start2,end2) = do
rq' <- mkRequest s
let rq = setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end
++ "," ++ show start2 ++ "-" ++ show end2)
rq'
liftM snd (runIt m rq)
------------------------------------------------------------------------------
goRangePrefix :: Snap a -> ByteString -> Int -> IO Response
goRangePrefix m s start = do
rq' <- mkRequest s
let rq = setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-")
rq'
liftM snd (runIt m rq)
------------------------------------------------------------------------------
goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response
goRangeSuffix m s end = do
rq' <- mkRequest s
let rq = setHeader "Range"
(S.pack $ "bytes=-" ++ show end)
rq'
liftM snd (runIt m rq)
------------------------------------------------------------------------------
mkRequest :: ByteString -> IO Request
mkRequest uri = Test.buildRequest $ do
Test.get pathPart Map.empty
Test.setQueryStringRaw queryPart
where
(pathPart, queryPart) = breakQuery uri
breakQuery s = (a, S.drop 1 b)
where
(a,b) = S.break (=='?') s
------------------------------------------------------------------------------
fs :: Snap ()
fs = do
x <- serveDirectory "test/data/fileServe"
return $! x `seq` ()
------------------------------------------------------------------------------
fsSingle :: Snap ()
fsSingle = do
x <- serveFile "test/data/fileServe/foo.html"
return $! x `seq` ()
------------------------------------------------------------------------------
fsCfg :: DirectoryConfig Snap -> Snap ()
fsCfg cfg = do
x <- serveDirectoryWith cfg "test/data/fileServe"
return $! x `seq` ()
------------------------------------------------------------------------------
testFooBin :: Test
testFooBin = testCase "fileServe/foo.bin" $ do
r1 <- go fs "foo.bin"
checkProps "fileServe/foo.bin/default" r1
let !lm = fromJust $ getHeader "last-modified" r1
go fs "foo.bin?blah=blah" >>= checkProps "fileServe/foo.bin/query-string"
-- check last modified stuff
r2 <- goIfModifiedSince fs "foo.bin" lm
assertEqual "foo.bin 304" 304 $ rspStatus r2
r3 <- goIfModifiedSince fs "foo.bin" "Wed, 15 Nov 1995 04:58:08 GMT"
checkProps "fileServe/foo.bin/ifModifiedSince" r3
where
checkProps name r = do
b <- Test.getResponseBody r
assertEqual (name ++ "/contents") "FOO\n" b
assertEqual (name ++ "/content-type")
(Just "application/octet-stream")
(getHeader "content-type" r)
assertEqual (name ++ "/size") (Just 4) (rspContentLength r)
assertBool (name ++ "/last-modified")
(isJust $ getHeader "last-modified" r)
assertEqual (name ++ "/accept-ranges")
(Just "bytes")
(getHeader "accept-ranges" r)
------------------------------------------------------------------------------
testFooTxt :: Test
testFooTxt = testCase "fileServe/foo.txt" $ do
go fs "foo.txt" >>= checkProps "fileServe/foo.txt/default"
go fs "foo.txt?blah=blah" >>= checkProps "fileServe/foo.txt/query"
where
checkProps name r = do
b <- Test.getResponseBody r
assertEqual (name ++ "/contents") "FOO\n" b
assertEqual (name ++ "/content-type")
(Just "text/plain")
(getHeader "content-type" r)
assertEqual (name ++ "/size") (Just 4) (rspContentLength r)
assertBool (name ++ "/last-modified")
(isJust $ getHeader "last-modified" r)
assertEqual (name ++ "/accept-ranges")
(Just "bytes")
(getHeader "accept-ranges" r)
------------------------------------------------------------------------------
testFooHtml :: Test
testFooHtml = testCase "fileServe/foo.html" $ do
go fs "foo.html" >>= checkProps "fileServe/foo.html/default"
go fs "foo.html?bar=bar" >>= checkProps "fileServe/foo.html/query"
where
checkProps name r = do
b <- Test.getResponseBody r
assertEqual (name ++ "/contents") "FOO\n" b
assertEqual (name ++ "/content-type")
(Just "text/html")
(getHeader "content-type" r)
assertEqual (name ++ "/size") (Just 4) (rspContentLength r)
assertBool (name ++ "/last-modified")
(isJust $ getHeader "last-modified" r)
assertEqual (name ++ "/accept-ranges")
(Just "bytes")
(getHeader "accept-ranges" r)
------------------------------------------------------------------------------
testFooBinBinBin :: Test
testFooBinBinBin = testCase "fileServe/foo.bin.bin.bin" $ do
go fs "foo.bin.bin.bin" >>= checkProps "fileServe/foo.bin.bin.bin"
where
checkProps name r = do
b <- Test.getResponseBody r
assertEqual (name ++ "/contents") "FOO\n" b
assertEqual (name ++ "/content-type")
(Just "application/octet-stream")
(getHeader "content-type" r)
assertEqual (name ++ "/size") (Just 4) (rspContentLength r)
assertBool (name ++ "/last-modified")
(isJust $ getHeader "last-modified" r)
assertEqual (name ++ "/accept-ranges")
(Just "bytes")
(getHeader "accept-ranges" r)
------------------------------------------------------------------------------
test404s :: Test
test404s = testCase "fileServe/404s" $ do
expect404 $ go fs "jfldksjflksd"
expect404 $ go fs "dummy/../foo.txt"
expect404 $ go fs "/etc/password"
coverMimeMap
------------------------------------------------------------------------------
printName :: FilePath -> Snap ()
printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c
------------------------------------------------------------------------------
cfgA, cfgB, cfgC, cfgD :: DirectoryConfig Snap
cfgA = DirectoryConfig {
indexFiles = []
, indexGenerator = const pass
, dynamicHandlers = HashMap.empty
, mimeTypes = defaultMimeTypes
, preServeHook = \x -> x `seq` (return $! ())
}
cfgB = DirectoryConfig {
indexFiles = ["index.txt", "altindex.html"]
, indexGenerator = const pass
, dynamicHandlers = HashMap.empty
, mimeTypes = defaultMimeTypes
, preServeHook = \x -> x `seq` (return $! ())
}
cfgC = DirectoryConfig {
indexFiles = ["index.txt", "altindex.html"]
, indexGenerator = printName
, dynamicHandlers = HashMap.empty
, mimeTypes = defaultMimeTypes
, preServeHook = \x -> x `seq` (return $! ())
}
cfgD = DirectoryConfig {
indexFiles = []
, indexGenerator = const pass
, dynamicHandlers = HashMap.fromList [ (".txt", printName) ]
, mimeTypes = defaultMimeTypes
, preServeHook = \x -> x `seq` (return $! ())
}
------------------------------------------------------------------------------
testFsCfgA :: Test
testFsCfgA = testCase "fileServe/cfgA" $ do
let gooo = go (fsCfg cfgA)
-- Named file in the root directory
gooo "foo.bin" >>= checkProps "cfgA1/1" "application/octet-stream"
gooo "foo.bin?blah=blah" >>=
checkProps "cfgA1/2" "application/octet-stream"
-- Missing file in the root directory
expect404 $ gooo "bar.bin"
-- Named file in a subdirectory
gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain"
gooo "mydir2/foo.txt?z=z" >>= checkProps "cfgA1/subdir/2" "text/plain"
-- Missing file in a subdirectory
expect404 $ gooo "mydir2/bar.txt"
-- Request for directory with no trailing slash
expect302 "/mydir1/" $ gooo "mydir1"
-- Request for directory with no trailing slash, with query param
expect302 "/mydir1/?z=z" $ gooo "mydir1?z=z"
-- Request for directory with trailing slash, no index
expect404 $ gooo "mydir1/"
expect404 $ gooo "mydir2/"
-- Request file with trailing slash
expect404 $ gooo "foo.html/"
expect404 $ gooo "mydir2/foo.txt/"
where
checkProps name ct r = do
b <- Test.getResponseBody r
assertEqual (name ++ "/contents") "FOO\n" b
assertEqual (name ++ "/content-type")
(Just ct)
(getHeader "content-type" r)
assertEqual (name ++ "/size") (Just 4) (rspContentLength r)
assertBool (name ++ "/last-modified")
(isJust $ getHeader "last-modified" r)
assertEqual (name ++ "/accept-ranges")
(Just "bytes")
(getHeader "accept-ranges" r)
------------------------------------------------------------------------------
testFsCfgB :: Test
testFsCfgB = testCase "fileServe/cfgB" $ do
let gooo = go (fsCfg cfgB)
-- Request for root directory with index
rB1 <- gooo "mydir1/"
bB1 <- Test.getResponseBody rB1
assertEqual "B1" "INDEX\n" bB1
assertEqual "B1 content-type"
(Just "text/plain")
(getHeader "content-type" rB1)
-- Request for root directory with index, query
rB2 <- gooo "mydir1/?z=z"
bB2 <- Test.getResponseBody rB2
assertEqual "B2" "INDEX\n" bB2
assertEqual "B2 content-type"
(Just "text/plain")
(getHeader "content-type" rB2)
-- Request for root directory with alternate index
rB3 <- gooo "mydir3/"
bB3 <- Test.getResponseBody rB3
assertEqual "B3" "ALTINDEX\n" bB3
assertEqual "B3 content-type"
(Just "text/html")
(getHeader "content-type" rB3)
-- Request for root directory with no index
expect404 $ gooo "mydir2/"
------------------------------------------------------------------------------
testFsCfgC :: Test
testFsCfgC = testCase "fileServe/cfgC" $ do
let gooo = go (fsCfg cfgC)
-- Request for root directory with index
rC1 <- gooo "mydir1/"
bC1 <- Test.getResponseBody rC1
assertEqual "C1" "INDEX\n" bC1
assertEqual "C1 content-type"
(Just "text/plain")
(getHeader "content-type" rC1)
-- Request for root directory with index, query
rC2 <- gooo "mydir1/?z=z"
bC2 <- Test.getResponseBody rC2
assertEqual "C2" "INDEX\n" bC2
assertEqual "C2 content-type"
(Just "text/plain")
(getHeader "content-type" rC2)
-- Request for root directory with generated index
rC3 <- gooo "mydir2/"
bC3 <- Test.getResponseBody rC3
assertEqual "C3" "mydir2" bC3
------------------------------------------------------------------------------
testFsCfgD :: Test
testFsCfgD = testCase "fileServe/cfgD" $ do
-- Request for file with dynamic handler
rD1 <- go (fsCfg cfgD) "mydir2/foo.txt"
bD1 <- Test.getResponseBody rD1
assertEqual "D1" "foo.txt" bD1
------------------------------------------------------------------------------
testFsCfgFancy :: Test
testFsCfgFancy = testCase "fileServe/cfgFancy" $ do
-- Request for directory with autogen index
rE1 <- go (fsCfg fancyDirectoryConfig) "mydir2/"
assertEqual "index-type" (Just "text/html; charset=utf-8")
(getHeader "content-type" rE1)
bE1 <- Test.getResponseBody rE1
assertBool "autogen-sub-index" $
"Directory Listing: /mydir2/" `S.isInfixOf` bE1
assertBool "autogen-sub-parent" $
"<a href='../'" `S.isInfixOf` bE1
assertBool "autogen-sub-dir" $
"<a href='dir/'" `S.isInfixOf` bE1
assertBool "autogen-sub-file" $
"<a href='foo.txt'" `S.isInfixOf` bE1
-- Request for directory with autogen index
rE2 <- go (fsCfg fancyDirectoryConfig) "mydir2/?z=z"
bE2 <- Test.getResponseBody rE2
assertBool "autogen-sub-index" $
"Directory Listing: /mydir2/" `S.isInfixOf` bE2
assertBool "autogen-sub-parent" $
"<a href='../'" `S.isInfixOf` bE2
assertBool "autogen-sub-file" $
"<a href='foo.txt'" `S.isInfixOf` bE2
rE3 <- go (fsCfg fancyDirectoryConfig) "mydir2/foo.txt"
assertEqual "c-t" (Just "text/plain") (getHeader "content-type" rE3)
------------------------------------------------------------------------------
testFsSingle :: Test
testFsSingle = testCase "fileServe/Single" $ do
r1 <- go fsSingle "foo.html"
b1 <- Test.getResponseBody r1
assertEqual "foo.html" "FOO\n" b1
assertEqual "foo.html content-type"
(Just "text/html")
(getHeader "content-type" r1)
assertEqual "foo.html size" (Just 4) (rspContentLength r1)
------------------------------------------------------------------------------
testRangeOK :: Test
testRangeOK = testCase "fileServe/range/ok" $ do
r1 <- goRange fsSingle "foo.html" (1,2)
assertEqual "foo.html 206" 206 $ rspStatus r1
b1 <- Test.getResponseBody r1
assertEqual "foo.html partial" "OO" b1
assertEqual "foo.html partial size" (Just 2) (rspContentLength r1)
assertEqual "foo.html content-range"
(Just "bytes 1-2/4")
(getHeader "Content-Range" r1)
r2 <- goRangeSuffix fsSingle "foo.html" 3
assertEqual "foo.html 206" 206 $ rspStatus r2
assertEqual "c-l" (Just 3) (rspContentLength r2)
assertEqual "c-l hdr" (Just "3") (getHeader "content-length" r2)
b2 <- Test.getResponseBody r2
assertEqual "foo.html partial suffix" "OO\n" b2
r3 <- goRangePrefix fsSingle "foo.html" 2
assertEqual "foo.html 206" 206 $ rspStatus r3
b3 <- Test.getResponseBody r3
assertEqual "foo.html partial prefix" "O\n" b3
------------------------------------------------------------------------------
testMultiRange :: Test
testMultiRange = testCase "fileServe/range/multi" $ do
r1 <- goMultiRange fsSingle "foo.html" (1,2) (3,3)
-- we don't support multiple ranges so it's ok for us to return 200 here;
-- test this behaviour
assertEqual "foo.html 200" 200 $ rspStatus r1
b1 <- Test.getResponseBody r1
assertEqual "foo.html" "FOO\n" b1
------------------------------------------------------------------------------
testRangeBad :: Test
testRangeBad = testCase "fileServe/range/bad" $ do
r1 <- goRange fsSingle "foo.html" (1,17)
assertEqual "bad range" 416 (rspStatus r1)
assertEqual "bad range content-range"
(Just "bytes */4")
(getHeader "Content-Range" r1)
assertEqual "bad range content-length" (Just 0) (rspContentLength r1)
b1 <- Test.getResponseBody r1
assertEqual "bad range empty body" "" b1
r2 <- goRangeSuffix fsSingle "foo.html" 4893
assertEqual "bad suffix range" 416 $ rspStatus r2
------------------------------------------------------------------------------
coverMimeMap :: (Monad m) => m ()
coverMimeMap = Prelude.mapM_ f $ HashMap.toList defaultMimeTypes
where
f (!k,!v) = return $ case k `seq` v `seq` () of () -> ()
------------------------------------------------------------------------------
testIfRange :: Test
testIfRange = testCase "fileServe/range/if-range" $ do
r <- goIfRange fs "foo.bin" (1,2) "Wed, 15 Nov 1995 04:58:08 GMT"
assertEqual "foo.bin 200" 200 $ rspStatus r
b <- Test.getResponseBody r
assertEqual "foo.bin" "FOO\n" b
r2 <- goIfRange fs "foo.bin" (1,2) "Tue, 01 Oct 2030 04:58:08 GMT"
assertEqual "foo.bin 206" 206 $ rspStatus r2
b2 <- Test.getResponseBody r2
assertEqual "foo.bin partial" "OO" b2
r3 <- goIfRange fs "foo.bin" (1,24324) "Tue, 01 Oct 2030 04:58:08 GMT"
assertEqual "foo.bin 200" 200 $ rspStatus r3
b3 <- Test.getResponseBody r3
assertEqual "foo.bin" "FOO\n" b3
------------------------------------------------------------------------------
testBadUrl :: Test
testBadUrl = testCase "fileServe/badUrl" $ do
expectExceptionH $ go (fs <|> error "foo") "%$z%%%%%%%%"
expectExceptionH $ go (fs <|> error "foo") "//etc/passwd"
------------------------------------------------------------------------------
testDirectoryPasses :: Test
testDirectoryPasses = testCase "fileServe/directory-passes" $ do
expectExceptionH $ go (fs <|> error "foo") ""
expectExceptionH $ go (fsCfg simpleDirectoryConfig <|> error "foo") ""
r <- go (fsCfg simpleDirectoryConfig) "foo.txt"
assertEqual "c-t" (Just "text/plain") (getHeader "content-type" r)
------------------------------------------------------------------------------
testDecodeFilePath :: Test
testDecodeFilePath = testCase "fileServe/decodeFilePath" $ do
forM_ table $ \(nm, inp, expected) -> do
out <- (map fromEnum . T.unpack) <$> decodeFilePath inp
assertEqual nm expected out
where
table = [ ("bad" , "\x00\xd8\x00\xd8" , [0, 0xd8, 0, 0xd8] )
, ("bom" , "\xfe\xff" , [0xfe, 0xff] )
, ("ok" , "ok" , [fromEnum 'o',
fromEnum 'k'] )
]