Commit 2339d123 authored by Christopher League's avatar Christopher League
Browse files

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}
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod
-- by overriding methods in the Yesod typeclass. That instance is
-- declared in the Foundation.hs file.
module Settings where
import qualified Calendar as Cal
{-|
Module: Settings
Description: Central server settings
Settings are centralized, as much as possible, into this file. This
includes database connection settings, static file locations, etc.
-}
module Settings
( AppSettings(..)
, TZLabelW
, tzByLabel
, Location(..)
, varGoogleRefreshToken
, oauthClientFromEnv
, compileTimeAppSettings
, configSettingsYmlValue
, widgetFile
, combineStylesheets
, combineScripts
) where
import qualified Calendar as Cal
import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
......@@ -20,13 +34,13 @@ import Data.Aeson (Result (..), fromJSON, withObject,
import qualified Data.Aeson.Types as Js
import Data.FileEmbed (embedFile)
import Data.Time.Clock (NominalDiffTime)
import qualified Data.Time.Zones.All as TZ
import Data.Time.Zones (TZ)
import Data.Time.Zones.All (TZLabel, fromTZName, toTZName)
import qualified Data.Time.Zones.All as TZ
import Data.Yaml (decodeEither')
import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Google.Auth (OAuthClient(..), ClientId(..),
Secret(..))
import Network.Google.Auth (ClientId (..), OAuthClient (..),
Secret (..))
import Network.Wai.Handler.Warp (HostPreference)
import System.Environment (getEnv)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
......@@ -34,76 +48,63 @@ 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 }
deriving (Eq, Ord, Show)
instance FromJSON ApptLength where
parseJSON s = ApptLengthMinutes <$> parseJSON s
data Location = Location
{ locId :: Text
{ locId :: Text
, locSearch :: Text
, locDescr :: Text
, locDescr :: Text
} deriving (Show, Eq)
makeLocs :: [(Text,Text)] -> [Location]
makeLocs = zipWith mk ['A'..]
where mk c (s,d) = Location (snoc "loc" c) s d
makeLocs :: [(Text, Text)] -> [Location]
makeLocs = zipWith mk ['A' ..]
where
mk c (s, d) = Location (snoc "loc" c) s d
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
data AppSettings = AppSettings
{ appStaticDir :: String
{ appStaticDir :: String
-- ^ Directory from which to serve static files.
, appRoot :: Maybe Text
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
, appHost :: HostPreference
, appHost :: HostPreference
-- ^ Host/interface the server should bind to.
, appPort :: Int
, appPort :: Int
-- ^ Port to listen on
, appIpFromHeader :: Bool
, appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
, appDetailedRequestLogging :: Bool
, appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system
, appShouldLogAll :: Bool
, appShouldLogAll :: Bool
-- ^ Should all log messages be displayed?
, appReloadTemplates :: Bool
, appReloadTemplates :: Bool
-- ^ Use the reload version of templates
, appMutableStatic :: Bool
, appMutableStatic :: Bool
-- ^ Assume that files in the static dir may change after compilation
, appSkipCombining :: Bool
, appSkipCombining :: Bool
-- ^ Perform no stylesheet/script combining
, appLocalAssets :: Bool
, appLocalAssets :: Bool
-- ^ Use local assets, rather than CDN
-- Example app-specific configuration values.
, appCopyright :: Text
, appCopyright :: Text
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appCredentials :: Cal.Credentials
, appDefaultTimeZone :: TZLabelW
, appLocations :: [Location]
, appFreeCalendarId :: Text
, appBusyCalendarId :: Text
, appLookahead :: NominalDiffTime
, appApptLengths :: [ApptLength]
, appDefaultApptLength :: ApptLength
, appCacheExpiry :: NominalDiffTime
}
newtype TZLabelW =
TZLabelW { unwrapTZLabel :: TZLabel }
deriving (Eq, Show, Read)
, appCredentials :: Cal.Credentials
, appDefaultTimeZone :: TZLabelW
, appLocations :: [Location]
, appFreeCalendarId :: Text
, appBusyCalendarId :: Text
, appLookaheadWeeks :: Int
, appApptLengthsMinutes :: [Int]
, appCacheExpiry :: NominalDiffTime
}
newtype TZLabelW = TZLabelW
{ unwrapTZLabel :: TZLabel
} deriving (Eq, Show, Read)
tzByLabel :: TZLabelW -> TZ
tzByLabel = TZ.tzByLabel . unwrapTZLabel
......@@ -119,47 +120,35 @@ instance PathPiece TZLabelW where
fromPathPiece = fmap TZLabelW . fromTZName . encodeUtf8
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
#ifdef DEVELOPMENT
True
#else
False
#endif
appStaticDir <- o .: "static-dir"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header"
dev <- o .:? "development" .!= defaultDev
appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev
appShouldLogAll <- o .:? "should-log-all" .!= dev
appReloadTemplates <- o .:? "reload-templates" .!= dev
appMutableStatic <- o .:? "mutable-static" .!= dev
appSkipCombining <- o .:? "skip-combining" .!= dev
appLocalAssets <- o .:? "local-assets" .!= dev
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appDefaultTimeZone <- o .: "time-zone"
appLocations <- makeLocs <$> o .: "locations"
appFreeCalendarId <- o .: "free-calendar"
appBusyCalendarId <- o .: "busy-calendar"
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 {..}
-- | Run a consistency check for settings.
verifySettings :: MonadIO m => AppSettings -> m ()
verifySettings AppSettings{..} =
unless (appDefaultApptLength `elem` appApptLengths) $
throwString "invalid default-appointment-length"
parseJSON =
withObject "AppSettings" $ \o -> do
appStaticDir <- o .: "static-dir"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header"
dev <- o .:? "development" .!= False
appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev
appShouldLogAll <- o .:? "should-log-all" .!= dev
appReloadTemplates <- o .:? "reload-templates" .!= dev
appMutableStatic <- o .:? "mutable-static" .!= dev
appSkipCombining <- o .:? "skip-combining" .!= dev
appLocalAssets <- o .:? "local-assets" .!= dev
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appDefaultTimeZone <- o .: "time-zone"
appLocations <- makeLocs <$> o .: "locations"
appFreeCalendarId <- o .: "free-calendar"
appBusyCalendarId <- o .: "busy-calendar"
appLookaheadWeeks <- o .: "look-ahead-weeks"
appApptLengthsMinutes <- o .: "appointment-lengths-minutes"
appCredentials <- o .: "calendar-credentials"
appCacheExpiry <-
o .:? "calendar-refresh-seconds" .!=
(if dev
then 15
else 300)
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
......@@ -176,12 +165,12 @@ combineSettings = def
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = (if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
widgetFile =
(if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
......@@ -189,31 +178,28 @@ configSettingsYmlBS = $(embedFile configSettingsYml)
-- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value
configSettingsYmlValue = either Exception.throw id
$ decodeEither' configSettingsYmlBS
configSettingsYmlValue =
either Exception.throw id $ decodeEither' configSettingsYmlBS
-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
compileTimeAppSettings :: AppSettings
compileTimeAppSettings =
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Error e -> error e
Success settings -> settings
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Error e -> error e
Success settings -> settings
-- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets'
(appSkipCombining compileTimeAppSettings)
combineSettings
combineStylesheets =
combineStylesheets' (appSkipCombining compileTimeAppSettings) combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts'
(appSkipCombining compileTimeAppSettings)
combineSettings
combineScripts =
combineScripts' (appSkipCombining compileTimeAppSettings) combineSettings
varGoogleClientId :: IsString s => s
varGoogleClientId = "BOOKME_GOOGLE_ID"
......
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