{-# 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" $ " 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'] ) ]