Commit 2339d123 authored by Christopher League's avatar Christopher League 🖥

Some simplification, export list on Settings

parent ec40b552
......@@ -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.
......
......@@ -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
......
......@@ -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")
......
......@@ -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}
......
This diff is collapsed.
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