Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Support HTTP 103 Early Hints #46

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Support HTTP 103 Early Hints #46

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
9d91078
Add nix stanza to stack.yaml
thomasjm Jan 7, 2024
733093a
Try implementing HTTP 103 Early Hints handling
thomasjm Jan 7, 2024
9772ca0
Bump major version and add CHANGELOG entry
thomasjm Jan 11, 2024
fac5e72
Fix chunking, tests now pass
thomasjm Jan 13, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 6 additions & 0 deletions ChangeLog.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,10 @@

## 0.7.0.0

* Support HTTP 103 Early Hints responses in `waiProxyTo`.
* This requires `http-client >= 0.7.16`.
* It also necessitates a change in the `wpsOnExc` handler. Now it is passed a raw callback for writing bytes to the client, rather than a `WAI.Application`. You can see an example of how to use this in the new `defaultOnExc`.

## 0.6.0.2

* Fix docker registry reverse proxying by preserving the 'Content-Length' response header to HTTP/2 and HEAD requests. [#45](https://github.com/fpco/http-reverse-proxy/pull/45)
Expand Down
194 changes: 117 additions & 77 deletions Network/HTTP/ReverseProxy.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,39 +38,38 @@ module Network.HTTP.ReverseProxy
-}
) where

import Blaze.ByteString.Builder (Builder, fromByteString,
toLazyByteString)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Blaze.ByteString.Builder (Builder, fromByteString, toByteString, toLazyByteString)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (unless, when)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Network as DCN
import Data.Functor.Identity (Identity (..))
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Network as DCN
import Data.Functor.Identity (Identity (..))
import Data.IORef
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid (mappend, mconcat, (<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Streaming.Network (AppData, readLens)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Word8 (isSpace, _colon, _cr)
import GHC.Generics (Generic)
import Network.HTTP.Client (BodyReader, brRead)
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified Network.Wai as WAI
import Network.Wai.Logger (showSockAddr)
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Monoid (mappend, mconcat, (<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Streaming.Network (AppData, readLens)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Word8 (isSpace, _colon, _cr)
import GHC.Generics (Generic)
import Network.HTTP.Client (BodyReader, brRead)
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified Network.HTTP.Types.Header as H
import qualified Network.Wai as WAI
import Network.Wai.Logger (showSockAddr)
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_)

-- | Host\/port combination to which we want to proxy.
data ProxyDest = ProxyDest
Expand Down Expand Up @@ -150,11 +149,12 @@ rawTcpProxyTo (ProxyDest host port) appdata = liftIO $

-- | Sends a simple 502 bad gateway error message with the contents of the
-- exception.
defaultOnExc :: SomeException -> WAI.Application
defaultOnExc exc _ sendResponse = sendResponse $ WAI.responseLBS
HT.status502
[("content-type", "text/plain")]
("Error connecting to gateway:\n\n" <> TLE.encodeUtf8 (TL.pack $ show exc))
defaultOnExc :: SomeException -> WAI.Request -> (ByteString -> IO ()) -> IO ()
defaultOnExc exc _req sendBytes = do
sendBytes "HTTP/1.1 502 Bad Gateway\r\n"
sendBytes "Content-Type: text/plain\r\n"
sendBytes "\r\n"
sendBytes ("Error connecting to gateway:\n\n" <> (S8.pack $ show exc))

-- | The different responses that could be generated by a @waiProxyTo@ lookup
-- function.
Expand Down Expand Up @@ -205,7 +205,7 @@ data WaiProxyResponse = WPRResponse WAI.Response
-- bodies, so please confirm that yours does (Warp, Snap, and Happstack, for example, do).
waiProxyTo :: (WAI.Request -> IO WaiProxyResponse)
-- ^ How to reverse proxy.
-> (SomeException -> WAI.Application)
-> (SomeException -> WAI.Request -> (ByteString -> IO ()) -> IO ())
-- ^ How to handle exceptions when calling remote server. For a
-- simple 502 error page, use 'defaultOnExc'.
-> HC.Manager -- ^ connection manager to utilize
Expand Down Expand Up @@ -236,7 +236,7 @@ setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
setLpsTimeBound x s = s { lpsTimeBound = x }

data WaiProxySettings = WaiProxySettings
{ wpsOnExc :: SomeException -> WAI.Application
{ wpsOnExc :: SomeException -> WAI.Request -> (ByteString -> IO ()) -> IO ()
, wpsTimeout :: Maybe Int
, wpsSetIpHeader :: SetIpHeader
-- ^ Set the X-Real-IP request header with the client's IP address.
Expand Down Expand Up @@ -394,48 +394,88 @@ waiProxyToSettings getDest wps' manager req0 sendResponse = do
WAI.KnownLength i -> HC.RequestBodyStream (fromIntegral i) scb
WAI.ChunkedBody -> HC.RequestBodyStreamChunked scb

let req' =
-- We don't want this to be used, but WAI requires us to provide a default response
-- when using WAI.responseRaw. This should be fine because none of the functions like
-- 'responseStatus' or 'responseHeaders' should be called on this.
let defaultResponse = WAI.responseLBS HT.conflict409 [] mempty

sendResponse $ flip WAI.responseRaw defaultResponse $ \_ sendToClient -> do
let req' =
#if MIN_VERSION_http_client(0, 5, 0)
HC.defaultRequest
{ HC.checkResponse = \_ _ -> return ()
, HC.responseTimeout = maybe HC.responseTimeoutNone HC.responseTimeoutMicro $ lpsTimeBound lps
HC.defaultRequest
{ HC.checkResponse = \_ _ -> return ()
, HC.responseTimeout = maybe HC.responseTimeoutNone HC.responseTimeoutMicro $ lpsTimeBound lps
#else
def
{ HC.checkStatus = \_ _ _ -> Nothing
, HC.responseTimeout = lpsTimeBound lps
def
{ HC.checkStatus = \_ _ _ -> Nothing
, HC.responseTimeout = lpsTimeBound lps
#endif
, HC.method = WAI.requestMethod req
, HC.secure = secure
, HC.host = host
, HC.port = port
, HC.path = WAI.rawPathInfo req
, HC.queryString = WAI.rawQueryString req
, HC.requestHeaders = fixReqHeaders wps req
, HC.requestBody = body
, HC.redirectCount = 0
#if MIN_VERSION_http_client(0, 7, 16)
, HC.earlyHintHeadersReceived = \headers ->
sendToClient $ L.toStrict $ toLazyByteString $
fromByteString "HTTP/1.1 103 Early Hints\r\n"
<> mconcat [renderHeader h | h <- headers]
<> "\r\n"
#endif
, HC.method = WAI.requestMethod req
, HC.secure = secure
, HC.host = host
, HC.port = port
, HC.path = WAI.rawPathInfo req
, HC.queryString = WAI.rawQueryString req
, HC.requestHeaders = fixReqHeaders wps req
, HC.requestBody = body
, HC.redirectCount = 0
}
bracket
(try $ do
liftIO $ wpsLogRequest wps' req'
HC.responseOpen req' manager)
(either (const $ return ()) HC.responseClose)
$ \case
Left e -> wpsOnExc wps e req sendResponse
Right res -> do
let conduit = fromMaybe
(awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush))
(wpsProcessBody wps req $ const () <$> res)
src = bodyReaderSource $ HC.responseBody res
noChunked = HT.httpMajor (WAI.httpVersion req) >= 2 || WAI.requestMethod req == HT.methodHead
sendResponse $ WAI.responseStream
(HC.responseStatus res)
(filter (\(key, v) -> not (key `Set.member` strippedHeaders) ||
key == "content-length" && (noChunked || v == "0"))
(HC.responseHeaders res))
(\sendChunk flush -> runConduit $ src .| conduit .| CL.mapM_ (\mb ->
case mb of
Flush -> flush
Chunk b -> sendChunk b))
}
bracket
(try $ do
liftIO $ wpsLogRequest wps' req'
HC.responseOpen req' manager
)
(either (const $ return ()) HC.responseClose)
$ \case
Left (e :: SomeException) -> wpsOnExc wps e req sendToClient
Right res -> do
let conduit = fromMaybe
(awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush))
(wpsProcessBody wps req $ const () <$> res)
src = bodyReaderSource $ HC.responseBody res
noChunked = HT.httpMajor (WAI.httpVersion req) >= 2 || WAI.requestMethod req == HT.methodHead

let (HT.Status code message) = HC.responseStatus res
sendToClient $ L.toStrict $ toLazyByteString $
fromByteString (S8.pack $ show (HC.responseVersion res)) <> " " <> fromByteString (S8.pack $ show code) <> " " <> fromByteString message <> "\r\n"

-- Handle HTTP chunking, just as Warp does for WAI.responseStream
let requestIsChunked = not noChunked
let responseHasLength = isJust (lookup "content-length" (HC.responseHeaders res))
let needsChunked = requestIsChunked && not responseHasLength

let headers' = (filter (\(key, v) -> not (key `Set.member` strippedHeaders) ||
key == "content-length" && (noChunked || v == "0"))
(HC.responseHeaders res))
let headers
| needsChunked = (H.hTransferEncoding, "chunked") : headers'
| otherwise = headers
sendToClient $ L.toStrict $ toLazyByteString $
mconcat [renderHeader h | h <- headers]
<> "\r\n"

-- It may look strange that we don't handle 'Flush' here, but 'Flush' is not actually used anywhere
-- except at the end of the stream in the conduit above.
let sendChunk
| needsChunked = sendToClient . toByteString . chunkedTransferEncoding
| otherwise = sendToClient . toByteString
runConduit $ src .| conduit .| CL.mapM_ (\mb ->
case mb of
Flush -> return ()
Chunk b -> sendChunk b
)
when needsChunked $ sendToClient (toByteString chunkedTransferTerminator)

where
renderHeader :: HT.Header -> Builder
renderHeader (name, value) = fromByteString (CI.original name) <> ": " <> fromByteString value <> "\r\n"

-- | Introduce a minor level of caching to handle some basic
-- retry cases inside http-client. But to avoid a DoS attack,
Expand Down
5 changes: 3 additions & 2 deletions http-reverse-proxy.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
name: http-reverse-proxy
version: 0.6.0.2
version: 0.7.0.0
synopsis: Reverse proxy HTTP requests, either over raw sockets or with WAI
description: Provides a simple means of reverse-proxying HTTP requests. The raw approach uses the same technique as leveraged by keter, whereas the WAI approach performs full request/response parsing via WAI and http-conduit.
homepage: https://github.com/fpco/http-reverse-proxy
Expand All @@ -20,12 +20,13 @@ library
buildable: False
build-depends: base >= 4.11 && < 5
, text >= 0.11
, bsb-http-chunked >= 0.0.0.4
, bytestring >= 0.9
, case-insensitive >= 0.4
, http-types >= 0.6
, word8 >= 0.0
, blaze-builder >= 0.3
, http-client >= 0.3
, http-client >= 0.7.16
, wai >= 3.0
, network
, conduit >= 1.3
Expand Down
13 changes: 12 additions & 1 deletion stack.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,2 +1,13 @@
resolver: lts-18.28
resolver: lts-21.21

packages:
- .

nix:
pure: false
packages:
- zlib

extra-deps:
# >=0.7.16 is required for early hints support
- http-client-0.7.16
Loading