diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 3.3.12 + +* Fixing HTTP/2 logging relating to status and push. +* Adding QUIC constructor to Transport. + ## 3.3.11 * Adding setAltSvc. diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -60,9 +60,8 @@ req <- toWAIRequest h2req0 aux0 ref <- I.newIORef Nothing eResponseReceived <- E.try $ app req $ \rsp -> do - let st = responseStatus rsp - h2rsp <- fromResponse settings ii req rsp - pps <- fromPushPromises ii req + (h2rsp,st,hasBody) <- fromResponse settings ii req rsp + pps <- if hasBody then fromPushPromises ii req else return [] I.writeIORef ref $ Just (h2rsp, pps, st) _ <- response h2rsp pps return ResponseReceived @@ -81,7 +80,7 @@ S.settingsOnException settings (Just req) e let ersp = S.settingsOnExceptionResponse settings e st = responseStatus ersp - h2rsp' <- fromResponse settings ii req ersp + (h2rsp',_,_) <- fromResponse settings ii req ersp let msiz = fromIntegral <$> H2.responseBodySize h2rsp' _ <- response h2rsp' [] logResponse req st msiz diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -30,6 +30,9 @@ ---------------------------------------------------------------- +http30 :: H.HttpVersion +http30 = H.HttpVersion 3 0 + toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq toRequest ii settings addr ht bodylen body th transport = do ref <- newIORef Nothing @@ -42,7 +45,7 @@ where !req = Request { requestMethod = colonMethod - , httpVersion = H.http20 + , httpVersion = if isTransportQUIC transport then http30 else H.http20 , rawPathInfo = rawPath , pathInfo = H.decodePathSegments path , rawQueryString = query @@ -83,7 +86,7 @@ $ Vault.insert setHTTP2DataKey (writeIORef ref) $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref) $ Vault.insert pauseTimeoutKey (T.pause th) - $ Vault.insert getClientCertificateKey (tlsClientCertificate transport) + $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport) Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data)) diff --git a/Network/Wai/Handler/Warp/HTTP2/Response.hs b/Network/Wai/Handler/Warp/HTTP2/Response.hs --- a/Network/Wai/Handler/Warp/HTTP2/Response.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -24,10 +24,10 @@ ---------------------------------------------------------------- -fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response +fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO (H2.Response, H.Status, Bool) fromResponse settings ii req rsp = do date <- getDate ii - h2rsp <- case rsp of + rspst@(h2rsp, st, hasBody) <- case rsp of ResponseFile st rsphdr path mpart -> do let rsphdr' = add date svr rsphdr responseFile st rsphdr' isHead path mpart ii reqhdr @@ -40,10 +40,11 @@ _ -> error "ResponseRaw is not supported in HTTP/2" mh2data <- getHTTP2Data req case mh2data of - Nothing -> return h2rsp + Nothing -> return rspst Just h2data -> do let !trailers = http2dataTrailers h2data - return $ H2.setResponseTrailersMaker h2rsp trailers + !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers + return (h2rsp', st, hasBody) where !isHead = requestMethod req == H.methodHead !reqhdr = requestHeaders req @@ -56,7 +57,7 @@ responseFile :: H.Status -> H.ResponseHeaders -> Bool -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders - -> IO H2.Response + -> IO (H2.Response, H.Status, Bool) responseFile st rsphdr _ _ _ _ _ | noBody st = return $ responseNoBody st rsphdr @@ -84,41 +85,43 @@ ---------------------------------------------------------------- -responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response +responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> (H2.Response, H.Status, Bool) responseFile2XX st rsphdr isHead fileSpec | isHead = responseNoBody st rsphdr - | otherwise = H2.responseFile st rsphdr fileSpec + | otherwise = (H2.responseFile st rsphdr fileSpec, st, True) ---------------------------------------------------------------- responseBuilder :: H.Status -> H.ResponseHeaders -> Bool -> BB.Builder - -> H2.Response + -> (H2.Response, H.Status, Bool) responseBuilder st rsphdr isHead builder | noBody st = responseNoBody st rsphdr | isHead = responseNoBody st rsphdr - | otherwise = H2.responseBuilder st rsphdr builder + | otherwise = (H2.responseBuilder st rsphdr builder, st, True) ---------------------------------------------------------------- responseStream :: H.Status -> H.ResponseHeaders -> Bool -> StreamingBody - -> H2.Response + -> (H2.Response, H.Status, Bool) responseStream st rsphdr isHead strmbdy | noBody st = responseNoBody st rsphdr | isHead = responseNoBody st rsphdr - | otherwise = H2.responseStreaming st rsphdr strmbdy + | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True) ---------------------------------------------------------------- -responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response -responseNoBody st rsphdr = H2.responseNoBody st rsphdr +responseNoBody :: H.Status -> H.ResponseHeaders -> (H2.Response, H.Status, Bool) +responseNoBody st rsphdr = (H2.responseNoBody st rsphdr, st, False) ---------------------------------------------------------------- -response404 :: H.ResponseHeaders -> H2.Response -response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body +response404 :: H.ResponseHeaders -> (H2.Response, H.Status, Bool) +response404 rsphdr = (h2rsp, st, True) where + h2rsp = H2.responseBuilder st rsphdr' body + st = H.notFound404 !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr !body = BB.byteString "File not found" diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -72,7 +72,7 @@ rawPath = if settingsNoParsePath settings then unparsedPath else path vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii) - $ Vault.insert getClientCertificateKey (tlsClientCertificate transport) + $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport) Vault.empty (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- body producing function which will produce '100-continue', if needed diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -182,7 +182,21 @@ , tlsChiperID :: Word16 , tlsClientCertificate :: Maybe CertificateChain } -- ^ Encrypted channel: TLS or SSL + | QUIC { + quicNegotiatedProtocol :: Maybe ByteString + , quicChiperID :: Word16 + , quicClientCertificate :: Maybe CertificateChain + } isTransportSecure :: Transport -> Bool isTransportSecure TCP = False isTransportSecure _ = True + +isTransportQUIC :: Transport -> Bool +isTransportQUIC QUIC{} = True +isTransportQUIC _ = False + +getTransportClientCertificate :: Transport -> Maybe CertificateChain +getTransportClientCertificate TCP = Nothing +getTransportClientCertificate (TLS _ _ _ _ cc) = cc +getTransportClientCertificate (QUIC _ _ cc) = cc diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.11 +Version: 3.3.12 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -45,7 +45,7 @@ , hashable , http-date , http-types >= 0.12 - , http2 + , http2 >= 2.0 && < 2.1 , iproute >= 1.3.1 , simple-sendfile >= 0.2.7 && < 0.3 , stm >= 2.3 @@ -197,7 +197,7 @@ , http-client , http-date , http-types >= 0.12 - , http2 + , http2 >= 2.0 && < 2.1 , iproute >= 1.3.1 , lifted-base >= 0.1 , network