Settings.hs 8.63 KB
Newer Older
1
{-# LANGUAGE DataKinds #-}
2
{-# LANGUAGE CPP               #-}
3
{-# LANGUAGE LambdaCase #-}
4
5
6
7
8
9
10
11
12
13
14
{-# 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

15
import qualified Calendar as Cal
16
17
18
19
20
21
22
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)
23
24
25
import qualified Data.Time.Zones.All        as TZ
import           Data.Time.Zones            (TZ)
import           Data.Time.Zones.All        (TZLabel, fromTZName, toTZName)
26
27
28
29
30
31
32
33
34
35
import           Data.Yaml                  (decodeEither')
import           Language.Haskell.TH.Syntax (Exp, Name, Q)
import           Network.Google.Auth        (OAuthClient(..), ClientId(..),
                                             Secret(..))
import           Network.Wai.Handler.Warp   (HostPreference)
import           System.Environment         (getEnv)
import           Yesod.Default.Config2      (applyEnvValue, configSettingsYml)
import           Yesod.Default.Util         (WidgetFileSettings,
                                             widgetFileNoReload,
                                             widgetFileReload)
36

37
38
39
40
41
42
43
44
-- | Represent the valid appointment lengths, in minutes.
newtype ApptLength =
  ApptLengthMinutes Int
  deriving (Eq, Ord, Show)

instance FromJSON ApptLength where
  parseJSON s = ApptLengthMinutes <$> parseJSON s

45
data Location = Location
46
  { locId :: Text
47
48
49
50
51
  , locSearch :: Text
  , locDescr :: Text
  } deriving (Show, Eq)

makeLocs :: [(Text,Text)] -> [Location]
52
53
makeLocs = zipWith mk ['A'..]
  where mk c (s,d) = Location (snoc "loc" c) s d
54

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
-- | 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
    -- ^ Directory from which to serve static files.
    , appRoot                   :: Maybe Text
    -- ^ Base for all generated URLs. If @Nothing@, determined
    -- from the request headers.
    , appHost                   :: HostPreference
    -- ^ Host/interface the server should bind to.
    , appPort                   :: Int
    -- ^ Port to listen on
    , appIpFromHeader           :: Bool
    -- ^ Get the IP address from the header when logging. Useful when sitting
    -- behind a reverse proxy.

    , appDetailedRequestLogging :: Bool
    -- ^ Use detailed request logging system
    , appShouldLogAll           :: Bool
    -- ^ Should all log messages be displayed?
    , appReloadTemplates        :: Bool
    -- ^ Use the reload version of templates
    , appMutableStatic          :: Bool
    -- ^ Assume that files in the static dir may change after compilation
    , appSkipCombining          :: Bool
    -- ^ Perform no stylesheet/script combining
82
83
    , appLocalAssets            :: Bool
    -- ^ Use local assets, rather than CDN
84
85
86
87
88
89

    -- Example app-specific configuration values.
    , appCopyright              :: Text
    -- ^ Copyright text to appear in the footer of the page
    , appAnalytics              :: Maybe Text
    -- ^ Google Analytics code
90
    , appCredentials            :: Cal.Credentials
91
    , appDefaultTimeZone        :: TZLabelW
92
    , appLocations              :: [Location]
93
94
95
    , appFreeCalendarId         :: Text
    , appBusyCalendarId         :: Text
    , appLookahead              :: NominalDiffTime
96
97
    , appApptLengths            :: [ApptLength]
    , appDefaultApptLength      :: ApptLength
98
99
    }

100
101
102
103
104
105
newtype TZLabelW =
  TZLabelW { unwrapTZLabel :: TZLabel }
  deriving (Eq, Show, Read)

tzByLabel :: TZLabelW -> TZ
tzByLabel = TZ.tzByLabel . unwrapTZLabel
106
107
108
109
110
111
112

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

113
114
115
116
instance PathPiece TZLabelW where
  toPathPiece = toPathPiece . decodeUtf8 . toTZName . unwrapTZLabel
  fromPathPiece = fmap TZLabelW . fromTZName . encodeUtf8

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
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
138
        appLocalAssets            <- o .:? "local-assets"     .!= dev
139
140
141

        appCopyright              <- o .: "copyright"
        appAnalytics              <- o .:? "analytics"
142
        appDefaultTimeZone        <- o .: "time-zone"
143
        appLocations              <- makeLocs <$> o .: "locations"
144
145
146
        appFreeCalendarId         <- o .: "free-calendar"
        appBusyCalendarId         <- o .: "busy-calendar"
        appLookahead              <- (7*24*60*60*) <$> o .: "look-ahead-weeks"
147
148
        appApptLengths            <- o .: "appointment-lengths-minutes"
        appDefaultApptLength      <- o .: "default-appointment-length"
149
        appCredentials            <- o .: "calendar-credentials"
150
151
152

        return AppSettings {..}

153
154
155
156
157
158
-- | Run a consistency check for settings.
verifySettings :: MonadIO m => AppSettings -> m ()
verifySettings AppSettings{..} =
  unless (appDefaultApptLength `elem` appApptLengths) $
  throwString "invalid default-appointment-length"

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
-- | 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

-- 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

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

-- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value
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

-- 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

combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts'
    (appSkipCombining compileTimeAppSettings)
    combineSettings
212
213
214
215
216
217
218
219
220
221
222
223
224
225

varGoogleClientId :: IsString s => s
varGoogleClientId = "BOOKME_GOOGLE_ID"

varGoogleSecret :: IsString s => s
varGoogleSecret = "BOOKME_GOOGLE_SECRET"

varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"

oauthClientFromEnv :: IO OAuthClient
oauthClientFromEnv =
  OAuthClient <$> (ClientId . pack <$> getEnv varGoogleClientId) <*>
  (Secret . pack <$> getEnv varGoogleSecret)