alarmclock (empty) → 0.1.0.0

raw patch · 5 files changed

+135/−0 lines, 5 filesdep +HUnitdep +alarmclockdep +basesetup-changed

Dependencies added: HUnit, alarmclock, base, test-framework, test-framework-hunit, time, timeout

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• alarmclock.cabal +35/−0
• src/Control/Concurrency/AlarmClock.hs +64/−0
• test/Main.hs +4/−0

@@ -0,0 +1,30 @@+Copyright (c) 2014, David Turner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of David Turner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,35 @@+name:                alarmclock+version:             0.1.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+category:            Concurrency+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Control.Concurrency.AlarmClock+  build-depends:+      base >=4.7 && <4.8+    , time+    , timeout+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options: -Wall++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language:   Haskell2010+  build-depends:      base+                    , alarmclock+                    , HUnit+                    , test-framework+                    , test-framework-hunit+                    , time

@@ -0,0 +1,64 @@+{-# 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,4 @@+module Main (main) where++main :: IO ()+main = return ()