keter/Keter/PortPool.hs

71 lines
2.4 KiB
Haskell
Raw Normal View History

{-# 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
import Keter.Types
import qualified Network
2013-07-28 14:41:42 +04:00
import Prelude hiding (log)
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) =
modifyMVar mstate loop
where
2013-07-28 14:41:42 +04:00
loop :: PPState -> IO (PPState, Either SomeException Port)
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
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
case res' of
Left e -> do
2013-07-28 14:41:42 +04:00
$logEx log 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.
2013-07-28 14:41:42 +04:00
releasePort :: PortPool -> Port -> IO ()
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
where
freshState = PPState portRange id