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

Fresh cache for calendar data

parent 496f8c44
......@@ -21,7 +21,8 @@ module Application
) where
import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc)
import Control.Monad.Logger (logInfoN, liftLoc)
import qualified FreshCache as FC
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
......@@ -58,26 +59,25 @@ mkYesodDispatch "App" resourcesApp
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
= do
makeFoundation appSettings@AppSettings{..} = do
verifySettings appSettings
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings
then staticDevel
else static)
(appStaticDir appSettings)
(if appMutableStatic then staticDevel else static) appStaticDir
let
partialApp = App{..}
where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
where
partialApp = App{..}
appCalendarCxt = error "LOOP: Accessing appCalendarCxt from logFunc"
appCalendarCxt <- Cal.initialize logFunc appHttpManager (appCredentials appSettings)
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
appCalendarCache <- unsafeHandler partialApp $ FC.newCache $ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt
appFreeCalendarId appBusyCalendarId appLookahead
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......
......@@ -19,6 +19,8 @@ module Calendar
, Context
, CalendarId
, SimpleEvent(..)
, SimpleEventUTC
, SimpleEventLocal
, initialize
, applyTz
, groupByDay
......
......@@ -14,6 +14,7 @@
module Foundation where
import qualified Calendar as Cal
import qualified FreshCache as FC
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
......@@ -35,6 +36,7 @@ data App = App
, appHttpManager :: Manager
, appLogger :: Logger
, appCalendarCxt :: Cal.Context
, appCalendarCache :: FC.Cache (HandlerFor App) [Cal.SimpleEventUTC]
}
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
import qualified Calendar as Cal
import qualified Data.Time.Format as TF
import qualified FreshCache as FC
import Import
import Text.Julius (RawJS (..))
......@@ -130,8 +131,15 @@ queryForm extra = do
|]
return (q, widget)
readCache :: Handler [Cal.SimpleEventUTC]
readCache =
(appCalendarCache &&& appCacheExpiry . appSettings) <$> getYesod
>>= uncurry FC.readCache
getHomeR :: Handler Html
getHomeR = do
-- Start (but don't wait for) refresh of calendar
void $ async $ readCache
(widget, enctype) <- generateFormPost queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout
......@@ -144,10 +152,10 @@ getAvailR = do
FormMissing -> invalidArgs ["missing"]
FormFailure errs -> invalidArgs errs
FormSuccess q -> do
App{..} <- getYesod
let AppSettings{..} = appSettings
tz = tzByLabel $ queryTzLabel q
evs1 <- Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId appLookahead
AppSettings{..} <- appSettings <$> getYesod
let tz = tzByLabel $ queryTzLabel q
let weeks = floor(appLookahead / secondsPerWeek) :: Int
evs1 <- readCache
let evs2 = Cal.partitionSlots (apptLengthMinutes (queryApptLength q)) evs1
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
fmt = if queryTimeFmt q == Time12h
......@@ -159,6 +167,8 @@ getAvailR = do
": " <> unpack (Cal.seSummary e)
withUrlRenderer
[hamlet|
$if null evs'
No appointments available in the next #{weeks} weeks.
$forall day <- evs'
$maybe firstSlot <- headMay day
<h4>#{showDate firstSlot}
......
......@@ -34,6 +34,9 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
secondsPerWeek :: NominalDiffTime
secondsPerWeek = 7*24*60*60
-- | Represent the valid appointment lengths, in minutes.
newtype ApptLength =
ApptLengthMinutes { apptLengthMinutes :: Int }
......@@ -95,6 +98,7 @@ data AppSettings = AppSettings
, appLookahead :: NominalDiffTime
, appApptLengths :: [ApptLength]
, appDefaultApptLength :: ApptLength
, appCacheExpiry :: NominalDiffTime
}
newtype TZLabelW =
......@@ -143,10 +147,11 @@ instance FromJSON AppSettings where
appLocations <- makeLocs <$> o .: "locations"
appFreeCalendarId <- o .: "free-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"
appDefaultApptLength <- o .: "default-appointment-length"
appCredentials <- o .: "calendar-credentials"
appCacheExpiry <- o .:? "calendar-refresh-seconds" .!= (if dev then 15 else 300)
return AppSettings {..}
......
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
......@@ -8,37 +6,13 @@
# A snapshot resolver dictates the compiler version and the set of packages
# 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
# 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:
- .
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps:
- git: git@github.com:brendanhay/gogol.git
commit: 344c9f781560e1ed8395b17e370ba1b085f2edc2
......@@ -47,10 +21,16 @@ extra-deps:
- gogol
- gogol-apps-calendar
# Nix support
nix:
enable: true
pure: false
# Build options
build:
haddock: true
haddock-internal: true
# Override default flag values for local packages and extra-deps
# 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