Settings.hs 8.9 KB
Newer Older
1
{-# LANGUAGE DataKinds                  #-}
Christopher League's avatar
Christopher League committed
2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 4 5 6 7
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
8 9 10 11 12 13 14 15 16 17 18 19 20

{-|
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(..)
Christopher League's avatar
Christopher League committed
21 22
  , varGoogleClientId
  , varGoogleSecret
23 24 25 26 27 28 29 30
  , varGoogleRefreshToken
  , compileTimeAppSettings
  , configSettingsYmlValue
  , widgetFile
  , combineStylesheets
  , combineScripts
  ) where

31
import           Calendar                   (CalendarCredentials, CalendarId)
32 33 34 35 36 37 38
import           ClassyPrelude.Yesod
import qualified Control.Exception          as Exception
import           Data.Aeson                 (Result (..), fromJSON, withObject,
                                             (.!=), (.:?))
import qualified Data.Aeson.Types           as Js
import           Data.FileEmbed             (embedFile)
import           Data.Time.Clock            (NominalDiffTime)
39 40
import           Data.Time.Zones            (TZ)
import           Data.Time.Zones.All        (TZLabel, fromTZName, toTZName)
41
import qualified Data.Time.Zones.All        as TZ
42 43 44 45 46 47 48
import           Data.Yaml                  (decodeEither')
import           Language.Haskell.TH.Syntax (Exp, Name, Q)
import           Network.Wai.Handler.Warp   (HostPreference)
import           Yesod.Default.Config2      (applyEnvValue, configSettingsYml)
import           Yesod.Default.Util         (WidgetFileSettings,
                                             widgetFileNoReload,
                                             widgetFileReload)
49

Christopher League's avatar
Christopher League committed
50
-- | Represent a location for an appointment
51
data Location = Location
Christopher League's avatar
Christopher League committed
52 53 54
  { locId     :: Text -- ^ Arbitrary identifier slug used as a path piece
  , locSearch :: Text -- ^ Search string, can be blank to allow all available slots
  , locDescr  :: Text -- ^ Description of location
55 56
  } deriving (Show, Eq)

Christopher League's avatar
Christopher League committed
57
-- | Construct locations, adding IDs like "locA", "locB".
58 59 60 61
makeLocs :: [(Text, Text)] -> [Location]
makeLocs = zipWith mk ['A' ..]
  where
    mk c (s, d) = Location (snoc "loc" c) s d
62

63 64 65 66
-- | 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
67
  { appStaticDir              :: String
68
    -- ^ Directory from which to serve static files.
69
  , appRoot                   :: Maybe Text
70 71
    -- ^ Base for all generated URLs. If @Nothing@, determined
    -- from the request headers.
72
  , appHost                   :: HostPreference
73
    -- ^ Host/interface the server should bind to.
74
  , appPort                   :: Int
75
    -- ^ Port to listen on
76
  , appIpFromHeader           :: Bool
77 78
    -- ^ Get the IP address from the header when logging. Useful when sitting
    -- behind a reverse proxy.
79
  , appDetailedRequestLogging :: Bool
80
    -- ^ Use detailed request logging system
81
  , appShouldLogAll           :: Bool
82
    -- ^ Should all log messages be displayed?
83
  , appReloadTemplates        :: Bool
84
    -- ^ Use the reload version of templates
85
  , appMutableStatic          :: Bool
86
    -- ^ Assume that files in the static dir may change after compilation
87
  , appSkipCombining          :: Bool
88
    -- ^ Perform no stylesheet/script combining
89
  , appLocalAssets            :: Bool
90
    -- ^ Use local assets, rather than CDN
91
    -- Example app-specific configuration values.
92
  , appCopyright              :: Text
93
    -- ^ Copyright text to appear in the footer of the page
94
  , appAnalytics              :: Maybe Text
95
    -- ^ Google Analytics code
96
  , appCredentials            :: CalendarCredentials
Christopher League's avatar
Christopher League committed
97
    -- ^ Credentials needed for accessing the calendar
98
  , appDefaultTimeZone        :: TZLabelW
Christopher League's avatar
Christopher League committed
99
    -- ^ Default time zone
100
  , appLocations              :: [Location]
Christopher League's avatar
Christopher League committed
101
    -- ^ Available locations for appointments
102
  , appFreeCalendarId         :: CalendarId
Christopher League's avatar
Christopher League committed
103
    -- ^ Calender specifying available time slots
104
  , appBusyCalendarId         :: CalendarId
Christopher League's avatar
Christopher League committed
105
    -- ^ Calendar specifying busy times
106
  , appLookaheadWeeks         :: Int
Christopher League's avatar
Christopher League committed
107
    -- ^ How far to look ahead when fetching calendar events
108 109
  , appLeadTime               :: NominalDiffTime
    -- ^ Minimum advance notice required for a meeting
110
  , appApptLengthsMinutes     :: [Int]
Christopher League's avatar
Christopher League committed
111
    -- ^ Valid lengths of appointments, in minutes
112
  , appCacheExpiry            :: NominalDiffTime
Christopher League's avatar
Christopher League committed
113
    -- ^ Cached calendar data older than this will be refreshed
114
  , appProviderName           :: Maybe Text
115
    -- ^ Name of person/service providing appointments
116
  , appProviderAvatar         :: Maybe Text
117
    -- ^ URL to image of person/service providing appointments
118 119
  }

Christopher League's avatar
Christopher League committed
120
-- | Wrap a time zone label, so we can specify type classes.
121 122
newtype TZLabelW = TZLabelW
  { unwrapTZLabel :: TZLabel
Christopher League's avatar
Christopher League committed
123
  } deriving (Eq, Show, Bounded, Enum)
124

Christopher League's avatar
Christopher League committed
125
-- | Look up the time zone spec for given label.
126 127
tzByLabel :: TZLabelW -> TZ
tzByLabel = TZ.tzByLabel . unwrapTZLabel
128 129 130 131 132 133 134

instance FromJSON TZLabelW where
  parseJSON v =
    fromTZName . encodeUtf8 <$> parseJSON v >>= \case
      Just tz -> return $ TZLabelW tz
      Nothing -> Js.typeMismatch "TZLabel" v

135 136 137 138
instance PathPiece TZLabelW where
  toPathPiece = toPathPiece . decodeUtf8 . toTZName . unwrapTZLabel
  fromPathPiece = fmap TZLabelW . fromTZName . encodeUtf8

139
instance FromJSON AppSettings where
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
  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"
161
      appLeadTime <- (* 60) <$> (o .: "lead-time-minutes")
162
      appApptLengthsMinutes <- o .: "appointment-lengths-minutes"
163 164
      appProviderName <- o .:? "provider-name"
      appProviderAvatar <- o .:? "provider-avatar"
165 166 167 168 169 170 171
      appCredentials <- o .: "calendar-credentials"
      appCacheExpiry <-
        o .:? "calendar-refresh-seconds" .!=
        (if dev
           then 15
           else 300)
      return AppSettings {..}
172

173 174 175 176 177 178 179 180 181 182 183 184 185
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
-- For more information on modifying behavior, see:
--
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def

-- | How static files should be combined.
combineSettings :: CombineSettings
combineSettings = def

Christopher League's avatar
Christopher League committed
186
-- | Load a widget from files with or without dynamic reload.
187
widgetFile :: String -> Q Exp
188 189 190 191 192
widgetFile =
  (if appReloadTemplates compileTimeAppSettings
     then widgetFileReload
     else widgetFileNoReload)
    widgetFileSettings
193 194 195 196 197 198 199

-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
configSettingsYmlBS = $(embedFile configSettingsYml)

-- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value
200 201
configSettingsYmlValue =
  either Exception.throw id $ decodeEither' configSettingsYmlBS
202 203 204 205

-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
compileTimeAppSettings :: AppSettings
compileTimeAppSettings =
206 207 208
  case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
    Error e          -> error e
    Success settings -> settings
209

Christopher League's avatar
Christopher League committed
210 211
-- | Combine CSS files at compile time to decrease the number of HTTP
-- requests.
212
combineStylesheets :: Name -> [Route Static] -> Q Exp
213 214
combineStylesheets =
  combineStylesheets' (appSkipCombining compileTimeAppSettings) combineSettings
215

Christopher League's avatar
Christopher League committed
216 217
-- | Combine JS files at compile time to decrease the number of HTTP
-- requests.
218
combineScripts :: Name -> [Route Static] -> Q Exp
219 220
combineScripts =
  combineScripts' (appSkipCombining compileTimeAppSettings) combineSettings
221

Christopher League's avatar
Christopher League committed
222
-- | Environment variable used for Google client ID.
223 224 225
varGoogleClientId :: IsString s => s
varGoogleClientId = "BOOKME_GOOGLE_ID"

Christopher League's avatar
Christopher League committed
226
-- | Environment variable used for Google client secret.
227 228 229
varGoogleSecret :: IsString s => s
varGoogleSecret = "BOOKME_GOOGLE_SECRET"

Christopher League's avatar
Christopher League committed
230
-- | Environment variable used for Google refresh token.
231 232
varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"