module Keter.PortManager
(
Port
, Host
, PortManager
, PortEntry (..)
, Settings
, portRange
, getPort
, releasePort
, addEntry
, removeEntry
, lookupPort
, 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, mzero, mplus)
import Data.ByteString.Char8 ()
import qualified Network
import qualified Data.ByteString as S
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml (FromJSON (parseJSON), Value (Object))
import Control.Applicative ((<$>))
type Port = Int
type Host = String
data Command = GetPort (Either SomeException Port -> KIO ())
| ReleasePort Port
| AddEntry Host PortEntry
| RemoveEntry Host
| AddDefaultEntry PortEntry
| RemoveDefaultEntry
| LookupPort S.ByteString (Maybe PortEntry -> KIO ())
newtype PortManager = PortManager (Command -> KIO ())
data Settings = Settings
{ portRange :: [Port]
}
instance Default Settings where
def = Settings
{ portRange = [4000..4999]
}
instance FromJSON Settings where
parseJSON (Object _) = Settings
<$> return (portRange def)
parseJSON _ = mzero
start :: Settings -> KIO (Either SomeException PortManager)
start Settings{..} = 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 $ PortManager $ writeChan chan
where
change f = do
ns <- S.get
let entries = f $ nsEntries ns
S.put $ ns { nsEntries = entries }
freshState = NState portRange [] Map.empty Nothing
data NState = NState
{ nsAvail :: [Port]
, nsRecycled :: [Port]
, nsEntries :: Map.Map S.ByteString PortEntry
, nsDefault :: Maybe PortEntry
}
getPort :: PortManager -> KIO (Either SomeException Port)
getPort (PortManager f) = do
x <- newEmptyMVar
f $ GetPort $ \p -> putMVar x p
takeMVar x
releasePort :: PortManager -> Port -> KIO ()
releasePort (PortManager f) p = f $ ReleasePort p
addEntry :: PortManager -> Host -> PortEntry -> KIO ()
addEntry (PortManager f) h p = f $ case h of
"*" -> AddDefaultEntry p
_ -> AddEntry h p
data PortEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString
removeEntry :: PortManager -> Host -> KIO ()
removeEntry (PortManager f) h = f $ case h of
"*" -> RemoveDefaultEntry
_ -> RemoveEntry h
lookupPort :: PortManager -> S.ByteString -> KIO (Maybe PortEntry)
lookupPort (PortManager f) h = do
x <- newEmptyMVar
f $ LookupPort h $ \p -> putMVar x p
takeMVar x