2012-08-06 18:44:41 +04:00
{- # LANGUAGE OverloadedStrings # -}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
( reverseProxy
, PortLookup
2012-08-09 19:12:32 +04:00
, reverseProxySsl
, setDir
2012-10-02 23:57:27 +04:00
, TLSConfig
, TLSConfigNoDir
2012-08-06 18:44:41 +04:00
) where
2012-08-09 19:12:32 +04:00
import Prelude hiding ( ( ++ ) , FilePath )
2012-11-04 12:35:21 +04:00
import Keter.Prelude ( ( ++ ) )
2012-08-06 18:44:41 +04:00
import Data.Conduit
import Data.Conduit.Network
import Data.ByteString ( ByteString )
2012-10-21 09:07:26 +04:00
import Keter.PortManager ( PortEntry ( .. ) )
import qualified Data.ByteString as S
2012-08-06 18:44:41 +04:00
import qualified Data.ByteString.Lazy as L
2012-08-09 19:12:32 +04:00
import Keter.SSL
2012-10-12 14:59:46 +04:00
import Network.HTTP.ReverseProxy ( rawProxyTo , ProxyDest ( ProxyDest ) , waiToRaw )
import Network.Wai.Application.Static ( defaultFileServerSettings , staticApp )
2012-10-21 09:07:26 +04:00
import qualified Network.Wai as Wai
import Network.HTTP.Types ( status301 )
2013-03-17 01:36:57 +04:00
import Data.Text.Encoding ( encodeUtf8 )
2012-08-06 18:44:41 +04:00
-- | Mapping from virtual hostname to port number.
2012-10-21 09:07:26 +04:00
type PortLookup = ByteString -> IO ( Maybe PortEntry )
2012-08-06 18:44:41 +04:00
2012-10-21 09:11:46 +04:00
reverseProxy :: ServerSettings IO -> PortLookup -> IO ()
reverseProxy settings = runTCPServer settings . withClient
2012-08-06 18:44:41 +04:00
2012-10-21 09:11:46 +04:00
reverseProxySsl :: TLSConfig -> PortLookup -> IO ()
reverseProxySsl settings = runTCPServerTLS settings . withClient
2012-08-09 19:12:32 +04:00
2012-08-06 18:44:41 +04:00
withClient :: PortLookup
2012-10-02 23:57:27 +04:00
-> Application IO
2012-10-21 09:11:46 +04:00
withClient portLookup =
2012-10-02 23:57:27 +04:00
rawProxyTo getDest
2012-08-06 18:44:41 +04:00
where
2012-10-02 23:57:27 +04:00
getDest headers = do
2012-11-04 12:35:21 +04:00
mport <- maybe ( return Nothing ) portLookup mhost
2012-10-02 23:57:27 +04:00
case mport of
2012-11-04 12:35:21 +04:00
Nothing -> return $ Left $ srcToApp $ toResponse mhost
2012-10-21 09:07:26 +04:00
Just ( PEPort port ) -> return $ Right $ ProxyDest " 127.0.0.1 " port
Just ( PEStatic root ) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root
Just ( PERedirect host ) -> return $ Left $ waiToRaw $ redirectApp host
2013-03-17 01:36:57 +04:00
Just ( PEReverseProxy host port ) -> return $ Right $ ProxyDest ( encodeUtf8 host ) port
2012-11-04 12:35:21 +04:00
where
mhost = lookup " host " headers
2012-10-21 09:07:26 +04:00
redirectApp :: ByteString -> Wai . Application
redirectApp host req = return $ Wai . responseLBS
status301
[ ( " Location " , dest ) ]
( L . fromChunks [ dest ] )
where
dest = S . concat
[ " http:// "
, host
, Wai . rawPathInfo req
, Wai . rawQueryString req
]
2012-08-06 18:44:41 +04:00
2012-10-04 20:26:21 +04:00
srcToApp :: Monad m => Source m ByteString -> Application m
srcToApp src appdata = src $$ appSink appdata
2012-11-04 12:35:21 +04:00
toResponse :: Monad m => Maybe ByteString -> Source m ByteString
toResponse Nothing =
yield " HTTP/1.1 200 OK \ r \ n Content-Type: text/html; charset=utf-8 \ r \ n \ r \ n <html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html> "
toResponse ( Just host ) =
yield $ " HTTP/1.1 200 OK \ r \ n Content-Type: text/html; charset=utf-8 \ r \ n \ r \ n <html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code> " ++ host ++ " </code>, is not recognized.</p></body></html> "
