Settings.hs 8.81 KB
Newer Older
1
2
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
3
{-# LANGUAGE NoImplicitPrelude #-}
Christopher League's avatar
Christopher League committed
4
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5
6
7
{-# 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
import           Data.Yaml                  (decodeEither')
43
import           Development.GitRev
44
45
46
47
48
49
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)
50

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

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

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

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

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

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

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

134
instance FromJSON AppSettings where
135
136
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
  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 {..}
164

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

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

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

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

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

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

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

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

Christopher League's avatar
Christopher League committed
222
-- | Environment variable used for Google refresh token.
223
224
varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"
225
226
227
228
229
230
231
232
233
234

showGit :: IO ()
showGit = do
  say $ "gitBranch       = " <> tshow $(gitBranch)
  say $ "gitCommitCount  = " <> tshow $(gitCommitCount)
  say $ "gitCommitDate   = " <> tshow $(gitCommitDate)
  say $ "gitDescribe     = " <> tshow $(gitDescribe)
  say $ "gitDirty        = " <> tshow $(gitDirty)
  say $ "gitDirtyTracked = " <> tshow $(gitDirtyTracked)
  say $ "gitHash         = " <> tshow $(gitHash)