{-# LANGUAGE OverloadedStrings #-} -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy , PortLookup , reverseProxySsl , TLSConfig (..) ) where import Prelude hiding ((++), FilePath) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Keter.PortManager (PortEntry (..)) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..)) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import qualified Network.Wai as Wai import Network.HTTP.Types (status301, status200) import qualified Keter.ReverseProxy as ReverseProxy 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) import Data.Default import Data.Yaml.FilePath import Data.Yaml ((.:?), (.!=)) import Data.Aeson (withObject) import Control.Applicative ((<$>)) import Filesystem.Path.CurrentOS (encodeString) import Data.String (fromString) data TLSConfig = TLSConfig !Warp.Settings !WarpTLS.TLSSettings instance ParseYamlFile TLSConfig where parseYamlFile basedir = withObject "TLSConfig" $ \o -> do cert <- lookupBase basedir o "certificate" key <- lookupBase basedir o "key" host <- (fmap fromString <$> o .:? "host") .!= "*" port <- o .:? "port" .!= 443 return $! TLSConfig Warp.defaultSettings { Warp.settingsHost = host , Warp.settingsPort = port } WarpTLS.defaultTlsSettings { WarpTLS.certFile = encodeString cert , WarpTLS.keyFile = encodeString key } -- | Mapping from virtual hostname to port number. type PortLookup = ByteString -> IO (Maybe PortEntry) reverseProxy :: Bool -> Manager -> Warp.Settings -> PortLookup -> IO () reverseProxy useHeader manager settings = Warp.runSettings settings . withClient useHeader manager reverseProxySsl :: Bool -> Manager -> WarpTLS.TLSSettings -> Warp.Settings -> PortLookup -> IO () reverseProxySsl useHeader manager tsettings settings = WarpTLS.runTLS tsettings settings . withClient useHeader manager withClient :: Bool -- ^ use incoming request header for IP address -> Manager -> PortLookup -> Wai.Application withClient useHeader manager portLookup = waiProxyToSettings getDest def { wpsSetIpHeader = if useHeader then SIHFromHeader else SIHFromSocket } manager where getDest req = do mport <- liftIO $ maybe (return Nothing) portLookup mhost case mport of 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 Just (PEReverseProxy rpentry) -> fmap WPRResponse $ ReverseProxy.simpleReverseProxy rpentry req where mhost = lookup "host" $ Wai.requestHeaders req redirectApp :: ByteString -> Wai.Request -> Wai.Response redirectApp host req = Wai.responseLBS status301 [("Location", dest)] (L.fromChunks [dest]) where dest = S.concat [ "http://" , host , Wai.rawPathInfo req , Wai.rawQueryString req ] toResponse :: Maybe ByteString -> Wai.Response toResponse mhost = Wai.ResponseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ case mhost of Nothing -> copyByteString "\nWelcome to Keter

Welcome to Keter

You did not provide a virtual hostname for this request.

" Just host -> copyByteString "\nWelcome to Keter

Welcome to Keter

The hostname you have provided, " `mappend` copyByteString host `mappend` copyByteString ", is not recognized.

"