diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 9064a83f4..8ad8c2aab 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -10,7 +10,7 @@ module Auth.LDAP , ldapLogin , CampusUserException(..) , ldapUser, ldapUser', ldapUser'' - , ldapUserReTest, ldapUserReTest' +--, ldapUserReTest, ldapUserReTest' , ldapUserMatr, ldapUserMatr' , CampusMessage(..) , ldapPrimaryKey @@ -131,18 +131,21 @@ makePrisms ''CampusUserException ldapUserWith :: ( MonadUnliftIO m , MonadCatch m + --, MonadLogger m ) - => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap - -> Failover (LdapConf, LdapPool) - -> FailoverMode - -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) - -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -- ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap + -- -> (LdapConf, LdapPool) + -- -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) + -- -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -- ) + => ( LdapPool + -> (Ldap -> m (Either CampusUserException (Ldap.AttrList []))) + -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) ) - -> Failover (LdapConf, LdapPool) - -> FailoverMode + -> (LdapConf, LdapPool) -> Creds site -> m (Either CampusUserException (Ldap.AttrList [])) -ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do +ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do lift $ Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do @@ -156,73 +159,70 @@ ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapErro _otherwise -> throwE CampusUserAmbiguous -ldapUserReTest :: ( MonadUnliftIO m - , MonadMask m - , MonadLogger m - ) - => Failover (LdapConf, LdapPool) - -> (Nano -> Bool) - -> FailoverMode - -> Creds site - -> m (Ldap.AttrList []) -ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds - -ldapUserReTest' :: ( MonadMask m - , MonadLogger m - , MonadUnliftIO m - ) - => Failover (LdapConf, LdapPool) - -> (Nano -> Bool) - -> FailoverMode - -> User - -> m (Maybe (Ldap.AttrList [])) -ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) - where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey +-- TODO: reintroduce once failover has been reimplemented +-- ldapUserReTest :: ( MonadUnliftIO m +-- , MonadMask m +-- , MonadLogger m +-- ) +-- => Failover (LdapConf, LdapPool) +-- -> (Nano -> Bool) +-- -> FailoverMode +-- -> Creds site +-- -> m (Ldap.AttrList []) +-- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds +-- +-- ldapUserReTest' :: ( MonadMask m +-- , MonadLogger m +-- , MonadUnliftIO m +-- ) +-- => Failover (LdapConf, LdapPool) +-- -> (Nano -> Bool) +-- -> FailoverMode +-- -> User +-- -> m (Maybe (Ldap.AttrList [])) +-- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} +-- = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) +-- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey ldapUser :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> Creds site -> m (Ldap.AttrList []) -ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds +ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds ldapUser' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> User -> m (Maybe (Ldap.AttrList [])) -ldapUser' pool mode User{userIdent} - = ldapUser'' pool mode $ CI.original userIdent +ldapUser' pool User{userIdent} + = ldapUser'' pool $ CI.original userIdent ldapUser'' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> Text -> m (Maybe (Ldap.AttrList [])) -ldapUser'' pool mode ident - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident []) +ldapUser'' pool ident + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool (Creds apLdap ident []) ldapUserMatr :: ( MonadUnliftIO m , MonadMask m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> UserMatriculation -> m (Ldap.AttrList []) -ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do +ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword results <- findUserMatr conf ldap userMatr [] case results of @@ -232,14 +232,12 @@ ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return < ldapUserMatr' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) -ldapUserMatr' pool mode - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode +ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool newtype ADInvalidCredentials = ADInvalidCredentials ADError diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 47eb4147c..96216e354 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later