875 lines
34 KiB
Haskell
875 lines
34 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.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.Mime
|
||
, module Settings.Cookies
|
||
, module Settings.Log
|
||
, module Settings.Locale
|
||
) 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 Data.Word (Word16)
|
||
|
||
import qualified Data.Text as Text
|
||
import qualified Data.Text.Encoding 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.Mime
|
||
import Settings.Cookies
|
||
import Settings.Log
|
||
import Settings.Locale
|
||
|
||
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
|
||
|
||
|
||
-- | 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
|
||
, appLdapConf :: Maybe (PointedList LdapConf)
|
||
-- ^ 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
|
||
|
||
, appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
|
||
, appSynchroniseLdapUsersInterval :: NominalDiffTime
|
||
|
||
, appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime
|
||
, appSynchroniseAvsUsersInterval :: NominalDiffTime
|
||
|
||
, appLdapReTestFailover :: DiffTime
|
||
|
||
, 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
|
||
|
||
, appQualificationCheckHour :: Maybe Natural
|
||
|
||
, appFileSourceARCConf :: Maybe (ARCConf Int)
|
||
, appFileSourcePrewarmConf :: Maybe PrewarmCacheConf
|
||
|
||
, appBotMitigations :: Set SettingBotMitigation
|
||
|
||
, appVolatileClusterSettingsCacheTime :: DiffTime
|
||
|
||
, appJobMaxFlush :: Maybe Natural
|
||
|
||
, appCommunicationAttachmentsMaxSize :: Maybe Natural
|
||
|
||
, appFileChunkingParams :: FastCDCParameters
|
||
|
||
, appLegalExternal :: Set LegalExternal
|
||
|
||
} deriving Show
|
||
|
||
|
||
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 LdapConf = LdapConf
|
||
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
|
||
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
|
||
, ldapBase :: Ldap.Dn
|
||
, ldapScope :: Ldap.Scope
|
||
, ldapTimeout :: NominalDiffTime
|
||
, ldapSearchTimeout :: Int32
|
||
, ldapPool :: ResourcePoolConf
|
||
} 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 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)
|
||
|
||
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 ''Ldap.Scope
|
||
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
|
||
|
||
|
||
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
|
||
| spec == "none" -> return Nothing
|
||
| spec == "notls" -> return Nothing
|
||
| 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"
|
||
ldapSearchTimeout <- o .: "search-timeout"
|
||
ldapPool <- o .: "pool"
|
||
return LdapConf{..}
|
||
|
||
deriveFromJSON
|
||
defaultOptions
|
||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||
}
|
||
''ResourcePoolConf
|
||
|
||
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{..}
|
||
|
||
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 LdapConf{..} = case ldapHost of
|
||
Ldap.Tls host _ -> not $ null host
|
||
Ldap.Plain host -> not $ null host
|
||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||
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"
|
||
|
||
appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
|
||
appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval"
|
||
|
||
appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within"
|
||
appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval"
|
||
|
||
appLdapReTestFailover <- o .: "ldap-re-test-failover"
|
||
|
||
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"
|
||
|
||
appQualificationCheckHour <- o .:? "qualification-check-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"
|
||
|
||
appLegalExternal <- o .: "legal-external"
|
||
|
||
return AppSettings{..}
|
||
where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
|
||
|
||
makeClassy_ ''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
|
||
|
||
|
||
submissionBlacklist :: [Pattern]
|
||
submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist")
|
||
|
||
personalisedSheetFilesCollatable :: Map Text Pattern
|
||
personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate")
|
||
|
||
-- The rest of this file contains settings which rarely need changing by a
|
||
-- user.
|
||
|
||
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
|
||
|
||
-- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile)
|
||
-- hamletFile' :: FilePath -> Q Exp
|
||
-- hamletFile' nameBase = hamletFile $ "templates" </> nameBase
|
||
|
||
|
||
-- | 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
|