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)