875 lines
36 KiB
Haskell
875 lines
36 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||
--
|
||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- memcached-binary requires bump
|
||
|
||
-- | 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
|
||
, module Settings.Cookies
|
||
, module Settings.Ldap
|
||
, module Settings.Log
|
||
, module Settings.Locale
|
||
, module Settings.Mime
|
||
, module Settings.OAuth2
|
||
, module Settings.ResourcePool
|
||
) where
|
||
|
||
import Import.NoModel
|
||
import qualified Control.Exception as Exception
|
||
import Data.Aeson (fromJSON, withObject, withScientific
|
||
,(.!=), (.:?)
|
||
)
|
||
import qualified Data.Aeson.Types as Aeson
|
||
import Data.FileEmbed (embedFile)
|
||
import Data.Yaml (decodeEither')
|
||
import Database.Persist.Postgresql (PostgresConf)
|
||
import Network.Wai.Handler.Warp (HostPreference)
|
||
#ifdef DEVELOPMENT
|
||
import Yesod.Default.Util (WidgetFileSettings, widgetFileReload)
|
||
import Language.Haskell.TH.Syntax (Exp, Q, location, Loc(..))
|
||
|
||
import Text.Blaze.Html (preEscapedToHtml)
|
||
#else
|
||
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload)
|
||
import Language.Haskell.TH.Syntax (Exp, Q)
|
||
#endif
|
||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||
|
||
import qualified Data.Scientific as Scientific
|
||
|
||
import qualified Data.Text as Text
|
||
|
||
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
|
||
import qualified Network.Socket as HaskellNet
|
||
|
||
import Network.Mail.Mime.Instances ()
|
||
|
||
import qualified Database.Memcached.Binary.Types as Memcached
|
||
|
||
import Model
|
||
|
||
import Settings.Cluster
|
||
import Settings.Cookies
|
||
import Settings.Ldap
|
||
import Settings.Log
|
||
import Settings.Locale
|
||
import Settings.Mime
|
||
import Settings.OAuth2
|
||
import Settings.ResourcePool
|
||
|
||
import qualified System.FilePath as FilePath
|
||
|
||
import Jose.Jwt (JwtEncoding(..))
|
||
|
||
import System.FilePath.Glob
|
||
import System.FilePath.Glob.TH
|
||
|
||
import qualified Web.ServerSession.Core as ServerSession
|
||
|
||
import Text.Show (showParen, showString)
|
||
|
||
import qualified Network.Minio as Minio
|
||
|
||
import Data.Conduit.Algorithms.FastCDC
|
||
|
||
import Utils.Lens.TH
|
||
|
||
import qualified Data.Set as Set
|
||
|
||
|
||
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
|
||
| JobsOffload
|
||
| JobsDrop
|
||
{ jobsAcceptOffload :: Bool
|
||
, jobsWriteFakeLastExec :: Bool
|
||
}
|
||
deriving (Eq, Ord, Read, Show, Generic)
|
||
deriving anyclass (Hashable)
|
||
|
||
data ApprootScope = ApprootUserGenerated | ApprootDefault
|
||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||
deriving anyclass (Universe, Finite, Hashable)
|
||
|
||
|
||
newtype ServerSessionSettings
|
||
= ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
|
||
|
||
instance Show ServerSessionSettings where
|
||
showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
|
||
|
||
data UserDefaultConf = UserDefaultConf
|
||
{ userDefaultTheme :: Theme
|
||
, userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
|
||
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
|
||
, userDefaultDownloadFiles :: Bool
|
||
, userDefaultWarningDays :: NominalDiffTime
|
||
, userDefaultShowSex :: Bool
|
||
, userDefaultExamOfficeGetSynced :: Bool
|
||
, userDefaultExamOfficeGetLabels :: Bool
|
||
, userDefaultPrefersPostal :: 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 AuthSourceConf = AuthSourceConfLdap LdapConf | AuthSourceConfAzureAdV2 AzureConf
|
||
deriving (Show)
|
||
|
||
newtype UserAuthConf =
|
||
UserAuthConfSingleSource -- ^ use only one specific source
|
||
{ userAuthConfSingleSource :: AuthSourceConf
|
||
}
|
||
-- TODO: other modes yet to be implemented
|
||
-- | UserAuthConfFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
|
||
-- { userAuthConfFailoverSources :: PointedList UserSource
|
||
-- , userAuthConfFailoverRetest :: NominalDiffTime
|
||
-- }
|
||
-- | UserAuthConfMultiSource -- ^ Multiple coequal user sources
|
||
-- { userAuthConfMultiSources :: Set UserSource
|
||
-- }
|
||
-- | UserAuthConfNoSource -- ^ allow no external sources at all -- TODO: either this, or make user-auth in settings.yml optional
|
||
deriving (Show)
|
||
|
||
mkAuthSourceIdent :: AuthSourceConf -> AuthSourceIdent
|
||
mkAuthSourceIdent = \case
|
||
AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfClientId
|
||
AuthSourceConfLdap LdapConf{..} -> AuthSourceIdLdap ldapConfSourceId
|
||
|
||
data LmsConf = LmsConf
|
||
{ lmsUploadHeader :: Bool
|
||
, lmsUploadDelimiter :: Maybe Char
|
||
, lmsDownloadHeader :: Bool
|
||
, lmsDownloadDelimiter :: Char
|
||
, lmsDownloadCrLf :: Bool
|
||
, lmsDeletionDays :: Int
|
||
} deriving (Show)
|
||
|
||
data AvsConf = AvsConf
|
||
{ avsHost :: String
|
||
, avsPort :: Int
|
||
, avsUser :: ByteString
|
||
, avsPass :: ByteString
|
||
} deriving (Show)
|
||
|
||
data LprConf = LprConf
|
||
{ lprHost :: String
|
||
, lprPort :: Int
|
||
, lprQueue:: String
|
||
} deriving (Show)
|
||
|
||
data SmtpConf = SmtpConf
|
||
{ smtpHost :: HaskellNet.HostName
|
||
, smtpPort :: HaskellNet.PortNumber
|
||
, smtpAuth :: Maybe SmtpAuthConf
|
||
, smtpSsl :: SmtpSslMode
|
||
, smtpPool :: ResourcePoolConf
|
||
} deriving (Show)
|
||
|
||
data WidgetMemcachedConf = WidgetMemcachedConf
|
||
{ widgetMemcachedConf :: MemcachedConf
|
||
, widgetMemcachedBaseUrl :: Text
|
||
} deriving (Show)
|
||
|
||
data MemcachedConf = MemcachedConf
|
||
{ memcachedConnectInfo :: Memcached.ConnectInfo
|
||
, memcachedExpiry :: Maybe NominalDiffTime
|
||
} deriving (Show)
|
||
|
||
instance FromJSON Memcached.Auth where
|
||
parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
|
||
|
||
instance FromJSON MemcachedConf where
|
||
parseJSON = withObject "MemcachedConf" $ \o -> do
|
||
connectHost <- o .:? "host" .!= ""
|
||
connectPort <- o .: "port"
|
||
connectAuth <- o .: "auth"
|
||
numConnection <- o .: "limit"
|
||
connectionIdleTime <- o .: "timeout"
|
||
memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
|
||
|
||
return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
|
||
|
||
instance FromJSON WidgetMemcachedConf where
|
||
parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
|
||
widgetMemcachedConf <- parseJSON v
|
||
widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
|
||
return WidgetMemcachedConf{..}
|
||
|
||
data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
|
||
deriving (Show)
|
||
|
||
data SmtpAuthConf = SmtpAuthConf
|
||
{ smtpAuthType :: HaskellNet.AuthType
|
||
, smtpAuthUsername :: HaskellNet.UserName
|
||
, smtpAuthPassword :: HaskellNet.Password
|
||
} deriving (Show)
|
||
|
||
data TokenBucketConf = TokenBucketConf
|
||
{ tokenBucketDepth :: Word64
|
||
, tokenBucketInvRate :: NominalDiffTime
|
||
, tokenBucketInitialValue :: Int64
|
||
} deriving (Eq, Ord, Show, Generic)
|
||
|
||
data VerpMode = VerpNone
|
||
| Verp { verpPrefix :: Text, verpSeparator :: Char }
|
||
deriving (Eq, Show, Read, Generic)
|
||
|
||
data ARCConf w = ARCConf
|
||
{ arccMaximumGhost :: Int
|
||
, arccMaximumWeight :: w
|
||
} deriving (Eq, Ord, Read, Show, Generic)
|
||
|
||
data PrewarmCacheConf = PrewarmCacheConf
|
||
{ precMaximumWeight :: Int
|
||
, precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
|
||
, precSteps :: Natural
|
||
, precMaxSpeedup :: Rational
|
||
} deriving (Eq, Ord, Read, Show, Generic)
|
||
|
||
data SettingBotMitigation
|
||
= SettingBotMitigationOnlyLoggedInTableSorting
|
||
| SettingBotMitigationUnauthorizedFormHoneypots
|
||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||
deriving anyclass (Universe, Finite)
|
||
|
||
data LegalExternal = LegalExternal
|
||
{ externalLanguage :: Lang
|
||
, externalImprint :: Text
|
||
, externalDataProtection :: Text
|
||
, externalTermsOfUse :: Text
|
||
, externalPayments :: Text
|
||
}
|
||
deriving (Eq, Ord, Read, Show, Generic)
|
||
makeLenses_ ''LegalExternal
|
||
|
||
|
||
nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
|
||
pathPieceJSON ''ApprootScope
|
||
pathPieceJSONKey ''ApprootScope
|
||
pathPieceBinary ''ApprootScope
|
||
pathPieceHttpApiData ''ApprootScope
|
||
|
||
deriveJSON defaultOptions
|
||
{ constructorTagModifier = camelToPathPiece' 1
|
||
, fieldLabelModifier = camelToPathPiece' 1
|
||
, sumEncoding = UntaggedValue
|
||
} ''VerpMode
|
||
|
||
deriveJSON defaultOptions
|
||
{ fieldLabelModifier = camelToPathPiece' 2
|
||
} ''TokenBucketConf
|
||
|
||
deriveFromJSON defaultOptions
|
||
{ fieldLabelModifier = camelToPathPiece' 2
|
||
} ''UserDefaultConf
|
||
|
||
deriveJSON defaultOptions
|
||
{ fieldLabelModifier = camelToPathPiece' 1
|
||
, constructorTagModifier = camelToPathPiece' 1
|
||
} ''JobMode
|
||
|
||
deriveJSON defaultOptions
|
||
{ fieldLabelModifier = camelToPathPiece' 1
|
||
} ''ARCConf
|
||
|
||
deriveJSON defaultOptions
|
||
{ fieldLabelModifier = camelToPathPiece' 1
|
||
} ''PrewarmCacheConf
|
||
|
||
makeLenses_ ''PrewarmCacheConf
|
||
|
||
nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3
|
||
pathPieceJSON ''SettingBotMitigation
|
||
pathPieceJSONKey ''SettingBotMitigation
|
||
|
||
makePrisms ''JobMode
|
||
makeLenses_ ''JobMode
|
||
|
||
makePrisms ''AuthSourceConf
|
||
makeLenses_ ''UserAuthConf
|
||
makePrisms ''UserAuthConf
|
||
|
||
deriveFromJSON defaultOptions
|
||
{ constructorTagModifier = toLower . dropPrefix "AuthSourceConf"
|
||
, sumEncoding = TaggedObject "protocol" "config"
|
||
} ''AuthSourceConf
|
||
|
||
deriveFromJSON defaultOptions
|
||
{ constructorTagModifier = camelToPathPiece' 3
|
||
, fieldLabelModifier = camelToPathPiece' 3
|
||
, sumEncoding = UntaggedValue -- TaggedObject "mode" "config"
|
||
, unwrapUnaryRecords = True
|
||
} ''UserAuthConf
|
||
|
||
instance FromJSON HaskellNet.PortNumber where
|
||
parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.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 LmsConf where
|
||
parseJSON = withObject "LmsConf" $ \o -> do
|
||
lmsUploadHeader <- o .: "upload-header"
|
||
lmsUploadDelimiter <- o .:? "upload-delimiter"
|
||
lmsDownloadHeader <- o .: "download-header"
|
||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||
lmsDownloadCrLf <- o .: "download-cr-lf"
|
||
lmsDeletionDays <- o .: "deletion-days"
|
||
return LmsConf{..}
|
||
|
||
makeLenses_ ''LmsConf
|
||
|
||
instance FromJSON AvsConf where
|
||
parseJSON = withObject "AvsConf" $ \o -> do
|
||
avsHost <- o .: "host"
|
||
avsPort <- o .: "port"
|
||
avsUser <- o .: "user"
|
||
avsPass <- o .:? "pass" .!= ""
|
||
return AvsConf{..}
|
||
|
||
instance FromJSON LprConf where
|
||
parseJSON = withObject "LprConf" $ \o -> do
|
||
lprHost <- o .: "host"
|
||
lprPort <- o .: "port"
|
||
lprQueue <- o .: "queue"
|
||
return LprConf{..}
|
||
|
||
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
|
||
|
||
instance FromJSON SmtpAuthConf where
|
||
parseJSON = withObject "SmtpAuthConf" $ \o -> do
|
||
smtpAuthType <- o .: "type"
|
||
smtpAuthUsername <- o .:? "user" .!= ""
|
||
smtpAuthPassword <- o .:? "pass" .!= ""
|
||
return SmtpAuthConf{..}
|
||
|
||
instance FromJSON JwtEncoding where
|
||
parseJSON v@(String _) = JwsEncoding <$> parseJSON v
|
||
parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
|
||
[ do
|
||
alg <- obj .: "alg"
|
||
return $ JwsEncoding alg
|
||
, do
|
||
alg <- obj .: "alg"
|
||
enc <- obj .: "enc"
|
||
return $ JweEncoding alg enc
|
||
]
|
||
|
||
instance FromJSON Minio.ConnectInfo where
|
||
parseJSON v@(String _) = fromString <$> parseJSON v
|
||
parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do
|
||
connectHost <- o .:? "host" .!= ""
|
||
connectPort <- o .: "port"
|
||
connectAccessKey <- o .:? "access-key" .!= ""
|
||
connectSecretKey <- o .:? "secret-key" .!= ""
|
||
connectIsSecure <- o .: "is-secure"
|
||
connectRegion <- o .:? "region" .!= ""
|
||
connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True
|
||
connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False
|
||
return Minio.ConnectInfo{..}
|
||
|
||
instance FromJSON ServerSessionSettings where
|
||
parseJSON = withObject "ServerSession.State" $ \o -> do
|
||
idleTimeout <- o .:? "idle-timeout"
|
||
absoluteTimeout <- o .:? "absolute-timeout"
|
||
timeoutResolution <- o .:? "timeout-resolution"
|
||
persistentCookies <- o .:? "persistent-cookies"
|
||
return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
|
||
[ pure $ ServerSession.setIdleTimeout idleTimeout
|
||
, pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
|
||
, pure $ ServerSession.setTimeoutResolution timeoutResolution
|
||
, ServerSession.setPersistentCookies <$> persistentCookies
|
||
])
|
||
|
||
instance FromJSON LegalExternal where
|
||
parseJSON = withObject "LegalExternal" $ \o -> do
|
||
externalLanguage <- o .: "language"
|
||
externalImprint <- o .: "imprint"
|
||
externalDataProtection <- o .: "data-protection"
|
||
externalTermsOfUse<- o .: "terms-of-use"
|
||
externalPayments <- o .: "payments"
|
||
return LegalExternal{..}
|
||
|
||
submissionBlacklist :: [Pattern]
|
||
submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist")
|
||
|
||
personalisedSheetFilesCollatable :: Map Text Pattern
|
||
personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate")
|
||
|
||
|
||
-- | 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 :: FilePath
|
||
-- ^ Directory from which to serve static files.
|
||
, appWebpackEntrypoints :: FilePath
|
||
, appWellKnownDir :: FilePath
|
||
, appWellKnownLinkFile :: FilePath
|
||
, appDatabaseConf :: PostgresConf
|
||
-- ^ Configuration settings for accessing the database.
|
||
, appAutoDbMigrate :: Bool
|
||
, appUserAuthConf :: UserAuthConf
|
||
, appSingleSignOn :: Bool
|
||
-- ^ Enable OIDC single sign-on
|
||
, appAutoSignOn :: Bool
|
||
-- ^ Automatically redirect to SSO route when not signed on
|
||
-- ^ Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials!
|
||
, appLmsConf :: LmsConf
|
||
-- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
|
||
, appAvsConf :: Maybe AvsConf
|
||
-- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- TODO, TODISCUSS: reimplement as user-auth source?
|
||
, appLprConf :: LprConf
|
||
-- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
|
||
, appSmtpConf :: Maybe SmtpConf
|
||
-- ^ Configuration settings for accessing a SMTP Mailserver
|
||
, appWidgetMemcachedConf :: Maybe WidgetMemcachedConf
|
||
-- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
|
||
, appRoot :: ApprootScope -> 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.
|
||
|
||
, appServerSessionConfig :: ServerSessionSettings
|
||
, appServerSessionAcidFallback :: Bool
|
||
, appSessionMemcachedConf :: Maybe MemcachedConf
|
||
, appSessionTokenStart
|
||
, appSessionTokenExpiration :: Maybe NominalDiffTime
|
||
, appSessionTokenEncoding :: JwtEncoding
|
||
, appSessionTokenClockLeniencyStart, appSessionTokenClockLeniencyEnd
|
||
, appBearerTokenClockLeniencyStart, appBearerTokenClockLeniencyEnd
|
||
, appUploadTokenClockLeniencyStart, appUploadTokenClockLeniencyEnd :: Maybe NominalDiffTime
|
||
|
||
, appMailObjectDomain :: Text
|
||
, appMailVerp :: VerpMode
|
||
, appMailRetainSent :: Maybe NominalDiffTime
|
||
, appMailEnvelopeFrom :: Text
|
||
, appMailFrom
|
||
, appMailSender
|
||
, appMailSupport :: Address
|
||
, appMailRerouteTo :: Maybe Address
|
||
, appMailUseReplyToInstead :: Bool
|
||
, appJobWorkers :: Natural
|
||
, appJobFlushInterval :: Maybe NominalDiffTime
|
||
, appJobCronInterval :: Maybe NominalDiffTime
|
||
, appJobStaleThreshold :: NominalDiffTime
|
||
, appJobMoveThreshold :: Maybe DiffTime
|
||
, appNotificationRateLimit :: NominalDiffTime
|
||
, appNotificationCollateDelay :: NominalDiffTime
|
||
, appNotificationExpiration :: NominalDiffTime
|
||
, appSessionTimeout :: NominalDiffTime
|
||
, appMaximumContentLength :: Maybe Word64
|
||
, appBearerExpiration :: Maybe NominalDiffTime
|
||
, appBearerEncoding :: JwtEncoding
|
||
|
||
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
|
||
, appHealthCheckDelayNotify :: Bool
|
||
, appHealthCheckHTTP :: Bool
|
||
|
||
, appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
|
||
, appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime
|
||
, appHealthCheckSMTPConnectTimeout :: NominalDiffTime
|
||
, appHealthCheckLDAPAdminsTimeout :: NominalDiffTime -- TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
|
||
, appHealthCheckHTTPReachableTimeout :: NominalDiffTime
|
||
, appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime
|
||
|
||
-- , appUserRetestFailover :: DiffTime -- TODO: reintroduce and move into failover settings once failover mode has been reimplemented
|
||
-- TODO; maybe implement syncWithin and syncInterval per auth source
|
||
, appUserSyncWithin :: Maybe NominalDiffTime
|
||
, appUserSyncInterval :: NominalDiffTime
|
||
|
||
, appLdapPoolConf :: Maybe ResourcePoolConf -- TODO: generalize for arbitrary auth protocols
|
||
-- TODO: maybe use separate pools for external databases?
|
||
|
||
, appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime
|
||
, appSynchroniseAvsUsersInterval :: NominalDiffTime
|
||
|
||
, appSessionFilesExpire :: NominalDiffTime
|
||
, appKeepUnreferencedFiles :: NominalDiffTime
|
||
|
||
, appPruneUnreferencedFilesWithin :: Maybe NominalDiffTime
|
||
, appPruneUnreferencedFilesInterval :: NominalDiffTime
|
||
|
||
, appInitialLogSettings :: LogSettings
|
||
|
||
, appTransactionLogIPRetentionTime :: NominalDiffTime
|
||
|
||
, 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
|
||
, appClearCache :: Bool
|
||
|
||
, appUserDefaults :: UserDefaultConf
|
||
, appAuthPWHash :: PWHashConf
|
||
|
||
, appExternalApisPingInterval
|
||
, appExternalApisPongTimeout
|
||
, appExternalApisExpiry :: NominalDiffTime
|
||
|
||
, appCookieSettings :: RegisteredCookie -> CookieSettings
|
||
|
||
, appMemcachedConf :: Maybe MemcachedConf
|
||
, appMemcacheAuth :: Bool
|
||
, appMemcachedLocalConf :: Maybe (ARCConf Int)
|
||
|
||
, appUploadCacheConf :: Maybe Minio.ConnectInfo
|
||
, appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket
|
||
, appInjectFiles :: Maybe NominalDiffTime
|
||
, appRechunkFiles :: Maybe NominalDiffTime
|
||
, appCheckMissingFiles :: Maybe NominalDiffTime
|
||
, appFileUploadDBChunksize :: Int
|
||
|
||
|
||
, appFavouritesQuickActionsBurstsize
|
||
, appFavouritesQuickActionsAvgInverseRate :: Word64
|
||
, appFavouritesQuickActionsTimeout :: DiffTime
|
||
, appFavouritesQuickActionsCacheTTL :: Maybe DiffTime
|
||
|
||
, appPersistentTokenBuckets :: TokenBucketIdent -> TokenBucketConf
|
||
|
||
, appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime
|
||
|
||
, appDownloadTokenExpire :: NominalDiffTime
|
||
|
||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||
, appRibbon :: Maybe Text
|
||
|
||
, appJobMode :: JobMode
|
||
|
||
, appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime
|
||
, appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime
|
||
|
||
, appJobLmsQualificationsEnqueueHour :: Maybe Natural
|
||
, appJobLmsQualificationsDequeueHour :: Maybe Natural
|
||
|
||
, appFileSourceARCConf :: Maybe (ARCConf Int)
|
||
, appFileSourcePrewarmConf :: Maybe PrewarmCacheConf
|
||
|
||
, appBotMitigations :: Set SettingBotMitigation
|
||
|
||
, appVolatileClusterSettingsCacheTime :: DiffTime
|
||
|
||
, appJobMaxFlush :: Maybe Natural
|
||
|
||
, appCommunicationAttachmentsMaxSize :: Maybe Natural
|
||
, appCommunicationGlobalCC :: Maybe UserEmail
|
||
|
||
, appFileChunkingParams :: FastCDCParameters
|
||
|
||
, appLegalExternal :: Set LegalExternal
|
||
|
||
} deriving Show
|
||
|
||
instance FromJSON AppSettings where
|
||
parseJSON = withObject "AppSettings" $ \o -> do
|
||
let defaultDev =
|
||
#ifdef DEVELOPMENT
|
||
True
|
||
#else
|
||
False
|
||
#endif
|
||
appStaticDir <- o .: "static-dir"
|
||
appWellKnownDir <- o .: "well-known-dir"
|
||
appWellKnownLinkFile <- o .: "well-known-link-file"
|
||
appWebpackEntrypoints <- o .: "webpack-manifest"
|
||
appDatabaseConf <- o .: "database"
|
||
appAutoDbMigrate <- o .: "auto-db-migrate"
|
||
-- TODO: reintroduce non-emptyness check for ldap hosts
|
||
-- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
|
||
-- Ldap.Tls host _ -> not $ null host
|
||
-- Ldap.Plain host -> not $ null host
|
||
-- nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
|
||
appUserAuthConf <- o .: "user-auth"
|
||
-- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
|
||
appLdapPoolConf <- o .:? "ldap-pool"
|
||
appSingleSignOn <- o .:? "single-sign-on" .!= False
|
||
appAutoSignOn <- o .:? "auto-sign-on" .!= False
|
||
appLmsConf <- o .: "lms-direct"
|
||
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
|
||
appLprConf <- o .: "lpr"
|
||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
|
||
[ not $ null connectHost
|
||
, numConnection > 0
|
||
, connectionIdleTime >= 0
|
||
]
|
||
validWidgetMemcachedConf WidgetMemcachedConf{..} = and
|
||
[ not $ null widgetMemcachedBaseUrl
|
||
, validMemcachedConf widgetMemcachedConf
|
||
]
|
||
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
|
||
appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
|
||
appRoot <- o .:? "approot" .!= const Nothing
|
||
appHost <- fromString <$> o .: "host"
|
||
appPort <- o .: "port"
|
||
appIpFromHeader <- o .: "ip-from-header"
|
||
|
||
appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
|
||
appMemcacheAuth <- o .:? "memcache-auth" .!= False
|
||
appMemcachedLocalConf <- assertM isValidARCConf <$> o .:? "memcached-local"
|
||
|
||
appMailFrom <- o .: "mail-from"
|
||
appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
|
||
appMailSender <- o .:? "mail-sender" .!= appMailFrom
|
||
appMailObjectDomain <- o .: "mail-object-domain"
|
||
appMailUseReplyToInstead <- o .: "mail-use-replyto-instead-sender" .!= True
|
||
|
||
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
|
||
appMailRetainSent <- o .: "mail-retain-sent"
|
||
appMailSupport <- o .: "mail-support"
|
||
appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing)
|
||
|
||
appJobWorkers <- o .: "job-workers"
|
||
appJobFlushInterval <- o .:? "job-flush-interval"
|
||
appJobCronInterval <- o .:? "job-cron-interval"
|
||
appJobStaleThreshold <- o .: "job-stale-threshold"
|
||
appJobMoveThreshold <- o .:? "job-move-threshold"
|
||
appNotificationRateLimit <- o .: "notification-rate-limit"
|
||
appNotificationCollateDelay <- o .: "notification-collate-delay"
|
||
appNotificationExpiration <- o .: "notification-expiration"
|
||
appBearerExpiration <- o .:? "bearer-expiration"
|
||
appBearerEncoding <- o .: "bearer-encoding"
|
||
|
||
appJobMode <- o .:? "job-mode" .!= JobsLocal True
|
||
|
||
let hciOverride :: HealthCheck -> Maybe NominalDiffTime -> Maybe NominalDiffTime
|
||
hciOverride HealthCheckDoesFlush _ | is _JobsOffload appJobMode = Nothing
|
||
hciOverride _ mInterval = mInterval
|
||
appHealthCheckInterval <- (\f hc -> hciOverride hc . assertM' (> 0) $ f hc) <$> o .: "health-check-interval"
|
||
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
|
||
appHealthCheckHTTP <- o .: "health-check-http"
|
||
|
||
appHealthCheckActiveJobExecutorsTimeout <- o .: "health-check-active-job-executors-timeout"
|
||
appHealthCheckActiveWidgetMemcachedTimeout <- o .: "health-check-active-widget-memcached-timeout"
|
||
appHealthCheckSMTPConnectTimeout <- o .: "health-check-smtp-connect-timeout"
|
||
appHealthCheckLDAPAdminsTimeout <- o .: "health-check-ldap-admins-timeout"
|
||
appHealthCheckHTTPReachableTimeout <- o .: "health-check-http-reachable-timeout"
|
||
appHealthCheckMatchingClusterConfigTimeout <- o .: "health-check-matching-cluster-config-timeout"
|
||
|
||
appSessionTimeout <- o .: "session-timeout"
|
||
|
||
-- appUserRetestFailover <- o .: "userdb-retest-failover"
|
||
appUserSyncWithin <- o .:? "user-sync-within"
|
||
appUserSyncInterval <- o .: "user-sync-interval"
|
||
|
||
appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within"
|
||
appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval"
|
||
|
||
appSessionFilesExpire <- o .: "session-files-expire"
|
||
appKeepUnreferencedFiles <- o .:? "keep-unreferenced-files" .!= 0
|
||
appInjectFiles <- o .:? "inject-files"
|
||
appRechunkFiles <- o .:? "rechunk-files"
|
||
appCheckMissingFiles <- o .:? "check-missing-files"
|
||
appFileUploadDBChunksize <- o .: "file-upload-db-chunksize"
|
||
|
||
appFileChunkingTargetExponent <- o .: "file-chunking-target-exponent"
|
||
appFileChunkingHashWindow <- o .: "file-chunking-hash-window"
|
||
appFileChunkingParams <- maybe (fail "Could not recommend FastCDCParameters") return $ recommendFastCDCParameters appFileChunkingTargetExponent appFileChunkingHashWindow
|
||
|
||
appPruneUnreferencedFilesWithin <- o .:? "prune-unreferenced-files-within"
|
||
appPruneUnreferencedFilesInterval <- o .: "prune-unreferenced-files-interval"
|
||
|
||
appMaximumContentLength <- o .: "maximum-content-length"
|
||
|
||
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
|
||
appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
|
||
appClearCache <- o .:? "clear-cache" .!= defaultDev
|
||
|
||
appInitialLogSettings <- o .: "log-settings"
|
||
|
||
appTransactionLogIPRetentionTime <- o .: "ip-retention-time"
|
||
|
||
appUserDefaults <- o .: "user-defaults"
|
||
appAuthPWHash <- o .: "auth-pw-hash"
|
||
|
||
appInitialInstanceID <- runMaybeT $ do
|
||
val <- MaybeT (o .:? "instance-id")
|
||
val' <- lift $ (Right <$> parseJSON val) <|> (Left <$> parseJSON val)
|
||
case val' of
|
||
Left fp -> guard $ FilePath.isValid fp
|
||
_ -> return ()
|
||
return val'
|
||
|
||
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
|
||
|
||
appCookieSettings <- o .: "cookies"
|
||
|
||
appServerSessionConfig' <- o .: "server-sessions"
|
||
let appServerSessionConfig = ServerSessionSettings $ httpOnlyCookie . secureCookie . applyServerSessionSettings appServerSessionConfig'
|
||
where httpOnlyCookie :: forall a. ServerSession.State a -> ServerSession.State a
|
||
httpOnlyCookie = maybe id ServerSession.setHttpOnlyCookies . cookieHttpOnly $ appCookieSettings CookieSession
|
||
secureCookie :: forall a. ServerSession.State a -> ServerSession.State a
|
||
secureCookie = maybe id ServerSession.setSecureCookies . cookieSecure $ appCookieSettings CookieSession
|
||
appSessionTokenStart <- o .:? "session-token-start"
|
||
appSessionTokenExpiration <- o .:? "session-token-expiration"
|
||
appSessionTokenEncoding <- o .: "session-token-encoding"
|
||
|
||
appExternalApisPingInterval <- o .: "external-apis-ping-interval"
|
||
appExternalApisPongTimeout <- o .: "external-apis-pong-timeout"
|
||
appExternalApisExpiry <- o .: "external-apis-expiry"
|
||
|
||
appSessionTokenClockLeniencyStart <- o .:? "session-token-clock-leniency-start"
|
||
appSessionTokenClockLeniencyEnd <- o .:? "session-token-clock-leniency-end"
|
||
appBearerTokenClockLeniencyStart <- o .:? "bearer-token-clock-leniency-start"
|
||
appBearerTokenClockLeniencyEnd <- o .:? "bearer-token-clock-leniency-end"
|
||
appUploadTokenClockLeniencyStart <- o .:? "upload-token-clock-leniency-start"
|
||
appUploadTokenClockLeniencyEnd <- o .:? "upload-token-clock-leniency-end"
|
||
|
||
appFavouritesQuickActionsBurstsize <- o .: "favourites-quick-actions-burstsize"
|
||
appFavouritesQuickActionsAvgInverseRate <- o .: "favourites-quick-actions-avg-inverse-rate"
|
||
appFavouritesQuickActionsTimeout <- o .: "favourites-quick-actions-timeout"
|
||
appFavouritesQuickActionsCacheTTL <- o .: "favourites-quick-actions-cache-ttl"
|
||
|
||
appPersistentTokenBuckets <- o .: "token-buckets"
|
||
|
||
appUploadCacheConf <- assertM (not . null . Minio.connectHost) <$> o .:? "upload-cache"
|
||
appUploadCacheBucket <- o .: "upload-cache-bucket"
|
||
appUploadTmpBucket <- o .: "upload-tmp-bucket"
|
||
|
||
appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire"
|
||
|
||
appDownloadTokenExpire <- o .: "download-token-expire"
|
||
|
||
appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within"
|
||
appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval"
|
||
|
||
appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour"
|
||
appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour"
|
||
|
||
appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc"
|
||
|
||
let isValidPrewarmConf PrewarmCacheConf{..} = and
|
||
[ precMaximumWeight > 0
|
||
, precStart >= 0
|
||
, precEnd >= 0, precEnd <= precStart
|
||
, precSteps > 0
|
||
, precMaxSpeedup >= 1
|
||
]
|
||
appFileSourcePrewarmConf <- over (_Just . _precInhibit) (max 0) . assertM isValidPrewarmConf <$> o .:? "file-source-prewarm"
|
||
|
||
appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty
|
||
|
||
appVolatileClusterSettingsCacheTime <- o .: "volatile-cluster-settings-cache-time"
|
||
|
||
appJobMaxFlush <- o .:? "job-max-flush"
|
||
|
||
appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size"
|
||
appCommunicationGlobalCC <- o .:? "communication-global-cc"
|
||
|
||
appLegalExternal <- o .: "legal-external"
|
||
|
||
return AppSettings{..}
|
||
where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
|
||
|
||
makeClassy_ ''AppSettings
|
||
|
||
-- | 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
|
||
Aeson.Error e -> error e
|
||
Aeson.Success settings -> settings
|
||
|
||
-- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile)
|
||
-- hamletFile' :: FilePath -> Q Exp
|
||
-- hamletFile' nameBase = hamletFile $ "templates" </> nameBase
|
||
|
||
-- | 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
|
||
|
||
widgetFile :: String -> Q Exp
|
||
#ifdef DEVELOPMENT
|
||
widgetFile nameBase = do
|
||
Loc{..} <- location
|
||
let nameBase' = "templates" </> nameBase
|
||
before, after :: Text
|
||
before = [st|<!-- BEGIN ‘#{nameBase'}.*’ IN ‘#{loc_filename}’ #{tshow loc_start}–#{tshow loc_end} -->|]
|
||
after = [st|<!-- END ‘#{nameBase'}.*’ -->|]
|
||
[e| do
|
||
toWidget $ preEscapedToHtml before
|
||
$(widgetFileReload widgetFileSettings nameBase)
|
||
toWidget $ preEscapedToHtml after
|
||
|]
|
||
#else
|
||
widgetFile
|
||
| appReloadTemplates compileTimeAppSettings
|
||
= widgetFileReload widgetFileSettings
|
||
| otherwise
|
||
= widgetFileNoReload widgetFileSettings
|
||
#endif
|