1 {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TupleSections, Rank2Types, ScopedTypeVariables #-} 2 module Databrary.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 Databrary.Has 17 import Databrary.Service.Types 18 import Databrary.Service.Log 19 import Databrary.Service.Notification 20 import Databrary.Context 21 import Databrary.Model.Periodic 22 import Databrary.Model.Token 23 import Databrary.Model.Volume 24 import Databrary.Model.Stats 25 import Databrary.Model.Notification 26 import Databrary.Controller.Notification 27 import Databrary.Solr.Index 28 import Databrary.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 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)