diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 1.1.1.2 +version: 1.1.2.0 synopsis: A web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -114,6 +114,7 @@ snap-core >= 1.0 && < 1.1, text >= 0.11 && < 1.3, time >= 1.0 && < 1.11, + transformers >= 0.3 && < 0.6, unix-compat >= 0.2 && < 0.6, vector >= 0.7 && < 0.13 @@ -213,7 +214,7 @@ build-depends: attoparsec, base, - base16-bytestring >= 0.1 && < 0.2, + base16-bytestring >= 0.1 && < 1.1, blaze-builder, bytestring-builder, bytestring, @@ -229,7 +230,7 @@ mtl, network, old-locale, - random >= 1.0 && < 1.2, + random >= 1.0 && < 1.3, snap-core, text, threads >= 0.5 && < 0.6, @@ -331,6 +332,7 @@ io-streams, io-streams-haproxy, snap-core, + transformers, vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields diff --git a/src/Snap/Internal/Http/Server/Parser.hs b/src/Snap/Internal/Http/Server/Parser.hs --- a/src/Snap/Internal/Http/Server/Parser.hs +++ b/src/Snap/Internal/Http/Server/Parser.hs @@ -29,9 +29,9 @@ import Control.Applicative ((<$>)) #endif import Control.Exception (Exception, throwIO) -import qualified Control.Exception as E import Control.Monad (void, when) -import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, skipWhile, take) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, takeTill) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (ByteString (..), c2w, memchr, w2c) #if MIN_VERSION_bytestring(0, 10, 6) @@ -40,9 +40,6 @@ import Data.ByteString.Internal (inlinePerformIO) #endif import qualified Data.ByteString.Unsafe as S -#if !MIN_VERSION_io_streams(1,2,0) -import Data.IORef (newIORef, readIORef, writeIORef) -#endif import Data.List (sort) import Data.Typeable (Typeable) import qualified Data.Vector as V @@ -53,12 +50,12 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Data.ByteString.Builder (Builder) -import System.IO.Streams (InputStream, OutputStream) +import System.IO.Streams (InputStream, OutputStream, Generator) import qualified System.IO.Streams as Streams import System.IO.Streams.Attoparsec (parseFromStream) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types (Method (..)) -import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat, ()) +import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H @@ -351,13 +348,11 @@ readChunkedTransferEncoding :: InputStream ByteString -> IO (InputStream ByteString) readChunkedTransferEncoding input = - Streams.makeInputStream $ parseFromStream pGetTransferChunk input - + Streams.fromGenerator (consumeChunks input) ------------------------------------------------------------------------------ writeChunkedTransferEncoding :: OutputStream Builder -> IO (OutputStream Builder) -#if MIN_VERSION_io_streams(1,2,0) writeChunkedTransferEncoding os = Streams.makeOutputStream f where f Nothing = do @@ -365,50 +360,77 @@ Streams.write Nothing os f x = Streams.write (chunkedTransferEncoding `fmap` x) os -#else -writeChunkedTransferEncoding os = do - -- make sure we only send the terminator once. - eof <- newIORef True - Streams.makeOutputStream $ f eof - where - f eof Nothing = readIORef eof >>= flip when (do - writeIORef eof True - Streams.write (Just chunkedTransferTerminator) os - Streams.write Nothing os) - f _ x = Streams.write (chunkedTransferEncoding `fmap` x) os -#endif - --------------------- -- parse functions -- --------------------- ------------------------------------------------------------------------------ --- We treat chunks larger than this from clients as a denial-of-service attack. --- 256kB should be enough buffer. -mAX_CHUNK_SIZE :: Int -mAX_CHUNK_SIZE = (2::Int)^(18::Int) +{- + For a response body in chunked transfer encoding, iterate over + the individual chunks, reading the size parameter, then + looping over that chunk in bites of at most bUFSIZ, + yielding them to the receiveResponse InputStream accordingly. +-} +consumeChunks :: InputStream ByteString -> Generator ByteString () +consumeChunks i1 = do + !n <- parseSize + if n > 0 + then do + -- read one or more bytes, then loop to next chunk + go n + skipCRLF + consumeChunks i1 + else do + -- NB: snap-server doesn't yet support chunked trailer parts + -- (see RFC7230#sec4.1.2) + -- consume final CRLF + skipCRLF ------------------------------------------------------------------------------- -pGetTransferChunk :: Parser (Maybe ByteString) -pGetTransferChunk = parser "pGetTransferChunk" where - parser = do - !hex <- hexadecimal "hexadecimal" - skipWhile (/= '\r') "skipToEOL" - void crlf "linefeed" - if hex >= mAX_CHUNK_SIZE - then return $! E.throw $! HttpParseException $! - "pGetTransferChunk: chunk of size " ++ show hex ++ " too long." - else if hex <= 0 - then (crlf >> return Nothing) "terminal crlf after 0 length" - else do - -- now safe to take this many bytes. - !x <- take hex "reading data chunk" - void crlf "linefeed after data chunk" - return $! Just x + go 0 = return () + go !n = do + (!x',!r) <- liftIO $ readN n i1 + Streams.yield x' + go r + parseSize = do + liftIO $ parseFromStream transferChunkSize i1 + + skipCRLF = do + liftIO $ void (parseFromStream crlf i1) + + transferChunkSize :: Parser (Int) + transferChunkSize = do + !n <- hexadecimal + -- skip over any chunk extensions (see RFC7230#sec4.1.1) + void (takeTill (== '\r')) + void crlf + return n + + {- + The chunk size coming down from the client is somewhat arbitrary; + it's really just an indication of how many bytes need to be read + before the next size marker or end marker - neither of which has + anything to do with streaming on our side. Instead, we'll feed + bytes into our InputStream at an appropriate intermediate size. + -} + bUFSIZ :: Int + bUFSIZ = 32752 + + {- + Read the specified number of bytes up to a maximum of bUFSIZ, + returning a resultant ByteString and the number of bytes remaining. + -} + readN :: Int -> InputStream ByteString -> IO (ByteString, Int) + readN n input = do + !x' <- Streams.readExactly p input + return (x', r) + where + !d = n - bUFSIZ + !p = if d > 0 then bUFSIZ else n + !r = if d > 0 then d else 0 ------------------------------------------------------------------------------ toLower :: ByteString -> ByteString diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs --- a/src/Snap/Internal/Http/Server/TLS.hs +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -25,9 +25,9 @@ import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL -import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.)) -import Snap.Internal.Http.Server.Address (getAddress, getSockAddr) -import Snap.Internal.Http.Server.Socket (acceptAndInitialize) +import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, not, ($), ($!)) +import Snap.Internal.Http.Server.Address (getAddress) +import Snap.Internal.Http.Server.Socket (acceptAndInitialize, bindSocket) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.SSL as SStreams @@ -98,22 +98,14 @@ bindHttps bindAddress bindPort cert chainCert key = withTLS $ bracketOnError - (do (family, addr) <- getSockAddr bindPort bindAddress - sock <- Socket.socket family Socket.Stream 0 - return (sock, addr) - ) - (Socket.close . fst) - $ \(sock, addr) -> do - Socket.setSocketOption sock Socket.ReuseAddr 1 - Socket.bindSocket sock addr - Socket.listen sock 150 - + (bindSocket bindAddress bindPort) + Socket.close + $ \sock -> do ctx <- SSL.context SSL.contextSetPrivateKeyFile ctx key if chainCert then SSL.contextSetCertificateChainFile ctx cert else SSL.contextSetCertificateFile ctx cert - certOK <- SSL.contextCheckPrivateKey ctx when (not certOK) $ do throwIO $ TLSException certificateError diff --git a/test/Snap/Internal/Http/Server/Parser/Tests.hs b/test/Snap/Internal/Http/Server/Parser/Tests.hs --- a/test/Snap/Internal/Http/Server/Parser/Tests.hs +++ b/test/Snap/Internal/Http/Server/Parser/Tests.hs @@ -9,7 +9,6 @@ import Control.Parallel.Strategies (rdeepseq, using) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Data.Int (Int64) import Data.List (sort) import qualified Data.Map as Map import Data.Monoid (mconcat) @@ -37,7 +36,6 @@ tests = [ testShow , testCookie , testChunked - , testChunkDoS , testNull , testPartial , testParseError @@ -125,22 +123,6 @@ Streams.write Nothing os' s <- liftM (toLazyByteString . mconcat) getList assertEqual "chunked" "002\r\nok\r\n0\r\n\r\n" s - - ------------------------------------------------------------------------------- --- | ensure that running 'readChunkedTransferEncoding' against --- 'transferEncodingChunked' returns the original string -testChunkDoS :: Test -testChunkDoS = testCase "parser/chunkedTransferEncoding/DoS" $ do - let n = ((2::Int64)^(18 :: Int64) + 10) :: Int64 - let s = S.concat $ L.toChunks $ L.take n $ L.fromChunks $ - cycle ["OKOKOKOKOKOKOKOK"] - let ch = transferEncodingChunked $ L.fromChunks [s] - - expectException (Streams.fromList (L.toChunks ch) >>= - readChunkedTransferEncoding >>= - Streams.toList) - ------------------------------------------------------------------------------ testCookie :: Test