alarmclock-0.7.0.1: test/Spec.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
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
import System.Clock
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)
let makeLog :: IO (a -> IO (), IO [a])
makeLog = do
logVar <- newIORef []
return (modifyIORef logVar . (:), reverse <$> readIORef logVar)
describe "AlarmClock" $ do
let waitUntilUnset ac = do
atomically $ guard . not =<< isAlarmSetSTM ac
threadDelay 50000 -- alarm becomes unset before action has completed
alarmClockSpec :: (TimeScale t, Eq t, Show t)
=> (AlarmClock t -> AlarmClock t) -> (Double -> t -> t) -> Spec
alarmClockSpec acid addTime = do
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 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 "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 "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 "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 "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 "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"
]
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
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