Separate PortPool, non-braindead host management (finally!)

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

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)

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

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)
 

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 "<!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>"
+    $ 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>"
+
+unknownHostResponse :: ByteString -> Wai.Response
+unknownHostResponse host = Wai.ResponseBuilder
+    status200
+    [("Content-Type", "text/html; charset=utf-8")]
+    (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>")

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 (..))

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

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
         }

keter.cabal

@@ -69,6 +69,7 @@ Library
                        Keter.Types.Common
                        Keter.App
                        Keter.Main
+                       Keter.PortPool
                        Keter.Prelude
                        Keter.Proxy
                        Keter.HostManager