Fresh cache for calendar data

src/Application.hs

@@ -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

src/Calendar.hs

@@ -19,6 +19,8 @@ module Calendar
   , Context
   , CalendarId
   , SimpleEvent(..)
+  , SimpleEventUTC
+  , SimpleEventLocal
   , initialize
   , applyTz
   , groupByDay

src/Foundation.hs

@@ -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

src/FreshCache.hs

+{-# 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

src/Handler/Home.hs

@@ -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}

src/Settings.hs

@@ -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 {..}
 

stack.yaml

-# 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: {}