2012-08-06 18:44:41 +04:00
{- # LANGUAGE OverloadedStrings # -}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
( reverseProxy
, PortLookup
, HostList
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-10-12 14:59:46 +04:00
import Keter.Prelude ( ( ++ ) , FilePath )
2012-08-09 19:12:32 +04:00
import Prelude hiding ( ( ++ ) , FilePath )
2012-08-06 18:44:41 +04:00
import Data.Conduit
import Data.Conduit.Network
import Data.ByteString ( ByteString )
import Keter.PortManager ( Port )
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder ( fromByteString , toLazyByteString )
import Data.Monoid ( mconcat )
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 )
2012-10-02 23:57:27 +04:00
import Control.Applicative ( ( <$> ) )
2012-10-12 14:59:46 +04:00
import Network.Wai.Application.Static ( defaultFileServerSettings , staticApp )
2012-08-06 18:44:41 +04:00
-- | Mapping from virtual hostname to port number.
2012-10-12 14:59:46 +04:00
type PortLookup = ByteString -> IO ( Maybe ( Either Port FilePath ) )
2012-08-06 18:44:41 +04:00
type HostList = IO [ ByteString ]
2012-10-04 20:26:21 +04:00
reverseProxy :: ServerSettings IO -> PortLookup -> HostList -> IO ()
2012-08-06 18:44:41 +04:00
reverseProxy settings x = runTCPServer settings . withClient x
2012-10-02 23:57:27 +04:00
reverseProxySsl :: TLSConfig -> PortLookup -> HostList -> IO ()
reverseProxySsl settings x = runTCPServerTLS settings . withClient x
2012-08-09 19:12:32 +04:00
2012-08-06 18:44:41 +04:00
withClient :: PortLookup
-> HostList
2012-10-02 23:57:27 +04:00
-> Application IO
withClient portLookup hostList =
rawProxyTo getDest
2012-08-06 18:44:41 +04:00
where
2012-10-02 23:57:27 +04:00
getDest headers = do
mport <- maybe ( return Nothing ) portLookup $ lookup " host " headers
case mport of
2012-10-04 20:26:21 +04:00
Nothing -> Left . srcToApp . toResponse <$> hostList
2012-10-12 14:59:46 +04:00
Just ( Left port ) -> return $ Right $ ProxyDest " 127.0.0.1 " port
Just ( Right root ) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root
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-10-02 23:57:27 +04:00
toResponse :: Monad m => [ ByteString ] -> Source m ByteString
2012-08-06 18:44:41 +04:00
toResponse hosts =
2012-10-02 23:57:27 +04:00
mapM_ yield $ L . toChunks $ toLazyByteString $ front ++ mconcat ( map go hosts ) ++ end
2012-08-06 18:44:41 +04:00
where
front = fromByteString " 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 may access the following sites:</p><ul> "
end = fromByteString " </ul></body></html> "
go host = fromByteString " <li><a href= \ " http:// " ++ fromByteString host ++ fromByteString " / \ " > " ++
fromByteString host ++ fromByteString " </a></li> "
