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)