Removed host list on Keter welcome page

This commit is contained in:
Michael Snoyman 2012-10-21 07:11:46 +02:00
parent b0c173a8c1
commit 52971e4b6f
3 changed files with 7 additions and 33 deletions

View File

@ -87,14 +87,12 @@ keter input' = do
_ <- forkIO $ Proxy.reverseProxy _ <- forkIO $ Proxy.reverseProxy
(serverSettings configPort configHost) (serverSettings configPort configHost)
(runKIOPrint . PortMan.lookupPort portman) (runKIOPrint . PortMan.lookupPort portman)
(runKIOPrint $ PortMan.hostList portman)
case configSsl of case configSsl of
Nothing -> return () Nothing -> return ()
Just ssl -> do Just ssl -> do
_ <- forkIO $ Proxy.reverseProxySsl _ <- forkIO $ Proxy.reverseProxySsl
(Proxy.setDir dir ssl) (Proxy.setDir dir ssl)
(runKIOPrint . PortMan.lookupPort portman) (runKIOPrint . PortMan.lookupPort portman)
(runKIOPrint $ PortMan.hostList portman)
return () return ()
mappMap <- M.newMVar Map.empty mappMap <- M.newMVar Map.empty

View File

@ -18,7 +18,6 @@ module Keter.PortManager
, addEntry , addEntry
, removeEntry , removeEntry
, lookupPort , lookupPort
, hostList
-- * Initialize -- * Initialize
, start , start
) where ) where
@ -46,7 +45,6 @@ data Command = GetPort (Either SomeException Port -> KIO ())
| AddEntry Host PortEntry | AddEntry Host PortEntry
| RemoveEntry Host | RemoveEntry Host
| LookupPort S.ByteString (Maybe PortEntry -> KIO ()) | LookupPort S.ByteString (Maybe PortEntry -> KIO ())
| HostList ([S.ByteString] -> KIO ())
-- | An abstract type which can accept commands and sends them to a background -- | An abstract type which can accept commands and sends them to a background
-- nginx thread. -- nginx thread.
@ -110,9 +108,6 @@ start Settings{..} = do
LookupPort h f -> do LookupPort h f -> do
NState {..} <- S.get NState {..} <- S.get
lift $ f $ Map.lookup h nsEntries lift $ f $ Map.lookup h nsEntries
HostList f -> do
NState {..} <- S.get
lift $ f $ Map.keys nsEntries
return $ Right $ PortManager $ writeChan chan return $ Right $ PortManager $ writeChan chan
where where
change f = do change f = do
@ -158,9 +153,3 @@ lookupPort (PortManager f) h = do
x <- newEmptyMVar x <- newEmptyMVar
f $ LookupPort h $ \p -> putMVar x p f $ LookupPort h $ \p -> putMVar x p
takeMVar x takeMVar x
hostList :: PortManager -> KIO [S.ByteString]
hostList (PortManager f) = do
x <- newEmptyMVar
f $ HostList $ \p -> putMVar x p
takeMVar x

View File

@ -3,14 +3,12 @@
module Keter.Proxy module Keter.Proxy
( reverseProxy ( reverseProxy
, PortLookup , PortLookup
, HostList
, reverseProxySsl , reverseProxySsl
, setDir , setDir
, TLSConfig , TLSConfig
, TLSConfigNoDir , TLSConfigNoDir
) where ) where
import Keter.Prelude ((++))
import Prelude hiding ((++), FilePath) import Prelude hiding ((++), FilePath)
import Data.Conduit import Data.Conduit
import Data.Conduit.Network import Data.Conduit.Network
@ -18,11 +16,8 @@ import Data.ByteString (ByteString)
import Keter.PortManager (PortEntry (..)) import Keter.PortManager (PortEntry (..))
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
import Data.Monoid (mconcat)
import Keter.SSL import Keter.SSL
import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw) import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)
import Control.Applicative ((<$>))
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
@ -30,24 +25,21 @@ import Network.HTTP.Types (status301)
-- | Mapping from virtual hostname to port number. -- | Mapping from virtual hostname to port number.
type PortLookup = ByteString -> IO (Maybe PortEntry) type PortLookup = ByteString -> IO (Maybe PortEntry)
type HostList = IO [ByteString] reverseProxy :: ServerSettings IO -> PortLookup -> IO ()
reverseProxy settings = runTCPServer settings . withClient
reverseProxy :: ServerSettings IO -> PortLookup -> HostList -> IO () reverseProxySsl :: TLSConfig -> PortLookup -> IO ()
reverseProxy settings x = runTCPServer settings . withClient x reverseProxySsl settings = runTCPServerTLS settings . withClient
reverseProxySsl :: TLSConfig -> PortLookup -> HostList -> IO ()
reverseProxySsl settings x = runTCPServerTLS settings . withClient x
withClient :: PortLookup withClient :: PortLookup
-> HostList
-> Application IO -> Application IO
withClient portLookup hostList = withClient portLookup =
rawProxyTo getDest rawProxyTo getDest
where where
getDest headers = do getDest headers = do
mport <- maybe (return Nothing) portLookup $ lookup "host" headers mport <- maybe (return Nothing) portLookup $ lookup "host" headers
case mport of case mport of
Nothing -> Left . srcToApp . toResponse <$> hostList Nothing -> return $ Left $ srcToApp $ toResponse []
Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port
Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root
Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host
@ -70,9 +62,4 @@ srcToApp src appdata = src $$ appSink appdata
toResponse :: Monad m => [ByteString] -> Source m ByteString toResponse :: Monad m => [ByteString] -> Source m ByteString
toResponse hosts = toResponse hosts =
mapM_ yield $ L.toChunks $ toLazyByteString $ front ++ mconcat (map go hosts) ++ end 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 is not recognized.</p></body></html>"
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>"