chore(settings): restructure Settings.hs; add OAuthConf to AppSettings
This commit is contained in:
Sarah Vaupel
parent
2356bf80a5
commit
3e9e90ed86
@ -105,7 +105,7 @@ import Handler.Utils.Routes (classifyHandler)
|
||||
import qualified Data.Acid.Memory as Acid
|
||||
import qualified Web.ServerSession.Backend.Acid as Acid
|
||||
|
||||
import qualified Ldap.Client as Ldap (Host(Plain, Tls))
|
||||
-- import qualified Ldap.Client as Ldap (Host(Plain, Tls))
|
||||
|
||||
import qualified Network.Minio as Minio
|
||||
|
||||
@ -290,13 +290,13 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
|
||||
void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
|
||||
|
||||
ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
|
||||
let ldapLabel = case ldapHost of
|
||||
Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
|
||||
Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
|
||||
$logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
|
||||
(ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
forM_ ldapPool $ registerFailoverMetrics "ldap"
|
||||
-- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
|
||||
-- let ldapLabel = case ldapHost of
|
||||
-- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
|
||||
-- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
|
||||
-- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
|
||||
-- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
-- forM_ ldapPool $ registerFailoverMetrics "ldap"
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
flip runReaderT tempFoundation $
|
||||
@ -376,7 +376,8 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
|
||||
$logDebugS "Runtime configuration" $ tshowCrop appSettings'
|
||||
|
||||
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
|
||||
-- TODO: reimplement user db failover
|
||||
let foundation = mkFoundation appSettings' sqlPool smtpPool Nothing appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
|
||||
|
||||
-- Return the foundation
|
||||
$logInfoS "setup" "*** DONE ***"
|
||||
@ -615,6 +616,8 @@ appMain = runResourceT $ do
|
||||
foundation <- makeFoundation settings
|
||||
|
||||
runAppLoggingT foundation $ do
|
||||
$logErrorS "AppSettings" $ tshow settings
|
||||
|
||||
$logInfoS "setup" "Job-Handling"
|
||||
handleJobs foundation
|
||||
|
||||
|
||||
@ -310,7 +310,8 @@ determineCrontab = execWriterT $ do
|
||||
return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
|
||||
|
||||
if
|
||||
| is _Just appLdapConf
|
||||
-- TODO: generalize user sync job to oauth
|
||||
| is _Just appUserDbConf
|
||||
, Just syncWithin <- appSynchroniseLdapUsersWithin
|
||||
, Just cInterval <- appJobCronInterval
|
||||
-> do
|
||||
|
||||
803
src/Settings.hs
803
src/Settings.hs
@ -84,6 +84,392 @@ 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 ResourcePoolConf = ResourcePoolConf
|
||||
{ poolStripes :: Int
|
||||
, poolTimeout :: NominalDiffTime
|
||||
, poolLimit :: Int
|
||||
} deriving (Show)
|
||||
|
||||
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)
|
||||
|
||||
makeLenses_ ''LdapConf
|
||||
|
||||
-- TODO: use better types
|
||||
data OAuthConf = OAuthConf
|
||||
{ oauthClientId :: Text
|
||||
, oauthCientSecret :: Text
|
||||
, oauthTenantId :: Text
|
||||
, oauthScopes :: Set Text
|
||||
} deriving (Show)
|
||||
|
||||
makeLenses_ ''OAuthConf
|
||||
|
||||
data UserDbConf = UserDbLdap LdapConf | UserDbOAuth OAuthConf
|
||||
deriving (Show)
|
||||
|
||||
makePrisms ''UserDbConf
|
||||
|
||||
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 ''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
|
||||
|
||||
|
||||
deriveFromJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
} ''ResourcePoolConf
|
||||
|
||||
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 = camelToPathPiece' 1
|
||||
} ''OAuthConf
|
||||
|
||||
deriveFromJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, sumEncoding = TaggedObject "type" "config"
|
||||
} ''UserDbConf
|
||||
|
||||
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.
|
||||
@ -96,7 +482,7 @@ data AppSettings = AppSettings
|
||||
, appDatabaseConf :: PostgresConf
|
||||
-- ^ Configuration settings for accessing the database.
|
||||
, appAutoDbMigrate :: Bool
|
||||
, appLdapConf :: Maybe (PointedList LdapConf)
|
||||
, appUserDbConf :: Maybe (PointedList UserDbConf)
|
||||
-- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
|
||||
, appLmsConf :: LmsConf
|
||||
-- ^ Configuration settings for accessing the LDAP-directory
|
||||
@ -254,365 +640,6 @@ data AppSettings = AppSettings
|
||||
|
||||
} 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 =
|
||||
@ -627,10 +654,11 @@ instance FromJSON AppSettings where
|
||||
appWebpackEntrypoints <- o .: "webpack-manifest"
|
||||
appDatabaseConf <- o .: "database"
|
||||
appAutoDbMigrate <- o .: "auto-db-migrate"
|
||||
let nonEmptyHost LdapConf{..} = case ldapHost of
|
||||
let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
nonEmptyHost (UserDbOAuth OAuthConf{..}) = not $ or [ null oauthTenantId, null oauthClientId, null oauthCientSecret ]
|
||||
appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-db" .!= []
|
||||
appLmsConf <- o .: "lms-direct"
|
||||
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
|
||||
appLprConf <- o .: "lpr"
|
||||
@ -816,6 +844,26 @@ instance FromJSON AppSettings where
|
||||
|
||||
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.
|
||||
--
|
||||
@ -825,16 +873,6 @@ makeClassy_ ''AppSettings
|
||||
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
|
||||
@ -855,24 +893,3 @@ widgetFile
|
||||
| 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
|
||||
|
||||
Reference in New Issue
Block a user