keter/Keter/Proxy.hs

{-# LANGUAGE OverloadedStrings #-}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
    ( reverseProxy
    , PortLookup
    , reverseProxySsl
    , setDir
    , TLSConfig
    , TLSConfigNoDir
    ) where

import Prelude hiding ((++), FilePath)
import Keter.Prelude ((++))
import Data.Conduit
import Data.Conduit.Network
import Data.ByteString (ByteString)
import Keter.PortManager (PortEntry (..))
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Keter.SSL
import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import qualified Network.Wai as Wai
import Network.HTTP.Types (status301)
import qualified Keter.ReverseProxy as ReverseProxy

-- | Mapping from virtual hostname to port number.
type PortLookup = ByteString -> IO (Maybe PortEntry)

reverseProxy :: ServerSettings IO -> PortLookup -> IO ()
reverseProxy settings = runTCPServer settings . withClient

reverseProxySsl :: TLSConfig -> PortLookup -> IO ()
reverseProxySsl settings = runTCPServerTLS settings . withClient

withClient :: PortLookup
           -> Application IO
withClient portLookup =
    rawProxyTo getDest
  where
    getDest headers = do
        mport <- maybe (return Nothing) portLookup mhost
        case mport of
            Nothing -> return $ Left $ srcToApp $ toResponse mhost
            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
            Just (PEReverseProxy rpentry) -> return $ Left $ waiToRaw $ ReverseProxy.simpleReverseProxy rpentry
      where
        mhost = lookup "host" headers

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
        ]

srcToApp :: Monad m => Source m ByteString -> Application m
srcToApp src appdata = src $$ appSink appdata

toResponse :: Monad m => Maybe ByteString -> Source m ByteString
toResponse Nothing =
    yield "HTTP/1.1 200 OK\r\nContent-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\nContent-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>"
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`
			`, setDir`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`, TLSConfig`
			`, TLSConfigNoDir`
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)`
Slightly more helpful error messages 2012-11-04 12:35:21 +04:00			`import Keter.Prelude ((++))`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`import Data.Conduit`
			`import Data.Conduit.Network`
			`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`
Initial SSL support 2012-08-09 19:12:32 +04:00			`import Keter.SSL`
static-hosts 2012-10-12 14:59:46 +04:00			`import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)`
			`import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)`
Host name redirects 2012-10-21 09:07:26 +04:00			`import qualified Network.Wai as Wai`
			`import Network.HTTP.Types (status301)`
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`
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
Removed host list on Keter welcome page 2012-10-21 09:11:46 +04:00			`reverseProxy :: ServerSettings IO -> PortLookup -> IO ()`
			`reverseProxy settings = runTCPServer settings . withClient`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
Removed host list on Keter welcome page 2012-10-21 09:11:46 +04:00			`reverseProxySsl :: TLSConfig -> PortLookup -> IO ()`
			`reverseProxySsl settings = runTCPServerTLS settings . withClient`
Initial SSL support 2012-08-09 19:12:32 +04:00
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`withClient :: PortLookup`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`-> Application IO`
Removed host list on Keter welcome page 2012-10-21 09:11:46 +04:00			`withClient portLookup =`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`rawProxyTo getDest`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00			`where`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`getDest headers = do`
Slightly more helpful error messages 2012-11-04 12:35:21 +04:00			`mport <- maybe (return Nothing) portLookup mhost`
network-conduit-tls and http-reverse-proxy 2012-10-02 23:57:27 +04:00			`case mport of`
Slightly more helpful error messages 2012-11-04 12:35:21 +04:00			`Nothing -> return $ Left $ srcToApp $ toResponse mhost`
Host name redirects 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`
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			`Just (PEReverseProxy rpentry) -> return $ Left $ waiToRaw $ ReverseProxy.simpleReverseProxy rpentry`
Slightly more helpful error messages 2012-11-04 12:35:21 +04:00			`where`
			`mhost = lookup "host" headers`
Host name redirects 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`
			`]`
Initial built-in reverse proxy (no Nginx required) 2012-08-06 18:44:41 +04:00
New network-conduit 2012-10-04 20:26:21 +04:00			`srcToApp :: Monad m => Source m ByteString -> Application m`
			`srcToApp src appdata = src $$ appSink appdata`

Slightly more helpful error messages 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\nContent-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\nContent-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>"`