1 {-# LANGUAGE TupleSections, Rank2Types, ScopedTypeVariables #-} 2 module Service.Periodic 3 ( forkPeriodic 4 ) where 5 6 import Control.Concurrent (ThreadId, forkFinally, threadDelay) 7 import Control.Exception (handle, mask) 8 import Control.Monad (void, when) 9 import Control.Monad.Trans.Reader (withReaderT) 10 import Data.Fixed (Fixed(..), Micro) 11 import Data.IORef (writeIORef) 12 import Data.Time.Calendar.OrdinalDate (sundayStartWeek) 13 import Data.Time.Clock (UTCTime(..), diffUTCTime, getCurrentTime) 14 import Data.Time.LocalTime (TimeOfDay(TimeOfDay), timeOfDayToTime) 15 16 import Has 17 import Service.Types 18 import Service.Log 19 import Service.Notification 20 import Context 21 import Model.Periodic 22 import Model.Token 23 import Model.Volume 24 import Model.Stats 25 import Model.Notification 26 import Controller.Notification 27 import Solr.Index 28 import EZID.Volume -- TODO 29 30 threadDelay' :: Micro -> IO () 31 threadDelay' (MkFixed t) 32 | t > m' = threadDelay m >> threadDelay' (MkFixed (t - m')) 33 | otherwise = threadDelay (fromInteger t) 34 where 35 m' = toInteger m 36 m = maxBound 37 38 run :: Period -> Service -> IO () 39 run p = runContextM $ withReaderT BackgroundContext $ do 40 t <- peek 41 focusIO $ logMsg t ("periodic running: " ++ show p) 42 cleanTokens 43 updateVolumeIndex 44 withReaderT (mkSolrIndexingContext . backgroundContext) updateIndex 45 ss <- lookupSiteStats 46 focusIO $ (`writeIORef` ss) . serviceStats 47 when (p >= PeriodWeekly) $ 48 void updateEZID 49 _ <- cleanNotifications 50 updateStateNotifications 51 focusIO $ triggerNotifications (Just p) 52 53 runPeriodic :: Service -> (forall a . IO a -> IO a) -> IO () 54 runPeriodic rc unmask = loop (if s <= st then d s else s) where 55 st = serviceStartTime rc 56 s = st{ utctDayTime = timeOfDayToTime $ TimeOfDay 7 0 0 } 57 d t = t{ utctDay = succ (utctDay t) } 58 loop t = do 59 n <- getCurrentTime 60 (t', p) <- handle (return . (t ,)) $ do 61 unmask $ threadDelay' $ realToFrac $ diffUTCTime t n 62 return (d t, if 0 == snd (sundayStartWeek (utctDay t)) 63 then PeriodWeekly 64 else PeriodDaily) 65 handle (\(_ :: Period) -> logMsg t "periodic interrupted" (view rc)) $ 66 unmask $ run p rc 67 loop t' 68 69 forkPeriodic :: Service -> IO ThreadId 70 forkPeriodic rc = forkFinally (mask $ runPeriodic rc) $ \r -> do 71 t <- getCurrentTime 72 logMsg t ("periodic aborted: " ++ show r) (view rc)