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

fix(campus-auth): properly handle login failures

Browse Source
This commit is contained in:
Gregor Kleen 2020-07-28 20:54:55 +02:00
parent 22882c1fa0
commit ec42d834ee
1 changed files with 27 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/Auth/LDAP.hs
View File

@ -189,28 +189,33 @@ campusLogin pool mode = AuthPlugin{..}
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
case searchResults of
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
| [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
| [principalName] <- nub $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
, Right credsIdent <- Text.decodeUtf8' principalName
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
other -> return $ Left other
-> handleIf isInvalidCredentials (return . Left) $ do
Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
return . Right $ Right (userDN, credsIdent)
other -> return . Right $ Left other
case ldapResult of
Left err
| LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
-> do
$logDebugS apName "Invalid credentials"
observeLoginOutcome apName LoginInvalidCredentials
loginErrorMessageI LoginR Msg.InvalidLogin
| otherwise -> do
$logErrorS apName $ "Error during login: " <> tshow err
observeLoginOutcome apName LoginError
loginErrorMessageI LoginR Msg.AuthError
Right (Right (userDN, credsIdent)) -> do
observeLoginOutcome apName LoginSuccessful
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
Right (Left searchResults) -> do
$logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
Left err -> do
$logErrorS apName $ "Error during login: " <> tshow err
observeLoginOutcome apName LoginError
loginErrorMessageI LoginR Msg.AuthError
Right (Left _bindErr) -> do
$logDebugS apName "Invalid credentials"
observeLoginOutcome apName LoginInvalidCredentials
loginErrorMessageI LoginR Msg.InvalidLogin
Right (Right (Left searchResults))
| null searchResults -> do
$logDebugS apName "User not found"
observeLoginOutcome apName LoginInvalidCredentials
loginErrorMessageI LoginR Msg.InvalidLogin
| otherwise -> do
$logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
observeLoginOutcome apName LoginError
loginErrorMessageI LoginR Msg.AuthError
Right (Right (Right (userDN, credsIdent))) -> do
observeLoginOutcome apName LoginSuccessful
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
maybe (redirect $ tp LoginR) return resp
apDispatch _ [] = badMethod
@ -228,3 +233,7 @@ campusLogin pool mode = AuthPlugin{..}
, formAnchor = Just "login--campus" :: Maybe Text
}
$(widgetFile "widgets/campus-login/campus-login-form")
isInvalidCredentials = \case
Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
_other -> False