fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(ldap): fix user lookup types

Browse Source
This commit is contained in:
Sarah Vaupel 2024-01-30 11:20:44 +01:00
parent 264aaab24c
commit 1cdb20eb60
2 changed files with 54 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
src/Auth/LDAP.hs
View File

@ -10,7 +10,7 @@ module Auth.LDAP
, ldapLogin , ldapLogin
, CampusUserException(..) , CampusUserException(..)
, ldapUser, ldapUser', ldapUser'' , ldapUser, ldapUser', ldapUser''
, ldapUserReTest, ldapUserReTest' --, ldapUserReTest, ldapUserReTest'
, ldapUserMatr, ldapUserMatr' , ldapUserMatr, ldapUserMatr'
, CampusMessage(..) , CampusMessage(..)
, ldapPrimaryKey , ldapPrimaryKey
@ -131,18 +131,21 @@ makePrisms ''CampusUserException
ldapUserWith :: ( MonadUnliftIO m ldapUserWith :: ( MonadUnliftIO m
, MonadCatch m , MonadCatch m
--, MonadLogger m
) )
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap -- ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
-> Failover (LdapConf, LdapPool) -- -> (LdapConf, LdapPool)
-> FailoverMode -- -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
-> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) -- -> m (Either LdapPoolError (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) -> (LdapConf, LdapPool)
-> FailoverMode
-> Creds site -> Creds site
-> m (Either CampusUserException (Ldap.AttrList [])) -> 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 lift $ Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of results <- case lookup "DN" credsExtra of
Just userDN -> do Just userDN -> do
@ -156,73 +159,70 @@ ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapErro
_otherwise -> throwE CampusUserAmbiguous _otherwise -> throwE CampusUserAmbiguous
ldapUserReTest :: ( MonadUnliftIO m -- TODO: reintroduce once failover has been reimplemented
, MonadMask m -- ldapUserReTest :: ( MonadUnliftIO m
, MonadLogger m -- , MonadMask m
) -- , MonadLogger m
=> Failover (LdapConf, LdapPool) -- )
-> (Nano -> Bool) -- => Failover (LdapConf, LdapPool)
-> FailoverMode -- -> (Nano -> Bool)
-> Creds site -- -> FailoverMode
-> m (Ldap.AttrList []) -- -> Creds site
ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds -- -> m (Ldap.AttrList [])
-- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
ldapUserReTest' :: ( MonadMask m --
, MonadLogger m -- ldapUserReTest' :: ( MonadMask m
, MonadUnliftIO m -- , MonadLogger m
) -- , MonadUnliftIO m
=> Failover (LdapConf, LdapPool) -- )
-> (Nano -> Bool) -- => Failover (LdapConf, LdapPool)
-> FailoverMode -- -> (Nano -> Bool)
-> User -- -> FailoverMode
-> m (Maybe (Ldap.AttrList [])) -- -> User
ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} -- -> m (Maybe (Ldap.AttrList []))
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) -- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey -- = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
-- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey
ldapUser :: ( MonadMask m ldapUser :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m --, MonadLogger m
) )
=> Failover (LdapConf, LdapPool) => (LdapConf, LdapPool)
-> FailoverMode
-> Creds site -> Creds site
-> m (Ldap.AttrList []) -> m (Ldap.AttrList [])
ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds
ldapUser' :: ( MonadMask m ldapUser' :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m --, MonadLogger m
) )
=> Failover (LdapConf, LdapPool) => (LdapConf, LdapPool)
-> FailoverMode
-> User -> User
-> m (Maybe (Ldap.AttrList [])) -> m (Maybe (Ldap.AttrList []))
ldapUser' pool mode User{userIdent} ldapUser' pool User{userIdent}
= ldapUser'' pool mode $ CI.original userIdent = ldapUser'' pool $ CI.original userIdent
ldapUser'' :: ( MonadMask m ldapUser'' :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m --, MonadLogger m
) )
=> Failover (LdapConf, LdapPool) => (LdapConf, LdapPool)
-> FailoverMode
-> Text -> Text
-> m (Maybe (Ldap.AttrList [])) -> m (Maybe (Ldap.AttrList []))
ldapUser'' pool mode ident ldapUser'' pool ident
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident []) = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool (Creds apLdap ident [])
ldapUserMatr :: ( MonadUnliftIO m ldapUserMatr :: ( MonadUnliftIO m
, MonadMask m , MonadMask m
, MonadLogger m --, MonadLogger m
) )
=> Failover (LdapConf, LdapPool) => (LdapConf, LdapPool)
-> FailoverMode
-> UserMatriculation -> UserMatriculation
-> m (Ldap.AttrList []) -> 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 Ldap.bind ldap ldapDn ldapPassword
results <- findUserMatr conf ldap userMatr [] results <- findUserMatr conf ldap userMatr []
case results of case results of
@ -232,14 +232,12 @@ ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <
ldapUserMatr' :: ( MonadMask m ldapUserMatr' :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m --, MonadLogger m
) )
=> Failover (LdapConf, LdapPool) => (LdapConf, LdapPool)
-> FailoverMode
-> UserMatriculation -> UserMatriculation
-> m (Maybe (Ldap.AttrList [])) -> m (Maybe (Ldap.AttrList []))
ldapUserMatr' pool mode ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode
newtype ADInvalidCredentials = ADInvalidCredentials ADError newtype ADInvalidCredentials = ADInvalidCredentials ADError

2
src/Ldap/Client/Pool.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later