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

config/settings.yml

@@ -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"
+    # protocol: "ldap"
-    config:
+    # config:
-      host:           "_env:LDAPHOST:"
+    #   host:           "_env:LDAPHOST:"
-      tls:            "_env:LDAPTLS:"
+    #   tls:            "_env:LDAPTLS:"
-      port:           "_env:LDAPPORT:389"
+    #   port:           "_env:LDAPPORT:389"
-      user:           "_env:LDAPUSER:"
+    #   user:           "_env:LDAPUSER:"
-      pass:           "_env:LDAPPASS:"
+    #   pass:           "_env:LDAPPASS:"
-      baseDN:         "_env:LDAPBASE:"
+    #   baseDN:         "_env:LDAPBASE:"
-      scope:          "_env:LDAPSCOPE:WholeSubtree"
+    #   scope:          "_env:LDAPSCOPE:WholeSubtree"
-      timeout:        "_env:LDAPTIMEOUT:5"
+    #   timeout:        "_env:LDAPTIMEOUT:5"
-      search-timeout: "_env:LDAPSEARCHTIME:5"
+    #   search-timeout: "_env:LDAPSEARCHTIME:5"
-      pool:
+    #   pool:
-        stripes:      "_env:LDAPSTRIPES:1"
+    #     stripes:      "_env:LDAPSTRIPES:1"
-        timeout:      "_env:LDAPTIMEOUT:20"
+    #     timeout:      "_env:LDAPTIMEOUT:20"
-        limit:        "_env:LDAPLIMIT:10"
+    #     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:"

src/Jobs/Crontab.hs

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

src/Settings.hs

@@ -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
+        -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
-              Ldap.Tls host _ -> not $ null host
+        --       Ldap.Tls host _ -> not $ null host
-              Ldap.Plain host -> not $ null host
+        --       Ldap.Plain host -> not $ null host
-            nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
+        --     nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
-        appUserDbConf             <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
+        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"