alarmclock 0.1.0.0 → 0.1.0.1

raw patch · 4 files changed

+153/−71 lines, 4 filesdep −HUnitdep −test-frameworkdep −test-framework-hunitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: HUnit, test-framework, test-framework-hunit, timeout

API changes (from Hackage documentation)

Files

• alarmclock.cabal +2/−6
• src/Control/Concurrency/AlarmClock.hs +0/−64
• src/Control/Concurrent/AlarmClock.hs +93/−0
• test/Main.hs +58/−1

@@ -1,5 +1,5 @@ name:                alarmclock-version:             0.1.0.0+version:             0.1.0.1 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@@ -13,11 +13,10 @@ cabal-version:       >=1.10  library-  exposed-modules:     Control.Concurrency.AlarmClock+  exposed-modules:     Control.Concurrent.AlarmClock   build-depends:       base >=4.7 && <4.8     , time-    , timeout   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options: -Wall@@ -29,7 +28,4 @@   default-language:   Haskell2010   build-depends:      base                     , alarmclock-                    , HUnit-                    , test-framework-                    , test-framework-hunit                     , time

@@ -1,64 +0,0 @@-{-# LANGUAGE LambdaCase #-}--{-| Device for running an action at (i.e. shortly after) a certain time, which-    can be used to implement things like time-based cache expiry.--    This implementation avoids the use of polling to achieve low-latency without-    lots of computational overhead.--    The alarm can be set multiple times, and in this case the alarm action-    will run on the earliest such time. If the alarm is set in the past,-    the action will run immediately. When the action runs, it clears all-    future alarms; the action can itself return the time at which it should-    run again.---}--module Control.Concurrency.AlarmClock where--import Control.Concurrent-import Control.Exception-import Control.Monad-import System.Timeout-import Data.Time--{-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}-data AlarmClock = AlarmClock (MVar UTCTime) ThreadId--mkAlarmClock :: IO (Maybe UTCTime) -> IO AlarmClock-mkAlarmClock onWakeUp = do-  mv <- newEmptyMVar-  tid <- mask $ \restore -> forkIO $ runAlarmClock mv $ void $ forkIO $-    restore onWakeUp >>= \case Nothing -> return ()-                               Just wakeUpTime -> setAlarmVar mv wakeUpTime -  return $ AlarmClock mv tid--destroyAlarmClock :: AlarmClock -> IO ()-destroyAlarmClock (AlarmClock _ tid) = killThread tid--setAlarmVar :: MVar UTCTime -> UTCTime -> IO ()-setAlarmVar mv wakeUpTime = tryTakeMVar mv >>= \case-  Nothing          -> putMVar mv      wakeUpTime-  Just wakeUpTime' -> putMVar mv (min wakeUpTime wakeUpTime')--setAlarm :: AlarmClock -> UTCTime -> IO ()-setAlarm (AlarmClock mv _) = setAlarmVar mv--runAlarmClock :: MVar UTCTime -> IO () -> IO ()-runAlarmClock wakeUpTimeVar wakeUpAction = alarmNotSet-  where-  alarmNotSet = takeMVar wakeUpTimeVar >>= alarmSet--  alarmSet wakeUpTime = do-    t <- getCurrentTime-    let dt = diffUTCTime wakeUpTime t-    if dt < 0 then wakeUpAction >> alarmNotSet-              else do-      let dt_usec = ceiling (1000000 * dt) :: Integer-      let dt_usec_int = if dt_usec > fromIntegral (maxBound :: Int) then maxBound else fromIntegral dt_usec-      timeout dt_usec_int (takeMVar wakeUpTimeVar) >>= \case-        Nothing -> do-          t' <- getCurrentTime-          if t' < wakeUpTime then alarmSet wakeUpTime else wakeUpAction >> alarmNotSet-        Just wakeUpTime' -> alarmSet (min wakeUpTime wakeUpTime')-

@@ -0,0 +1,93 @@+{-# LANGUAGE LambdaCase #-}++{-| Device for running an action at (i.e. shortly after) a certain time, which+can be used to implement things like time-based cache expiry.++This implementation avoids the use of polling and leans on Haskell's scheduler+to achieve low-latency without lots of computational overhead.++The alarm can be set multiple times, and in this case the alarm will go off at+the earliest requested time. If the alarm is set in the past, the action will+run immediately. When the action runs, it clears all future alarms; the action+can itself return the time at which it should run again.++To perform time-based cache expiry, create an 'AlarmClock' whose action flushes+any stale entries from the cache and returns the next time that an entry will+expire. If the cache contains no entries that will expire, return 'Nothing'+from the reaper action. When expiring entries are added to the cache, call+'setAlarm' to ensure that they will be reaped.++-}++module Control.Concurrent.AlarmClock+  ( AlarmClock()+  , newAlarmClock+  , destroyAlarmClock+  , setAlarm+  , setAlarmNow+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import System.Timeout+import Data.Time++{-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}+data AlarmClock = AlarmClock (MVar UTCTime) ThreadId++{-| Create a new 'AlarmClock' that runs the given action. Initially, there is+no wakeup time set: you must call 'setAlarm' for anything else to happen. -}+newAlarmClock+  :: IO (Maybe UTCTime)+    -- ^ Action to run when the alarm goes off. The return value, if 'Just', is+    -- used as the next wakeup time. If 'Nothing', the alarm will not wake up again+    -- until 'setAlarm' or 'setAlarmNow' is called, even if 'setAlarm' has previously+    -- been called with a time that is still in the future.+  -> IO AlarmClock+newAlarmClock onWakeUp = do+  mv <- newEmptyMVar+  tid <- mask $ \restore -> forkIO $ runAlarmClock mv $ void $ forkIO $+    restore onWakeUp >>= \case Nothing -> return ()+                               Just wakeUpTime -> setAlarmVar mv wakeUpTime +  return $ AlarmClock mv tid++{-| Destroy the 'AlarmClock' so no further alarms will occur. If a wakeup is in+progress then it will run to completion. -}+destroyAlarmClock :: AlarmClock -> IO ()+destroyAlarmClock (AlarmClock _ tid) = killThread tid++setAlarmVar :: MVar UTCTime -> UTCTime -> IO ()+setAlarmVar mv wakeUpTime = tryTakeMVar mv >>= \case+  Nothing          -> putMVar mv      wakeUpTime+  Just wakeUpTime' -> putMVar mv (min wakeUpTime wakeUpTime')++{-| Make the 'AlarmClock' go off at (or shortly after) the given time.+This can be called more than once; in which case, the alarm will go off+at the first given time. -}+setAlarm :: AlarmClock -> UTCTime -> IO ()+setAlarm (AlarmClock mv _) = setAlarmVar mv++{-| Make the 'AlarmClock' go off right now. -}+setAlarmNow :: AlarmClock -> IO ()+setAlarmNow alarm = getCurrentTime >>= setAlarm alarm++runAlarmClock :: MVar UTCTime -> IO () -> IO ()+runAlarmClock wakeUpTimeVar wakeUpAction = alarmNotSet+  where+  alarmNotSet = takeMVar wakeUpTimeVar >>= alarmSet++  alarmSet wakeUpTime = do+    t <- getCurrentTime+    let dt = diffUTCTime wakeUpTime t+    if dt < 0 then wakeUpAction >> alarmNotSet+              else timeout (fromIntegral $ min maxDelay $ ceiling $ 1000000 * dt)+                           (takeMVar wakeUpTimeVar) >>= \case+          Nothing -> do+            t' <- getCurrentTime+            if t' < wakeUpTime then alarmSet wakeUpTime else wakeUpAction >> alarmNotSet++          Just wakeUpTime' -> alarmSet (min wakeUpTime wakeUpTime')++maxDelay :: Integer+maxDelay = fromIntegral (maxBound :: Int)

@@ -1,4 +1,61 @@+{-# LANGUAGE LambdaCase #-}+ module Main (main) where +import Control.Applicative+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 -> IO (Maybe UTCTime)+alarmAction v = do+  printWithTime "alarm went off"+  readIORef v >>= \case+    False -> do+      printWithTime "not resetting alarm"+      return Nothing+    True -> do+      t <- addUTCTime 5 <$> getCurrentTime+      printWithTime $ printf "alarm reset for %s" $ show t+      return $ Just t++setAlarmLog :: AlarmClock -> UTCTime -> IO ()+setAlarmLog ac t = do+  printWithTime $ printf "alarm set for %s" $ show t+  setAlarm ac t++setAlarmNowLog :: AlarmClock -> IO ()+setAlarmNowLog ac = do+  printWithTime "alarm set for now"+  setAlarmNow ac+ main :: IO ()-main = return ()+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"