diff --git a/Keter/HostManager.hs b/Keter/HostManager.hs index f46f0b3..5dcd0c1 100644 --- a/Keter/HostManager.hs +++ b/Keter/HostManager.hs @@ -1,139 +1,129 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Keter.HostManager ( -- * Types - Port - , Host - , HostManager - , HostEntry (..) + HostManager + , Reservations + , Conflicts -- * Actions - , getPort - , releasePort - , addEntry - , removeEntry - , lookupPort + , reserveHosts + , forgetReservations + , activateApp + , lookupAction -- * Initialize , start ) where -import Keter.Prelude -import qualified Control.Monad.Trans.State as S -import Control.Monad.Trans.Class (lift) -import qualified Data.Map as Map -import Control.Monad (forever, mplus) -import Data.ByteString.Char8 () -import qualified Network -import qualified Data.ByteString as S -import Data.Text.Encoding (encodeUtf8) -import Network.HTTP.ReverseProxy.Rewrite (RPEntry) -import Keter.Types +import Control.Applicative +import qualified Control.Concurrent.MVar as M +import Control.Exception (assert) +import Data.ByteString.Char8 () +import Data.Either (partitionEithers) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text.Encoding (encodeUtf8) +import Keter.Prelude +import Keter.Types +import Prelude (null) +import Prelude (IO) -data Command = GetPort (Either SomeException Port -> KIO ()) - | ReleasePort Port - | AddEntry Host HostEntry - | RemoveEntry Host - | AddDefaultEntry HostEntry - | RemoveDefaultEntry - | LookupPort S.ByteString (Maybe HostEntry -> KIO ()) +type HMState = Map.Map HostBS HostValue --- | An abstract type which can accept commands and sends them to a background --- nginx thread. -newtype HostManager = HostManager (Command -> KIO ()) +data HostValue = HVActive !Appname !ProxyAction + | HVReserved !Appname --- | Start running a separate thread which will accept commands and modify --- Nginx's behavior accordingly. -start :: PortSettings -> KIO (Either SomeException HostManager) -start PortSettings{..} = do - chan <- newChan - forkKIO $ flip S.evalStateT freshState $ forever $ do - command <- lift $ readChan chan - case command of - GetPort f -> do - ns0 <- S.get - let loop :: NState -> KIO (Either SomeException Port, NState) - loop ns = - case nsAvail ns of - p:ps -> do - res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p - case res of - Left (_ :: SomeException) -> do - log $ RemovingPort p - loop ns { nsAvail = ps } - Right socket -> do - res' <- liftIO $ Network.sClose socket - case res' of - Left e -> do - $logEx e - log $ RemovingPort p - loop ns { nsAvail = ps } - Right () -> return (Right p, ns { nsAvail = ps }) - [] -> - case reverse $ nsRecycled ns of - [] -> return (Left $ toException NoPortsAvailable, ns) - ps -> loop ns { nsAvail = ps, nsRecycled = [] } - (eport, ns) <- lift $ loop ns0 - S.put ns - lift $ f eport - ReleasePort p -> - S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns } - AddEntry h e -> change $ Map.insert (encodeUtf8 h) e - RemoveEntry h -> change $ Map.delete $ encodeUtf8 h - AddDefaultEntry e -> S.modify $ \ns -> ns { nsDefault = Just e } - RemoveDefaultEntry -> S.modify $ \ns -> ns { nsDefault = Nothing } - LookupPort h f -> do - NState {..} <- S.get - lift $ f $ mplus (Map.lookup h nsEntries) nsDefault - return $ Right $ HostManager $ writeChan chan +newtype HostManager = HostManager (MVar HMState) -- FIXME use an IORef instead + +type Conflicts = Map.Map Host Appname +type Reservations = Set.Set Host + +start :: IO HostManager +start = HostManager <$> M.newMVar Map.empty + +-- | Reserve the given hosts so that no other application may use them. Does +-- not yet enable any action. The semantics are: +-- +-- 1. If a requested host is currently actively used or by an app of the same name, it is +-- considered reserved. +-- +-- 2. If a requested host is currently reserved by an app of the same name, it +-- is considered an error in calling this API. Only one app reservation can +-- happen at a time. +-- +-- 3. If any requested host is currently used or reserved by an app with a +-- different name, then those values are returned as @Left@. +-- +-- 4. Otherwise, the hosts which were reserved are returned as @Right@. This +-- does /not/ include previously active hosts. +reserveHosts :: HostManager + -> Appname + -> Set.Set Host + -> KIO (Either Conflicts Reservations) +reserveHosts (HostManager mstate) app hosts = modifyMVar mstate $ \entries0 -> + return $ case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of + ([], toReserve) -> + (Set.foldr reserve entries0 $ Set.unions toReserve, Right Set.empty) + (conflicts, _) -> (entries0, Left $ Map.fromList conflicts) where - change f = do - ns <- S.get - let entries = f $ nsEntries ns - S.put $ ns { nsEntries = entries } - freshState = NState portRange [] Map.empty Nothing + checkHost entries0 host = + case Map.lookup (encodeUtf8 host) entries0 of + Nothing -> Right $ Set.singleton host + Just (HVReserved app') -> assert (app /= app') + $ Left (host, app') + Just (HVActive app' _) + | app == app' -> Right Set.empty + | otherwise -> Left (host, app') -data NState = NState - { nsAvail :: [Port] - , nsRecycled :: [Port] - , nsEntries :: Map.Map S.ByteString HostEntry - , nsDefault :: Maybe HostEntry - } + hvres = HVReserved app + reserve host es = + assert (Map.notMember hostBS es) $ Map.insert hostBS hvres es + where + hostBS = encodeUtf8 host --- | Gets an unassigned port number. -getPort :: HostManager -> KIO (Either SomeException Port) -getPort (HostManager f) = do - x <- newEmptyMVar - f $ GetPort $ \p -> putMVar x p - takeMVar x +-- | Forget previously made reservations. +forgetReservations :: HostManager + -> Appname + -> Reservations + -> KIO () +forgetReservations (HostManager mstate) app hosts = modifyMVar_ mstate $ \state0 -> + return $ Set.foldr forget state0 hosts + where + forget host state = + assert isReservedByMe $ Map.delete hostBS state + where + hostBS = encodeUtf8 host + isReservedByMe = + case Map.lookup hostBS state of + Nothing -> False + Just (HVReserved app') -> app == app' + Just HVActive{} -> False --- | Inform the nginx thread that the given port number is no longer being --- used, and may be reused by a new process. Note that recycling puts the new --- ports at the end of the queue (FIFO), so that if an application holds onto --- the port longer than expected, there should be no issues. -releasePort :: HostManager -> Port -> KIO () -releasePort (HostManager f) p = f $ ReleasePort p +-- | Activate a new app. Note that you /must/ first reserve the hostnames you'll be using. +activateApp :: HostManager + -> Appname + -> Map.Map Host ProxyAction + -> KIO () +activateApp (HostManager mstate) app actions = modifyMVar_ mstate $ \state0 -> + return $ Map.foldrWithKey activate state0 actions + where + activate host action state = + assert isOwnedByMe $ Map.insert hostBS (HVActive app action) state + where + hostBS = encodeUtf8 host + isOwnedByMe = + case Map.lookup hostBS state of + Nothing -> False + Just (HVReserved app') -> app == app' + Just (HVActive app' _) -> app == app' --- | Add a new entry to the configuration for the given hostname and reload --- nginx. Will overwrite any existing configuration for the given host. The --- second point is important: it is how we achieve zero downtime transitions --- between an old and new version of an app. -addEntry :: HostManager -> Host -> HostEntry -> KIO () -addEntry (HostManager f) h p = f $ case h of - "*" -> AddDefaultEntry p - _ -> AddEntry h p - -data HostEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString | PEReverseProxy RPEntry - --- | Remove an entry from the configuration and reload nginx. -removeEntry :: HostManager -> Host -> KIO () -removeEntry (HostManager f) h = f $ case h of - "*" -> RemoveDefaultEntry - _ -> RemoveEntry h - -lookupPort :: HostManager -> S.ByteString -> KIO (Maybe HostEntry) -lookupPort (HostManager f) h = do - x <- newEmptyMVar - f $ LookupPort h $ \p -> putMVar x p - takeMVar x +lookupAction :: HostManager + -> HostBS + -> KIO (Maybe ProxyAction) +lookupAction (HostManager mstate) host = withMVar mstate $ \state -> + return $ case Map.lookup host state of + Nothing -> Nothing + Just (HVActive _ action) -> Just action + Just (HVReserved _) -> Nothing diff --git a/Keter/Main.hs b/Keter/Main.hs index 1b70cf1..fa9ef9a 100644 --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -13,6 +13,7 @@ import qualified Codec.Archive.TempTarball as TempFolder import qualified Keter.App as App import Keter.Types import qualified Keter.HostManager as HostMan +import qualified Keter.PortPool as PortPool import qualified Keter.Proxy as Proxy import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite import System.Posix.Files (modificationTime, getFileStatus) @@ -66,7 +67,8 @@ keter (F.decodeString -> input) mkPlugins = do Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue)) processTracker <- initProcessTracker - portman <- runThrow $ HostMan.start kconfigHostMan + hostman <- HostMan.start + portpool <- PortPool.start kconfigPortPool tf <- runThrow $ liftIO $ TempFolder.setup $ kconfigDir "temp" plugins <- runThrow $ loadPlugins $ map ($ kconfigDir) mkPlugins mainlog <- runThrow $ liftIO $ LogFile.openRotatingLog @@ -92,7 +94,7 @@ keter (F.decodeString -> input) mkPlugins = do { Warp.settingsPort = kconfigPort , Warp.settingsHost = kconfigHost } - (runKIOPrint . HostMan.lookupPort portman) + (runKIOPrint . HostMan.lookupAction hostman) case kconfigSsl of Nothing -> return () Just (Proxy.TLSConfig s ts) -> do @@ -101,7 +103,7 @@ keter (F.decodeString -> input) mkPlugins = do manager ts s - (runKIOPrint . HostMan.lookupPort portman) + (runKIOPrint . HostMan.lookupAction hostman) return () mappMap <- M.newMVar Map.empty @@ -132,7 +134,7 @@ keter (F.decodeString -> input) mkPlugins = do tf muid processTracker - portman + hostman plugins logger appname @@ -158,7 +160,7 @@ keter (F.decodeString -> input) mkPlugins = do {- FIXME handle static stanzas let staticReverse r = do - HostMan.addEntry portman (ReverseProxy.reversingHost r) + HostMan.addEntry hostman (ReverseProxy.reversingHost r) $ HostMan.PEReverseProxy $ ReverseProxy.RPEntry r manager runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy) diff --git a/Keter/PortPool.hs b/Keter/PortPool.hs new file mode 100644 index 0000000..8489722 --- /dev/null +++ b/Keter/PortPool.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Manages a pool of available ports and allocates them. +module Keter.PortPool + ( -- * Types + PortPool + -- * Actions + , getPort + , releasePort + -- * Initialize + , start + ) where + +import Control.Applicative ((<$>)) +import qualified Control.Concurrent.MVar as M +import Keter.Prelude +import Keter.Types +import qualified Network +import Prelude (IO) + +data PPState = PPState + { ppAvail :: ![Port] + , ppRecycled :: !([Port] -> [Port]) + } + +newtype PortPool = PortPool (MVar PPState) + +-- | Gets an unassigned port number. +getPort :: PortPool -> KIO (Either SomeException Port) +getPort (PortPool mstate) = + modifyMVar mstate loop + where + loop :: PPState -> KIO (PPState, Either SomeException Port) + loop PPState {..} = + case ppAvail of + p:ps -> do + let next = PPState ps ppRecycled + res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p + case res of + Left (_ :: SomeException) -> do + log $ RemovingPort p + loop next + Right socket -> do + res' <- liftIO $ Network.sClose socket + case res' of + Left e -> do + $logEx e + log $ RemovingPort p + loop next + Right () -> return (next, Right p) + [] -> + case ppRecycled [] of + [] -> return (PPState [] id, Left $ toException NoPortsAvailable) + ps -> loop $ PPState ps id + +-- | Return a port to the recycled collection of the pool. Note that recycling +-- puts the new ports at the end of the queue (FIFO), so that if an application +-- holds onto the port longer than expected, there should be no issues. +releasePort :: PortPool -> Port -> KIO () +releasePort (PortPool mstate) p = + modifyMVar_ mstate $ \(PPState avail recycled) -> return $ PPState avail $ recycled . (p:) + +start :: PortSettings -> IO PortPool +start PortSettings{..} = + PortPool <$> M.newMVar freshState + where + freshState = PPState portRange id diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs index 56d563d..1c04716 100644 --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -83,6 +83,7 @@ module Keter.Prelude , newEmptyMVar , modifyMVar , modifyMVar_ + , withMVar , swapMVar , takeMVar , tryTakeMVar @@ -245,6 +246,9 @@ newEmptyMVar = liftIO_ M.newEmptyMVar modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x) +withMVar :: M.MVar a -> (a -> KIO b) -> KIO b +withMVar m f = KIO $ \x -> M.withMVar m (\a -> unKIO (f a) x) + modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO () modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x) diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs index 0388a27..915daa9 100644 --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -2,7 +2,7 @@ -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy - , PortLookup + , HostLookup , reverseProxySsl , TLSConfig (..) ) where @@ -10,7 +10,6 @@ module Keter.Proxy import Prelude hiding ((++), FilePath) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) -import Keter.HostManager (HostEntry (..)) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..)) @@ -27,17 +26,17 @@ import Data.Default import Keter.Types -- | Mapping from virtual hostname to port number. -type PortLookup = ByteString -> IO (Maybe HostEntry) +type HostLookup = ByteString -> IO (Maybe ProxyAction) -reverseProxy :: Bool -> Manager -> Warp.Settings -> PortLookup -> IO () +reverseProxy :: Bool -> Manager -> Warp.Settings -> HostLookup -> IO () reverseProxy useHeader manager settings = Warp.runSettings settings . withClient useHeader manager -reverseProxySsl :: Bool -> Manager -> WarpTLS.TLSSettings -> Warp.Settings -> PortLookup -> IO () +reverseProxySsl :: Bool -> Manager -> WarpTLS.TLSSettings -> Warp.Settings -> HostLookup -> IO () reverseProxySsl useHeader manager tsettings settings = WarpTLS.runTLS tsettings settings . withClient useHeader manager withClient :: Bool -- ^ use incoming request header for IP address -> Manager - -> PortLookup + -> HostLookup -> Wai.Application withClient useHeader manager portLookup = waiProxyToSettings getDest def @@ -47,14 +46,21 @@ withClient useHeader manager portLookup = else SIHFromSocket } manager where - getDest req = do - mport <- liftIO $ maybe (return Nothing) portLookup mhost + getDest req = + case lookup "host" $ Wai.requestHeaders req of + Nothing -> return $ WPRResponse missingHostResponse + Just host -> processHost req host + + processHost req host = do + mport <- liftIO $ portLookup host case mport of - Nothing -> return $ WPRResponse $ toResponse mhost + Nothing -> return $ WPRResponse $ unknownHostResponse host + {- FIXME 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 (PERedirect dest) -> return $ WPRResponse $ redirectApp dest req Just (PEReverseProxy rpentry) -> fmap WPRResponse $ Rewrite.simpleReverseProxy rpentry req + -} where mhost = lookup "host" $ Wai.requestHeaders req @@ -71,13 +77,16 @@ redirectApp host req = Wai.responseLBS , Wai.rawQueryString req ] -toResponse :: Maybe ByteString -> Wai.Response -toResponse mhost = Wai.ResponseBuilder +missingHostResponse :: Wai.Response +missingHostResponse = 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.

" + $ copyByteString "\nWelcome to Keter

Welcome to Keter

You did not provide a virtual hostname for this request.

" + +unknownHostResponse :: ByteString -> Wai.Response +unknownHostResponse host = Wai.ResponseBuilder + status200 + [("Content-Type", "text/html; charset=utf-8")] + (copyByteString "\nWelcome to Keter

Welcome to Keter

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

") diff --git a/Keter/Types.hs b/Keter/Types.hs index 366b72a..25bdfc1 100644 --- a/Keter/Types.hs +++ b/Keter/Types.hs @@ -11,5 +11,6 @@ import Keter.Types.V10 as X , StaticFilesConfig (..) , KeterConfig (..) , Stanza (..) + , ProxyAction (..) ) -import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig (..), RewriteRule (..)) +import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..)) diff --git a/Keter/Types/Common.hs b/Keter/Types/Common.hs index bb934ab..04fe8fb 100644 --- a/Keter/Types/Common.hs +++ b/Keter/Types/Common.hs @@ -1,9 +1,10 @@ {-# LANGUAGE TypeFamilies #-} module Keter.Types.Common where -import Data.Text (Text) -import Data.Aeson (Object) -import Keter.Prelude (KIO) +import Data.Aeson (Object) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Keter.Prelude (KIO) -- | Name of the application. Should just be the basename of the application -- file. @@ -28,3 +29,5 @@ type Port = Int -- | A virtual host we want to serve content from. type Host = Text + +type HostBS = ByteString diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs index 3c79acd..649f108 100644 --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -45,7 +45,7 @@ instance ParseYamlFile BundleConfig where data KeterConfig = KeterConfig { kconfigDir :: F.FilePath - , kconfigHostMan :: V04.PortSettings + , kconfigPortPool :: V04.PortSettings , kconfigHost :: HostPreference , kconfigPort :: Port , kconfigSsl :: Maybe V04.TLSConfig @@ -69,7 +69,7 @@ instance ToCurrent KeterConfig where instance Default KeterConfig where def = KeterConfig { kconfigDir = "." - , kconfigHostMan = def + , kconfigPortPool = def , kconfigHost = "*" , kconfigPort = 80 , kconfigSsl = Nothing @@ -98,6 +98,18 @@ data Stanza = StanzaStaticFiles StaticFilesConfig | StanzaWebApp WebAppConfig | StanzaReverseProxy ReverseProxyConfig +-- | An action to be performed for a requested hostname. +-- +-- This datatype is very similar to Stanza, but is necessarily separate since: +-- +-- 1. Webapps will be assigned ports. +-- +-- 2. Not all stanzas have an associated proxy action. +data ProxyAction = PAPort Port + | PAStatic StaticFilesConfig + | PARedirect RedirectConfig + | PAReverseProxy ReverseProxyConfig + instance ParseYamlFile Stanza where parseYamlFile basedir = withObject "Stanza" $ \o -> do typ <- o .: "type" @@ -120,7 +132,7 @@ instance ToCurrent StaticFilesConfig where toCurrent (V04.StaticHost host root) = StaticFilesConfig { sfconfigRoot = root , sfconfigHosts = Set.singleton host - , sfconfigListings = False + , sfconfigListings = True } instance ParseYamlFile StaticFilesConfig where @@ -139,7 +151,7 @@ instance ToCurrent RedirectConfig where type Previous RedirectConfig = V04.Redirect toCurrent (V04.Redirect from to) = RedirectConfig { redirconfigHosts = Set.singleton from - , redirconfigStatus = 303 + , redirconfigStatus = 301 , redirconfigActions = V.singleton $ RedirectAction SPAny $ RDPrefix False to 80 } diff --git a/keter.cabal b/keter.cabal index d5f09ca..2531669 100644 --- a/keter.cabal +++ b/keter.cabal @@ -69,6 +69,7 @@ Library Keter.Types.Common Keter.App Keter.Main + Keter.PortPool Keter.Prelude Keter.Proxy Keter.HostManager