From 97f33f53c295a8f0bfb2ec90e37f2a68e9ac29ba Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 31 May 2020 10:17:03 +0200 Subject: [PATCH 1/4] Reject HTTP-versions not conforming to RFC 7230 RFC 7230 section 3.1.1 defines the first line of a request as request-line = method SP request-target SP HTTP-version CRLF and RFC 7230 section 2.6 defines the HTTP-version part as HTTP-version = HTTP-name "/" DIGIT "." DIGIT HTTP-name = %x48.54.54.50 ; "HTTP", case-sensitive in other words, HTTP-version is intended to be two single digits. The two most common values encountered are HTTP/1.0 and HTTP/1.1 and so we provide direct matching for those. This implicitly also fixes the bug of absurdly big version numbers wrapping over into negative HTTP version integer parts. --- snap-server.cabal | 2 +- src/Snap/Internal/Http/Server/Parser.hs | 43 ++++++++++++++++++------- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/snap-server.cabal b/snap-server.cabal index a364f23e..3fdccc57 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -99,7 +99,7 @@ Library attoparsec >= 0.12 && < 0.14, base >= 4.6 && < 4.15, blaze-builder >= 0.4 && < 0.5, - bytestring >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, bytestring-builder >= 0.10.4 && < 0.11, case-insensitive >= 1.1 && < 1.3, clock >= 0.7.1 && < 0.9, diff --git a/src/Snap/Internal/Http/Server/Parser.hs b/src/Snap/Internal/Http/Server/Parser.hs index 8699b985..ff9e36fe 100644 --- a/src/Snap/Internal/Http/Server/Parser.hs +++ b/src/Snap/Internal/Http/Server/Parser.hs @@ -55,7 +55,7 @@ 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) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H @@ -148,13 +148,17 @@ instance Exception HttpParseException {-# INLINE parseRequest #-} parseRequest :: InputStream ByteString -> IO IRequest parseRequest input = do + -- RFC 7230 section 3.1.1 defines the first line of a request as + -- + -- request-line = method SP request-target SP HTTP-version CRLF + -- line <- pLine input let (!mStr, !s) = bSp line let (!uri, !vStr) = bSp s let method = methodFromString mStr - let !version = pVer vStr let (host, uri') = getHost uri let uri'' = if S.null uri' then "/" else uri' + !version <- pVer vStr stdHdrs <- newMStandardHeaders MV.unsafeWrite stdHdrs hostTag host @@ -173,18 +177,35 @@ parseRequest input = do in (Just $! host, uri) | otherwise = (Nothing, s) - pVer s = if "HTTP/" `S.isPrefixOf` s - then pVers (S.unsafeDrop 5 s) - else (1, 0) + -- RFC 7230 section 2.6 defines + -- + -- HTTP-version = HTTP-name "/" DIGIT "." DIGIT + -- HTTP-name = %x48.54.54.50 ; "HTTP", case-sensitive + -- + pVer s = case bsStripHttpPrefix s of + Nothing -> return (1, 0) + Just "1.1" -> return (1, 1) + Just "1.0" -> return (1, 0) + Just vstr + | [mjs,'.',mns] <- S.unpack vstr + , Just mj <- digitToInt mjs + , Just mn <- digitToInt mns -> return (mj,mn) + | otherwise -> throwIO $ + HttpParseException "parse error: invalid HTTP-version in request-line" + + -- NB: 'stripPrefix' operation is available in bytestring-0.10.8 and later + bsStripHttpPrefix s + | "HTTP/" `S.isPrefixOf` s = Just $! S.unsafeDrop 5 s + | otherwise = Nothing + + digitToInt c + | n >= 0, n <= 9 = Just n + | otherwise = Nothing + where + n = fromEnum c - 0x30 bSp = splitCh ' ' - pVers s = (c, d) - where - (!a, !b) = splitCh '.' s - !c = unsafeFromNat a - !d = unsafeFromNat b - ------------------------------------------------------------------------------ pLine :: InputStream ByteString -> IO ByteString From 0d63e12ddeedf34d3f516aeec80865d1ce8a1fad Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 31 May 2020 10:26:37 +0200 Subject: [PATCH 2/4] Send back a code 400 bad-request response on parsing failures Previously, `HttpParseException`s on the HTTP request would silently terminate the connection without any explanation being sent to the client. With this commit, `HttpParseException`s occuring during request parsing are transformed into basic code-400 HTTP error responses before terminating the connection. --- src/Snap/Internal/Http/Server/Session.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Snap/Internal/Http/Server/Session.hs b/src/Snap/Internal/Http/Server/Session.hs index 4c0b4fe5..0fad49b8 100644 --- a/src/Snap/Internal/Http/Server/Session.hs +++ b/src/Snap/Internal/Http/Server/Session.hs @@ -64,7 +64,7 @@ import Snap.Internal.Core (fixupResponse) import Snap.Internal.Http.Server.Clock (getClockTime) import Snap.Internal.Http.Server.Common (eatException) import Snap.Internal.Http.Server.Date (getDateString) -import Snap.Internal.Http.Server.Parser (IRequest (..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) +import Snap.Internal.Http.Server.Parser (IRequest (..), HttpParseException(..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) import Snap.Internal.Http.Server.Thread (SnapThread) import qualified Snap.Internal.Http.Server.Thread as Thread import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) @@ -300,7 +300,19 @@ httpSession !buffer !serverHandler !config !sessionData = loop receiveRequest :: IO Request receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do readEnd' <- Streams.throwIfProducesMoreThan mAX_HEADERS_SIZE readEnd - parseRequest readEnd' >>= toRequest + (parseRequest readEnd' `E.catch` parseErrHandler) >>= toRequest + where + parseErrHandler (HttpParseException emsg) = do + let msg = mconcat + [ byteString "HTTP/1.1 400 Bad Request\r\n\r\n" + , byteString (S.pack emsg) + , byteString "\r\n" + , flush + ] + writeEndB <- mkBuffer + Streams.write (Just msg) writeEndB + Streams.write Nothing writeEndB + terminateSession BadRequestException {-# INLINE receiveRequest #-} -------------------------------------------------------------------------- From 6c5ce646cf1c85ba4c3230d5a9fb5a653e873e32 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 31 May 2020 10:44:58 +0200 Subject: [PATCH 3/4] Reject too new HTTP versions requests with 505-response According to RFC 7230 section 2.6 "A server can send a 505 (HTTP Version Not Supported) response if it wishes, for any reason, to refuse service of the client's major protocol version." Since HTTP/2 with is significantly different on-wire message format has been released, we *know* that a major version larger than 1 is definitely not supported by snap-server currently and so it's reasonable to reject such doomed to fail requests with the appropriate 505 response code early on. --- src/Snap/Internal/Http/Server/Session.hs | 28 ++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/Snap/Internal/Http/Server/Session.hs b/src/Snap/Internal/Http/Server/Session.hs index 0fad49b8..a746cc66 100644 --- a/src/Snap/Internal/Http/Server/Session.hs +++ b/src/Snap/Internal/Http/Server/Session.hs @@ -11,6 +11,7 @@ module Snap.Internal.Http.Server.Session , snapToServerHandler , BadRequestException(..) , LengthRequiredException(..) + , HTTPVersionNotSupportedException(..) , TerminateSessionException(..) ) where @@ -90,6 +91,9 @@ data LengthRequiredException = LengthRequiredException deriving (Typeable, Show) instance Exception LengthRequiredException +data HTTPVersionNotSupportedException = HTTPVersionNotSupportedException + deriving (Typeable, Show) +instance Exception HTTPVersionNotSupportedException ------------------------------------------------------------------------------ snapToServerHandler :: Snap a -> ServerHandler hookState @@ -318,6 +322,18 @@ httpSession !buffer !serverHandler !config !sessionData = loop -------------------------------------------------------------------------- toRequest :: IRequest -> IO Request toRequest !ireq = {-# SCC "httpSession/toRequest" #-} do + -- RFC 7230 section 2.6: "A server can send a 505 (HTTP + -- Version Not Supported) response if it wishes, for any + -- reason, to refuse service of the client's major protocol + -- version." + -- + -- Since HTTP/2 has been released, we *know* that a major + -- version larger than 1 is definitely not supported by + -- snap-server currently and so it's reasonable to reject such + -- doomed to fail requests with the appropriate 505 response + -- code early on. + when (fst version >= 2) return505 + -- HTTP spec section 14.23: "All Internet-based HTTP/1.1 servers MUST -- respond with a 400 (Bad Request) status code to any HTTP/1.1 request -- message which lacks a Host header field." @@ -439,6 +455,18 @@ httpSession !buffer !serverHandler !config !sessionData = loop Streams.write Nothing writeEndB terminateSession LengthRequiredException + ---------------------------------------------------------------------- + return505 = do + let resp = mconcat + [ byteString "HTTP/1.1 505 HTTP Version Not Supported\r\n\r\n" + , byteString "HTTP version >= 2 not supported\r\n" + , flush + ] + writeEndB <- mkBuffer + Streams.write (Just resp) writeEndB + Streams.write Nothing writeEndB + terminateSession HTTPVersionNotSupportedException + ---------------------------------------------------------------------- parseForm readEnd' = if hasForm then getForm From 962ea07142abd1e969a51f63d130be4e8df031ed Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 31 May 2020 10:49:18 +0200 Subject: [PATCH 4/4] Treat HTTP versions >= 1.1 more appropriately Some of the HTTP-version tests were assuming that if version does not match "HTTP/1.1" it is to be treated as "HTTP/1.0" which is not proper for dealing with a hypothetical HTTP/1.2 request; this patch changes the checks to be more in accordance with RFC 7230 section 2.6 which denotes > The minor version advertises the sender's > communication capabilities even when the sender is only using a > backwards-compatible subset of the protocol, thereby letting the > recipient know that more advanced features can be used in response > (by servers) or in future requests (by clients). and > A server SHOULD send a response version equal to the highest version > to which the server is conformant that has a major version less than > or equal to the one received in the request. A server MUST NOT send > a version to which it is not conformant. Fwiw, the section also states that in principle it is legitimate for a HTTP server to reply to a HTTP/1.0 message with ah HTTP/1.1 response with the caveat > When an HTTP/1.1 message is sent to an HTTP/1.0 recipient [RFC1945] > or a recipient whose version is unknown, the HTTP/1.1 message is > constructed such that it can be interpreted as a valid HTTP/1.0 > message if all of the newer features are ignored. However, the current patch merely avoids treating a HTTP/1.2 request incorrectly as a HTTP/1.0 style request, whereas it is more appropriate to treat a HTTP/1.2 request as a HTTP/1.1 request with unknown features ignored and responding with HTTP/1.1 replies to inform the (hypothetical) HTTP/1.2 client that HTTP/1.1 is the highest version understood by the server. --- src/Snap/Internal/Http/Server/Session.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Snap/Internal/Http/Server/Session.hs b/src/Snap/Internal/Http/Server/Session.hs index a746cc66..b29ecc1c 100644 --- a/src/Snap/Internal/Http/Server/Session.hs +++ b/src/Snap/Internal/Http/Server/Session.hs @@ -495,7 +495,7 @@ httpSession !buffer !serverHandler !config !sessionData = loop -- For HTTP/1.0: if there is no explicit Connection: Keep-Alive, -- close the socket later. let v = CI.mk <$> connection - when ((version == (1, 1) && v == Just "close") || + when ((version >= (1, 1) && v == Just "close") || (version == (1, 0) && v /= Just "keep-alive")) $ writeIORef forceConnectionClose True @@ -659,7 +659,7 @@ httpSession !buffer !serverHandler !config !sessionData = loop -> ResponseBody -> (Headers, ResponseBody, Bool) noCL req hdrs body = - if v == (1,1) + if v >= (1,1) then let origBody = rspBodyToEnum body body' = \os -> do os' <- writeChunkedTransferEncoding os @@ -738,7 +738,7 @@ httpSession !buffer !serverHandler !config !sessionData = loop mkHeaderLine :: HttpVersion -> Response -> FixedPrim () mkHeaderLine outVer r = case outCode of - 200 | outVer == (1, 1) -> + 200 | outVer >= (1, 1) -> -- typo in bytestring here fixedPrim 17 $ const (void . cpBS "HTTP/1.1 200 OK\r\n") 200 | otherwise -> @@ -747,7 +747,7 @@ mkHeaderLine outVer r = where outCode = rspStatus r - v = if outVer == (1,1) then "HTTP/1.1 " else "HTTP/1.0 " + v = if outVer >= (1,1) then "HTTP/1.1 " else "HTTP/1.0 " outCodeStr = S.pack $ show outCode space !op = do