mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-15 01:23:09 +03:00
60 lines
2.2 KiB
Haskell
60 lines
2.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | A light-weight, minimalistic reverse HTTP proxy.
|
|
module Keter.Proxy
|
|
( reverseProxy
|
|
, PortLookup
|
|
, HostList
|
|
, reverseProxySsl
|
|
, setDir
|
|
, TLSConfig
|
|
, TLSConfigNoDir
|
|
) where
|
|
|
|
import Keter.Prelude ((++))
|
|
import Prelude hiding ((++), FilePath)
|
|
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)
|
|
import Keter.SSL
|
|
import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest))
|
|
import Control.Applicative ((<$>))
|
|
|
|
-- | Mapping from virtual hostname to port number.
|
|
type PortLookup = ByteString -> IO (Maybe Port)
|
|
|
|
type HostList = IO [ByteString]
|
|
|
|
reverseProxy :: ServerSettings IO -> PortLookup -> HostList -> IO ()
|
|
reverseProxy settings x = runTCPServer settings . withClient x
|
|
|
|
reverseProxySsl :: TLSConfig -> PortLookup -> HostList -> IO ()
|
|
reverseProxySsl settings x = runTCPServerTLS settings . withClient x
|
|
|
|
withClient :: PortLookup
|
|
-> HostList
|
|
-> Application IO
|
|
withClient portLookup hostList =
|
|
rawProxyTo getDest
|
|
where
|
|
getDest headers = do
|
|
mport <- maybe (return Nothing) portLookup $ lookup "host" headers
|
|
case mport of
|
|
Nothing -> Left . srcToApp . toResponse <$> hostList
|
|
Just port -> return $ Right $ ProxyDest "127.0.0.1" port
|
|
|
|
srcToApp :: Monad m => Source m ByteString -> Application m
|
|
srcToApp src appdata = src $$ appSink appdata
|
|
|
|
toResponse :: Monad m => [ByteString] -> Source m ByteString
|
|
toResponse hosts =
|
|
mapM_ yield $ L.toChunks $ toLazyByteString $ front ++ mconcat (map go hosts) ++ end
|
|
where
|
|
front = fromByteString "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 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>"
|