381 lines
14 KiB
Haskell
381 lines
14 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
-- | 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
|
|
( module Settings
|
|
, module Settings.Cluster
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (Proxy)
|
|
import Data.UUID (UUID)
|
|
import qualified Control.Exception as Exception
|
|
import Data.Aeson (Result (..), fromJSON, withObject
|
|
,(.!=), (.:?), withScientific
|
|
)
|
|
import qualified Data.Aeson.Types as Aeson
|
|
import Data.Aeson.TH
|
|
import Data.FileEmbed (embedFile)
|
|
import Data.Yaml (decodeEither')
|
|
import Database.Persist.Postgresql (PostgresConf)
|
|
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)
|
|
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
|
|
|
import Data.Time (NominalDiffTime)
|
|
|
|
import Data.Scientific (toBoundedInteger)
|
|
import Data.Word (Word16)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import qualified Ldap.Client as Ldap
|
|
|
|
import Utils hiding (MessageClass(..))
|
|
import Control.Lens
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Char as Char
|
|
|
|
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
|
|
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
|
|
|
|
import Network.Mail.Mime (Address)
|
|
|
|
import Mail (VerpMode)
|
|
|
|
import Model
|
|
import Settings.Cluster
|
|
|
|
-- | 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.
|
|
, appDatabaseConf :: PostgresConf
|
|
-- ^ Configuration settings for accessing the database.
|
|
, appLdapConf :: Maybe LdapConf
|
|
-- ^ Configuration settings for accessing the LDAP-directory
|
|
, appSmtpConf :: Maybe SmtpConf
|
|
-- ^ Configuration settings for accessing a SMTP Mailserver
|
|
, 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.
|
|
, appMailFrom :: Address
|
|
, appMailObjectDomain :: Text
|
|
, appMailVerp :: VerpMode
|
|
, appMailSupport :: Address
|
|
, appJobWorkers :: Int
|
|
, appJobFlushInterval :: Maybe NominalDiffTime
|
|
, appJobCronInterval :: NominalDiffTime
|
|
, appJobStaleThreshold :: NominalDiffTime
|
|
, appNotificationRateLimit :: NominalDiffTime
|
|
, appNotificationCollateDelay :: NominalDiffTime
|
|
, appNotificationExpiration :: NominalDiffTime
|
|
, appSessionTimeout :: NominalDiffTime
|
|
|
|
, appInitialLogSettings :: LogSettings
|
|
|
|
, 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
|
|
, appAuthDummyLogin :: Bool
|
|
-- ^ Indicate if auth dummy login should be enabled.
|
|
, appAllowDeprecated :: Bool
|
|
-- ^ Indicate if deprecated routes are accessible for everyone
|
|
, appEncryptErrors :: Bool
|
|
|
|
, appUserDefaults :: UserDefaultConf
|
|
, appAuthPWHash :: PWHashConf
|
|
|
|
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
|
} deriving (Show)
|
|
|
|
data LogSettings = LogSettings
|
|
{ logAll, logDetailed :: Bool
|
|
, logMinimumLevel :: LogLevel
|
|
} deriving (Show, Read, Generic, Eq, Ord)
|
|
|
|
deriving instance Generic LogLevel
|
|
instance Hashable LogLevel
|
|
instance Hashable LogSettings
|
|
|
|
data UserDefaultConf = UserDefaultConf
|
|
{ userDefaultTheme :: Theme
|
|
, userDefaultMaxFavourites :: Int
|
|
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
|
|
, userDefaultDownloadFiles :: Bool
|
|
} deriving (Show)
|
|
|
|
data PWHashConf = PWHashConf
|
|
{ pwHashAlgorithm :: PWHashAlgorithm
|
|
, pwHashStrength :: Int
|
|
}
|
|
|
|
instance Show PWHashConf where
|
|
show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
|
|
|
|
instance FromJSON PWHashConf where
|
|
parseJSON = withObject "PWHashConf" $ \o -> do
|
|
pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
|
|
pwHashAlgorithm <- if
|
|
| pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
|
|
| pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
|
|
| otherwise -> fail "Unsupported hash algorithm"
|
|
pwHashStrength <- o .: "strength"
|
|
|
|
return PWHashConf{..}
|
|
|
|
data LdapConf = LdapConf
|
|
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
|
|
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
|
|
, ldapBase :: Ldap.Dn
|
|
, ldapScope :: Ldap.Scope
|
|
, ldapTimeout :: Int32
|
|
} deriving (Show)
|
|
|
|
data SmtpConf = SmtpConf
|
|
{ smtpHost :: HaskellNet.HostName
|
|
, smtpPort :: HaskellNet.PortNumber
|
|
, smtpAuth :: Maybe SmtpAuthConf
|
|
, smtpSsl :: SmtpSslMode
|
|
, smtpPool :: ResourcePoolConf
|
|
} deriving (Show)
|
|
|
|
data ResourcePoolConf = ResourcePoolConf
|
|
{ poolStripes :: Int
|
|
, poolTimeout :: NominalDiffTime
|
|
, poolLimit :: Int
|
|
} deriving (Show)
|
|
|
|
data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
|
|
deriving (Show)
|
|
|
|
data SmtpAuthConf = SmtpAuthConf
|
|
{ smtpAuthType :: HaskellNet.AuthType
|
|
, smtpAuthUsername :: HaskellNet.UserName
|
|
, smtpAuthPassword :: HaskellNet.Password
|
|
} deriving (Show)
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . splitCamel
|
|
} ''LogSettings
|
|
|
|
deriveFromJSON defaultOptions ''Ldap.Scope
|
|
deriveFromJSON defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
|
} ''UserDefaultConf
|
|
|
|
instance FromJSON LdapConf where
|
|
parseJSON = withObject "LdapConf" $ \o -> do
|
|
ldapTls <- o .:? "tls"
|
|
tlsSettings <- case ldapTls :: Maybe String of
|
|
Just spec
|
|
| spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
|
|
| spec == "default" -> return $ Just Ldap.defaultTlsSettings
|
|
| null spec -> return Nothing
|
|
Nothing -> return Nothing
|
|
_otherwise -> fail "Could not parse LDAP TLSSettings"
|
|
ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
|
|
ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
|
|
ldapDn <- Ldap.Dn <$> o .: "user"
|
|
ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
|
|
ldapBase <- Ldap.Dn <$> o .: "baseDN"
|
|
ldapScope <- o .: "scope"
|
|
ldapTimeout <- o .: "timeout"
|
|
return LdapConf{..}
|
|
|
|
deriveFromJSON
|
|
defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
}
|
|
''ResourcePoolConf
|
|
|
|
deriveJSON
|
|
defaultOptions
|
|
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
|
|
, sumEncoding = UntaggedValue
|
|
}
|
|
''LogLevel
|
|
|
|
instance FromJSON HaskellNet.PortNumber where
|
|
parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
|
|
Just int -> return $ fromIntegral (int :: Word16)
|
|
Nothing -> fail "Expected whole number of plausible size to denote port"
|
|
|
|
deriveFromJSON
|
|
defaultOptions
|
|
{ constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
|
|
, allNullaryToStringTag = True
|
|
}
|
|
''HaskellNet.AuthType
|
|
|
|
instance FromJSON SmtpConf where
|
|
parseJSON = withObject "SmtpConf" $ \o -> do
|
|
smtpHost <- o .: "host"
|
|
smtpPort <- o .: "port"
|
|
smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
|
|
smtpSsl <- o .: "ssl"
|
|
smtpPool <- o .: "pool"
|
|
return SmtpConf{..}
|
|
|
|
deriveFromJSON
|
|
defaultOptions
|
|
{ constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
|
, allNullaryToStringTag = True
|
|
}
|
|
''SmtpSslMode
|
|
|
|
deriveFromJSON
|
|
defaultOptions
|
|
{ fieldLabelModifier = let
|
|
nameMap "username" = "user"
|
|
nameMap "password" = "pass"
|
|
nameMap x = x
|
|
in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel
|
|
}
|
|
''SmtpAuthConf
|
|
|
|
deriveFromJSON
|
|
defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
}
|
|
''Address
|
|
|
|
|
|
instance FromJSON AppSettings where
|
|
parseJSON = withObject "AppSettings" $ \o -> do
|
|
let defaultDev =
|
|
#ifdef DEVELOPMENT
|
|
True
|
|
#else
|
|
False
|
|
#endif
|
|
appStaticDir <- o .: "static-dir"
|
|
appDatabaseConf <- o .: "database"
|
|
let nonEmptyHost LdapConf{..} = case ldapHost of
|
|
Ldap.Tls host _ -> not $ null host
|
|
Ldap.Plain host -> not $ null host
|
|
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
|
|
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
|
appRoot <- o .:? "approot"
|
|
appHost <- fromString <$> o .: "host"
|
|
appPort <- o .: "port"
|
|
appIpFromHeader <- o .: "ip-from-header"
|
|
|
|
appMailFrom <- o .: "mail-from"
|
|
appMailObjectDomain <- o .: "mail-object-domain"
|
|
appMailVerp <- o .: "mail-verp"
|
|
appMailSupport <- o .: "mail-support"
|
|
|
|
appJobWorkers <- o .: "job-workers"
|
|
appJobFlushInterval <- o .:? "job-flush-interval"
|
|
appJobCronInterval <- o .: "job-cron-interval"
|
|
appJobStaleThreshold <- o .: "job-stale-threshold"
|
|
appNotificationRateLimit <- o .: "notification-rate-limit"
|
|
appNotificationCollateDelay <- o .: "notification-collate-delay"
|
|
appNotificationExpiration <- o .: "notification-expiration"
|
|
|
|
appSessionTimeout <- o .: "session-timeout"
|
|
|
|
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
|
|
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
|
|
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
|
|
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
|
|
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
|
|
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
|
|
|
|
appInitialLogSettings <- o .: "log-settings"
|
|
|
|
appUserDefaults <- o .: "user-defaults"
|
|
appAuthPWHash <- o .: "auth-pw-hash"
|
|
|
|
appInitialInstanceID <- (o .:? "instance-id") >>= maybe (return Nothing) (\v -> Just <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v)))
|
|
|
|
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
|