snap-core 0.5.3.1 → 0.5.4
raw patch · 5 files changed
+109/−26 lines, 5 filesdep +unixdep ~deepseqdep ~unix-compatdep ~vector
Dependencies added: unix
Dependency ranges changed: deepseq, unix-compat, vector
Files
- snap-core.cabal +8/−6
- src/Snap/Util/FileUploads.hs +26/−7
- test/snap-core-testsuite.cabal +8/−6
- test/suite/Snap/Test/Common.hs +6/−3
- test/suite/Snap/Util/FileUploads/Tests.hs +61/−4
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.5.3.1+version: 0.5.4 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -105,7 +105,9 @@ else c-sources: cbits/timefuncs.c include-dirs: cbits- build-depends: bytestring-mmap >= 0.2.2 && <0.3+ build-depends: bytestring-mmap >= 0.2.2 && <0.3,+ unix >= 2.4 && <3.0+ cpp-options: -DUSE_UNIX exposed-modules: Snap.Types,@@ -135,7 +137,7 @@ bytestring-nums, case-insensitive >= 0.2 && < 0.4, containers,- deepseq >= 1.1 && <1.2,+ deepseq >= 1.1 && <1.3, directory, dlist >= 0.5 && < 0.6, enumerator >= 0.4.13.1 && < 0.5,@@ -147,8 +149,8 @@ text >= 0.11 && <0.12, time >= 1.0 && < 1.4, transformers == 0.2.*,- unix-compat == 0.2.*,- vector >= 0.6 && <0.8,+ unix-compat >= 0.2 && <0.4,+ vector >= 0.6 && <0.10, zlib ghc-prof-options: -prof -auto-all@@ -161,4 +163,4 @@ source-repository head type: git- location: http://git.snapframework.com/snap-core.git+ location: git://github.com/snapframework/snap-core.git
src/Snap/Util/FileUploads.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-}@@ -65,6 +66,7 @@ ------------------------------------------------------------------------------ import Control.Arrow import Control.Applicative+import Control.Concurrent.MVar import Control.Exception (SomeException(..)) import Control.Monad import Control.Monad.CatchIO@@ -99,6 +101,10 @@ import Snap.Internal.Parsing import Snap.Types +#ifdef USE_UNIX+import System.FilePath ((</>))+import System.Posix.Temp (mkstemp)+#endif ------------------------------------------------------------------------------ -- | Reads uploaded files into a temporary directory and calls a user handler@@ -845,18 +851,23 @@ -------------------------------------------------------------------------------newtype UploadedFiles = UploadedFiles (IORef UploadedFilesState)+data UploadedFiles = UploadedFiles (IORef UploadedFilesState)+ (MVar ()) ------------------------------------------------------------------------------ newUploadedFiles :: MonadIO m => m UploadedFiles-newUploadedFiles = liftM UploadedFiles $- liftIO $ newIORef emptyUploadedFilesState+newUploadedFiles = liftIO $ do+ r <- newIORef emptyUploadedFilesState+ m <- newMVar ()+ let u = UploadedFiles r m+ addMVarFinalizer m $ cleanupUploadedFiles u+ return u ------------------------------------------------------------------------------ cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()-cleanupUploadedFiles (UploadedFiles stateRef) = liftIO $ do+cleanupUploadedFiles (UploadedFiles stateRef _) = liftIO $ do state <- readIORef stateRef killOpenFile state mapM_ killFile $ _alreadyReadFiles state@@ -877,7 +888,7 @@ UploadedFiles -> FilePath -> m (FilePath, Handle)-openFileForUpload ufs@(UploadedFiles stateRef) tmpdir = liftIO $ do+openFileForUpload ufs@(UploadedFiles stateRef _) tmpdir = liftIO $ do state <- readIORef stateRef -- It should be an error to open a new file with this interface if there@@ -886,7 +897,7 @@ cleanupUploadedFiles ufs throw $ GenericFileUploadException alreadyOpenMsg - fph@(_,h) <- openBinaryTempFile tmpdir "snap-"+ fph@(_,h) <- makeTempFile tmpdir "snap-" hSetBuffering h NoBuffering writeIORef stateRef $ state { _currentFile = Just fph }@@ -900,7 +911,7 @@ ------------------------------------------------------------------------------ closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()-closeActiveFile (UploadedFiles stateRef) = liftIO $ do+closeActiveFile (UploadedFiles stateRef _) = liftIO $ do state <- readIORef stateRef let m = _currentFile state maybe (return ())@@ -916,3 +927,11 @@ eatException :: (MonadCatchIO m) => m a -> m () eatException m = (m >> return ()) `catch` (\(_ :: SomeException) -> return ())+++makeTempFile :: FilePath -> String -> IO (FilePath, Handle)+#ifdef USE_UNIX+makeTempFile fp temp = mkstemp $ fp </> (temp ++ "XXXXXXX")+#else+makeTempFile = openBinaryTempFile+#endif
test/snap-core-testsuite.cabal view
@@ -17,7 +17,9 @@ else c-sources: ../cbits/timefuncs.c include-dirs: ../cbits- build-depends: bytestring-mmap >= 0.2.2 && <0.3+ build-depends: bytestring-mmap >= 0.2.2 && <0.3,+ unix >= 2.4 && <3.0+ cpp-options: -DUSE_UNIX build-depends: QuickCheck >= 2.3.0.2,@@ -31,7 +33,7 @@ case-insensitive >= 0.2 && < 0.4, cereal == 0.3.*, containers,- deepseq >= 1.1 && <1.2,+ deepseq >= 1.1 && <1.3, directory, dlist >= 0.5 && < 0.6, filepath,@@ -43,15 +45,15 @@ old-time, parallel >= 3 && <4, pureMD5 == 2.1.*,- regex-posix >= 0.94.4 && <0.95,- test-framework >= 0.3.1 && <0.4,+ regex-posix >= 0.94.4 && <0.96,+ test-framework >= 0.3.1 && <0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time, transformers,- unix-compat == 0.2.*,- vector >= 0.6 && <0.8,+ unix-compat >= 0.2 && <0.4,+ vector >= 0.6 && <0.10, zlib ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
test/suite/Snap/Test/Common.hs view
@@ -10,11 +10,13 @@ , coverShowInstance , coverTypeableInstance , forceSameType+ , eatException ) where import Control.DeepSeq-import Control.Exception+import Control.Exception (SomeException(..), evaluate) import Control.Monad+import Control.Monad.CatchIO import Control.Monad.Trans import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -43,11 +45,12 @@ c = showList [x] "" -eatException :: IO a -> IO ()+eatException :: (MonadCatchIO m) => m a -> m () eatException a = (a >> return ()) `catch` handler where- handler :: SomeException -> IO ()+ handler :: (MonadCatchIO m) => SomeException -> m () handler _ = return ()+ forceSameType :: a -> a -> a forceSameType _ a = a
test/suite/Snap/Util/FileUploads/Tests.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Util.FileUploads.Tests@@ -9,7 +10,7 @@ import Control.Applicative import Control.Concurrent (threadDelay) import Control.DeepSeq-import Control.Exception (SomeException(..))+import Control.Exception (Exception(..), SomeException(..)) import Control.Monad import Control.Monad.CatchIO import Control.Monad.Trans@@ -19,8 +20,10 @@ import qualified Data.Map as Map import Data.Maybe import qualified Data.Text as T+import Data.Typeable import Prelude hiding (catch) import System.Directory+import System.Mem import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit@@ -30,10 +33,19 @@ import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug import Snap.Internal.Types-import Snap.Util.FileUploads import Snap.Iteratee hiding (map)+import Snap.Test.Common+import Snap.Util.FileUploads + ------------------------------------------------------------------------------+data TestException = TestException+ deriving (Show, Typeable)++instance Exception TestException+++------------------------------------------------------------------------------ tests :: [Test] tests = [ testSuccess1 , testSuccess2@@ -46,6 +58,7 @@ , testWrongContentType , testSlowEnumerator , testTrivials+ , testDisconnectionCleanup ] @@ -302,7 +315,33 @@ 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 (run_ $ 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 @@ -332,6 +371,24 @@ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs enum Nothing POST (1,1) [] "" "/" "/" "/" "" Map.empty+++------------------------------------------------------------------------------+mkDamagedRequest :: ByteString -> IO Request+mkDamagedRequest body = do+ enum <- newIORef $ SomeEnumerator $ enum++ let hdrs = Map.fromList [+ ("Content-type", [S.append "multipart/form-data; boundary="+ boundaryValue])+ ]++ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs+ enum Nothing POST (1,1) [] "" "/" "/"+ "/" "" Map.empty+ where+ enum = enumBS (S.take (S.length body - 1) body) >==> dieNow+ dieNow _ = throw TestException ------------------------------------------------------------------------------