diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 3.3.11 + +* Adding setAltSvc. + [#801](https://github.com/yesodweb/wai/pull/801) +* Fixing timeout of builder for HTTP/1.1. + [#800](https://github.com/yesodweb/wai/pull/800) +* `http2server` and `withII` are exported from `Internal` module. + ## 3.3.10 * Convert ResourceVanished error to ConnectionClosedByPeer exception diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -75,6 +75,7 @@ , setGracefulCloseTimeout1 , setGracefulCloseTimeout2 , setMaxTotalHeaderLength + , setAltSvc -- ** Getters , getPort , getHost @@ -449,6 +450,13 @@ setMaxTotalHeaderLength :: Int -> Settings -> Settings setMaxTotalHeaderLength maxTotalHeaderLength settings = settings { settingsMaxTotalHeaderLength = maxTotalHeaderLength } + + +-- | Setting the header value of Alternative Services (AltSvc:). +-- +-- Since 3.3.11 +setAltSvc :: ByteString -> Settings -> Settings +setAltSvc altsvc settings = settings { settingsAltSvc = Just altsvc } -- | Explicitly pause the slowloris timeout. -- 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 @@ -4,7 +4,10 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Network.Wai.Handler.Warp.HTTP2 (http2) where +module Network.Wai.Handler.Warp.HTTP2 ( + http2 + , http2server + ) where import qualified Data.IORef as I import qualified Control.Exception as E @@ -24,9 +27,17 @@ ---------------------------------------------------------------- -http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO () -http2 conn transport ii addr settings readN send app = - H2.run conf http2server +http2 :: S.Settings + -> InternalInfo + -> Connection + -> Transport + -> SockAddr + -> (BufSize -> IO ByteString) + -> (ByteString -> IO ()) + -> Application + -> IO () +http2 settings ii conn transport addr readN send app = + H2.run conf $ http2server settings ii transport addr app where conf = H2.Config { confWriteBuffer = connWriteBuffer conn @@ -36,37 +47,46 @@ , confPositionReadMaker = pReadMaker ii } - http2server h2req aux response = do - req <- toWAIRequest h2req aux - 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 - I.writeIORef ref $ Just (h2rsp, pps, st) - _ <- response h2rsp pps - return ResponseReceived - case eResponseReceived of - Right ResponseReceived -> do - Just (h2rsp, pps, st) <- I.readIORef ref - let msiz = fromIntegral <$> H2.responseBodySize h2rsp - logResponse req st msiz - mapM_ (logPushPromise req) pps - Left e@(E.SomeException _) - -- killed by the local worker manager - | Just E.ThreadKilled <- E.fromException e -> return () - -- killed by the local timeout manager - | Just T.TimeoutThread <- E.fromException e -> return () - | otherwise -> do - S.settingsOnException settings (Just req) e - let ersp = S.settingsOnExceptionResponse settings e - st = responseStatus ersp - h2rsp' <- fromResponse settings ii req ersp - let msiz = fromIntegral <$> H2.responseBodySize h2rsp' - _ <- response h2rsp' [] - logResponse req st msiz - return () - +-- | Converting WAI application to the server type of http2 library. +-- +-- Since 3.3.11 +http2server :: S.Settings + -> InternalInfo + -> Transport + -> SockAddr + -> Application + -> H2.Server +http2server settings ii transport addr app h2req0 aux0 response = do + 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 + I.writeIORef ref $ Just (h2rsp, pps, st) + _ <- response h2rsp pps + return ResponseReceived + case eResponseReceived of + Right ResponseReceived -> do + Just (h2rsp, pps, st) <- I.readIORef ref + let msiz = fromIntegral <$> H2.responseBodySize h2rsp + logResponse req st msiz + mapM_ (logPushPromise req) pps + Left e@(E.SomeException _) + -- killed by the local worker manager + | Just E.ThreadKilled <- E.fromException e -> return () + -- killed by the local timeout manager + | Just T.TimeoutThread <- E.fromException e -> return () + | otherwise -> do + S.settingsOnException settings (Just req) e + let ersp = S.settingsOnExceptionResponse settings e + st = responseStatus ersp + h2rsp' <- fromResponse settings ii req ersp + let msiz = fromIntegral <$> H2.responseBodySize h2rsp' + _ <- response h2rsp' [] + logResponse req st msiz + return () + where toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport where !hdr = H2.requestHeaders h2req 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 @@ -48,7 +48,8 @@ !isHead = requestMethod req == H.methodHead !reqhdr = requestHeaders req !svr = S.settingsServerName settings - add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr + add date server rsphdr = R.addAltSvc settings $ + (H.hDate, date) : (H.hServer, server) : rsphdr -- fixme: not adding svr if already exists ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs --- a/Network/Wai/Handler/Warp/Internal.hs +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -67,6 +67,9 @@ -- * Platform dependent helper functions , setSocketCloseOnExec , windowsThreadBlockHack + -- * Misc + , http2server + , withII ) where import System.TimeManager @@ -75,6 +78,7 @@ import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache +import Network.Wai.Handler.Warp.HTTP2 import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -11,6 +11,7 @@ , hasBody , replaceHeader , addServer -- testing + , addAltSvc ) where import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator) @@ -108,7 +109,7 @@ -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent. sendResponse settings conn ii th req reqidxhdr src response = do - hs <- addServerAndDate hs0 + hs <- addAltSvc settings <$> addServerAndDate hs0 if hasBody s then do -- The response to HEAD does not have body. -- But to handle the conditional requests defined RFC 7232 and @@ -116,14 +117,14 @@ -- and status, the response to HEAD is processed here. -- -- See definition of rsp below for proper body stripping. - (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp + (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr rsp case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen T.tickle th return ret else do - _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody + _ <- sendRsp conn ii th ver s hs rspidxhdr RspNoBody logger req s Nothing T.tickle th return isPersist @@ -147,8 +148,8 @@ | otherwise -> RspBuilder b needsChunked ResponseStream _ _ fb | isHead -> RspNoBody - | otherwise -> RspStream fb needsChunked th - ResponseRaw raw _ -> RspRaw raw src (T.tickle th) + | otherwise -> RspStream fb needsChunked + ResponseRaw raw _ -> RspRaw raw src -- Make sure we don't hang on to 'response' (avoid space leak) !ret = case response of ResponseFile {} -> isPersist @@ -186,13 +187,14 @@ data Rsp = RspNoBody | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ()) | RspBuilder Builder Bool - | RspStream StreamingBody Bool T.Handle - | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ()) + | RspStream StreamingBody Bool + | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) ---------------------------------------------------------------- sendRsp :: Connection -> InternalInfo + -> T.Handle -> H.HttpVersion -> H.Status -> H.ResponseHeaders @@ -202,7 +204,7 @@ ---------------------------------------------------------------- -sendRsp conn _ ver s hs _ RspNoBody = do +sendRsp conn _ _ ver s hs _ RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn @@ -210,7 +212,7 @@ ---------------------------------------------------------------- -sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do +sendRsp conn _ th ver s hs _ (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body @@ -218,12 +220,12 @@ | otherwise = header <> body buffer = connWriteBuffer conn size = connBufferSize conn - toBufIOWith buffer size (connSendAll conn) hdrBdy + toBufIOWith buffer size (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- -sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do +sendRsp conn _ th ver s hs _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn) @@ -247,22 +249,22 @@ ---------------------------------------------------------------- -sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do +sendRsp conn _ th _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where recv = do bs <- src - unless (S.null bs) tickle + unless (S.null bs) $ T.tickle th return bs - send bs = connSendAll conn bs >> tickle + send bs = connSendAll conn bs >> T.tickle th ---------------------------------------------------------------- -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value. -sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) = - sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook +sendRsp conn ii th ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) = + sendRspFile2XX conn ii th ver s0 hs rspidxhdr path beg len isHead hook where beg = filePartOffset part len = filePartByteCount part @@ -272,22 +274,23 @@ -- Simple WAI applications. -- Status is ignored -sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do +sendRsp conn ii th ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif - sendRspFile404 conn ii ver hs0 rspidxhdr + sendRspFile404 conn ii th ver hs0 rspidxhdr Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of - WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody - WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook + WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr RspNoBody + WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook ---------------------------------------------------------------- sendRspFile2XX :: Connection -> InternalInfo + -> T.Handle -> H.HttpVersion -> H.Status -> H.ResponseHeaders @@ -298,8 +301,8 @@ -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer) -sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook - | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody +sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook + | isHead = sendRsp conn ii th ver s hs rspidxhdr RspNoBody | otherwise = do lheader <- composeHeader ver s hs (mfd, fresher) <- getFd ii path @@ -310,11 +313,12 @@ sendRspFile404 :: Connection -> InternalInfo + -> T.Handle -> H.HttpVersion -> H.ResponseHeaders -> IndexedHeader -> IO (Maybe H.Status, Maybe Integer) -sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True) +sendRspFile404 conn ii th ver hs0 rspidxhdr = sendRsp conn ii th ver s hs rspidxhdr (RspBuilder body True) where s = H.notFound404 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 @@ -408,6 +412,11 @@ addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> (H.hServer, serverName) : hdrs _ -> hdrs + +addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders +addAltSvc settings hs = case settingsAltSvc settings of + Nothing -> hs + Just v -> ("Alt-Svc", v) : hs ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -200,16 +200,20 @@ runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter - withII $ acceptConnection set getConnMaker app counter - where - withII action = - withTimeoutManager $ \tm -> - D.withDateCache $ \dc -> - F.withFdCache fdCacheDurationInSeconds $ \fdc -> - I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do - let ii = InternalInfo tm dc fdc fic - action ii + withII set $ acceptConnection set getConnMaker app counter +-- | Running an action with internal info. +-- +-- Since 3.3.11 +withII :: Settings -> (InternalInfo -> IO a) -> IO a +withII set action = + withTimeoutManager $ \tm -> + D.withDateCache $ \dc -> + F.withFdCache fdCacheDurationInSeconds $ \fdc -> + I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do + let ii = InternalInfo tm dc fdc fic + action ii + where !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 !timeoutInSeconds = settingsTimeout set * 1000000 @@ -362,7 +366,7 @@ -- fixme: origAddr checkTLS setConnHTTP2 conn True - http2 conn transport ii origAddr settings recvN sendBS app + http2 settings ii conn transport origAddr recvN sendBS app else do src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings)) writeIORef istatus True diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -130,8 +130,14 @@ -- Since 3.3.5 , settingsMaxTotalHeaderLength :: Int -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x. - -- + -- -- Since 3.3.8 + , settingsAltSvc :: Maybe ByteString + -- ^ Specify the header value of Alternative Services (AltSvc:). + -- + -- Default: Nothing + -- + -- Since 3.3.11 } -- | Specify usage of the PROXY protocol. @@ -171,6 +177,7 @@ , settingsGracefulCloseTimeout1 = 0 , settingsGracefulCloseTimeout2 = 2000 , settingsMaxTotalHeaderLength = 50 * 1024 + , settingsAltSvc = Nothing } -- | Apply the logic provided by 'defaultOnException' to determine if an diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.10 +Version: 3.3.11 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 >= 2.0 && < 2.1 + , http2 , 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 >= 2.0 && < 2.1 + , http2 , iproute >= 1.3.1 , lifted-base >= 0.1 , network