1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Application.Classic.RevProxy (revProxyApp) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (uncons)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as BS hiding (uncons)
import Data.Conduit
import qualified Network.HTTP.Client as H
import Network.HTTP.Types
import Network.Wai.Application.Classic.Conduit
import Network.Wai.Application.Classic.EventSource
import Network.Wai.Application.Classic.Field
import Network.Wai.Application.Classic.Header
import Network.Wai.Application.Classic.Path
import Network.Wai.Application.Classic.Types
import Network.Wai.Conduit
----------------------------------------------------------------
-- | Relaying any requests as reverse proxy.
revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application
revProxyApp cspec spec route req respond = H.withResponse httpClientRequest mgr proxy
where
proxy hrsp = do
let status = H.responseStatus hrsp
hdr = fixHeader $ H.responseHeaders hrsp
clientBody = H.responseBody hrsp
ct = lookup hContentType hdr
src = toSource ct clientBody
respond $ responseSource status hdr src
httpClientRequest = reqToHReq req route
mgr = revProxyManager spec
fixHeader = addVia cspec req . filter headerToBeRelay
headerToBeRelay :: Header -> Bool
headerToBeRelay (k,_)
| k == hTransferEncoding = False
| k == hAcceptEncoding = False
| k == hContentLength = False
| k == hContentEncoding = False -- See H.decompress.
| otherwise = True
----------------------------------------------------------------
reqToHReq :: Request -> RevProxyRoute -> H.Request
reqToHReq req route = H.defaultRequest {
H.host = revProxyDomain route
, H.port = revProxyPort route
, H.secure = False -- FIXME: upstream is HTTP only
, H.requestHeaders = addForwardedFor req $ filter headerToBeRelay hdr
, H.path = path'
, H.queryString = dropQuestion query
, H.requestBody = bodyToHBody len body
, H.method = requestMethod req
, H.proxy = Nothing
-- , H.rawBody = False
, H.decompress = const True
, H.checkResponse = \_ _ -> return ()
, H.redirectCount = 0
}
where
path = rawPathInfo req
src = revProxySrc route
dst = revProxyDst route
hdr = requestHeaders req
query = rawQueryString req
len = requestBodyLength req
body = getRequestBodyChunk req
path' = dst </> (path <\> src)
dropQuestion q = case BS.uncons q of
Just (63, q') -> q' -- '?' is 63
_ -> q
bodyToHBody :: RequestBodyLength -> IO ByteString -> H.RequestBody
bodyToHBody ChunkedBody src = H.RequestBodyStreamChunked ($ src)
bodyToHBody (KnownLength len) src = H.RequestBodyStream (fromIntegral len) ($ src)
----------------------------------------------------------------
#if MIN_VERSION_conduit(1,3,0)
toSource :: Maybe ByteString -> H.BodyReader -> ConduitT () (Flush Builder) IO ()
#else
toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder)
#endif
toSource (Just "text/event-stream") = bodyToEventSource
toSource _ = bodyToSource
#if MIN_VERSION_conduit(1,3,0)
bodyToSource :: H.BodyReader -> ConduitT () (Flush Builder) IO ()
#else
bodyToSource :: H.BodyReader -> Source IO (Flush Builder)
#endif
bodyToSource br = loop
where
loop = do
bs <- liftIO $ H.brRead br
unless (BS.null bs) $ do
yield $ Chunk $ byteStringToBuilder bs
loop
{-
FIXME:
badGateway :: ClassicAppSpec -> Request-> SomeException -> IO Response
badGateway cspec req _ =
return $ responseBuilder st hdr bdy
where
hdr = addServer cspec textPlainHeader
bdy = byteStringToBuilder "Bad Gateway\r\n"
st = badGateway502
-}
|
