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

chore(auth): do not authenticate against external sources on dummy login

Browse Source
This commit is contained in:
Sarah Vaupel 2024-03-01 20:42:51 +01:00
parent f88e527fe4
commit 434eed2217
1 changed files with 22 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/Foundation/Yesod/Auth.hs
View File

@ -105,7 +105,6 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
excRecovery . ServerError $ mr cExc excRecovery . ServerError $ mr cExc
] ]
-- | Authenticate already existing ExternalUser entries only
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
acceptExisting = do acceptExisting = do
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
@ -121,19 +120,21 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
$logDebugS "Auth" $ tshow Creds{..} $logDebugS "Auth" $ tshow Creds{..}
flip catches excHandlers $ case userAuthConf of flip catches excHandlers $ if
UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) | not isDummy, not isOther
| Just upsertMode' <- upsertMode -> do , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
, Just upsertMode' <- upsertMode -> do
upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) | not isDummy, not isOther
| Just upsertMode' <- upsertMode -> do , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
, Just upsertMode' <- upsertMode -> do
ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
upsertUserLdapData <- ldapUser ldapPool Creds{..} upsertUserLdapData <- ldapUser ldapPool Creds{..}
$logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..} Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
_other | otherwise
-> acceptExisting -> acceptExisting
@ -150,7 +151,6 @@ data UserConversionException
deriving anyclass (Exception) deriving anyclass (Exception)
-- TODO: this is probably not a sane traversal anymore...
_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode _upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
_upsertUserMode mMode cs@Creds{..} _upsertUserMode mMode cs@Creds{..}
| credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent) | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)