diff --git a/async-timer.cabal b/async-timer.cabal --- a/async-timer.cabal +++ b/async-timer.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 591c3b4ee57f39cdee5778c4cedee60c71f1a62a5f5a1143919d71f77f00e0ac +-- hash: 097822e1ed8a2252fc52e9ea9b7aad2825e1e6038a125bdce24d3e0b0d32cdd1 name: async-timer -version: 0.1.4.1 +version: 0.2.0.0 synopsis: Provides API for timer based execution of IO actions description: This is a lightweight package built on top of the async package providing easy to use periodic timers. This can be used for executing @@ -28,20 +28,25 @@ type: git location: https://github.com/mtesseract/async-timer +flag devel + manual: True + default: False + library hs-source-dirs: src - ghc-options: -Wall -fno-warn-type-defaults build-depends: - base >=4.9.1.0 && <5 - , lifted-async >=0.9.1.1 && <0.11 - , lifted-base >=0.2.3.11 && <0.3 - , monad-control >=1.0.1.0 && <1.1 - , safe-exceptions >=0.1.5.0 && <0.2 - , transformers-base >=0.4.4 && <0.5 + async >=2.2.1 && <2.3 + , base >=4.9.1.0 && <5 + , safe-exceptions >=0.1.7.0 && <0.2 + , unliftio >=0.2.4.0 && <0.3 + , unliftio-core >=0.1.1.0 && <0.2 + if flag(devel) + ghc-options: -Wall -fno-warn-type-defaults -Werror + else + ghc-options: -Wall -fno-warn-type-defaults exposed-modules: Control.Concurrent.Async.Timer - Control.Concurrent.Async.Timer.Unsafe other-modules: Control.Concurrent.Async.Timer.Internal Paths_async_timer @@ -53,16 +58,18 @@ hs-source-dirs: test default-extensions: OverloadedStrings - ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - HUnit + async , async-timer , base , containers , criterion - , lifted-async - , test-framework - , test-framework-hunit + , tasty + , tasty-hunit + if flag(devel) + ghc-options: -Wall -fno-warn-type-defaults -Werror + else + ghc-options: -Wall -fno-warn-type-defaults other-modules: Paths_async_timer default-language: Haskell2010 diff --git a/src/Control/Concurrent/Async/Timer.hs b/src/Control/Concurrent/Async/Timer.hs --- a/src/Control/Concurrent/Async/Timer.hs +++ b/src/Control/Concurrent/Async/Timer.hs @@ -1,30 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-| +Module : Control.Concurrent.Async.Timer +Description : Public API for asynchronous Timers +Copyright : (c) Moritz Clasmeier 2016, 2018 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX +This module exports the public API for asynchronous timers. +-} + module Control.Concurrent.Async.Timer ( Timer - , defaultTimerConf - , timerConfSetInitDelay - , timerConfSetInterval + , TimerConf + , defaultConf + , setInitDelay + , setInterval , withAsyncTimer - , timerWait + , wait + , reset ) where -import Control.Concurrent.Async.Lifted.Safe import Control.Concurrent.Async.Timer.Internal -import qualified Control.Concurrent.Async.Timer.Unsafe as Unsafe -import Control.Exception.Safe -import Control.Monad.Trans.Control - --- | Spawn a timer thread based on the provided timer configuration --- and then run the provided IO action, which receives the new timer --- as an argument and call 'timerWait' on it for synchronization. When --- the provided IO action has terminated, the timer thread will be --- terminated also. --- --- This functions requires the contraint @'Forall' ('Pure' m)@, which --- means that the monad 'm' needs to satisfy @'StM' m a ~ a@ for all --- 'a'. -withAsyncTimer :: (MonadBaseControl IO m, MonadMask m, Forall (Pure m)) - => TimerConf -> (Timer -> m b) -> m b -withAsyncTimer = Unsafe.withAsyncTimer diff --git a/src/Control/Concurrent/Async/Timer/Internal.hs b/src/Control/Concurrent/Async/Timer/Internal.hs --- a/src/Control/Concurrent/Async/Timer/Internal.hs +++ b/src/Control/Concurrent/Async/Timer/Internal.hs @@ -1,77 +1,119 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-| +Module : Control.Concurrent.Async.Timer.Internal +Description : Implementation of asynchronous Timers +Copyright : (c) Moritz Clasmeier 2016, 2018 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX -module Control.Concurrent.Async.Timer.Internal - ( Timer(..) - , TimerConf(..) - , TimerException(..) - , defaultTimerConf - , timerThread - , timerConfSetInitDelay - , timerConfSetInterval - , timerWait - ) where +This module contains the internal implementation of asynchronous +timers. +-} -import Control.Concurrent.Lifted -import Control.Exception.Safe -import Control.Monad -import Control.Monad.Base -import Control.Monad.Trans.Control +{-# LANGUAGE LambdaCase #-} --- | Timer specific exception; only used for a graceful termination --- mechanism for timer threads. -data TimerException = TimerEnd deriving (Typeable, Show) +module Control.Concurrent.Async.Timer.Internal where -instance Exception TimerException +import qualified Control.Concurrent.Async as Async +import Control.Exception.Safe +import Control.Monad (void) +import Control.Monad.IO.Unlift +import UnliftIO.Async +import UnliftIO.Concurrent +import UnliftIO.STM -- | This is the type of timer handle, which will be provided to the -- IO action to be executed within 'withAsyncTimer'. The user can use -- 'timerWait' on this timer to delay execution until the next timer -- synchronization event. -newtype Timer = Timer { timerMVar :: MVar () } +data Timer = Timer { timerMVar :: MVar () + , timerControl :: TBQueue TimerCommand } +-- | Timer commands that can be sent over a timer control channel to +-- an asynchronous timer. +data TimerCommand = TimerReset deriving (Show, Eq) + -- | Type of a timer configuration. data TimerConf = TimerConf { _timerConfInitDelay :: Int , _timerConfInterval :: Int } --- | This exception handler acts on exceptions of type --- 'TimerException'. What it essentially does is providing a mechanism --- for graceful termination of timer threads by simply ignoring the --- TimerEnd exception. -timerHandler :: Monad m => Handler m () -timerHandler = Handler $ \case - TimerEnd -> return () - -- | Sleep 'dt' milliseconds. -millisleep :: MonadBase IO m => Int -> m () -millisleep dt = threadDelay (fromIntegral dt * 10 ^ 3) +millisleep :: MonadIO m => Int -> m () +millisleep dt = threadDelay (dt * 10 ^ 3) -- | Default timer configuration specifies no initial delay and an -- interval delay of 1s. -defaultTimerConf :: TimerConf -defaultTimerConf = TimerConf { _timerConfInitDelay = 0 - , _timerConfInterval = 1000 } +defaultConf :: TimerConf +defaultConf = TimerConf { _timerConfInitDelay = 0 + , _timerConfInterval = 1000 } -- | Set the initial delay in the provided timer configuration. -timerConfSetInitDelay :: Int -> TimerConf -> TimerConf -timerConfSetInitDelay n conf = conf { _timerConfInitDelay = n } +setInitDelay :: Int -> TimerConf -> TimerConf +setInitDelay n conf = conf { _timerConfInitDelay = n } -- | Set the interval delay in the provided timer configuration. -timerConfSetInterval :: Int -> TimerConf -> TimerConf -timerConfSetInterval n conf = conf { _timerConfInterval = n } - --- | IO action to be executed within in a timer thread. -timerThread :: (MonadBaseControl IO m, MonadCatch m) => Int -> Int -> MVar () -> m () -timerThread initDelay intervalDelay syncMVar = - catches (timerLoop initDelay intervalDelay syncMVar) [timerHandler] +setInterval :: Int -> TimerConf -> TimerConf +setInterval n conf = conf { _timerConfInterval = n } -- | Timer loop to be executed within in a timer thread. -timerLoop :: (MonadBaseControl IO m) => Int -> Int -> MVar () -> m () -timerLoop initDelay intervalDelay syncMVar = do - millisleep initDelay - forever $ putMVar syncMVar () >> millisleep intervalDelay +timerLoop + :: MonadUnliftIO m + => Int + -> Int + -> Timer + -> m () +timerLoop initDelay intervalDelay timer = go initDelay + where go delay = do + race (millisleep delay) readCmd >>= \ case + Left () -> do + wakeUp + go intervalDelay + Right cmd -> + case cmd of + TimerReset -> + go intervalDelay + + wakeUp = putMVar (timerMVar timer) () + readCmd = atomically $ readTBQueue (timerControl timer) + -- | Wait for the next synchronization event on the givem timer. -timerWait :: MonadBaseControl IO m => Timer -> m () -timerWait = void . takeMVar . timerMVar +wait + :: MonadUnliftIO m + => Timer + -> m () +wait = void . takeMVar . timerMVar + +-- | Reset the provided timer. +reset + :: MonadUnliftIO m + => Timer + -> m () +reset timer = + atomically $ writeTBQueue (timerControl timer) TimerReset + +-- | Spawn a timer thread based on the provided timer configuration +-- and then run the provided IO action, which receives the new timer +-- as an argument and call 'timerWait' on it for synchronization. When +-- the provided IO action has terminated, the timer thread will be +-- terminated also. +withAsyncTimer + :: (MonadUnliftIO m, MonadMask m) + => TimerConf + -> (Timer -> m b) + -> m b +withAsyncTimer conf io = do + -- This MVar will be our synchronization mechanism. + mVar <- newEmptyMVar + controlChannel <- atomically $ newTBQueue 1 + let timer = Timer { timerMVar = mVar + , timerControl = controlChannel } + initDelay = _timerConfInitDelay conf + intervalDelay = _timerConfInterval conf + withAsync (timerLoop initDelay intervalDelay timer) $ \ asyncTimer -> do + -- This guarantees that we will be informed right away if our + -- timer thread disappears, for example because of an async + -- exception: + liftIO $ Async.link asyncTimer + io timer diff --git a/src/Control/Concurrent/Async/Timer/Unsafe.hs b/src/Control/Concurrent/Async/Timer/Unsafe.hs deleted file mode 100644 --- a/src/Control/Concurrent/Async/Timer/Unsafe.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Concurrent.Async.Timer.Unsafe - ( Timer - , defaultTimerConf - , timerConfSetInitDelay - , timerConfSetInterval - , withAsyncTimer - , timerWait - ) where - -import Control.Concurrent.Async.Lifted -import Control.Concurrent.Async.Timer.Internal -import Control.Concurrent.Lifted -import Control.Exception.Safe -import Control.Monad.Trans.Control - --- | Spawn a timer thread based on the provided timer configuration --- and then run the provided IO action, which receives the new timer --- as an argument and call 'timerWait' on it for synchronization. When --- the provided IO action has terminated, the timer thread will be --- terminated also. -withAsyncTimer :: (MonadBaseControl IO m, MonadMask m) - => TimerConf -> (Timer -> m b) -> m b -withAsyncTimer conf io = do - -- This MVar will be our synchronization mechanism. - mVar <- newEmptyMVar - let timer = Timer { timerMVar = mVar } - initDelay = _timerConfInitDelay conf - intervalDelay = _timerConfInterval conf - withAsync (timerThread initDelay intervalDelay mVar) $ \asyncHandle -> do - -- This guarantees that we will be informed right away if our - -- timer thread disappears, for example because of an async - -- exception: - link asyncHandle - -- This guarantees that we will throw the TimerEnd exception to - -- the timer thread after the provided IO action has ended - -- (w/ or w/o an exception): - io timer `finally` cancelWith asyncHandle TimerEnd diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,16 +1,16 @@ module Main where import Control.Concurrent -import Control.Concurrent.Async.Timer +import Control.Concurrent.Async +import qualified Control.Concurrent.Async.Timer as Timer import Control.Exception import Control.Monad import Criterion.Measurement import Data.Function ((&)) import Data.IORef import Data.Typeable -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) +import Test.Tasty +import Test.Tasty.HUnit data MyException = MyException deriving (Show, Typeable) @@ -18,35 +18,64 @@ instance Exception MyException main :: IO () -main = do - cap <- getNumCapabilities - putStrLn "" - putStrLn $ "Cap = " ++ show cap - defaultMain tests +main = defaultMain (testGroup "Unit Tests" unitTests) -tests :: [Test.Framework.Test] -tests = - [ testGroup "1st Test Group" - [ testCase "1st Test" test1 ] +unitTests :: [TestTree] +unitTests = + [ testGroup "Timer Tests" + [ testCase "Timer reset" testTimerReset + , testCase "Simple timer ticks" testSimpleTimerTicks + ] ] -test1 :: IO () -test1 = do - let conf = defaultTimerConf & timerConfSetInitDelay 0 - & timerConfSetInterval 1000 -- ms - noOfTicks = 5 +timedAssert :: Int -> IO () -> IO () -> IO () +timedAssert delay before after = do + threadDelay $ delay - epsilon + before + threadDelay $ 2 * epsilon + after + where epsilon = 2 * 10^5 + +testTimerReset :: IO () +testTimerReset = do + let conf = Timer.defaultConf + & Timer.setInitDelay 1000 + & Timer.setInterval 1000 -- ms + noOfTicks = 3 + counter <- newIORef 0 + + _handle <- async $ + Timer.withAsyncTimer conf $ \ timer -> + forM_ [1..noOfTicks] $ \ idx -> do + when (idx == 2) $ do + threadDelay (5 * 10^5) + Timer.reset timer + Timer.wait timer + modifyIORef counter (+ 1) + + timedAssert (2 * 10^6 + 5 * 10^5) + ((1 @=?) =<< readIORef counter) + ((2 @=?) =<< readIORef counter) + +testSimpleTimerTicks :: IO () +testSimpleTimerTicks = do + let conf = Timer.defaultConf + & Timer.setInitDelay 0 + & Timer.setInterval 1000 -- ms + noOfTicks = 3 + + counter <- newIORef 0 times <- newIORef [] - withAsyncTimer conf $ \ timer -> + Timer.withAsyncTimer conf $ \ timer -> forM_ [1..noOfTicks] $ \_ -> do - timerWait timer + Timer.wait timer void $ forkIO $ myAction counter times threadDelay (5 * 10^5) - n <- readIORef counter - n @?= noOfTicks + readIORef counter >>= (noOfTicks @=?) ts <- readIORef times let deltas = case ts of