chore(settings): add support for multiple modes for userdb

This commit is contained in:
Sarah Vaupel 2024-01-23 02:16:06 +01:00
parent d56c9c3c31
commit 1f31fe8cf2
3 changed files with 57 additions and 31 deletions

View File

@ -131,32 +131,33 @@ auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
# External databases used for authentication and user data lookup
# If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc.
user-database:
- protocol: "oauth2"
mode: simple
config:
protocol: "oauth2"
config:
client-id: "_env:OAUTH2CLIENTID:"
client-secret: "_env:OAUTH2CLIENTSECRET:"
tenant-id: "_env:OAUTH2TENANTID:"
- protocol: "ldap"
config:
host: "_env:LDAPHOST:"
tls: "_env:LDAPTLS:"
port: "_env:LDAPPORT:389"
user: "_env:LDAPUSER:"
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5"
search-timeout: "_env:LDAPSEARCHTIME:5"
pool:
stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20"
limit: "_env:LDAPLIMIT:10"
# protocol: "ldap"
# config:
# host: "_env:LDAPHOST:"
# tls: "_env:LDAPTLS:"
# port: "_env:LDAPPORT:389"
# user: "_env:LDAPUSER:"
# pass: "_env:LDAPPASS:"
# baseDN: "_env:LDAPBASE:"
# scope: "_env:LDAPSCOPE:WholeSubtree"
# timeout: "_env:LDAPTIMEOUT:5"
# search-timeout: "_env:LDAPSEARCHTIME:5"
# pool:
# stripes: "_env:LDAPSTRIPES:1"
# timeout: "_env:LDAPTIMEOUT:20"
# limit: "_env:LDAPLIMIT:10"
userdb-retest-failover: 60
userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde
lms-direct:
upload-header: "_env:LMSUPLOADHEADER:true"
upload-delimiter: "_env:LMSUPLOADDELIMITER:"

View File

@ -311,9 +311,8 @@ determineCrontab = execWriterT $ do
if
-- TODO: generalize user sync job to oauth
| is _Just appUserDbConf
, Just syncWithin <- appUserdbSyncWithin
, Just cInterval <- appJobCronInterval
| Just syncWithin <- appUserdbSyncWithin
, Just cInterval <- appJobCronInterval
-> do
nextIntervals <- getNextIntervals syncWithin appUserdbSyncInterval cInterval

View File

@ -48,7 +48,7 @@ import Data.Word (Word16)
import qualified Data.Text as Text
import qualified Ldap.Client as Ldap
-- import qualified Ldap.Client as Ldap
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet
@ -79,7 +79,7 @@ import qualified Web.ServerSession.Core as ServerSession
import Text.Show (showParen, showString)
import qualified Data.List.PointedList as P
-- import qualified Data.List.PointedList as P
import qualified Network.Minio as Minio
@ -142,10 +142,22 @@ instance FromJSON PWHashConf where
return PWHashConf{..}
data UserDbConf = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf
data UserDbConf' = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf
deriving (Show)
makePrisms ''UserDbConf
data UserDbConf =
UserDbSimple -- ^ use only one specific source
{ userdbSource :: UserDbConf'
}
-- TODO: other modes yet to be implemented
-- | UserDbFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
-- { userdbFailoverSources :: PointedList UserDbConf
-- , userDbFailoverRetest :: NominalDiffTime
-- }
-- | UserDbMerge -- ^ Multiple coequal user sources
-- { userdbMergeSources :: Set UserDbConf
-- }
deriving (Show)
data LmsConf = LmsConf
{ lmsUploadHeader :: Bool
@ -297,10 +309,23 @@ pathPieceJSONKey ''SettingBotMitigation
makePrisms ''JobMode
makeLenses_ ''JobMode
makePrisms ''UserDbConf'
makeLenses_ ''UserDbConf
makePrisms ''UserDbConf
deriveFromJSON defaultOptions
{ constructorTagModifier = toLower . dropPrefix "UserDb"
, sumEncoding = TaggedObject "protocol" "config"
} ''UserDbConf
} ''UserDbConf'
instance FromJSON UserDbConf where
parseJSON = withObject "UserDbConf" $ \o -> do
mode <- o .: "mode"
case mode of
"simple" -> do
userdbSource <- o .: "config"
return UserDbSimple{..}
other -> error $ "Unsupported user database mode: " <> other
instance FromJSON HaskellNet.PortNumber where
parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
@ -428,7 +453,7 @@ data AppSettings = AppSettings
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
, appAutoDbMigrate :: Bool
, appUserDbConf :: Maybe (PointedList UserDbConf)
, appUserDbConf :: UserDbConf
-- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
, appLmsConf :: LmsConf
-- ^ Configuration settings for accessing the LDAP-directory
@ -599,11 +624,12 @@ instance FromJSON AppSettings where
appWebpackEntrypoints <- o .: "webpack-manifest"
appDatabaseConf <- o .: "database"
appAutoDbMigrate <- o .: "auto-db-migrate"
let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host
nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
-- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
-- Ldap.Tls host _ -> not $ null host
-- Ldap.Plain host -> not $ null host
-- nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
appUserDbConf <- o .: "user-database"
-- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
appLmsConf <- o .: "lms-direct"
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
appLprConf <- o .: "lpr"