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
2013-07-10 10:57:38 +04:00
, TLSConfig ( .. )
2012-08-06 18:44:41 +04:00
) where
2012-08-09 19:12:32 +04:00
import Prelude hiding ( ( ++ ) , FilePath )
2013-06-03 15:15:13 +04:00
import Control.Monad.IO.Class ( liftIO )
2012-08-06 18:44:41 +04:00
import Data.ByteString ( ByteString )
2013-07-25 14:07:48 +04:00
import Keter.HostManager ( HostEntry ( .. ) )
2012-10-21 09:07:26 +04:00
import qualified Data.ByteString as S
2012-08-06 18:44:41 +04:00
import qualified Data.ByteString.Lazy as L
2013-06-03 15:45:52 +04:00
import Network.HTTP.ReverseProxy ( waiProxyToSettings , wpsSetIpHeader , SetIpHeader ( .. ) , ProxyDest ( ProxyDest ) , WaiProxyResponse ( .. ) )
2012-10-12 14:59:46 +04:00
import Network.Wai.Application.Static ( defaultFileServerSettings , staticApp )
2012-10-21 09:07:26 +04:00
import qualified Network.Wai as Wai
2013-06-03 15:15:13 +04:00
import Network.HTTP.Types ( status301 , status200 )
2013-07-25 15:18:32 +04:00
import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite
2013-06-03 15:15:13 +04:00
import Network.HTTP.Conduit ( Manager )
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import Blaze.ByteString.Builder ( copyByteString )
import Data.Monoid ( mappend )
2013-06-03 15:45:52 +04:00
import Data.Default
2013-07-14 16:55:05 +04:00
import Keter.Types
2012-08-06 18:44:41 +04:00
-- | Mapping from virtual hostname to port number.
2013-07-25 14:07:48 +04:00
type PortLookup = ByteString -> IO ( Maybe HostEntry )
2012-08-06 18:44:41 +04:00
2013-06-03 15:45:52 +04:00
reverseProxy :: Bool -> Manager -> Warp . Settings -> PortLookup -> IO ()
reverseProxy useHeader manager settings = Warp . runSettings settings . withClient useHeader manager
2012-08-06 18:44:41 +04:00
2013-06-03 15:45:52 +04:00
reverseProxySsl :: Bool -> Manager -> WarpTLS . TLSSettings -> Warp . Settings -> PortLookup -> IO ()
reverseProxySsl useHeader manager tsettings settings = WarpTLS . runTLS tsettings settings . withClient useHeader manager
2012-08-09 19:12:32 +04:00
2013-06-03 15:45:52 +04:00
withClient :: Bool -- ^ use incoming request header for IP address
-> Manager
2013-06-03 15:15:13 +04:00
-> PortLookup
-> Wai . Application
2013-06-03 15:45:52 +04:00
withClient useHeader manager portLookup =
waiProxyToSettings getDest def
{ wpsSetIpHeader =
if useHeader
then SIHFromHeader
else SIHFromSocket
} manager
2012-08-06 18:44:41 +04:00
where
2013-06-03 15:15:13 +04:00
getDest req = do
mport <- liftIO $ maybe ( return Nothing ) portLookup mhost
2012-10-02 23:57:27 +04:00
case mport of
2013-06-03 15:15:13 +04:00
Nothing -> return $ WPRResponse $ toResponse mhost
Just ( PEPort port ) -> return $ WPRProxyDest $ ProxyDest " 127.0.0.1 " port
Just ( PEStatic root ) -> fmap WPRResponse $ staticApp ( defaultFileServerSettings root ) req
Just ( PERedirect host ) -> return $ WPRResponse $ redirectApp host req
2013-07-25 15:18:32 +04:00
Just ( PEReverseProxy rpentry ) -> fmap WPRResponse $ Rewrite . simpleReverseProxy rpentry req
2012-11-04 12:35:21 +04:00
where
2013-06-03 15:15:13 +04:00
mhost = lookup " host " $ Wai . requestHeaders req
2012-10-21 09:07:26 +04:00
2013-06-03 15:15:13 +04:00
redirectApp :: ByteString -> Wai . Request -> Wai . Response
redirectApp host req = Wai . responseLBS
2012-10-21 09:07:26 +04:00
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
2013-06-03 15:15:13 +04:00
toResponse :: Maybe ByteString -> Wai . Response
toResponse mhost = Wai . ResponseBuilder
status200
[ ( " Content-Type " , " text/html; charset=utf-8 " ) ]
$ case mhost of
Nothing -> copyByteString " <!DOCTYPE html> \ 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> "
Just host ->
copyByteString " <!DOCTYPE html> \ n <html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code> "
` mappend ` copyByteString host
` mappend ` copyByteString " </code>, is not recognized.</p></body></html> "
