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