{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings #-}
module Network.HTTP.Proxy
( Port
, Request (..)
, Settings (..)
, UpstreamProxy (..)
, httpProxyApp
, warpSettings
, runProxy
, runProxySettings
, runProxySettingsSocket
, defaultProxySettings
)
where
import Data.ByteString.Builder (byteString)
import Control.Concurrent.Async (race_)
import Control.Exception
import Data.ByteString.Char8 (ByteString)
import Data.Conduit (ConduitT, Flush (..), (.|), mapOutput, runConduit, yield)
import Data.Conduit.Network
#if ! MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Void (Void)
import Network.Socket
import Network.Wai.Conduit hiding (Request, requestMethod)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.Network as NC
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Conduit as HC
import qualified Network.HTTP.Client.Conduit as HCC
import qualified Network.HTTP.Types as HT
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.HTTP.Proxy.Request
#if 0
import Data.Version (showVersion)
import qualified Paths_httpProxy
httpProxyVersion :: String
httpProxyVersion = showVersion Paths_warp.version
#endif
runProxy :: Port -> IO ()
runProxy :: Port -> IO ()
runProxy Port
port = Settings -> IO ()
runProxySettings (Settings -> IO ()) -> Settings -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings
defaultProxySettings { proxyPort :: Port
proxyPort = Port
port }
runProxySettings :: Settings -> IO ()
runProxySettings :: Settings -> IO ()
runProxySettings Settings
set = do
Manager
mgr <- ManagerSettings -> IO Manager
HC.newManager ManagerSettings
HC.tlsManagerSettings
Settings -> Application -> IO ()
Warp.runSettings (Settings -> Settings
warpSettings Settings
set) (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings -> Manager -> Application
httpProxyApp Settings
set Manager
mgr
runProxySettingsSocket :: Settings -> Socket -> IO ()
runProxySettingsSocket :: Settings -> Socket -> IO ()
runProxySettingsSocket Settings
set Socket
sock = do
PortNumber
port <- Socket -> IO PortNumber
socketPort Socket
sock
Manager
mgr <- ManagerSettings -> IO Manager
HC.newManager ManagerSettings
HC.tlsManagerSettings
Settings -> Socket -> Application -> IO ()
Warp.runSettingsSocket (Settings -> Settings
warpSettings Settings
set) Socket
sock
(Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings -> Manager -> Application
httpProxyApp Settings
set { proxyPort :: Port
proxyPort = PortNumber -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port } Manager
mgr
data Settings = Settings
{ Settings -> Port
proxyPort :: Int
, Settings -> HostPreference
proxyHost :: HostPreference
, Settings -> SomeException -> Response
proxyOnException :: SomeException -> Wai.Response
, Settings -> Port
proxyTimeout :: Int
, Settings -> Request -> IO (Either Response Request)
proxyHttpRequestModifier :: Request -> IO (Either Response Request)
, Settings -> ByteString -> IO ()
proxyLogger :: ByteString -> IO ()
, Settings -> Maybe UpstreamProxy
proxyUpstream :: Maybe UpstreamProxy
}
data UpstreamProxy = UpstreamProxy
{ UpstreamProxy -> ByteString
upstreamHost :: ByteString
, UpstreamProxy -> Port
upstreamPort :: Int
, UpstreamProxy -> Maybe (ByteString, ByteString)
upstreamAuth :: Maybe (ByteString, ByteString)
}
warpSettings :: Settings -> Warp.Settings
warpSettings :: Settings -> Settings
warpSettings Settings
pset = Port -> Settings -> Settings
Warp.setPort (Settings -> Port
proxyPort Settings
pset)
(Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostPreference -> Settings -> Settings
Warp.setHost (Settings -> HostPreference
proxyHost Settings
pset)
(Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
Warp.setTimeout (Settings -> Port
proxyTimeout Settings
pset)
(Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (\ Maybe Request
_ SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> Response) -> Settings -> Settings
Warp.setOnExceptionResponse SomeException -> Response
defaultExceptionResponse
(Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Bool -> Settings -> Settings
Warp.setNoParsePath Bool
True Settings
Warp.defaultSettings
defaultProxySettings :: Settings
defaultProxySettings :: Settings
defaultProxySettings = Settings :: Port
-> HostPreference
-> (SomeException -> Response)
-> Port
-> (Request -> IO (Either Response Request))
-> (ByteString -> IO ())
-> Maybe UpstreamProxy
-> Settings
Settings
{ proxyPort :: Port
proxyPort = Port
3100
, proxyHost :: HostPreference
proxyHost = HostPreference
"*"
, proxyOnException :: SomeException -> Response
proxyOnException = SomeException -> Response
defaultExceptionResponse
, proxyTimeout :: Port
proxyTimeout = Port
30
, proxyHttpRequestModifier :: Request -> IO (Either Response Request)
proxyHttpRequestModifier = Either Response Request -> IO (Either Response Request)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Response Request -> IO (Either Response Request))
-> (Request -> Either Response Request)
-> Request
-> IO (Either Response Request)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Either Response Request
forall a b. b -> Either a b
Right
, proxyLogger :: ByteString -> IO ()
proxyLogger = IO () -> ByteString -> IO ()
forall a b. a -> b -> a
const (IO () -> ByteString -> IO ()) -> IO () -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, proxyUpstream :: Maybe UpstreamProxy
proxyUpstream = Maybe UpstreamProxy
forall a. Maybe a
Nothing
}
defaultExceptionResponse :: SomeException -> Wai.Response
defaultExceptionResponse :: SomeException -> Response
defaultExceptionResponse SomeException
e =
Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HT.internalServerError500
[ (HeaderName
HT.hContentType, ByteString
"text/plain; charset=utf-8") ]
(ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
LBS.fromChunks [String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e]
httpProxyApp :: Settings -> HC.Manager -> Application
httpProxyApp :: Settings -> Manager -> Application
httpProxyApp Settings
settings Manager
mgr Request
wreq Response -> IO ResponseReceived
respond = do
Either Response Request
mwreq <- Settings -> Request -> IO (Either Response Request)
proxyHttpRequestModifier Settings
settings (Request -> IO (Either Response Request))
-> Request -> IO (Either Response Request)
forall a b. (a -> b) -> a -> b
$ Request -> Request
proxyRequest Request
wreq
(Response -> IO ResponseReceived)
-> (Request -> IO ResponseReceived)
-> Either Response Request
-> IO ResponseReceived
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Response -> IO ResponseReceived
respond (Settings
-> Manager
-> (Response -> IO ResponseReceived)
-> Request
-> IO ResponseReceived
doUpstreamRequest Settings
settings Manager
mgr Response -> IO ResponseReceived
respond (Request -> IO ResponseReceived)
-> (Request -> Request) -> Request -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request -> Request
waiRequest Request
wreq) Either Response Request
mwreq
doUpstreamRequest :: Settings -> HC.Manager -> (Wai.Response -> IO Wai.ResponseReceived) -> Wai.Request -> IO Wai.ResponseReceived
doUpstreamRequest :: Settings
-> Manager
-> (Response -> IO ResponseReceived)
-> Request
-> IO ResponseReceived
doUpstreamRequest Settings
settings Manager
mgr Response -> IO ResponseReceived
respond Request
mwreq
| Request -> ByteString
Wai.requestMethod Request
mwreq ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT" =
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ (Source IO ByteString -> Sink ByteString IO () -> IO ())
-> Response -> Response
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
(Source m ByteString -> Sink ByteString n () -> IO ())
-> Response -> Response
responseRawSource (Request -> Source IO ByteString -> Sink ByteString IO () -> IO ()
forall a.
Request
-> Source IO ByteString -> ConduitT ByteString Void IO a -> IO ()
handleConnect Request
mwreq)
(Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HT.status500 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"No support for responseRaw")
| Bool
otherwise = do
Request
hreq0 <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HC.parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack (Request -> ByteString
Wai.rawPathInfo Request
mwreq ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString Request
mwreq)
let hreq :: Request
hreq = Request
hreq0
{ method :: ByteString
HC.method = Request -> ByteString
Wai.requestMethod Request
mwreq
, requestHeaders :: ResponseHeaders
HC.requestHeaders = ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName, ByteString) -> Bool
forall a b. (Eq a, IsString a) => (a, b) -> Bool
dropRequestHeader (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
Wai.requestHeaders Request
mwreq
, redirectCount :: Port
HC.redirectCount = Port
0
, requestBody :: RequestBody
HC.requestBody =
case Request -> RequestBodyLength
Wai.requestBodyLength Request
mwreq of
RequestBodyLength
Wai.ChunkedBody ->
Source IO ByteString -> RequestBody
HC.requestBodySourceChunkedIO (Request -> Source IO ByteString
forall (m :: * -> *). MonadIO m => Request -> Source m ByteString
sourceRequestBody Request
mwreq)
Wai.KnownLength Word64
l ->
Int64 -> Source IO ByteString -> RequestBody
HC.requestBodySourceIO (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l) (Request -> Source IO ByteString
forall (m :: * -> *). MonadIO m => Request -> Source m ByteString
sourceRequestBody Request
mwreq)
, decompress :: ByteString -> Bool
HC.decompress = Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
False
}
(SomeException -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (SomeException -> Response)
-> SomeException
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Response
errorResponse) (IO ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
Request
-> Manager
-> (Response BodyReader -> IO ResponseReceived)
-> IO ResponseReceived
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
HC.withResponse Request
hreq Manager
mgr ((Response BodyReader -> IO ResponseReceived)
-> IO ResponseReceived)
-> (Response BodyReader -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> do
let body :: ConduitT i (Flush Builder) IO ()
body = (ByteString -> Flush Builder)
-> ConduitT i ByteString IO () -> ConduitT i (Flush Builder) IO ()
forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
mapOutput (Builder -> Flush Builder
forall a. a -> Flush a
Chunk (Builder -> Flush Builder)
-> (ByteString -> Builder) -> ByteString -> Flush Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString) (ConduitT i ByteString IO () -> ConduitT i (Flush Builder) IO ())
-> (BodyReader -> ConduitT i ByteString IO ())
-> BodyReader
-> ConduitT i (Flush Builder) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyReader -> ConduitT i ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
HCC.bodyReaderSource (BodyReader -> ConduitT i (Flush Builder) IO ())
-> BodyReader -> ConduitT i (Flush Builder) IO ()
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall body. Response body -> body
HC.responseBody Response BodyReader
res
headers :: ResponseHeaders
headers = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"X-Via-Proxy", ByteString
"yes") (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName, ByteString) -> Bool
forall a b. Eq a => (a, b) -> Bool
dropResponseHeader (Response BodyReader -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HC.responseHeaders Response BodyReader
res)
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Source IO (Flush Builder) -> Response
responseSource (Response BodyReader -> Status
forall body. Response body -> Status
HC.responseStatus Response BodyReader
res) ResponseHeaders
headers Source IO (Flush Builder)
forall i. ConduitT i (Flush Builder) IO ()
body
where
dropRequestHeader :: (a, b) -> Bool
dropRequestHeader (a
k, b
_) = a
k a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[ a
"content-encoding"
, a
"content-length"
]
dropResponseHeader :: (a, b) -> Bool
dropResponseHeader (a
k, b
_) = a
k a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` []
errorResponse :: SomeException -> Wai.Response
errorResponse :: SomeException -> Response
errorResponse = Settings -> SomeException -> Response
proxyOnException Settings
settings (SomeException -> Response)
-> (SomeException -> SomeException) -> SomeException -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> SomeException
forall e. Exception e => e -> SomeException
toException
handleConnect :: Wai.Request -> ConduitT () ByteString IO () -> ConduitT ByteString Void IO a -> IO ()
handleConnect :: Request
-> Source IO ByteString -> ConduitT ByteString Void IO a -> IO ()
handleConnect Request
wreq Source IO ByteString
fromClient ConduitT ByteString Void IO a
toClient = do
let (ByteString
host, Port
port) =
case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawPathInfo Request
wreq of
(ByteString
x, ByteString
"") -> (ByteString
x, Port
80)
(ByteString
x, ByteString
y) ->
case ByteString -> Maybe (Port, ByteString)
BS.readInt (ByteString -> Maybe (Port, ByteString))
-> ByteString -> Maybe (Port, ByteString)
forall a b. (a -> b) -> a -> b
$ Port -> ByteString -> ByteString
BS.drop Port
1 ByteString
y of
Just (Port
port', ByteString
_) -> (ByteString
x, Port
port')
Maybe (Port, ByteString)
Nothing -> (ByteString
x, Port
80)
settings :: ClientSettings
settings = Port -> ByteString -> ClientSettings
clientSettings Port
port ByteString
host
ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient ClientSettings
settings ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppData
ad -> do
a
_ <- ConduitT () Void IO a -> IO a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO a -> IO a) -> ConduitT () Void IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> Source IO ByteString
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"HTTP/1.1 200 OK\r\n\r\n" Source IO ByteString
-> ConduitT ByteString Void IO a -> ConduitT () Void IO a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Void IO a
toClient
IO () -> IO a -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
(ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source IO ByteString
fromClient Source IO ByteString
-> Sink ByteString IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| AppData -> Sink ByteString IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
NC.appSink AppData
ad)
(ConduitT () Void IO a -> IO a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO a -> IO a) -> ConduitT () Void IO a -> IO a
forall a b. (a -> b) -> a -> b
$ AppData -> Source IO ByteString
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
NC.appSource AppData
ad Source IO ByteString
-> ConduitT ByteString Void IO a -> ConduitT () Void IO a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Void IO a
toClient)