diff --git a/alarmclock.cabal b/alarmclock.cabal --- a/alarmclock.cabal +++ b/alarmclock.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: f32314cdbecd0b94d48ef50017c7c0a732da2ba508258c9709bc7614c5e3d173 +-- hash: 8d07c55bfbba37064e7a34b1ddfaeb436a9c8a9c2335f1bb78be9cb1827d6d37 name: alarmclock -version: 0.5.0.1 +version: 0.5.0.2 synopsis: Wake up and perform an action at a certain time. description: Please see the README on Bitbucket at category: Concurrency @@ -51,6 +51,5 @@ , time , unbounded-delays other-modules: - Main Paths_alarmclock default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# 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 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,11 @@ import Test.Hspec import Control.Concurrent +import Control.Concurrent.AlarmClock import Control.Concurrent.AlarmClock.TimeScale +import Control.Concurrent.STM +import Control.Monad +import Data.IORef import Data.Proxy import Data.Time @@ -40,4 +44,163 @@ describe "UTCTime" $ beforeAll beforeTimescaleTest $ timescaleSpec (Proxy :: Proxy UTCTime) describe "Monotonic" $ beforeAll beforeTimescaleTest $ timescaleSpec (Proxy :: Proxy MonotonicTime) - return () + let makeLog :: IO (a -> IO (), IO [a]) + makeLog = do + logVar <- newIORef [] + return (modifyIORef logVar . (:), reverse <$> readIORef logVar) + + describe "AlarmClock" $ do + it "wakes up immediately on setAlarmNow" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarmNow (ac :: AlarmClock UTCTime) + threadDelay 100000 + readLog `shouldReturn` ["alarm went off"] + + it "wakes up a bit later using setAlarm" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarm ac . addUTCTime 0.2 =<< getCurrentTime + writeLog "waiting" + threadDelay 100000 + writeLog "still waiting" + threadDelay 200000 + writeLog "should have gone off by now" + readLog `shouldReturn` + [ "waiting" + , "still waiting" + , "alarm went off" + , "should have gone off by now" + ] + + it "wakes up at the earliest set time and no others" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarm ac . addUTCTime 0.3 =<< getCurrentTime + setAlarm ac . addUTCTime 0.2 =<< getCurrentTime + writeLog "waiting" + threadDelay 100000 + writeLog "still waiting" + threadDelay 300000 + writeLog "should have gone off once by now" + readLog `shouldReturn` + [ "waiting" + , "still waiting" + , "alarm went off" + , "should have gone off once by now" + ] + + it "reports whether it is set or not" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + let logIfSet = do + currentlySet <- isAlarmSet ac + writeLog $ if currentlySet then "alarm is set" else "alarm is not set" + logIfSet + setAlarm ac . addUTCTime 0.2 =<< getCurrentTime + logIfSet + writeLog "waiting" + threadDelay 100000 + writeLog "still waiting" + logIfSet + threadDelay 200000 + writeLog "should have gone off by now" + logIfSet + readLog `shouldReturn` + [ "alarm is not set" + , "alarm is set" + , "waiting" + , "still waiting" + , "alarm is set" + , "alarm went off" + , "should have gone off by now" + , "alarm is not set" + ] + + it "works within the STM monad" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + now <- getCurrentTime + atomically $ do + guard . not =<< isAlarmSetSTM ac + setAlarmSTM ac $ addUTCTime 0.1 now + guard =<< isAlarmSetSTM ac + writeLog "alarm is set" + atomically $ guard . not =<< isAlarmSetSTM ac + writeLog "alarm now not set again" + readLog `shouldReturn` + [ "alarm is set" + , "alarm went off" + , "alarm now not set again" + ] + + it "can be set again once it goes off" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + startTime <- getCurrentTime + setAlarm ac $ addUTCTime 0.1 startTime + writeLog "alarm is set" + atomically $ guard . not =<< isAlarmSetSTM ac + writeLog "alarm is not set" + setAlarm ac $ addUTCTime 0.2 startTime + writeLog "alarm is set" + atomically $ guard . not =<< isAlarmSetSTM ac + writeLog "alarm is not set" + readLog `shouldReturn` + [ "alarm is set" + , "alarm went off" + , "alarm is not set" + , "alarm is set" + , "alarm went off" + , "alarm is not set" + ] + + it "goes off immediately if set to go off in the past" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + startTime <- getCurrentTime + setAlarm ac $ addUTCTime (-0.1) startTime + writeLog "alarm is set" + atomically $ guard . not =<< isAlarmSetSTM ac + writeLog "done" + endTime <- getCurrentTime + diffUTCTime endTime startTime `shouldSatisfy` (\t -> 0.0 <= t && t < 0.1) + readLog `shouldReturn` + [ "alarm is set" + , "alarm went off" + , "done" + ] + + it "blocks destruction if the alarm is going off" $ do + (writeLog, readLog) <- makeLog + let alarmAction _ _ = do + writeLog "alarm going off" + threadDelay 200000 + writeLog "alarm finished going off" + + withAlarmClock alarmAction $ \ac -> do + setAlarmNow (ac :: AlarmClock UTCTime) + threadDelay 100000 + writeLog "destroying alarm clock" + writeLog "alarm clock destroyed" + readLog `shouldReturn` + [ "alarm going off" + , "destroying alarm clock" + , "alarm finished going off" + , "alarm clock destroyed" + ] + + it "re-checks the time before going off" $ + withAlarmClock (\_ _ -> return ()) $ \ac -> do + startTime <- getCurrentTime + setAlarm ac $ AdjustingClock $ addUTCTime 0.3 startTime + atomically $ guard . not =<< isAlarmSetSTM ac + endTime <- getCurrentTime + diffUTCTime endTime startTime `shouldSatisfy` (\t -> 0.3 <= t && t <= 0.5) + +newtype AdjustingClock = AdjustingClock UTCTime deriving (Show, Eq, Ord) + +instance TimeScale AdjustingClock where + getAbsoluteTime = AdjustingClock <$> getCurrentTime + earlierOf = min + microsecondsDiff (AdjustingClock t1) (AdjustingClock t2) = 10000 + microsecondsDiff t1 t2 `div` 2