chore(ldap): fix user lookup types

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

src/Ldap/Client/Pool.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later