snap-core-1.0.3.0: test/Snap/Util/FileUploads/Tests.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Util.FileUploads.Tests
( tests ) where
------------------------------------------------------------------------------
import Control.Applicative (Alternative ((<|>)), (<$>))
import Control.DeepSeq (deepseq)
import Control.Exception (ErrorCall (..), evaluate, throwIO)
import Control.Exception.Lifted (Exception (fromException, toException), catch, finally, throw)
import Control.Monad (Monad (return, (>>), (>>=)), liftM, void)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef)
import Data.List (foldl', length)
import qualified Data.Map as Map
import Data.Maybe (Maybe (..), fromJust, maybe)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Prelude (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Show (..), const, either, error, filter, map, seq, snd, ($), ($!), (&&), (++), (.))
import Snap.Internal.Core (EscapeSnap (TerminateConnection), Snap, getParam, getPostParam, getQueryParam, runSnap)
import Snap.Internal.Http.Types (Request (rqBody), Response, setHeader)
import Snap.Internal.Util.FileUploads (BadPartException (..), FileUploadException (..), FormFile (..), PartDisposition (..), PartInfo (..), PolicyViolationException (..), allowWithMaximumSize, defaultFileUploadPolicy, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, foldMultipart, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleFileUploads, handleFormUploads, setMaximumFileSize, setMaximumFormInputSize, setMaximumNumberOfFiles, setMaximumNumberOfFormInputs, setMaximumSkippedFileSize, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setSkipFilesWithoutNames, setUploadTimeout, storeAsLazyByteString, toPartDisposition, withTemporaryStore)
import qualified Snap.Test as Test
import Snap.Test.Common (coverEqInstance, coverShowInstance, coverTypeableInstance, eatException, expectExceptionH, seconds, waitabit)
import qualified Snap.Types.Headers as H
import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeDirectoryRecursive, removeFile)
import System.IO.Streams (RateTooSlowException)
import qualified System.IO.Streams as Streams
import System.Mem (performGC)
import System.Timeout (timeout)
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure)
------------------------------------------------------------------------------
------------------------------------------------------------------------------
data TestException = TestException
deriving (Show, Typeable)
instance Exception TestException
------------------------------------------------------------------------------
tests :: [Test]
tests = [ testFoldMultipart1
, testFoldMultipart2
, testFilePolicyViolation1
, testFilePolicyViolation2
, testEmptyNamePolicyViolation
, testEmptyNameStore
, testEmptyNameSkip
, testTemporaryStore
, testTemporaryStoreSafeMove
, testSuccess1
, testSuccess2
, testSuccessUtf8Filename
, testBadParses
, testPerPartPolicyViolation1
, testPerPartPolicyViolation2
, testFormInputsPolicyViolation
, testFormSizePolicyViolation
, testNoFileName
, testNoFileNameTooBig
, testTooManyHeaders
, testNoBoundary
, testNoMixedBoundary
, testWrongContentType
, testSlowEnumerator
, testSlowEnumerator2
, testAbortedBody
, testTrivials
, testDisconnectionCleanup
]
------------------------------------------------------------------------------
testFoldMultipart1 :: Test
testFoldMultipart1 = testCase "fileUploads/fold1" $
void $ go hndl mixedTestBody
where
hndl :: Snap ()
hndl = do
(params, files) <- foldMultipart defaultUploadPolicy hndl' []
let fileMap = foldl' f Map.empty files
liftIO $ assertEqual "2 params returned" 2 (length params)
let [p1, p2] = params
liftIO $ do
let Just (a1, a2, a3) = Map.lookup "file1.txt" fileMap
let Just (b1, b2, b3) = Map.lookup "file2.gif" fileMap
assertEqual "file1 contents"
("text/plain", file1Contents)
(a1, a2)
assertEqual "file1 header 1"
(Just "text/plain")
(H.lookup "content-type" a3)
assertEqual "file1 header 2"
(Just "attachment; filename=\"file1.txt\"")
(H.lookup "content-disposition" a3)
assertEqual "file2 contents"
("image/gif", file2Contents)
(b1, b2)
assertEqual "file2 header 1"
(Just "image/gif")
(H.lookup "content-type" b3)
assertEqual "file2 header 2"
(Just "attachment; filename=\"file2.gif\"")
(H.lookup "content-disposition" b3)
assertEqual "field1 contents"
("field1", formContents1)
p1
assertEqual "field2 contents"
("field2", formContents2)
p2
f mp (fn, ct, x, hdrs) = Map.insert fn (ct,x,hdrs) mp
hndl' partInfo istream acc = do
let
fn = fromJust $ partFileName partInfo
ct = partContentType partInfo
hdrs = partHeaders partInfo
body <- S.concat <$> Streams.toList istream
return (acc ++ [(fn, ct, body, hdrs)])
------------------------------------------------------------------------------
testFoldMultipart2 :: Test
testFoldMultipart2 = testCase "fileUploads/fold2" $
void $ go hndl mixedTestBody
where
policy = setProcessFormInputs False defaultUploadPolicy
hndl = do
(fields, fileCount) <- foldMultipart policy hndl' (0::Int)
liftIO $ do
assertEqual "num params" 4 fileCount
assertEqual "num processed" 0 (length fields)
hndl' !_ !_ !acc = return $ acc + 1
------------------------------------------------------------------------------
testFilePolicyViolation1 :: Test
testFilePolicyViolation1 = testCase "fileUploads/filePolicyViolation1" $
assertThrows (go hndl mixedTestBody) h
where
h e = assertIsFileSizeException e
hndl = handleFormUploads defaultUploadPolicy
(setMaximumFileSize 0 defaultFileUploadPolicy)
(const storeAsLazyByteString)
------------------------------------------------------------------------------
testFilePolicyViolation2 :: Test
testFilePolicyViolation2 = testCase "fileUploads/filePolicyViolation2" $
assertThrows (go hndl mixedTestBody) h
where
h (PolicyViolationException r) =
assertBool "correct exception"
(T.isInfixOf "number of files exceeded the maximum" r)
hndl = handleFormUploads defaultUploadPolicy
(setMaximumNumberOfFiles 0 defaultFileUploadPolicy)
(const storeAsLazyByteString)
------------------------------------------------------------------------------
testEmptyNamePolicyViolation :: Test
testEmptyNamePolicyViolation = testCase "fileUploads/emptyNamePolicyViolation" $
assertThrows (go hndl noFileNameTestBody) h
where
h e = assertIsFileSizeException e
hndl = handleFormUploads defaultUploadPolicy
(setSkipFilesWithoutNames True defaultFileUploadPolicy)
(const storeAsLazyByteString)
------------------------------------------------------------------------------
assertIsFileSizeException :: PolicyViolationException -> Assertion
assertIsFileSizeException (PolicyViolationException r) =
assertBool "file size exception"
(T.isInfixOf "File" r &&
T.isInfixOf "exceeded maximum allowable size" r)
------------------------------------------------------------------------------
testEmptyNameStore :: Test
testEmptyNameStore = testCase "fileUploads/emptyNameStore" $
void $ go hndl noFileNameTestBody
where
hndl = do
(inputs, files) <- handleFormUploads defaultUploadPolicy
(setSkipFilesWithoutNames False defaultFileUploadPolicy)
(const storeAsLazyByteString)
liftIO $ do
assertEqual "got both files" 2 (length files)
let [f1, f2] = files
assertEqual "file1 contents"
(FormFile "files" $ L.fromChunks [file1Contents])
f1
assertEqual "file2 contents"
(FormFile "files" $ L.fromChunks [file2Contents])
f2
assertEqual "inputs present" 2 (length inputs)
return ()
------------------------------------------------------------------------------
testEmptyNameSkip :: Test
testEmptyNameSkip = testCase "fileUploads/emptyNameSkip" $
void $ go hndl noFileNameTestBody
where
hndl = do
(inputs, files) <- handleFormUploads defaultUploadPolicy
( setMaximumSkippedFileSize 4000
. setSkipFilesWithoutNames True
$ defaultFileUploadPolicy )
(const storeAsLazyByteString)
liftIO $ do
assertEqual "files skipped" 0 (length files)
assertEqual "inputs present" 2 (length inputs)
return ()
------------------------------------------------------------------------------
testTemporaryStore :: Test
testTemporaryStore = testCase "fileUploads/temporaryStore" $
harness "tempdir1" hndl mixedTestBody
where
hndl = do
(fn1, fn2) <- withTemporaryStore "tempdir1" "upload" $ \store -> do
(inputs, files) <- handleFormUploads defaultUploadPolicy
defaultFileUploadPolicy
(const store)
liftIO $ do
assertEqual "num files" 2 (length files)
assertEqual "inputs present" 2 (length inputs)
let [FormFile name1 fn1, FormFile name2 fn2] = files
fc1 <- liftIO $ S.readFile fn1
fc2 <- liftIO $ S.readFile fn2
assertEqual "file1 content"
("files", file1Contents)
(name1, fc1)
assertEqual "file2 content"
("files", file2Contents)
(name2, fc2)
return (fn1, fn2)
liftIO $ do
ex1 <- doesFileExist fn1
ex2 <- doesFileExist fn2
assertEqual "file1 deleted" False ex1
assertEqual "file2 deleted" False ex2
------------------------------------------------------------------------------
testTemporaryStoreSafeMove :: Test
testTemporaryStoreSafeMove = testCase "fileUploads/temporaryStoreSafeMove" $
harness "tempdir1" hndl mixedTestBody
where
hndl = do
-- should not throw
withTemporaryStore "tempdir1" "upload" $ \store -> do
(_, files) <- handleFormUploads defaultUploadPolicy
defaultFileUploadPolicy
(const store)
liftIO $ do
assertEqual "num files" 2 (length files)
let [FormFile _ fn1, FormFile _ fn2] = files
removeFile fn1
removeFile fn2
------------------------------------------------------------------------------
testSuccess1 :: Test
testSuccess1 = testCase "fileUploads/success1" $
harness tmpdir hndl mixedTestBody
where
tmpdir = "tempdir1"
hndl = do
xs <- handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
let fileMap = foldl' f Map.empty xs
p1 <- getParam "field1"
p1P <- getPostParam "field1"
p1Q <- getQueryParam "field1"
p2 <- getParam "field2"
liftIO $ do
let Just (a1, a2, a3) = Map.lookup "file1.txt" fileMap
let Just (b1, b2, b3) = Map.lookup "file2.gif" fileMap
assertEqual "file1 contents"
("text/plain", file1Contents)
(a1, a2)
assertEqual "file1 header 1"
(Just "text/plain")
(H.lookup "content-type" a3)
assertEqual "file1 header 2"
(Just "attachment; filename=\"file1.txt\"")
(H.lookup "content-disposition" a3)
assertEqual "file2 contents"
("image/gif", file2Contents)
(b1, b2)
assertEqual "file2 header 1"
(Just "image/gif")
(H.lookup "content-type" b3)
assertEqual "file2 header 2"
(Just "attachment; filename=\"file2.gif\"")
(H.lookup "content-disposition" b3)
assertEqual "field1 contents"
(Just formContents1)
p1
assertEqual "field1 POST contents" (Just formContents1) p1P
assertEqual "field1 query contents" Nothing p1Q
assertEqual "field2 contents" (Just formContents2) p2
f mp (fn, ct, x, hdrs) = Map.insert fn (ct,x,hdrs) mp
hndl' partInfo =
either throw
(\fp -> do
x <- liftIO $ S.readFile fp
let fn = fromJust $ partFileName partInfo
let ct = partContentType partInfo
let hdrs = partHeaders partInfo
return (fn, ct, x, hdrs))
------------------------------------------------------------------------------
testSuccess2 :: Test
testSuccess2 = testCase "fileUploads/success2" $
harness tmpdir hndl mixedTestBody
where
tmpdir = "tempdir2"
policy = setProcessFormInputs False defaultUploadPolicy
hndl = do
ref <- liftIO $ newIORef (0::Int)
_ <- handleFileUploads tmpdir
policy
(const $ allowWithMaximumSize 300000)
(hndl' ref)
n <- liftIO $ readIORef ref
liftIO $ assertEqual "num params" 4 n
hndl' !ref !_ !_ = atomicModifyIORef ref (\x -> (x+1, ()))
------------------------------------------------------------------------------
testSuccessUtf8Filename :: Test
testSuccessUtf8Filename = testCase "fileUploads/utf8-filename" $
harness tmpdir hndl utf8FilenameBody
where
tmpdir = "tempdir3"
hndl = do
xs <- handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
liftIO $ assertEqual "filename" [filenameUtf8] xs
hndl' pinfo _ = return $ fromJust $ partFileName pinfo
------------------------------------------------------------------------------
testBadParses :: Test
testBadParses = testCase "fileUploads/badParses" $ do
harness tmpdir hndl mixedTestBodyWithBadTypes
where
tmpdir = "tempdir_bad_types"
hndl = do
xs <- handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
let fileMap = foldl' f Map.empty xs
p1 <- getParam "field1"
p1P <- getPostParam "field1"
p1Q <- getQueryParam "field1"
p2 <- getParam "field2"
pBoo <- getParam "boo"
liftIO $ do
assertEqual "file1 contents"
(Just ("text/plain", file1Contents))
(Map.lookup "file1.txt" fileMap)
assertEqual "file2 contents"
(Just ("text/plain", file2Contents))
(Map.lookup "file2.gif" fileMap)
assertEqual "field1 param contents" (Just formContents1) p1
assertEqual "field1 POST contents" (Just formContents1) p1P
assertEqual "field1 query contents" Nothing p1Q
assertEqual "field2 contents" Nothing p2
assertEqual "boo contents" (Just "boo") pBoo
f mp (fn, ct, x) = Map.insert fn (ct,x) mp
hndl' partInfo =
either throw
(\fp -> do
x <- liftIO $ S.readFile fp
let fn = fromJust $ partFileName partInfo
let ct = partContentType partInfo
return (fn, ct, x))
------------------------------------------------------------------------------
testPerPartPolicyViolation1 :: Test
testPerPartPolicyViolation1 = testCase "fileUploads/perPartPolicyViolation1" $
harness tmpdir hndl mixedTestBody
where
tmpdir = "tempdir_pol1"
hndl = do
_ <- handleFileUploads tmpdir defaultUploadPolicy
(const disallow)
hndl'
p1 <- getParam "field1"
p2 <- getParam "field2"
liftIO $ do
assertEqual "field1 contents"
(Just formContents1)
p1
assertEqual "field2 contents"
(Just formContents2)
p2
hndl' !_ e = either (\i -> show i `deepseq` return $! ())
(const $ error "expected policy violation")
e
------------------------------------------------------------------------------
testPerPartPolicyViolation2 :: Test
testPerPartPolicyViolation2 = testCase "fileUploads/perPartPolicyViolation2" $
harness tmpdir hndl mixedTestBody
where
tmpdir = "tempdir_pol2"
hndl = handleFileUploads tmpdir defaultUploadPolicy
(const $ allowWithMaximumSize 4)
hndl'
hndl' partInfo e = (if partFileName partInfo == Just "file1.txt"
then ePass
else eFail) e
eFail = either (\i -> show i `deepseq` return ())
(const $ error "expected policy violation")
ePass = either (throw)
(\i -> show i `deepseq` return ())
------------------------------------------------------------------------------
testNoFileName :: Test
testNoFileName = testCase "fileUploads/noFileName" $
(harness tmpdir hndl noFileNameTestBody)
where
tmpdir = "tempdir_noname"
hndl = handleFileUploads tmpdir defaultUploadPolicy
(const $ allowWithMaximumSize 400000)
hndl'
hndl' pinfo !_ = do
assertEqual "filename" Nothing $ partFileName pinfo
assertEqual "disposition" DispositionFile $ partDisposition pinfo
------------------------------------------------------------------------------
testNoFileNameTooBig :: Test
testNoFileNameTooBig = testCase "fileUploads/noFileNameTooBig" $
assertThrows (harness tmpdir hndl noFileNameTestBody) h
where
h !(e :: FileUploadException) = do
let r = fileUploadExceptionReason e
assertBool "correct exception"
(T.isInfixOf "File" r &&
T.isInfixOf "exceeded maximum allowable size" r)
tmpdir = "tempdir_noname_toobig"
hndl = handleFileUploads tmpdir defaultUploadPolicy
(const $ allowWithMaximumSize 1)
hndl'
hndl' pinfo !e = do
let (Left !x) = e
coverShowInstance x
assertEqual "filename" Nothing $ partFileName pinfo
assertEqual "disposition" DispositionFile $ partDisposition pinfo
throwIO x
------------------------------------------------------------------------------
testFormSizePolicyViolation :: Test
testFormSizePolicyViolation =
testCase "fileUploads/formSizePolicy" $
assertThrows (harness tmpdir hndl mixedTestBody) h
where
h !(e :: FileUploadException) = do
let r = fileUploadExceptionReason e
assertBool "correct exception"
(T.isInfixOf "form input" r &&
T.isInfixOf "exceeded maximum permissible" r)
tmpdir = "tempdir_formpol"
policy = setMaximumFormInputSize 2 defaultUploadPolicy
hndl = handleFileUploads tmpdir policy
(const $ allowWithMaximumSize 4)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testFormInputsPolicyViolation :: Test
testFormInputsPolicyViolation =
testCase "fileUploads/formInputsPolicy" $
assertThrows (harness tmpdir hndl mixedTestBody) h
where
h !(e :: FileUploadException) = do
let r = fileUploadExceptionReason e
assertBool "correct exception"
(T.isInfixOf "number of form inputs" r &&
T.isInfixOf "exceeded maximum" r)
tmpdir = "tempdir_formpol2"
policy = setMaximumNumberOfFormInputs 0 defaultUploadPolicy
hndl = handleFileUploads tmpdir policy
(\x -> x `seq` allowWithMaximumSize 4000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testNoBoundary :: Test
testNoBoundary = testCase "fileUploads/noBoundary" $
expectExceptionH $
harness' goBadContentType tmpdir hndl mixedTestBody
where
tmpdir = "tempdir_noboundary"
hndl = handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testNoMixedBoundary :: Test
testNoMixedBoundary = testCase "fileUploads/noMixedBoundary" $
expectExceptionH $
harness' go tmpdir hndl badMixedBody
where
tmpdir = "tempdir_mixednoboundary"
hndl = handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testWrongContentType :: Test
testWrongContentType = testCase "fileUploads/wrongContentType" $
expectExceptionH $
harness' goWrongContentType tmpdir hndl mixedTestBody
where
tmpdir = "tempdir_noboundary"
hndl = handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
<|> error "expect fail here"
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testTooManyHeaders :: Test
testTooManyHeaders = testCase "fileUploads/tooManyHeaders" $
assertThrows (harness tmpdir hndl bigHeadersBody) h
where
h (e :: BadPartException) = show e `deepseq` return ()
tmpdir = "tempdir_tooManyHeaders"
hndl = handleFileUploads tmpdir defaultUploadPolicy
(const $ allowWithMaximumSize 4)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testAbortedBody :: Test
testAbortedBody = testCase "fileUploads/abortedBody" $
expectExceptionH $
harness' goAndAbort tmpdir hndl abortedTestBody
where
tmpdir = "tempdir_abort"
hndl = handleFileUploads tmpdir defaultUploadPolicy
(const $ allowWithMaximumSize 400000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testSlowEnumerator :: Test
testSlowEnumerator =
testCase "fileUploads/tooSlow" $
assertThrows (harness' goSlowEnumerator tmpdir hndl mixedTestBody) h0
where
h0 (e :: EscapeSnap) = do
let (TerminateConnection se) = e
(me :: Maybe RateTooSlowException) = fromException se
maybe (throw e) h me
h (e :: RateTooSlowException) = coverShowInstance e
tmpdir = "tempdir_tooslow"
policy = setMinimumUploadRate 200000 $
setMinimumUploadSeconds 2 $
defaultUploadPolicy
hndl = handleFileUploads tmpdir policy
(const $ allowWithMaximumSize 400000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testSlowEnumerator2 :: Test
testSlowEnumerator2 =
testCase "fileUploads/tooSlow2" $
assertThrows (harness' goSlowEnumerator tmpdir hndl mixedTestBody) h0
where
h0 (e :: EscapeSnap) = do
let (TerminateConnection se) = e
(me :: Maybe RateTooSlowException) = fromException se
maybe (throw e) h me
h (e :: RateTooSlowException) = e `seq` return ()
tmpdir = "tempdir_tooslow2"
policy = setUploadTimeout 2 defaultUploadPolicy
hndl = handleFileUploads tmpdir policy
(const $ allowWithMaximumSize 400000)
hndl'
hndl' xs _ = show xs `deepseq` return ()
------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "fileUploads/trivials" $ do
assertEqual "" False $ doProcessFormInputs policy
assertEqual "" 1000 $ getMinimumUploadRate policy
assertEqual "" 1000 $ getMinimumUploadRate defaultUploadPolicy
assertEqual "" 5 $ getMinimumUploadSeconds policy
assertEqual "" 9 $ getUploadTimeout policy
let pvi = PolicyViolationException ""
coverTypeableInstance pvi
evaluate $ ((fromJust $
fromException (toException pvi)) :: PolicyViolationException)
evaluate $ ((fromJust $
fromException (toException pvi)) :: FileUploadException)
let !_ = policyViolationExceptionReason pvi
let bpi = BadPartException ""
coverTypeableInstance bpi
let !_ = badPartExceptionReason bpi
coverShowInstance $ WrappedFileUploadException $ BadPartException ""
coverShowInstance $ PartInfo "" Nothing "" DispositionFile (H.empty)
coverShowInstance $ toPartDisposition ""
coverEqInstance $ DispositionOther ""
let !gfui = WrappedFileUploadException $ BadPartException ""
evaluate $ fileUploadExceptionReason gfui
void $ evaluate
$ getMaximumNumberOfFormInputs
$ setMaximumNumberOfFormInputs 2 policy
where
policy = setProcessFormInputs False $
setMinimumUploadRate 1000 $
setMinimumUploadSeconds 5 $
setUploadTimeout 9 $
defaultUploadPolicy
------------------------------------------------------------------------------
testDisconnectionCleanup :: Test
testDisconnectionCleanup = testCase "fileUploads/disconnectionCleanup" $ do
runTest `finally` removeDirectoryRecursive tmpdir
where
runTest = do
eatException $ removeDirectoryRecursive tmpdir
createDirectoryIfMissing True tmpdir
rq <- mkDamagedRequest mixedTestBody
eatException $ liftM snd (runIt hndl rq)
performGC
dirs <- liftM (filter (\x -> x /= "." && x /= "..")) $
getDirectoryContents tmpdir
assertEqual "files should be cleaned up" [] dirs
tmpdir = "tempdirC"
hndl = handleFileUploads tmpdir
defaultUploadPolicy
(const $ allowWithMaximumSize 300000)
hndl'
hndl' _ _ = return ()
------------------------------------------------------------------------------
harness :: FilePath -> Snap a -> ByteString -> IO ()
harness = harness' go
------------------------------------------------------------------------------
harness' :: (Snap a -> ByteString -> IO Response)
-> FilePath
-> Snap a
-> ByteString
-> IO ()
harness' g tmpdir hndl body = (do
createDirectoryIfMissing True tmpdir
!_ <- g hndl body
return ()) `finally` removeDirectoryRecursive tmpdir
------------------------------------------------------------------------------
assertThrows :: Exception e => IO a -> (e -> IO ()) -> IO ()
assertThrows act handle = catch action handle
where
action = act >> assertFailure "Expected exception to be thrown"
------------------------------------------------------------------------------
mkRequest :: ByteString -> IO Request
mkRequest body = Test.buildRequest $ Test.postRaw "/" ct body
where
ct = S.append "multipart/form-data; boundary=" boundaryValue
------------------------------------------------------------------------------
mkDamagedRequest :: ByteString -> IO Request
mkDamagedRequest body = do
req <- Test.buildRequest $ Test.postRaw "/" ct ""
e <- newIORef False >>= Streams.makeInputStream . enum
return $! req { rqBody = e }
where
ct = S.append "multipart/form-data; boundary=" boundaryValue
enum ref = do
x <- readIORef ref
if x
then throw TestException
else do writeIORef ref True
return $! Just $! S.take (S.length body - 1) body
------------------------------------------------------------------------------
go :: Snap a -> ByteString -> IO Response
go m s = do
rq <- mkRequest s
liftM snd (runIt m rq)
------------------------------------------------------------------------------
goBadContentType :: Snap a -> ByteString -> IO Response
goBadContentType m s = do
rq <- mkRequest s
let rq' = setHeader "Content-Type" "multipart/form-data" rq
liftM snd (runIt m rq')
------------------------------------------------------------------------------
goWrongContentType :: Snap a -> ByteString -> IO Response
goWrongContentType m s = do
rq <- mkRequest s
let rq' = setHeader "Content-Type" "text/plain" rq
liftM snd (runIt m rq')
------------------------------------------------------------------------------
goSlowEnumerator :: Snap a -> ByteString -> IO Response
goSlowEnumerator m s = do
rq <- mkRequest s
e <- Streams.fromGenerator slowInput
let rq' = rq { rqBody = e }
mx <- timeout (20*seconds) (liftM snd (runIt m rq'))
maybe (error "timeout") return mx
where
body = S.unpack s
slowInput = f body
where
f [] = return ()
f (x:xs) = do
liftIO waitabit
Streams.yield $ S.singleton x
f xs
------------------------------------------------------------------------------
goAndAbort :: Snap a -> ByteString -> IO Response
goAndAbort m s = do
rq <- mkRequest s
e <- Streams.fromGenerator generator
let rq' = rq { rqBody = e }
mx <- timeout (20*seconds) (liftM snd (runIt m rq'))
maybe (error "timeout") return mx
where
generator = do
Streams.yield s
liftIO $ throwIO
$ ErrorCall "For in that sleep of death what dreams may come."
------------------------------------------------------------------------------
runIt :: Snap a -> Request -> IO (Request, Response)
runIt m rq = runSnap m d bump rq
where
bump !f = let !_ = f 1 in return $! ()
d :: forall a . Show a => a -> IO ()
d = \x -> show x `deepseq` return ()
------------------------------------------------------------------------------
-- TEST DATA
formContents1 :: ByteString
formContents1 = "form contents 1"
formContents2 :: ByteString
formContents2 = "form contents 2 zzzzzzzzzzzzzzzzzzzz"
file1Contents :: ByteString
file1Contents = "foo"
file2Contents :: ByteString
file2Contents = "... contents of file2.gif ..."
filenameUtf8 :: ByteString
filenameUtf8 = "\xd1\x82\xd0\xb5\xd1\x81\xd1\x82.png" -- "тест.png" as UTF-8
boundaryValue :: ByteString
boundaryValue = "fkjldsakjfdlsafldksjf"
subBoundaryValue :: ByteString
subBoundaryValue = "zjkzjjfjskzjzjkz"
crlf :: ByteString
crlf = "\r\n"
------------------------------------------------------------------------------
mixedTestBody :: ByteString
mixedTestBody =
S.concat
[ "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field1\"\r\n"
, crlf
, formContents1
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field2\"\r\n"
, crlf
, formContents2
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"files\"\r\n"
, "Content-type: multipart/mixed; boundary="
, subBoundaryValue
, crlf
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file1.txt\"\r\n"
, "Content-Type: text/plain\r\n"
, crlf
, file1Contents
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file2.gif\"\r\n"
, "Content-type: image/gif\r\n"
, "Content-Transfer-Encoding: binary\r\n"
, crlf
, file2Contents
, crlf
, "--"
, subBoundaryValue
, "--\r\n"
, "--"
, boundaryValue
, "--\r\n"
]
------------------------------------------------------------------------------
mixedTestBodyWithBadTypes :: ByteString
mixedTestBodyWithBadTypes =
S.concat
[ "--"
, boundaryValue
, crlf
, "content-type: ;\x01;\x01;\x01;\r\n"
, "content-disposition: form-data; name=\"field1\"\r\n\r\n"
, formContents1
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data;\x01;;;\x01 name=\"field2\"\r\n"
, crlf
, formContents2
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: \x01\x01\x01\x01\r\n"
, "Content-type: multipart/mixed; boundary="
, subBoundaryValue
, crlf
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file1.txt\"\r\n"
, "Content-Type: ;\x01;\x01;\x01;\r\n"
, crlf
, file1Contents
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file2.gif\"\r\n"
, "Content-type: ;\x01;\x01;\x01\r\n"
, "Content-Transfer-Encoding: binary\r\n"
, crlf
, file2Contents
, crlf
, "--"
, subBoundaryValue
, "--\r\n"
, "--"
, boundaryValue
, crlf
, "Content-type: multipart/mixed; \x01\x01;;\x01;\r\n"
, "Content-disposition: form-data; name=boo\r\n"
, crlf
, "boo"
, crlf
, "--"
, boundaryValue
, "--\r\n"
]
------------------------------------------------------------------------------
badMixedBody :: ByteString
badMixedBody =
S.concat
[ crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field1\"\r\n"
, crlf
, formContents1
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field2\"\r\n"
, crlf
, formContents2
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"files\"\r\n"
, "Content-type: multipart/mixed"
, crlf
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file1.txt\"\r\n"
, "Content-Type: text/plain\r\n"
, crlf
, file1Contents
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: attachment; filename=\"file2.gif\"\r\n"
, "Content-type: image/gif\r\n"
, "Content-Transfer-Encoding: binary\r\n"
, crlf
, file2Contents
, crlf
, "--"
, subBoundaryValue
, "--\r\n"
, "--"
, boundaryValue
, "--\r\n"
]
------------------------------------------------------------------------------
bigHeadersBody :: ByteString
bigHeadersBody =
S.concat (
[ "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field1\"\r\n" ]
++
map (\i -> S.pack ("field_" ++ show i ++ ": bar\r\n")) [1..40000::Int]
++
[ crlf
, formContents1
, crlf
, "--"
, boundaryValue
, "--\r\n"
])
------------------------------------------------------------------------------
noFileNameTestBody :: ByteString
noFileNameTestBody =
S.concat
[ "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field1\"\r\n"
, crlf
, formContents1
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field2\"\r\n"
, crlf
, formContents2
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"files\"\r\n"
, "Content-type: multipart/mixed; boundary="
, subBoundaryValue
, crlf
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: file\r\n"
, "Content-Type: text/plain\r\n"
, crlf
, file1Contents
, crlf
, "--"
, subBoundaryValue
, crlf
, "Content-disposition: file\r\n"
, "Content-type: image/gif\r\n"
, "Content-Transfer-Encoding: binary\r\n"
, crlf
, file2Contents
, crlf
, "--"
, subBoundaryValue
, "--\r\n"
, "--"
, boundaryValue
, "--\r\n"
]
------------------------------------------------------------------------------
abortedTestBody :: ByteString
abortedTestBody =
S.concat [ "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field1\"\r\n"
, crlf
, formContents1
, crlf
, "--"
, boundaryValue
, crlf
, "content-disposition: form-data; name=\"field2\"\r\n"
, "fdjkljflsdkjfsd"
]
------------------------------------------------------------------------------
utf8FilenameBody :: ByteString
utf8FilenameBody =
S.concat
[ "--"
, boundaryValue
, crlf
, "Content-Disposition: form-data; name=\"file\"; filename=\""
, filenameUtf8
, "\"\r\n"
, "Content-Type: image/png\r\n"
, crlf
, file2Contents
, crlf
, "--"
, boundaryValue
, "--\r\n"
]