snap-core 0.5.1.4 → 0.5.2
raw patch · 10 files changed
+226/−55 lines, 10 filesdep ~enumerator
Dependency ranges changed: enumerator
Files
- snap-core.cabal +2/−2
- src/Snap/Internal/Types.hs +74/−16
- src/Snap/Iteratee.hs +2/−2
- src/Snap/Types.hs +1/−0
- src/Snap/Util/FileUploads.hs +41/−15
- src/Snap/Util/GZip.hs +5/−1
- test/snap-core-testsuite.cabal +2/−2
- test/suite/Snap/Types/Tests.hs +61/−9
- test/suite/Snap/Util/FileUploads/Tests.hs +6/−1
- test/suite/Snap/Util/GZip/Tests.hs +32/−7
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.5.1.4+version: 0.5.2 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -138,7 +138,7 @@ deepseq >= 1.1 && <1.2, directory, dlist >= 0.5 && < 0.6,- enumerator >= 0.4.8 && < 0.5,+ enumerator >= 0.4.13.1 && < 0.5, filepath, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*,
src/Snap/Internal/Types.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Types where -------------------------------------------------------------------------------import "MonadCatchIO-transformers" Control.Monad.CatchIO- import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 import Control.Applicative-import Control.Exception (throwIO, ErrorCall(..))+import Control.Exception (SomeException, throwIO, ErrorCall(..)) import Control.Monad+import Control.Monad.CatchIO import Control.Monad.State import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S@@ -181,7 +181,11 @@ catch (Snap m) handler = Snap $ do x <- try m case x of- (Left e) -> let (Snap z) = handler e in z+ (Left e) -> do+ rethrowIfTermination $ fromException e+ maybe (throw e)+ (\e' -> let (Snap z) = handler e' in z)+ (fromException e) (Right y) -> return y block (Snap m) = Snap $ block m@@ -189,6 +193,14 @@ ------------------------------------------------------------------------------+rethrowIfTermination :: (MonadCatchIO m) =>+ Maybe ConnectionTerminatedException ->+ m ()+rethrowIfTermination Nothing = return ()+rethrowIfTermination (Just e) = throw e+++------------------------------------------------------------------------------ instance MonadPlus Snap where mzero = Snap $ return PassOnProcessing @@ -242,14 +254,21 @@ ------------------------------------------------------------------------------ -- | Sends the request body through an iteratee (data consumer) and -- returns the result.+--+-- If the iteratee you pass in here throws an exception, Snap will attempt to+-- clear the rest of the unread request body before rethrowing the exception.+-- If your iteratee used 'terminateConnection', however, Snap will give up and+-- immediately close the socket. runRequestBody :: MonadSnap m => Iteratee ByteString IO a -> m a runRequestBody iter = do- req <- getRequest- senum <- liftIO $ readIORef $ rqBody req+ bumpTimeout <- liftM ($ 5) getTimeoutAction+ req <- getRequest+ senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum -- make sure the iteratee consumes all of the output- let iter' = iter >>= \a -> skipToEof >> return a+ let iter' = handle bumpTimeout req+ (iter >>= \a -> skipToEnd bumpTimeout >> return a) -- run the iteratee step <- liftIO $ runIteratee iter'@@ -257,12 +276,30 @@ -- stuff a new dummy enumerator into the request, so you can only try to -- read the request body from the socket once- liftIO $ writeIORef (rqBody req)- (SomeEnumerator $ joinI . take 0 )-+ resetEnum req return result + where+ resetEnum req = liftIO $+ writeIORef (rqBody req) $+ SomeEnumerator $ joinI . take 0 + skipToEnd bump = killIfTooSlow bump 500 5 skipToEof `catchError` \e ->+ throwError $ ConnectionTerminatedException e++ handle bump req =+ (`catches` [+ Handler $ \(e :: ConnectionTerminatedException) -> do+ let en = SomeEnumerator $ const $ throwError e+ liftIO $ writeIORef (rqBody req) en+ throwError e+ , Handler $ \(e :: SomeException) -> do+ resetEnum req+ skipToEnd bump+ throwError e+ ])++ ------------------------------------------------------------------------------ -- | Returns the request body as a bytestring. getRequestBody :: MonadSnap m => m L.ByteString@@ -746,6 +783,27 @@ ------------------------------------------------------------------------------ instance Exception NoHandlerException+++------------------------------------------------------------------------------+data ConnectionTerminatedException = ConnectionTerminatedException SomeException+ deriving (Typeable)+++------------------------------------------------------------------------------+instance Show ConnectionTerminatedException where+ show (ConnectionTerminatedException e) =+ "Connection terminated with exception: " ++ show e+++------------------------------------------------------------------------------+instance Exception ConnectionTerminatedException+++------------------------------------------------------------------------------+-- | Terminate the HTTP session with the given exception.+terminateConnection :: (Exception e, MonadCatchIO m) => e -> m a+terminateConnection = throw . ConnectionTerminatedException . toException ------------------------------------------------------------------------------
src/Snap/Iteratee.hs view
@@ -198,7 +198,7 @@ skipToEof :: (Monad m) => Iteratee a m () skipToEof = continue k where- k EOF = return ()+ k EOF = yield () EOF k _ = skipToEof @@ -724,4 +724,4 @@ ------------------------------------------------------------------------------ getTime :: IO Double-getTime = (fromRational . toRational) `fmap` getPOSIXTime+getTime = realToFrac `fmap` getPOSIXTime
src/Snap/Types.hs view
@@ -17,6 +17,7 @@ , finishWith , catchFinishWith , pass+ , terminateConnection -- ** Routing , method
src/Snap/Util/FileUploads.hs view
@@ -131,8 +131,8 @@ -- function skips processing using 'pass'. -- -- If the client's upload rate passes below the configured minimum (see--- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function throws--- a 'RateTooSlowException'. This setting is there to protect the server+-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function+-- terminates the connection. This setting is there to protect the server -- against slowloris-style denial of service attacks. -- -- If the given 'UploadPolicy' stipulates that you wish form inputs to be@@ -174,15 +174,24 @@ retVal (_,x) = (partInfo, Right x) takeIt maxSize = do+ debug "handleFileUploads/takeIt: begin" let it = fmap retVal $ joinI' $+ iterateeDebugWrapper "takeNoMoreThan" $ takeNoMoreThan maxSize $$ fileReader uploadedFiles tmpdir partInfo - it `catches` [ Handler $ \(_ :: TooManyBytesReadException) ->- (skipToEof >> tooMany maxSize)- , Handler $ \(e :: SomeException) -> throw e- ]+ it `catches` [+ Handler $ \(_ :: TooManyBytesReadException) -> do+ debug $ "handleFileUploads/iter: " +++ "caught TooManyBytesReadException"+ skipToEof+ tooMany maxSize+ , Handler $ \(e :: SomeException) -> do+ debug $ "handleFileUploads/iter: caught " ++ show e+ debug "handleFileUploads/iter: rethrowing"+ throw e+ ] tooMany maxSize = return ( partInfo@@ -215,8 +224,8 @@ -- function skips processing using 'pass'. -- -- If the client's upload rate passes below the configured minimum (see--- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function throws--- a 'RateTooSlowException'. This setting is there to protect the server+-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function+-- terminates the connection. This setting is there to protect the server -- against slowloris-style denial of service attacks. -- -- If the given 'UploadPolicy' stipulates that you wish form inputs to be@@ -261,12 +270,21 @@ procCaptures [] captures where+ rateLimit bump m =+ killIfTooSlow bump+ (minimumUploadRate uploadPolicy)+ (minimumUploadSeconds uploadPolicy)+ m+ `catchError` \e -> do+ debug $ "rateLimit: caught " ++ show e+ let (me::Maybe RateTooSlowException) = fromException e+ maybe (throwError e)+ terminateConnection+ me+ iter bump boundary ph = iterateeDebugWrapper "killIfTooSlow" $- killIfTooSlow- bump- (minimumUploadRate uploadPolicy)- (minimumUploadSeconds uploadPolicy)- (internalHandleMultipart boundary ph)+ rateLimit bump $+ internalHandleMultipart boundary ph ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v] @@ -543,10 +561,15 @@ return $ Capture fieldName var handler e = do+ debug $ "captureVariableOrReadFile/handler: caught " ++ show e let m = fromException e :: Maybe TooManyBytesReadException case m of- Nothing -> throwError e- Just _ -> throwError $ PolicyViolationException $+ Nothing -> do+ debug "didn't expect this error, rethrowing"+ throwError e+ Just _ -> do+ debug "rethrowing as PolicyViolationException"+ throwError $ PolicyViolationException $ T.concat [ "form input '" , TE.decodeUtf8 fieldName , "' exceeded maximum permissible size ("@@ -566,6 +589,7 @@ -> PartInfo -> Iteratee ByteString IO (PartInfo, FilePath) fileReader uploadedFiles tmpdir partInfo = do+ debug "fileReader: begin" (fn, h) <- openFileForUpload uploadedFiles tmpdir let i = iterateeDebugWrapper "fileReader" $ iter fn h i `catch` \(e::SomeException) -> throwError e@@ -622,6 +646,7 @@ iterParser pHeadersWithSeparator handler e = do+ debug $ "internalHandleMultipart/takeHeaders: caught " ++ show e let m = fromException e :: Maybe TooManyBytesReadException case m of Nothing -> throwError e@@ -631,6 +656,7 @@ -------------------------------------------------------------------------- iter = do hdrs <- takeHeaders+ debug $ "internalHandleMultipart/iter: got headers" -- are we using mixed? let (contentType, mboundary) = getContentType hdrs
src/Snap/Util/GZip.hs view
@@ -19,6 +19,8 @@ import Data.Attoparsec.Char8 hiding (Done) import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.Char as Char import Data.Maybe import qualified Data.Set as Set import Data.Set (Set)@@ -85,7 +87,7 @@ -- If a content-encoding is already set, do nothing. This prevents -- "withCompression $ withCompression m" from ruining your day. when (not $ isJust $ getHeader "Content-Encoding" resp) $ do- let mbCt = getHeader "Content-Type" resp+ let mbCt = fmap chop $ getHeader "Content-Type" resp debug $ "withCompression', content-type is " ++ show mbCt @@ -97,6 +99,8 @@ getResponse >>= finishWith where+ chop = S.takeWhile (\c -> c /= ';' && not (Char.isSpace c))+ chkAcceptEncoding = do req <- getRequest debug $ "checking accept-encoding"
test/snap-core-testsuite.cabal view
@@ -36,12 +36,12 @@ dlist >= 0.5 && < 0.6, filepath, HUnit >= 1.2 && < 2,- enumerator >= 0.4.7 && <0.5,+ enumerator >= 0.4.13.1 && < 0.5, MonadCatchIO-transformers >= 0.2 && < 0.3, mtl >= 2 && <3, old-locale, old-time,- parallel >= 2.2 && <2.3,+ parallel >= 3 && <4, pureMD5 == 2.1.*, regex-posix >= 0.94.4 && <0.95, test-framework >= 0.3.1 && <0.4,
test/suite/Snap/Types/Tests.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Types.Tests@@ -33,6 +34,7 @@ import Snap.Internal.Types import Snap.Internal.Http.Types import Snap.Iteratee+import qualified Snap.Iteratee as I import Snap.Test.Common @@ -42,6 +44,8 @@ , testEarlyTermination , testCatchFinishWith , testRqBody+ , testRqBodyException+ , testRqBodyTermination , testTrivials , testMethod , testMethods@@ -60,17 +64,19 @@ , testBracketSnap ] -expectException :: IO () -> IO ()+expectException :: IO a -> IO () expectException m = do- r <- (try m :: IO (Either SomeException ()))- let b = either (\e -> show e `using` rdeepseq `seq` True)- (const False) r+ r <- try m+ let b = either (\e -> (show (e::SomeException) `using` rdeepseq)+ `seq` True)+ (const False)+ r assertBool "expected exception" b -expectSpecificException :: Exception e => e -> IO () -> IO ()+expectSpecificException :: Exception e => e -> IO a -> IO () expectSpecificException e0 m = do- r <- (try m :: IO (Either SomeException ()))+ r <- try m let b = either (\se -> isJust $ forceSameType (Just e0) (fromException se))@@ -129,13 +135,16 @@ mkRqWithBody :: IO Request-mkRqWithBody = do- enum <- newIORef $ SomeEnumerator (enumBS "zazzle" >==> enumEOF)+mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF)+++mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request+mkRqWithEnum e = do+ enum <- newIORef $ SomeEnumerator e return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty - testCatchIO :: Test testCatchIO = testCase "types/catchIO" $ do (_,rsp) <- go f@@ -196,6 +205,16 @@ dummy = const $ return () +goEnum :: (forall a . Enumerator ByteString IO a)+ -> Snap b+ -> IO (Request,Response)+goEnum enum m = do+ rq <- mkRqWithEnum enum+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()++ testFail :: Test testFail = testCase "failure" $ expect404 (go pass) @@ -324,6 +343,39 @@ getRequestBody >>= liftIO . putMVar mvar2 g = transformRequestBody returnI+++testRqBodyException :: Test+testRqBodyException = testCase "types/requestBodyException" $ do+ (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr+ bd <- getBody resp++ (SomeEnumerator e) <- readIORef $ rqBody req+ b' <- liftM (S.concat) $ run_ $ e $$ consume+ assertEqual "request body was consumed" "" b'+ assertEqual "response body was produced" "OK" bd++ where+ h0 = runRequestBody $ do+ _ <- I.head+ throw $ ErrorCall "foo"++ hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"+++testRqBodyTermination :: Test+testRqBodyTermination =+ testCase "types/requestBodyTermination" $+ expectException $+ goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr++ where+ h0 = runRequestBody $ do+ _ <- I.head+ terminateConnection $ ErrorCall "foo"++ hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"+ testTrivials :: Test
test/suite/Snap/Util/FileUploads/Tests.hs view
@@ -264,8 +264,13 @@ testSlowEnumerator :: Test testSlowEnumerator = testCase "fileUploads/tooSlow" $ (harness' goSlowEnumerator tmpdir hndl mixedTestBody- `catch` h)+ `catch` h0) where+ h0 (e :: ConnectionTerminatedException) =+ let (ConnectionTerminatedException se) = e+ (me :: Maybe RateTooSlowException) = fromException se+ in maybe (throw e) h me+ h (e :: RateTooSlowException) = e `seq` return () tmpdir = "tempdir_tooslow"
test/suite/Snap/Util/GZip/Tests.hs view
@@ -11,6 +11,7 @@ import qualified Codec.Compression.Zlib as Zlib import Control.Exception hiding (assert) import Control.Monad (liftM)+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as L import Data.Digest.Pure.MD5 import Data.IORef@@ -39,6 +40,7 @@ ------------------------------------------------------------------------------ tests :: [Test] tests = [ testIdentity1+ , testIdentity1_charset , testIdentity2 , testIdentity3 , testIdentity4@@ -157,19 +159,21 @@ noContentType s = modifyResponse $ setResponseBody $ enumBuilder $ fromLazyByteString s +------------------------------------------------------------------------------+withContentType :: ByteString -> L.ByteString -> Snap ()+withContentType ct body =+ modifyResponse $+ setResponseBody (enumBuilder $ fromLazyByteString body) .+ setContentType ct ------------------------------------------------------------------------------ textPlain :: L.ByteString -> Snap ()-textPlain s = modifyResponse $- setResponseBody (enumBuilder $ fromLazyByteString s) .- setContentType "text/plain"+textPlain = withContentType "text/plain" ------------------------------------------------------------------------------ binary :: L.ByteString -> Snap ()-binary s = modifyResponse $- setResponseBody (enumBuilder $ fromLazyByteString s) .- setContentType "application/octet-stream"+binary = withContentType "application/octet-stream" ------------------------------------------------------------------------------@@ -201,7 +205,7 @@ where prop :: L.ByteString -> PropertyM IO () prop s = do- -- if there's no content-type, withCompression should be a no-op+ -- if there's no accept-encoding, withCompression should be a no-op (!_,!rsp) <- liftQ $ goNoHeaders (seqSnap $ withCompression $ textPlain s) assert $ getHeader "Content-Encoding" rsp == Nothing@@ -221,6 +225,27 @@ prop :: L.ByteString -> PropertyM IO () prop s = do (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $ textPlain s)+ assert $ getHeader "Content-Encoding" rsp == Just "gzip"+ assert $ getHeader "Vary" rsp == Just "Accept-Encoding"+ let body = rspBodyToEnum $ rspBody rsp++ c <- liftQ $+ runIteratee stream2stream >>= run_ . body++ let s1 = GZip.decompress c+ assert $ s == s1+++------------------------------------------------------------------------------+testIdentity1_charset :: Test+testIdentity1_charset = testProperty "gzip/identity1_charset" $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = do+ (!_,!rsp) <- liftQ $+ goGZip (seqSnap $ withCompression $+ withContentType "text/plain; charset=utf-8" s) assert $ getHeader "Content-Encoding" rsp == Just "gzip" assert $ getHeader "Vary" rsp == Just "Accept-Encoding" let body = rspBodyToEnum $ rspBody rsp