diff --git a/config/settings.yml b/config/settings.yml index 4de2d872a..c7f3018e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -128,9 +128,9 @@ database: auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' -# External databases used for authentication and userdata lookups -user-database: - mode: single-source +# External sources used for authentication and userdata lookups +user-source: +# mode: single-source protocol: azureadv2 config: client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000" @@ -149,14 +149,15 @@ user-database: # timeout: "_env:LDAPTIMEOUT:5" # search-timeout: "_env:LDAPSEARCHTIME:5" +# TODO: might move later ldap-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 +# user-retest-failover: 60 +user-sync-within: "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden +user-sync-interval: "_env:USER_SYNC_INTERVAL:3600" # jede Stunde lms-direct: upload-header: "_env:LMSUPLOADHEADER:true" diff --git a/src/Application.hs b/src/Application.hs index 8eb2a1151..8aa072a36 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -246,7 +246,7 @@ makeFoundation appSettings''@AppSettings{..} = do (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") - (error "userdbPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") (error "sessionStore forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") @@ -314,8 +314,8 @@ makeFoundation appSettings''@AppSettings{..} = do -- TODO: reintroduce failover once UserDbFailover is implemented (see above) ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if - | UserDbSingleSource{..} <- appUserDbConf - , UserDbLdap LdapConf{..} <- userdbSingleSource + | UserSourceConfSingleSource{..} <- appUserSourceConf + , UserSourceLdap LdapConf{..} <- usersrcSingleSource -> do -- set up a singleton ldap pool with no failover let ldapLabel = case ldapHost of Ldap.Plain str -> pack str <> ":" <> tshow ldapPort @@ -421,7 +421,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' -- TODO: reimplement user db failover - let foundation = mkFoundation appSettings' sqlPool smtpPool userdbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 47e210866..541cf7857 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -101,14 +101,14 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $logDebugS "auth" $ tshow Creds{..} - userdbConf <- getsYesod $ view _appUserDbConf - flip catches excHandlers $ case userdbConf of - UserDbSingleSource (UserDbAzureAdV2 azureConf) + userSourceConf <- getsYesod $ view _appUserSourceConf + flip catches excHandlers $ case userSourceConf of + UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) | Just upsertMode' <- upsertMode -> do - azureData <- oauth2User azureConf Creds{..} + azureData <- azureUser azureConf Creds{..} $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData - UserDbSingleSource (UserDbLdap _) + UserSourceConfSingleSource (UserSourceLdap _) | Just upsertMode' <- upsertMode -> do -- TODO WIP ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs index 954a5edf2..34069a90d 100644 --- a/src/Jobs/Handler/SynchroniseUserdb.hs +++ b/src/Jobs/Handler/SynchroniseUserdb.hs @@ -45,8 +45,8 @@ dispatchJobSynchroniseUserdb numIterations epoch iteration dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do UniWorX{..} <- getYesod - case appUserDbConf of - UserDbSingleSource (UserDbLdap ldapConf) -> + case appUserSourceConf of + UserSourceConfSingleSource (UserSourceLdap ldapConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey @@ -55,12 +55,12 @@ dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user void . lift $ upsertLdapUser (UpsertLdapUserLdapSync upsertIdent) ldapAttrs - UserDbSingleSource (UserDbOAuth2 oauth2Conf) -> + UserSourceConfSingleSource (UserSourceAzure azureConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|] - void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) oauth2Conf + void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) azureConf where handleExc :: MaybeT DB a -> MaybeT DB a handleExc diff --git a/src/Settings.hs b/src/Settings.hs index d86518124..242b0ca0d 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -142,20 +142,20 @@ instance FromJSON PWHashConf where return PWHashConf{..} -data UserDbConf' = UserDbLdap LdapConf | UserDbAzureAdV2 AzureConf +data UserSource = UserSourceLdap LdapConf | UserSourceAzureAdV2 AzureConf deriving (Show) -data UserDbConf = - UserDbSingleSource -- ^ use only one specific source - { userdbSingleSource :: UserDbConf' +data UserSourceConf = + UserSourceConfSingleSource -- ^ use only one specific source + { usersrcSingleSource :: UserSource } -- 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 + -- | UserFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable + -- { usersrcFailoverSources :: PointedList UserSource + -- , usersrcFailoverRetest :: NominalDiffTime -- } - -- | UserDbMultiSource -- ^ Multiple coequal user sources - -- { userdbMultiSources :: Set UserDbConf + -- | UserMultiSource -- ^ Multiple coequal user sources + -- { usersrcMultiSources :: Set UserSource -- } deriving (Show) @@ -309,21 +309,21 @@ pathPieceJSONKey ''SettingBotMitigation makePrisms ''JobMode makeLenses_ ''JobMode -makePrisms ''UserDbConf' -makeLenses_ ''UserDbConf -makePrisms ''UserDbConf +makePrisms ''UserSource +makeLenses_ ''UserSourceConf +makePrisms ''UserSourceConf deriveFromJSON defaultOptions - { constructorTagModifier = toLower . dropPrefix "UserDb" + { constructorTagModifier = toLower . dropPrefix "UserSource" , sumEncoding = TaggedObject "protocol" "config" - } ''UserDbConf' + } ''UserSource deriveFromJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 + { constructorTagModifier = camelToPathPiece' 3 , fieldLabelModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "mode" "config" + , sumEncoding = UntaggedValue -- TaggedObject "mode" "config" , unwrapUnaryRecords = True - } ''UserDbConf + } ''UserSourceConf instance FromJSON HaskellNet.PortNumber where parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of @@ -451,7 +451,7 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appUserDbConf :: UserDbConf + , appUserSourceConf :: UserSourceConf -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory @@ -517,9 +517,9 @@ data AppSettings = AppSettings , appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime - -- , appUserdbRetestFailover :: DiffTime - , appUserdbSyncWithin :: Maybe NominalDiffTime - , appUserdbSyncInterval :: NominalDiffTime + -- , appUserRetestFailover :: DiffTime + , appUserSyncWithin :: Maybe NominalDiffTime + , appUserSyncInterval :: NominalDiffTime , appLdapPoolConf :: Maybe ResourcePoolConf @@ -628,7 +628,7 @@ instance FromJSON AppSettings where -- 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" + appUserSourceConf <- o .: "user-source" -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] appLdapPoolConf <- o .:? "ldap-pool" appLmsConf <- o .: "lms-direct" @@ -695,9 +695,9 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" - -- appUserdbRetestFailover <- o .: "userdb-retest-failover" - appUserdbSyncWithin <- o .:? "userdb-sync-within" - appUserdbSyncInterval <- o .: "userdb-sync-interval" + -- appUserRetestFailover <- o .: "userdb-retest-failover" + appUserSyncWithin <- o .:? "user-sync-within" + appUserSyncInterval <- o .: "user-sync-interval" appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within" appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval"