snap-server 1.1.1.2 → 1.1.2.0
raw patch · 4 files changed
+77/−79 lines, 4 filesdep ~attoparsecdep ~basedep ~bytestring
Dependency ranges changed: attoparsec, base, bytestring, random, text, time, transformers, unix-compat, vector
Files
- snap-server.cabal +5/−3
- src/Snap/Internal/Http/Server/Parser.hs +66/−44
- src/Snap/Internal/Http/Server/TLS.hs +6/−14
- test/Snap/Internal/Http/Server/Parser/Tests.hs +0/−18
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Server/Parser.hs view
@@ -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
src/Snap/Internal/Http/Server/TLS.hs view
@@ -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
test/Snap/Internal/Http/Server/Parser/Tests.hs view
@@ -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