async-timer 0.1.4.1 → 0.2.0.0

raw patch · 5 files changed

+183/−150 lines, 5 filesdep +asyncdep +tastydep +tasty-hunitdep −HUnitdep −lifted-asyncdep −lifted-basedep ~safe-exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: async, tasty, tasty-hunit, unliftio, unliftio-core

Dependencies removed: HUnit, lifted-async, lifted-base, monad-control, test-framework, test-framework-hunit, transformers-base

Dependency ranges changed: safe-exceptions

API changes (from Hackage documentation)

Files

• async-timer.cabal +22/−15
• src/Control/Concurrent/Async/Timer.hs +17/−23
• src/Control/Concurrent/Async/Timer/Internal.hs +93/−51
• src/Control/Concurrent/Async/Timer/Unsafe.hs +0/−39
• test/Spec.hs +51/−22

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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