Settings.hs 8.44 KB
Newer Older
1 2
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
3 4 5 6
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
7 8 9 10 11 12 13 14 15 16 17 18 19

{-|
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
20 21
  , varGoogleClientId
  , varGoogleSecret
22 23 24 25 26 27 28 29
  , varGoogleRefreshToken
  , compileTimeAppSettings
  , configSettingsYmlValue
  , widgetFile
  , combineStylesheets
  , combineScripts
  ) where

30
import           Calendar                   (CalendarCredentials, CalendarId)
31 32 33 34 35 36 37
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)
38 39
import           Data.Time.Zones            (TZ)
import           Data.Time.Zones.All        (TZLabel, fromTZName, toTZName)
40
import qualified Data.Time.Zones.All        as TZ
41 42 43 44 45 46 47
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)
48

Christopher League's avatar
Christopher League committed
49
-- | Represent a location for an appointment
50
data Location = Location
Christopher League's avatar
Christopher League committed
51 52 53
  { 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
54 55
  } deriving (Show, Eq)

56 57 58 59
instance PathPiece Location where
  toPathPiece = locId
  fromPathPiece _ = Nothing -- Warning: not a round-trip!

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

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

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

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

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

132 133 134 135
instance PathPiece TZLabelW where
  toPathPiece = toPathPiece . decodeUtf8 . toTZName . unwrapTZLabel
  fromPathPiece = fmap TZLabelW . fromTZName . encodeUtf8

136
instance FromJSON AppSettings where
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
  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 {..}
166

167 168 169 170 171 172 173 174 175 176 177 178 179
-- | 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
180
-- | Load a widget from files with or without dynamic reload.
181
widgetFile :: String -> Q Exp
182 183 184 185 186
widgetFile =
  (if appReloadTemplates compileTimeAppSettings
     then widgetFileReload
     else widgetFileNoReload)
    widgetFileSettings
187 188 189 190 191 192 193

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

-- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value
194 195
configSettingsYmlValue =
  either Exception.throw id $ decodeEither' configSettingsYmlBS
196 197 198 199

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

Christopher League's avatar
Christopher League committed
204 205
-- | Combine CSS files at compile time to decrease the number of HTTP
-- requests.
206
combineStylesheets :: Name -> [Route Static] -> Q Exp
207 208
combineStylesheets =
  combineStylesheets' (appSkipCombining compileTimeAppSettings) combineSettings
209

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

Christopher League's avatar
Christopher League committed
216
-- | Environment variable used for Google client ID.
217 218 219
varGoogleClientId :: IsString s => s
varGoogleClientId = "BOOKME_GOOGLE_ID"

Christopher League's avatar
Christopher League committed
220
-- | Environment variable used for Google client secret.
221 222 223
varGoogleSecret :: IsString s => s
varGoogleSecret = "BOOKME_GOOGLE_SECRET"

Christopher League's avatar
Christopher League committed
224
-- | Environment variable used for Google refresh token.
225 226
varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"