Some simplification, export list on Settings

config/settings.yml

@@ -12,7 +12,6 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
 
 time-zone: _env:BOOKME_TIME_ZONE:America/New_York
 appointment-lengths-minutes: [15, 20, 25]
-default-appointment-length: 15
 locations:
   - - "#office"
     - At LIU Brooklyn (usually H700)
@@ -27,10 +26,7 @@ free-calendar: _env:BOOKME_FREE_CAL:free
 busy-calendar: _env:BOOKME_BUSY_CAL:busy
 look-ahead-weeks: 4
 
-# By default, `yesod devel` runs in development, and built executables use
-# production settings (see below). To override this, use the following:
-#
-# development: false
+development: "_env:BOOKME_DEVEL:false"
 
 # Optional values with the following production defaults.
 # In development, they default to the inverse.

src/Application.hs

@@ -25,6 +25,7 @@ import           Control.Monad.Logger                   (logInfoN, liftLoc)
 import qualified FreshCache as FC
 import           Import
 import           Language.Haskell.TH.Syntax             (qLocation)
+import Data.Time.Clock (NominalDiffTime)
 import           Network.HTTP.Client.TLS                (getGlobalManager)
 import           Network.Wai                            (Middleware)
 import           Network.Wai.Handler.Warp               (Settings,
@@ -54,13 +55,15 @@ import           Handler.Home
 -- comments there for more details.
 mkYesodDispatch "App" resourcesApp
 
+fromWeeks :: Int -> NominalDiffTime
+fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w
+
 -- | This function allocates resources (such as a database connection pool),
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
 makeFoundation :: AppSettings -> IO App
 makeFoundation appSettings@AppSettings{..} = do
-  verifySettings appSettings
   appHttpManager <- getGlobalManager
   appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
   appStatic <-
@@ -68,16 +71,17 @@ makeFoundation appSettings@AppSettings{..} = do
   let
     partialApp = App{..}
       where
-        appCalendarCxt   = error "partialApp loop: Accessing appCalendarCxt"
-        appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
+        appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
+        appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
     logFunc loc src lv =
       whenM (shouldLogIO partialApp "" lv) .
       messageLoggerSource partialApp appLogger loc src lv
   appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
-  appCalendarCache <- unsafeHandler partialApp $ FC.newCache $ do
+  cache <- unsafeHandler partialApp $ FC.newCache $ do
     logInfoN "Refreshing calendar cache"
     Cal.listAvailMinusBusy appCalendarCxt
-      appFreeCalendarId appBusyCalendarId appLookahead
+      appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks
+  let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
   return App {..}
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and

src/Foundation.hs

@@ -9,16 +9,15 @@
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ViewPatterns               #-}
 
 module Foundation where
 
-import qualified Calendar as Cal
-import qualified FreshCache as FC
+import qualified Calendar             as Cal
 import qualified Control.Monad.Catch  as MC
 import           Control.Monad.Logger (LogSource)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding   as TE
+import           Data.Time.Clock      (NominalDiffTime)
 import           Import.NoFoundation  as Pre
 import           Text.Hamlet          (hamletFile)
 import           Text.Jasmine         (minifym)
@@ -31,12 +30,15 @@ import           Yesod.Default.Util   (addStaticContentExternal)
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data App = App
-  { appSettings    :: AppSettings
-  , appStatic      :: Static -- ^ Settings for static file serving.
+  { appSettings :: AppSettings
+  , appStatic :: Static -- ^ Settings for static file serving.
   , appHttpManager :: Manager
-  , appLogger      :: Logger
+  , appLogger :: Logger
   , appCalendarCxt :: Cal.Context
-  , appCalendarCache :: FC.Cache (HandlerFor App) [Cal.SimpleEventUTC]
+  , appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [Cal.SimpleEventUTC]
+    -- ^ Fetch latest available times from the calendars. Return cached
+    -- version if it's less than given age, which defaults to
+    -- 'appCacheExpiry'.
   }
 
 data MenuItem = MenuItem
@@ -72,14 +74,14 @@ instance MC.MonadCatch (HandlerFor App) where
 addStylesheetL :: Route App -> Text -> [(Text, Text)] -> Widget
 addStylesheetL route cdn attrs =
   appLocalAssets . appSettings <$> getYesod >>= \case
-  True -> addStylesheet route
-  False -> addStylesheetRemoteAttrs cdn attrs
+    True -> addStylesheet route
+    False -> addStylesheetRemoteAttrs cdn attrs
 
 addScriptL :: Route App -> Text -> [(Text, Text)] -> Widget
 addScriptL route cdn attrs =
   appLocalAssets . appSettings <$> getYesod >>= \case
-  True -> addScript route
-  False -> addScriptRemoteAttrs cdn attrs
+    True -> addScript route
+    False -> addScriptRemoteAttrs cdn attrs
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
@@ -126,19 +128,24 @@ instance Yesod App
       widgetToPageContent $ do
         let fontFamily =
               asText "'Play', 'Helvetica Neue', Helvetica, Arial, sans-serif"
-        addScriptL (StaticR js_jquery_3_3_1_min_js)
+        addScriptL
+          (StaticR js_jquery_3_3_1_min_js)
           "https://code.jquery.com/jquery-3.3.1.min.js"
-          [("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
-          ,("crossorigin", "anonymous")
+          [ ("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
+          , ("crossorigin", "anonymous")
           ]
-        addScriptL (StaticR js_js_cookie_2_2_0_min_js)
+        addScriptL
+          (StaticR js_js_cookie_2_2_0_min_js)
           "https://cdn.jsdelivr.net/npm/js-cookie@2.2.0/src/js.cookie.min.js"
           []
-        addStylesheetRemote "https://fonts.googleapis.com/css?family=Play:400,700"
-        addStylesheetL (StaticR css_bootstrap_3_3_7_min_css)
+        addStylesheetRemote
+          "https://fonts.googleapis.com/css?family=Play:400,700"
+        addStylesheetL
+          (StaticR css_bootstrap_3_3_7_min_css)
           "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"
-          [("integrity", "sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u")
-          ,("crossorigin", "anonymous")
+          [ ( "integrity"
+            , "sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u")
+          , ("crossorigin", "anonymous")
           ]
         --   $ StaticR css_bootstrap_css
         $(widgetFile "default-layout")

src/Handler/Home.hs

@@ -11,23 +11,21 @@ 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 (..))
 
-apptLengthOptions :: Handler (OptionList ApptLength)
+apptLengthOptions :: Handler (OptionList Int)
 apptLengthOptions = do
-  lengths <- appApptLengths . appSettings <$> getYesod
+  lengths <- appApptLengthsMinutes . appSettings <$> getYesod
   let
-    toOption a@(ApptLengthMinutes m) =
+    toOption m =
       Option
       { optionDisplay = tshow m <> " minute"
-      , optionInternalValue = a
+      , optionInternalValue = m
       , optionExternalValue = tshow m
       }
     okLength m =
-      if len `elem` lengths then Just len else Nothing
-      where len = ApptLengthMinutes m
+      if m `elem` lengths then Just m else Nothing
   return $ OptionList
     { olOptions = map toOption lengths
     , olReadExternal = fromPathPiece >=> okLength
@@ -80,7 +78,7 @@ timeFmtOptions = return $ OptionList
   }
 
 data QueryForm = QueryForm
-  { queryApptLength :: ApptLength
+  { queryApptLength :: Int
   , queryTimeFmt    :: TimeFmt
   , queryTzLabel    :: TZLabelW
   , queryLocation   :: Location
@@ -92,7 +90,7 @@ queryForm extra = do
   AppSettings{..} <- appSettings <$> getYesod
   qc <- newIdent
   let qs n = "" {fsName = Just n, fsId = Just n, fsAttrs = [("class", qc)]}
-  (lenRes, lenView) <- mreq (selectField apptLengthOptions) (qs "len") (Just appDefaultApptLength)
+  (lenRes, lenView) <- mreq (selectField apptLengthOptions) (qs "len") (headMay appApptLengthsMinutes)
   (fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
   (locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
   (slotRes, _) <- mopt textField (qs "slot") Nothing
@@ -131,15 +129,11 @@ 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
+  App{..} <- getYesod
+  void $ async $ appGetCalendar Nothing
   (widget, enctype) <- generateFormPost queryForm
   (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
   defaultLayout
@@ -152,11 +146,10 @@ getAvailR = do
     FormMissing -> invalidArgs ["missing"]
     FormFailure errs -> invalidArgs errs
     FormSuccess q -> do
-      AppSettings{..} <- appSettings <$> getYesod
+      App{appSettings=AppSettings{..}, ..} <- getYesod
       let tz = tzByLabel $ queryTzLabel q
-      let weeks = floor(appLookahead / secondsPerWeek) :: Int
-      evs1 <- readCache
-      let evs2 = Cal.partitionSlots (apptLengthMinutes (queryApptLength q)) evs1
+      evs1 <- appGetCalendar Nothing
+      let evs2 = Cal.partitionSlots (queryApptLength q) evs1
       let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
           fmt = if queryTimeFmt q == Time12h
                 then "%l:%M %p"
@@ -168,7 +161,7 @@ getAvailR = do
       withUrlRenderer
         [hamlet|
                $if null evs'
-                 No appointments available in the next #{weeks} weeks.
+                 No appointments available in the next #{appLookaheadWeeks} weeks.
                $forall day <- evs'
                  $maybe firstSlot <- headMay day
                    <h4>#{showDate firstSlot}