diff --git a/alarmclock.cabal b/alarmclock.cabal --- a/alarmclock.cabal +++ b/alarmclock.cabal @@ -1,26 +1,56 @@ -name: alarmclock -version: 0.5.0.0 -synopsis: Wake up and perform an action at a certain time. -description: Wake up and perform an action at a certain time. -homepage: https://bitbucket.org/davecturner/alarmclock -license: BSD3 -license-file: LICENSE -author: David Turner -maintainer: dave.c.turner@gmail.com -copyright: (c) David Turner 2014-2018 -category: Concurrency -build-type: Simple -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f32314cdbecd0b94d48ef50017c7c0a732da2ba508258c9709bc7614c5e3d173 +name: alarmclock +version: 0.5.0.1 +synopsis: Wake up and perform an action at a certain time. +description: Please see the README on Bitbucket at +category: Concurrency +homepage: https://bitbucket.org/davecturner/alarmclock +author: David Turner +maintainer: dave.c.turner@gmail.com +copyright: 2014-2018 David Turner +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + library - exposed-modules: Control.Concurrent.AlarmClock + hs-source-dirs: + src build-depends: - base >=4.8 && <4.12 + async + , base >=4.8 && <4.12 + , clock , stm - , async , time + , unbounded-delays + exposed-modules: + Control.Concurrent.AlarmClock + Control.Concurrent.AlarmClock.TimeScale + other-modules: + Paths_alarmclock + default-language: Haskell2010 + +test-suite alarmclock-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + alarmclock + , async + , base >=4.8 && <4.12 , clock + , hspec + , stm + , time , unbounded-delays - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + other-modules: + Main + Paths_alarmclock + default-language: Haskell2010 diff --git a/src/Control/Concurrent/AlarmClock.hs b/src/Control/Concurrent/AlarmClock.hs --- a/src/Control/Concurrent/AlarmClock.hs +++ b/src/Control/Concurrent/AlarmClock.hs @@ -35,59 +35,18 @@ , MonotonicTime(..) ) where -import Control.Concurrent.Async (async, wait) -import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', - newTVarIO, readTVar, retry, - writeTVar) -import Control.Concurrent.Timeout (timeout) -import Control.Exception (bracket) -import Control.Monad.Fix (mfix) -import Data.Time (UTCTime, diffUTCTime, - getCurrentTime) -import GHC.Conc (labelThread, myThreadId) -import System.Clock (Clock (Monotonic), TimeSpec, - diffTimeSpec, getTime, - toNanoSecs) - -{-| Abstraction that allows for a choice between the UTC timescale and a -monotonic timescale, which differ in their handling of irregularities such as -clock adjustments and leap seconds. - -Alarms set using the 'UTCTime' timescale wait for the system clock to pass the -given time before going off, and account for the clock being adjusted -backwards and for (positive) leap seconds while waiting. If the clock is set -forwards, or a negative leap second occurs, then the alarm may go off later -than expected by an amount that is roughly equal to the adjustment. It is -possible to correct for this by setting the alarm again after the adjustment -has occurred. - -The 'Monotonic' timescale cannot be so adjusted, which may be more suitable for -some applications. - -Note that the timeliness of the alarm going off is very much on a "best effort" -basis, and there are many environmental factors that could cause the alarm to -go off later than expected. - --} - -class TimeScale t where - getAbsoluteTime :: IO t - microsecondsDiff :: t -> t -> Integer - earlierOf :: t -> t -> t - -instance TimeScale UTCTime where - getAbsoluteTime = getCurrentTime - earlierOf = min - microsecondsDiff t1 t2 = ceiling $ (1000000 *) $ diffUTCTime t1 t2 - -{-| Representation of system monotonic clock. -} -newtype MonotonicTime = MonotonicTime TimeSpec deriving (Show, Eq, Ord) +import Control.Concurrent.Async (async, wait) +import Control.Concurrent.STM (STM, TVar, atomically, + modifyTVar', + newTVarIO, readTVar, + retry, writeTVar) +import Control.Concurrent.Timeout (timeout) +import Control.Exception (bracket) +import Control.Monad.Fix (mfix) +import GHC.Conc (labelThread, + myThreadId) -instance TimeScale MonotonicTime where - getAbsoluteTime = MonotonicTime <$> getTime Monotonic - earlierOf = min - microsecondsDiff (MonotonicTime t1) (MonotonicTime t2) - = (`div` 1000) $ toNanoSecs $ diffTimeSpec t1 t2 +import Control.Concurrent.AlarmClock.TimeScale {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -} data AlarmClock t = AlarmClock diff --git a/src/Control/Concurrent/AlarmClock/TimeScale.hs b/src/Control/Concurrent/AlarmClock/TimeScale.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/AlarmClock/TimeScale.hs @@ -0,0 +1,51 @@ + +{-| Abstraction that allows for a choice of timescale when setting alarms. +Exposed in a separate module so it can be faked for testing purposes, but +client applications should just import "Control.Concurrent.AlarmClock". -} + +module Control.Concurrent.AlarmClock.TimeScale where + +import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import System.Clock (Clock (Monotonic), TimeSpec, diffTimeSpec, + getTime, toNanoSecs) + +{-| Abstraction that allows for a choice between the UTC timescale and a +monotonic timescale, which differ in their handling of irregularities such as +clock adjustments and leap seconds. + +Alarms set using the 'UTCTime' timescale wait for the system clock to pass the +given time before going off, and account for the clock being adjusted +backwards and for (positive) leap seconds while waiting. If the clock is set +forwards, or a negative leap second occurs, then the alarm may go off later +than expected by an amount that is roughly equal to the adjustment. It is +possible to correct for this by setting the alarm again after the adjustment +has occurred. + +The 'Monotonic' timescale cannot be so adjusted, which may be more suitable for +some applications. + +Note that the timeliness of the alarm going off is very much on a "best effort" +basis, and there are many environmental factors that could cause the alarm to +go off later than expected. + +-} + +class TimeScale t where + getAbsoluteTime :: IO t + microsecondsDiff :: t -> t -> Integer + earlierOf :: t -> t -> t + +instance TimeScale UTCTime where + getAbsoluteTime = getCurrentTime + earlierOf = min + microsecondsDiff t1 t2 = ceiling $ (1000000 *) $ diffUTCTime t1 t2 + +{-| Representation of system monotonic clock. -} +newtype MonotonicTime = MonotonicTime TimeSpec deriving (Show, Eq, Ord) + +instance TimeScale MonotonicTime where + getAbsoluteTime = MonotonicTime <$> getTime Monotonic + earlierOf = min + microsecondsDiff (MonotonicTime t1) (MonotonicTime t2) + | t1 < t2 = -microsecondsDiff (MonotonicTime t2) (MonotonicTime t1) + | otherwise = (`div` 1000) $ toNanoSecs $ diffTimeSpec t1 t2 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Control.Concurrent +import Control.Concurrent.AlarmClock +import Control.Exception +import Data.IORef +import Data.Time +import Text.Printf + +printWithTime :: String -> IO () +printWithTime s = do + t <- getCurrentTime + putStrLn $ printf "%-32s: %s" (show t) s + +alarmAction :: IORef Bool -> AlarmClock UTCTime -> IO () +alarmAction v ac = do + printWithTime "alarm went off" + threadDelay 3000000 + readIORef v >>= \case + False -> return () + True -> do + t <- addUTCTime 5 <$> getCurrentTime + setAlarmLog ac t + threadDelay 3000000 + printWithTime "alarm action finished" + +setAlarmLog :: AlarmClock UTCTime -> UTCTime -> IO () +setAlarmLog ac t = do + printWithTime $ printf "alarm set for %s" $ show t + setAlarm ac t + +setAlarmNowLog :: AlarmClock UTCTime -> IO () +setAlarmNowLog ac = do + printWithTime "alarm set for now" + setAlarmNow ac + +main :: IO () +main = do + v <- newIORef True + bracket (newAlarmClock $ alarmAction v) destroyAlarmClock $ \ac -> do + t <- getCurrentTime + mask $ \_ -> do + setAlarmLog ac $ addUTCTime 2 t + setAlarmLog ac $ addUTCTime (pred 2) t + setAlarmLog ac $ addUTCTime (succ 2) t + threadDelay 500000 + setAlarmLog ac $ addUTCTime 4 t + threadDelay 1900000 + setAlarmNowLog ac + threadDelay 8000000 + printWithTime "cancelling alarm repeat" + writeIORef v False + threadDelay 7000000 + setAlarmLog ac $ addUTCTime 1 t + threadDelay 500000 + setAlarmLog ac $ addUTCTime 20 t + threadDelay 4000000 + printWithTime "done" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Test.Hspec + +import Control.Concurrent +import Control.Concurrent.AlarmClock.TimeScale +import Data.Proxy +import Data.Time + +main :: IO () +main = hspec $ describe "Control.Concurrent.AlarmClock" $ do + + describe "Timescale" $ do + let beforeTimescaleTest :: TimeScale t => IO (t,t) + beforeTimescaleTest = do + putStrLn "getting first time" + t0 <- getAbsoluteTime + threadDelay 500000 + putStrLn "getting second time" + t1 <- getAbsoluteTime + putStrLn "got times" + return (t0, t1) + + timescaleSpec :: (TimeScale t, Eq t, Show t) => Proxy t -> SpecWith (t,t) + timescaleSpec _ = do + describe "earlierOf" $ do + it "picks the first if earlier" $ \(t0,t1) -> earlierOf t0 t1 `shouldBe` t0 + it "picks the second if earlier" $ \(t0,t1) -> earlierOf t1 t0 `shouldBe` t0 + + describe "microsecondsDiff" $ do + it "finds a difference of at least 500ms" + $ \(t0,t1) -> microsecondsDiff t1 t0 `shouldSatisfy` (>= 500000) + it "finds a difference of no more than 600ms" + $ \(t0,t1) -> microsecondsDiff t1 t0 `shouldSatisfy` (<= 600000) + it "finds a negative difference if args reversed" + $ \(t0,t1) -> microsecondsDiff t0 t1 `shouldSatisfy` (<= (-500000)) + + describe "UTCTime" $ beforeAll beforeTimescaleTest $ timescaleSpec (Proxy :: Proxy UTCTime) + describe "Monotonic" $ beforeAll beforeTimescaleTest $ timescaleSpec (Proxy :: Proxy MonotonicTime) + + return ()