module LockedPoll (Key,KeyFcn,makeLockingFunction) where
import Control.Exception (bracket)
import Data.IORef
import Data.Int (Int64)
import Data.Monoid ((<>))
import System.IO
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import System.Clock (Clock (..), TimeSpec (..), getTime)
type Key k = (Ord k,Eq k,Show k)
type KeyFcn st k = Key k => st -> k
type LockStatus = Maybe Bool
pattern KeyAcquired :: LockStatus
pattern KeyAcquired <- Just True
pattern IOLocked :: LockStatus
pattern IOLocked <- Just False
pattern LockTimedOut :: LockStatus
pattern LockTimedOut <- Nothing
makeLockingFunction :: forall k lockableState . (Key k,Show lockableState) => Int64 ->
(KeyFcn lockableState k) ->
IO ((lockableState -> IO ()) ->
lockableState ->
IO ())
makeLockingFunction timeout getKey = do
ioRefMapOfKeyValues <- newIORef Map.empty :: IO (IORef (Map k TimeSpec) )
return $ exportFunction ioRefMapOfKeyValues
where
unlock :: IORef (Map k TimeSpec) -> k -> IO ()
unlock ioRef k = atomicModifyIORef' ioRef (\map' -> (Map.delete k map', ()))
obtainLock :: (Key k) => TimeSpec -> k -> Map k TimeSpec -> (Map k TimeSpec ,Maybe Bool)
obtainLock lockTime@(TimeSpec s1 _) k map' = case Map.lookup k map' of
Just (TimeSpec s _)
| abs s1 s >= timeout -> (Map.insert k lockTime map', Nothing)
| otherwise -> (map',Just False)
Nothing -> (Map.insert k lockTime map',Just True)
exportFunction :: IORef (Map k TimeSpec) ->
(lockableState -> IO ()) -> lockableState -> IO ()
exportFunction ioRef f st = bracket ioLock ioUnlock runFunction
where
ioLock :: IO (Maybe Bool)
ioLock = do
lockTime <- getTime Monotonic
atomicModifyIORef' ioRef . obtainLock lockTime . getKey $ st
ioUnlock :: LockStatus -> IO ()
ioUnlock lockStatus = case lockStatus of
IOLocked -> return ()
KeyAcquired -> unlock ioRef (getKey st)
LockTimedOut -> unlock ioRef (getKey st)
_ -> error "no match for bottom in ioUnlock"
runFunction :: LockStatus -> IO ()
runFunction iCanRun = case iCanRun of
KeyAcquired -> f st
IOLocked -> hPrint stderr ("skipping locked thread" <> (show . getKey $ st ))
LockTimedOut -> hPrint stderr ("thread timeout " <> show st ) >> f st
_ -> error "no match for bottom of Maybe Bool in makeLockingFunction"