diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..7d9172652 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 72ae6a7c4..05725f0bf 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index e3fcc6105..96a5eb4da 100644 --- a/src/Settings.hs +++ b/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