nicer logging
This commit is contained in:
parent
c3332b57ef
commit
540bb8fe2e
@ -60,6 +60,9 @@ import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
|
|||||||
import Data.Pool
|
import Data.Pool
|
||||||
|
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
|
import System.Log.FastLogger.Date
|
||||||
|
import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
-- Import all relevant handler modules here.
|
||||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||||
@ -91,7 +94,10 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
|||||||
-- Some basic initializations: HTTP connection manager, logger, and static
|
-- Some basic initializations: HTTP connection manager, logger, and static
|
||||||
-- subsite.
|
-- subsite.
|
||||||
appHttpManager <- newManager
|
appHttpManager <- newManager
|
||||||
appLogger <- liftIO $ newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
appLogger <- liftIO $ do
|
||||||
|
tgetter <- newTimeCache "%Y-%m-%d %T %z"
|
||||||
|
loggerSet <- newStdoutLoggerSet defaultBufSize
|
||||||
|
return $ Yesod.Logger loggerSet tgetter
|
||||||
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
|
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
|
||||||
|
|
||||||
appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
|
appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
|
||||||
|
|||||||
@ -165,7 +165,7 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
|
|||||||
MatchAt nextTime -> do
|
MatchAt nextTime -> do
|
||||||
JobContext{jobCrontab} <- ask
|
JobContext{jobCrontab} <- ask
|
||||||
nextTime' <- applyJitter jobCtl nextTime
|
nextTime' <- applyJitter jobCtl nextTime
|
||||||
$logDebugS "Cron" [st|Waiting until #{tshow nextTime'} to execute #{tshow jobCtl}|]
|
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
|
||||||
logFunc <- askLoggerIO
|
logFunc <- askLoggerIO
|
||||||
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
|
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
|
||||||
doJob
|
doJob
|
||||||
@ -177,7 +177,7 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
|
|||||||
applyJitter seed t = do
|
applyJitter seed t = do
|
||||||
appInstance <- getsYesod appInstanceID
|
appInstance <- getsYesod appInstanceID
|
||||||
let
|
let
|
||||||
halfRange = floor $ 0.5 / acc
|
halfRange = truncate $ 0.5 / acc
|
||||||
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
|
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
|
||||||
return $ addUTCTime diff t
|
return $ addUTCTime diff t
|
||||||
|
|
||||||
@ -196,7 +196,7 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
|
|||||||
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
|
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
|
||||||
waitUntil crontabTV crontab nextTime = runResourceT $ do
|
waitUntil crontabTV crontab nextTime = runResourceT $ do
|
||||||
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
|
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
|
||||||
let waitTime = fromInteger (floor $ diffT / acc) * toRational acc
|
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
|
||||||
waitTime' = realToFrac waitTime :: NominalDiffTime
|
waitTime' = realToFrac waitTime :: NominalDiffTime
|
||||||
$logDebugS "waitUntil" [st|#{tshow diffT} (#{tshow waitTime'})|]
|
$logDebugS "waitUntil" [st|#{tshow diffT} (#{tshow waitTime'})|]
|
||||||
if
|
if
|
||||||
|
|||||||
Reference in New Issue
Block a user