-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost -- -- 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 Ldap.Client as Ldap 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 Data.List.PointedList as P 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) data 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) 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 -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory , appAvsConf :: Maybe AvsConf -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) , 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 , appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime -- , appUserRetestFailover :: DiffTime , appUserSyncWithin :: Maybe NominalDiffTime , appUserSyncInterval :: NominalDiffTime , appLdapPoolConf :: Maybe ResourcePoolConf , 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" -- 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" 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||] after = [st||] [e| do toWidget $ preEscapedToHtml before $(widgetFileReload widgetFileSettings nameBase) toWidget $ preEscapedToHtml after |] #else widgetFile | appReloadTemplates compileTimeAppSettings = widgetFileReload widgetFileSettings | otherwise = widgetFileNoReload widgetFileSettings #endif