keter/Keter/Proxy.hs

{-# 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 "<!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>"
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`{-# LANGUAGE OverloadedStrings #-}`
			`-- \| A light-weight, minimalistic reverse HTTP proxy.`
			`module Keter.Proxy`
			`( reverseProxy`
			`, PortLookup`
Initial SSL support 2012-08-09 19:12:32 +04:00			`, reverseProxySsl`
Data.Yaml.FilePath 2013-07-10 10:57:38 +04:00			`, TLSConfig (..)`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`) where`

Initial SSL support 2012-08-09 19:12:32 +04:00			`import Prelude hiding ((++), FilePath)`
Use WAI proxying 2013-06-03 15:15:13 +04:00			`import Control.Monad.IO.Class (liftIO)`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`import Data.ByteString (ByteString)`
Host name redirects 2012-10-21 09:07:26 +04:00			`import Keter.PortManager (PortEntry (..))`
			`import qualified Data.ByteString as S`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`import qualified Data.ByteString.Lazy as L`
IP address headers #8 2013-06-03 15:45:52 +04:00			`import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..))`
static-hosts 2012-10-12 14:59:46 +04:00			`import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)`
Host name redirects 2012-10-21 09:07:26 +04:00			`import qualified Network.Wai as Wai`
Use WAI proxying 2013-06-03 15:15:13 +04:00			`import Network.HTTP.Types (status301, status200)`
Built-in reverse proxy now supports rewriting headers This is necessary for using Keter as a front-end to other web services that may require hacks like Jenkins does, where the "Location" header needs to be rewritten to use https on every response. Example: ``` root: .. port: 80 ssl: # host: port: key: certificate: reverse-proxy: - reversed-host: jenkins-internal.corp.example.com reversed-port: 8080 reversing-host: jenkins.example.com ssl: False rewrite-response: - header: Location from: ^http://jenkins.example.com to: https://jenkins.example.com ``` 2013-03-20 09:01:43 +04:00			`import qualified Keter.ReverseProxy as ReverseProxy`
Use WAI proxying 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)`
IP address headers #8 2013-06-03 15:45:52 +04:00			`import Data.Default`
Removed Keter.SSL 2013-07-10 11:00:02 +04:00			`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`
Better app config loading 2013-07-14 14:02:18 +04:00			`cert <- lookupBase basedir o "certificate"`
			`key <- lookupBase basedir o "key"`
Removed Keter.SSL 2013-07-10 11:00:02 +04:00			`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`
			`}`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
			`-- \| Mapping from virtual hostname to port number.`
Host name redirects 2012-10-21 09:07:26 +04:00			`type PortLookup = ByteString -> IO (Maybe PortEntry)`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
IP address headers #8 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`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
IP address headers #8 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`
Initial SSL support 2012-08-09 19:12:32 +04:00
IP address headers #8 2013-06-03 15:45:52 +04:00			`withClient :: Bool -- ^ use incoming request header for IP address`
			`-> Manager`
Use WAI proxying 2013-06-03 15:15:13 +04:00			`-> PortLookup`
			`-> Wai.Application`
IP address headers #8 2013-06-03 15:45:52 +04:00			`withClient useHeader manager portLookup =`
			`waiProxyToSettings getDest def`
			`{ wpsSetIpHeader =`
			`if useHeader`
			`then SIHFromHeader`
			`else SIHFromSocket`
			`} manager`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`where`
Use WAI proxying 2013-06-03 15:15:13 +04:00			`getDest req = do`
			`mport <- liftIO $ maybe (return Nothing) portLookup mhost`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`case mport of`
Use WAI proxying 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`
			`Just (PEReverseProxy rpentry) -> fmap WPRResponse $ ReverseProxy.simpleReverseProxy rpentry req`
Slightly more helpful error messages 2012-11-04 12:35:21 +04:00			`where`
Use WAI proxying 2013-06-03 15:15:13 +04:00			`mhost = lookup "host" $ Wai.requestHeaders req`
Host name redirects 2012-10-21 09:07:26 +04:00
Use WAI proxying 2013-06-03 15:15:13 +04:00			`redirectApp :: ByteString -> Wai.Request -> Wai.Response`
			`redirectApp host req = Wai.responseLBS`
Host name redirects 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`
			`]`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
Use WAI proxying 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>"