2013-07-25 16:44:23 +04:00
|
|
|
{-# 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 ((<$>))
|
2013-07-28 14:41:42 +04:00
|
|
|
import Control.Concurrent.MVar
|
|
|
|
import Control.Exception
|
2013-07-25 16:44:23 +04:00
|
|
|
import Keter.Types
|
|
|
|
import qualified Network
|
2013-07-28 14:41:42 +04:00
|
|
|
import Prelude hiding (log)
|
2013-07-25 16:44:23 +04:00
|
|
|
|
|
|
|
data PPState = PPState
|
|
|
|
{ ppAvail :: ![Port]
|
|
|
|
, ppRecycled :: !([Port] -> [Port])
|
|
|
|
}
|
|
|
|
|
|
|
|
newtype PortPool = PortPool (MVar PPState)
|
|
|
|
|
|
|
|
-- | Gets an unassigned port number.
|
2013-07-28 14:41:42 +04:00
|
|
|
getPort :: (LogMessage -> IO ())
|
|
|
|
-> PortPool
|
|
|
|
-> IO (Either SomeException Port)
|
|
|
|
getPort log (PortPool mstate) =
|
2013-07-25 16:44:23 +04:00
|
|
|
modifyMVar mstate loop
|
|
|
|
where
|
2013-07-28 14:41:42 +04:00
|
|
|
loop :: PPState -> IO (PPState, Either SomeException Port)
|
2013-07-25 16:44:23 +04:00
|
|
|
loop PPState {..} =
|
|
|
|
case ppAvail of
|
|
|
|
p:ps -> do
|
|
|
|
let next = PPState ps ppRecycled
|
2013-07-28 14:41:42 +04:00
|
|
|
res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p
|
2013-07-25 16:44:23 +04:00
|
|
|
case res of
|
|
|
|
Left (_ :: SomeException) -> do
|
|
|
|
log $ RemovingPort p
|
|
|
|
loop next
|
|
|
|
Right socket -> do
|
2013-07-28 14:41:42 +04:00
|
|
|
res' <- try $ Network.sClose socket
|
2013-07-25 16:44:23 +04:00
|
|
|
case res' of
|
|
|
|
Left e -> do
|
2013-07-28 14:41:42 +04:00
|
|
|
$logEx log e
|
2013-07-25 16:44:23 +04:00
|
|
|
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.
|
2013-07-28 14:41:42 +04:00
|
|
|
releasePort :: PortPool -> Port -> IO ()
|
2013-07-25 16:44:23 +04:00
|
|
|
releasePort (PortPool mstate) p =
|
|
|
|
modifyMVar_ mstate $ \(PPState avail recycled) -> return $ PPState avail $ recycled . (p:)
|
|
|
|
|
|
|
|
start :: PortSettings -> IO PortPool
|
|
|
|
start PortSettings{..} =
|
2013-07-28 14:41:42 +04:00
|
|
|
PortPool <$> newMVar freshState
|
2013-07-25 16:44:23 +04:00
|
|
|
where
|
|
|
|
freshState = PPState portRange id
|