Settings.hs 7.37 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
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
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)
import           Data.Time.Zones.All        (TZLabel, fromTZName)
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)
33

34
35
36
37
38
39
40
41
42
43
data Location = Location
  { locId :: Int
  , locSearch :: Text
  , locDescr :: Text
  } deriving (Show, Eq)

makeLocs :: [(Text,Text)] -> [Location]
makeLocs = zipWith mk [1..]
  where mk i (s,d) = Location i s d

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
-- | 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

    -- Example app-specific configuration values.
    , appCopyright              :: Text
    -- ^ Copyright text to appear in the footer of the page
    , appAnalytics              :: Maybe Text
    -- ^ Google Analytics code
77
    , appDefaultTimeZone        :: TZLabel
78
    , appLocations              :: [Location]
79
80
81
    , appFreeCalendarId         :: Text
    , appBusyCalendarId         :: Text
    , appLookahead              :: NominalDiffTime
82
83
    }

84
85
86
87
88
89
90
91
newtype TZLabelW = TZLabelW { unwrapTZLabel :: TZLabel }

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

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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

        appCopyright              <- o .: "copyright"
        appAnalytics              <- o .:? "analytics"
116
        appDefaultTimeZone        <- unwrapTZLabel <$> o .: "time-zone"
117
        appLocations              <- makeLocs <$> o .: "locations"
118
119
120
        appFreeCalendarId         <- o .: "free-calendar"
        appBusyCalendarId         <- o .: "busy-calendar"
        appLookahead              <- (7*24*60*60*) <$> o .: "look-ahead-weeks"
121
122
123
124
125
126
127
128
129
130
131
132
133
134
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
164
165
166
167
168
169
170
171
172
173
174
175
176

        return AppSettings {..}

-- | 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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

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

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

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

type CalendarScope = '[ "https://www.googleapis.com/auth/calendar"]

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