Commit ec40b552 authored by Christopher League's avatar Christopher League 🖥

Fresh cache for calendar data

parent 496f8c44
...@@ -21,7 +21,8 @@ module Application ...@@ -21,7 +21,8 @@ module Application
) where ) where
import qualified Calendar as Cal import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc) import Control.Monad.Logger (logInfoN, liftLoc)
import qualified FreshCache as FC
import Import import Import
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Client.TLS (getGlobalManager)
...@@ -58,26 +59,25 @@ mkYesodDispatch "App" resourcesApp ...@@ -58,26 +59,25 @@ mkYesodDispatch "App" resourcesApp
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App makeFoundation :: AppSettings -> IO App
makeFoundation appSettings makeFoundation appSettings@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
= do
verifySettings appSettings verifySettings appSettings
appHttpManager <- getGlobalManager appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <- appStatic <-
(if appMutableStatic appSettings (if appMutableStatic then staticDevel else static) appStaticDir
then staticDevel
else static)
(appStaticDir appSettings)
let let
partialApp = App{..}
where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
logFunc loc src lv = logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) . whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv messageLoggerSource partialApp appLogger loc src lv
where appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
partialApp = App{..} appCalendarCache <- unsafeHandler partialApp $ FC.newCache $ do
appCalendarCxt = error "LOOP: Accessing appCalendarCxt from logFunc" logInfoN "Refreshing calendar cache"
appCalendarCxt <- Cal.initialize logFunc appHttpManager (appCredentials appSettings) Cal.listAvailMinusBusy appCalendarCxt
appFreeCalendarId appBusyCalendarId appLookahead
return App {..} return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......
...@@ -19,6 +19,8 @@ module Calendar ...@@ -19,6 +19,8 @@ module Calendar
, Context , Context
, CalendarId , CalendarId
, SimpleEvent(..) , SimpleEvent(..)
, SimpleEventUTC
, SimpleEventLocal
, initialize , initialize
, applyTz , applyTz
, groupByDay , groupByDay
......
...@@ -14,6 +14,7 @@ ...@@ -14,6 +14,7 @@
module Foundation where module Foundation where
import qualified Calendar as Cal import qualified Calendar as Cal
import qualified FreshCache as FC
import qualified Control.Monad.Catch as MC import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource) import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
...@@ -35,6 +36,7 @@ data App = App ...@@ -35,6 +36,7 @@ data App = App
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , appLogger :: Logger
, appCalendarCxt :: Cal.Context , appCalendarCxt :: Cal.Context
, appCalendarCache :: FC.Cache (HandlerFor App) [Cal.SimpleEventUTC]
} }
data MenuItem = MenuItem data MenuItem = MenuItem
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: FreshCache
Description: TODO
TODO
-}
module FreshCache
( Cache
, newCache
, readCache
, cacheDemo
) where
import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime)
newtype Cache m a =
Cache (MVar (a, UTCTime, m a))
newCache :: MonadIO m => m a -> m (Cache m a)
newCache refresh = do
now <- liftIO getCurrentTime
result <- refresh
Cache <$> newMVar (result, now, refresh)
readCache :: MonadUnliftIO m => Cache m a -> NominalDiffTime -> m a
readCache (Cache mvar) maxAge =
modifyMVar mvar $ \val@(result, prev, refresh) -> do
now <- liftIO getCurrentTime
if now `diffUTCTime` prev < maxAge
then return (val, result)
else do
newResult <- refresh
return ((newResult, now, refresh), newResult)
cacheDemo :: IO ()
cacheDemo = do
let w sec = threadDelay (sec * 1000 * 1000)
pr :: Int -> Text -> IO ()
pr i r = say (tshow i <> ": " <> r)
k <-
newCache $ do
say "Refreshing..."
w 2
say "Refreshing...done"
return $ asText "OK"
threads <-
forM [1 .. 5] $ \i ->
async $ do
readCache k 6 >>= pr i
w (i + 1)
readCache k 6 >>= pr i
w (i + 2)
readCache k 6 >>= pr i
mapM_ waitAsync threads
say "Now forcing an immediate refresh"
readCache k 0 >>= pr 0
...@@ -11,6 +11,7 @@ module Handler.Home where ...@@ -11,6 +11,7 @@ module Handler.Home where
import qualified Calendar as Cal import qualified Calendar as Cal
import qualified Data.Time.Format as TF import qualified Data.Time.Format as TF
import qualified FreshCache as FC
import Import import Import
import Text.Julius (RawJS (..)) import Text.Julius (RawJS (..))
...@@ -130,8 +131,15 @@ queryForm extra = do ...@@ -130,8 +131,15 @@ queryForm extra = do
|] |]
return (q, widget) return (q, widget)
readCache :: Handler [Cal.SimpleEventUTC]
readCache =
(appCalendarCache &&& appCacheExpiry . appSettings) <$> getYesod
>>= uncurry FC.readCache
getHomeR :: Handler Html getHomeR :: Handler Html
getHomeR = do getHomeR = do
-- Start (but don't wait for) refresh of calendar
void $ async $ readCache
(widget, enctype) <- generateFormPost queryForm (widget, enctype) <- generateFormPost queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout defaultLayout
...@@ -144,10 +152,10 @@ getAvailR = do ...@@ -144,10 +152,10 @@ getAvailR = do
FormMissing -> invalidArgs ["missing"] FormMissing -> invalidArgs ["missing"]
FormFailure errs -> invalidArgs errs FormFailure errs -> invalidArgs errs
FormSuccess q -> do FormSuccess q -> do
App{..} <- getYesod AppSettings{..} <- appSettings <$> getYesod
let AppSettings{..} = appSettings let tz = tzByLabel $ queryTzLabel q
tz = tzByLabel $ queryTzLabel q let weeks = floor(appLookahead / secondsPerWeek) :: Int
evs1 <- Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId appLookahead evs1 <- readCache
let evs2 = Cal.partitionSlots (apptLengthMinutes (queryApptLength q)) evs1 let evs2 = Cal.partitionSlots (apptLengthMinutes (queryApptLength q)) evs1
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2 let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
fmt = if queryTimeFmt q == Time12h fmt = if queryTimeFmt q == Time12h
...@@ -159,6 +167,8 @@ getAvailR = do ...@@ -159,6 +167,8 @@ getAvailR = do
": " <> unpack (Cal.seSummary e) ": " <> unpack (Cal.seSummary e)
withUrlRenderer withUrlRenderer
[hamlet| [hamlet|
$if null evs'
No appointments available in the next #{weeks} weeks.
$forall day <- evs' $forall day <- evs'
$maybe firstSlot <- headMay day $maybe firstSlot <- headMay day
<h4>#{showDate firstSlot} <h4>#{showDate firstSlot}
......
...@@ -34,6 +34,9 @@ import Yesod.Default.Util (WidgetFileSettings, ...@@ -34,6 +34,9 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload, widgetFileNoReload,
widgetFileReload) widgetFileReload)
secondsPerWeek :: NominalDiffTime
secondsPerWeek = 7*24*60*60
-- | Represent the valid appointment lengths, in minutes. -- | Represent the valid appointment lengths, in minutes.
newtype ApptLength = newtype ApptLength =
ApptLengthMinutes { apptLengthMinutes :: Int } ApptLengthMinutes { apptLengthMinutes :: Int }
...@@ -95,6 +98,7 @@ data AppSettings = AppSettings ...@@ -95,6 +98,7 @@ data AppSettings = AppSettings
, appLookahead :: NominalDiffTime , appLookahead :: NominalDiffTime
, appApptLengths :: [ApptLength] , appApptLengths :: [ApptLength]
, appDefaultApptLength :: ApptLength , appDefaultApptLength :: ApptLength
, appCacheExpiry :: NominalDiffTime
} }
newtype TZLabelW = newtype TZLabelW =
...@@ -143,10 +147,11 @@ instance FromJSON AppSettings where ...@@ -143,10 +147,11 @@ instance FromJSON AppSettings where
appLocations <- makeLocs <$> o .: "locations" appLocations <- makeLocs <$> o .: "locations"
appFreeCalendarId <- o .: "free-calendar" appFreeCalendarId <- o .: "free-calendar"
appBusyCalendarId <- o .: "busy-calendar" appBusyCalendarId <- o .: "busy-calendar"
appLookahead <- (7*24*60*60*) <$> o .: "look-ahead-weeks" appLookahead <- (*secondsPerWeek) <$> o .: "look-ahead-weeks"
appApptLengths <- o .: "appointment-lengths-minutes" appApptLengths <- o .: "appointment-lengths-minutes"
appDefaultApptLength <- o .: "default-appointment-length" appDefaultApptLength <- o .: "default-appointment-length"
appCredentials <- o .: "calendar-credentials" appCredentials <- o .: "calendar-credentials"
appCacheExpiry <- o .:? "calendar-refresh-seconds" .!= (if dev then 15 else 300)
return AppSettings {..} return AppSettings {..}
......
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file. # Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see: # For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/ # https://docs.haskellstack.org/en/stable/yaml_configuration/
...@@ -8,37 +6,13 @@ ...@@ -8,37 +6,13 @@
# A snapshot resolver dictates the compiler version and the set of packages # A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example: # to be used for project dependencies. For example:
# #
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-11.10 resolver: lts-11.10
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages: packages:
- . - .
# Dependency packages to be pulled from upstream that are not in the resolver # Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: extra-deps:
- git: git@github.com:brendanhay/gogol.git - git: git@github.com:brendanhay/gogol.git
commit: 344c9f781560e1ed8395b17e370ba1b085f2edc2 commit: 344c9f781560e1ed8395b17e370ba1b085f2edc2
...@@ -47,10 +21,16 @@ extra-deps: ...@@ -47,10 +21,16 @@ extra-deps:
- gogol - gogol
- gogol-apps-calendar - gogol-apps-calendar
# Nix support
nix: nix:
enable: true enable: true
pure: false pure: false
# Build options
build:
haddock: true
haddock-internal: true
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment