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 diff --git a/src/Snap/Internal/Http/Server/Session.hs b/src/Snap/Internal/Http/Server/Session.hs index 4c0b4fe5..b29ecc1c 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 @@ -64,7 +65,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) @@ -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 @@ -300,12 +304,36 @@ 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 #-} -------------------------------------------------------------------------- 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." @@ -427,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 @@ -455,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 @@ -619,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 @@ -698,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 -> @@ -707,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