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: 44a47bdfae866e267373a17e05a860171ce7403ef47d41b0661cfef2a6c7ca2c +-- hash: d74c70148c171d47980440b9ddfe657d30d2c024c58bad0dd5838f12a505554d name: alarmclock -version: 0.6.0.2 +version: 0.7.0.1 synopsis: Wake up and perform an action at a certain time. description: Please see the README on Bitbucket at category: Concurrency 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 @@ -44,10 +44,10 @@ writeTVar) import Control.Concurrent.Thread.Delay (delay) import Control.Exception (bracket) +import Control.Monad (join) import Control.Monad.Fix (mfix) import GHC.Conc (labelThread, myThreadId) -import Control.Monad (join) import Control.Concurrent.AlarmClock.TimeScale @@ -144,7 +144,7 @@ let microsecondsTimeout = microsecondsDiff wakeUpTime now if 0 < microsecondsTimeout then join $ withAsync (delay microsecondsTimeout) $ \a -> atomically $ - waitSTM a >> return (whenSet wakeUpTime) + (waitSTM a >> return (whenSet wakeUpTime)) `orElse` (readTVar acNewSetting >>= \case AlarmSet wakeUpTime' | earlierOf wakeUpTime' wakeUpTime /= wakeUpTime -> return $ whenSet wakeUpTime' @@ -153,6 +153,8 @@ ) else do - atomically $ writeTVar acNewSetting AlarmNotSet + atomically $ modifyTVar' acNewSetting $ \case + AlarmSet _ -> AlarmNotSet + setting -> setting wakeUpAction now loop diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,6 +12,7 @@ import Data.IORef import Data.Proxy import Data.Time +import System.Clock main :: IO () main = hspec $ describe "Control.Concurrent.AlarmClock" $ do @@ -54,145 +55,189 @@ atomically $ guard . not =<< isAlarmSetSTM ac threadDelay 50000 -- alarm becomes unset before action has completed - 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"] + alarmClockSpec :: (TimeScale t, Eq t, Show t) + => (AlarmClock t -> AlarmClock t) -> (Double -> t -> t) -> Spec + alarmClockSpec acid addTime = do - 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 immediately on setAlarmNow" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarmNow $ acid ac + threadDelay 100000 + readLog `shouldReturn` ["alarm went off"] - 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 "wakes up a bit later using setAlarm" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarm ac . addTime 0.2 =<< getAbsoluteTime + 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 "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 "wakes up at the earliest set time and no others" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + setAlarm ac . addTime 0.4 =<< getAbsoluteTime + setAlarm ac . addTime 0.2 =<< getAbsoluteTime + writeLog "waiting" + threadDelay 100000 + writeLog "still waiting" + threadDelay 200000 + writeLog "should have gone off once by now" + threadDelay 200000 + writeLog "should not have gone off again" + readLog `shouldReturn` + [ "waiting" + , "still waiting" + , "alarm went off" + , "should have gone off once by now" + , "should not have gone off again" + ] - 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" - waitUntilUnset ac - writeLog "alarm now not set again" - readLog `shouldReturn` - [ "alarm is set" - , "alarm went off" - , "alarm now not set again" - ] + 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 . addTime 0.2 =<< getAbsoluteTime + 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 "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" - waitUntilUnset ac - writeLog "alarm is not set" - setAlarm ac $ addUTCTime 0.2 startTime - writeLog "alarm is set" - waitUntilUnset 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 "works within the STM monad" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + now <- getAbsoluteTime + atomically $ do + guard . not =<< isAlarmSetSTM ac + setAlarmSTM ac $ addTime 0.1 now + guard =<< isAlarmSetSTM ac + writeLog "alarm is set" + waitUntilUnset ac + writeLog "alarm now not set again" + readLog `shouldReturn` + [ "alarm is set" + , "alarm went off" + , "alarm now not set again" + ] - 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" - waitUntilUnset 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 "can be set again once it goes off" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do + startTime <- getAbsoluteTime + setAlarm ac $ addTime 0.1 startTime + writeLog "alarm is set" + waitUntilUnset ac + writeLog "alarm is not set" + setAlarm ac $ addTime 0.2 startTime + writeLog "alarm is set" + waitUntilUnset 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 "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" + 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 + now <- getAbsoluteTime + setAlarm ac $ addTime (-0.1) now + writeLog "alarm is set" + waitUntilUnset 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" + ] - 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 "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 $ acid ac + 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 "successfully destroys even if wakeup action tries to set again" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\ac t -> writeLog "alarm went off" >> setAlarm ac (addTime 0.2 t)) $ \ac -> do + setAlarmNow $ acid ac + threadDelay 100000 + threadDelay 300000 + readLog `shouldReturn` ["alarm went off"] + + it "picks the shorter time if a longer time is set in the wakeup" $ do + (writeLog, readLog) <- makeLog + withAlarmClock (\ac t -> writeLog "alarm went off" >> setAlarm ac (addTime 0.5 t)) $ \ac -> do + setAlarmNow $ acid ac + threadDelay 100000 + setAlarm ac . addTime 0.1 =<< getAbsoluteTime + writeLog "set a shorter time" + threadDelay 200000 + writeLog "alarm should have gone off after shorter time" + threadDelay 500000 + writeLog "alarm should have gone off after longer time" + readLog `shouldReturn` + [ "alarm went off" + , "set a shorter time" + , "alarm went off" + , "alarm should have gone off after shorter time" + , "alarm went off" + , "alarm should have gone off after longer time" + ] + + it "doesn't block destruction even in a tight loop" $ withAlarmClock (\ac t -> setAlarm ac t) $ \ac -> do + setAlarmNow $ acid ac + threadDelay 100000 + + describe "UTCTime" $ alarmClockSpec id $ addUTCTime . fromRational . toRational + describe "MonotonicTime" $ alarmClockSpec id $ \dts (MonotonicTime ts) -> + MonotonicTime $ fromNanoSecs $ toNanoSecs ts + floor (dts * 1e9) it "re-checks the time before going off" $ withAlarmClock (\_ _ -> return ()) $ \ac -> do