chore: user sources

config/settings.yml

@@ -128,9 +128,9 @@ database:
 
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
-# External databases used for authentication and userdata lookups
+# External sources used for authentication and userdata lookups
-user-database:
+user-source:
-  mode: single-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
+# user-retest-failover: 60
-userdb-sync-within:   "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
+user-sync-within:   "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
-userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600"  # jede Stunde
+user-sync-interval: "_env:USER_SYNC_INTERVAL:3600"  # jede Stunde
 
 lms-direct:
   upload-header:        "_env:LMSUPLOADHEADER:true"

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
+        | UserSourceConfSingleSource{..} <- appUserSourceConf
-        , UserDbLdap LdapConf{..} <- userdbSingleSource
+        , 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 ***"

src/Foundation/Yesod/Auth.hs

@@ -101,14 +101,14 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   $logDebugS "auth" $ tshow Creds{..}
 
-  userdbConf <- getsYesod $ view _appUserDbConf
+  userSourceConf <- getsYesod $ view _appUserSourceConf
-  flip catches excHandlers $ case userdbConf of
+  flip catches excHandlers $ case userSourceConf of
-    UserDbSingleSource (UserDbAzureAdV2 azureConf)
+    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

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
+  case appUserSourceConf of
-    UserDbSingleSource (UserDbLdap ldapConf) ->
+    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

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 =
+data UserSourceConf =
-      UserDbSingleSource -- ^ use only one specific source
+      UserSourceConfSingleSource -- ^ use only one specific source
-      { userdbSingleSource :: UserDbConf'
+      { 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
+  -- | UserFailover  -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
-  --   { userdbFailoverSources :: PointedList UserDbConf
+  --   { usersrcFailoverSources :: PointedList UserSource
-  --   , userDbFailoverRetest  :: NominalDiffTime
+  --   , usersrcFailoverRetest  :: NominalDiffTime
   --   }
-  -- | UserDbMultiSource  -- ^ Multiple coequal user sources
+  -- | UserMultiSource  -- ^ Multiple coequal user sources
-  --   { userdbMultiSources :: Set UserDbConf
+  --   { usersrcMultiSources :: Set UserSource
   --   }
   deriving (Show)
 
@@ -309,21 +309,21 @@ pathPieceJSONKey ''SettingBotMitigation
 makePrisms ''JobMode
 makeLenses_ ''JobMode
 
-makePrisms ''UserDbConf'
+makePrisms ''UserSource
-makeLenses_ ''UserDbConf
+makeLenses_ ''UserSourceConf
-makePrisms ''UserDbConf
+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
+    -- , appUserRetestFailover :: DiffTime
-    , appUserdbSyncWithin     :: Maybe NominalDiffTime
+    , appUserSyncWithin     :: Maybe NominalDiffTime
-    , appUserdbSyncInterval   :: 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"
+        -- appUserRetestFailover     <- o .:  "userdb-retest-failover"
-        appUserdbSyncWithin   <- o .:? "userdb-sync-within"
+        appUserSyncWithin   <- o .:? "user-sync-within"
-        appUserdbSyncInterval <- o .:  "userdb-sync-interval"
+        appUserSyncInterval <- o .:  "user-sync-interval"
 
         appSynchroniseAvsUsersWithin    <- o .:? "synchronise-avs-users-within"
         appSynchroniseAvsUsersInterval  <- o .:  "synchronise-avs-users-interval"