0ec27e9d27
Former-commit-id: 3a5b68b568058848a84c5801e99be1e3d11f2675 Former-commit-id: b9c43a5b446e9c3fde4e9016864e036b1c97dfba [formerly 7cf2553244e5ff0af1c729564905ab05d072720f] [formerly 0a79f27e64df05797d06a8da9bf7543c84e86ed7 [formerly 5599e859e906704ab0d6b0a65658a4aeb8403f8e [formerly 5599e859e906704ab0d6b0a65658a4aeb8403f8e [formerly 5599e859e906704ab0d6b0a65658a4aeb8403f8e [formerly 843382a22560623c415f2e527be2a1bb1bb87772]]]]] Former-commit-id: 75969df6de5f2c3ee08f81dc1a4d457d492b87ed [formerly 592aadc955cf333a8e23f7b75707159ed9510d8a] Former-commit-id: 94cebea834834afcb565978fd8a188af8afa86a6 Former-commit-id: 8549165bda8f705454ee2f2dedc81276918c4b71 Former-commit-id: 0761f82c3eb56fded8c6f5c4ed4b4056625948e9 Former-commit-id: 74c23dae521058b04ea41ac90e9ba06f76ecd6d1 [formerly 3e7d2e15cc64a4ddb87f24d817a64c714a7f6c81] Former-commit-id: e3a78bcbc38400fd94f9cc0dcf7cd4517000baa4
81 lines
3.3 KiB
Haskell
81 lines
3.3 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
module HttpProxy () where
|
|
|
|
|
|
|
|
import ClassyPrelude
|
|
import qualified Data.ByteString.Char8 as BC
|
|
|
|
import Control.Monad.Except
|
|
import qualified Data.Conduit.Network.TLS as N
|
|
import qualified Data.Streaming.Network as N
|
|
import System.Timeout
|
|
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import Network.Socket (HostName, PortNumber)
|
|
import qualified Network.Socket as N hiding (recv, recvFrom, send,
|
|
sendTo)
|
|
import qualified Network.Socket.ByteString as N
|
|
|
|
import Logger
|
|
import Types
|
|
|
|
|
|
data HttpProxySettings = HttpProxySettings
|
|
{ proxyHost :: HostName
|
|
, proxyPort :: PortNumber
|
|
, credentials :: Maybe (ByteString, ByteString)
|
|
} deriving (Show)
|
|
|
|
|
|
httpProxyConnection :: MonadError Error m => HttpProxySettings -> (HostName, PortNumber) -> (Connection -> IO (m a)) -> IO (m a)
|
|
httpProxyConnection HttpProxySettings{..} (host, port) app = onError $ do
|
|
debug $ "Opening tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort
|
|
|
|
ret <- N.runTCPClient (N.clientSettingsTCP (fromIntegral proxyPort) (fromString proxyHost)) $ \conn' -> do
|
|
let conn = toConnection conn'
|
|
_ <- sendConnectRequest conn
|
|
|
|
-- wait 10sec for a reply before giving up
|
|
let _10sec = 1000000 * 10
|
|
responseM <- timeout _10sec $ readConnectResponse mempty conn
|
|
|
|
case responseM of
|
|
Just (isAuthorized -> True) -> app conn
|
|
Just response -> return . throwError $ ProxyForwardError (BC.unpack response)
|
|
Nothing -> return . throwError $ ProxyForwardError ("No response from the proxy after "
|
|
<> show (_10sec `div` 1000000) <> "sec" )
|
|
|
|
debug $ "Closing tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort
|
|
return ret
|
|
|
|
where
|
|
credentialsToHeader :: (ByteString, ByteString) -> ByteString
|
|
credentialsToHeader (user, password) = "Proxy-Authorization: Basic " <> B64.encode (user <> ":" <> password) <> "\r\n"
|
|
|
|
sendConnectRequest :: Connection -> IO ()
|
|
sendConnectRequest h = write h $ "CONNECT " <> fromString host <> ":" <> fromString (show port) <> " HTTP/1.0\r\n"
|
|
<> "Host: " <> fromString host <> ":" <> (fromString $ show port) <> "\r\n"
|
|
<> maybe mempty credentialsToHeader credentials
|
|
<> "\r\n"
|
|
|
|
readConnectResponse :: ByteString -> Connection -> IO ByteString
|
|
readConnectResponse buff conn = do
|
|
responseM <- read conn
|
|
case responseM of
|
|
Nothing -> return buff
|
|
Just response -> if "\r\n\r\n" `isInfixOf` response
|
|
then return $ buff <> response
|
|
else readConnectResponse (buff <> response) conn
|
|
|
|
isAuthorized :: ByteString -> Bool
|
|
isAuthorized response = " 200 " `isInfixOf` response
|
|
|
|
onError f = catch f $ \(e :: SomeException) -> return $
|
|
if (take 10 (show e) == "user error")
|
|
then throwError $ ProxyConnectionError (show e)
|
|
else throwError $ ProxyConnectionError ("Unknown Error :: " <> show e)
|