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

Fix login troubles and make it behave as advertised

Browse Source
This commit is contained in:
Gregor Kleen 2019-04-03 20:26:30 +02:00
parent 8bedeeffa7
commit 8bf9e44c82
2 changed files with 13 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
shell.nix
View File

@ -19,7 +19,7 @@ let
''; '';
override = oldAttrs: { override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = '' shellHook = ''
export PROMPT_INFO="${oldAttrs.name}" export PROMPT_INFO="${oldAttrs.name}"

24
src/Auth/LDAP.hs
View File

@ -88,9 +88,14 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
FormMissing -> redirect LoginR FormMissing -> redirect LoginR
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
ldapResult <- withLdap pool $ \ldap -> do ldapResult <- withLdap pool $ \ldap -> do
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
Ldap.bind ldap ldapDn ldapPassword Ldap.bind ldap ldapDn ldapPassword
findUser conf ldap campusIdent [userPrincipalName] searchResults <- findUser conf ldap campusIdent [userPrincipalName]
case searchResults of
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
| Just [principalName] <- lookup userPrincipalName userAttrs
, Right credsIdent <- Text.decodeUtf8' principalName
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
other -> return $ Left other
case ldapResult of case ldapResult of
Left err Left err
| LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
@ -100,16 +105,11 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
| otherwise -> do | otherwise -> do
$logErrorS "LDAP" $ "Error during login: " <> tshow err $logErrorS "LDAP" $ "Error during login: " <> tshow err
loginErrorMessageI LoginR Msg.AuthError loginErrorMessageI LoginR Msg.AuthError
Right searchResults Right (Right (userDN, credsIdent)) ->
| [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
, Just [principalName] <- lookup userPrincipalName userAttrs Right (Left searchResults) -> do
, Right credsIdent <- Text.decodeUtf8' principalName $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
-> do loginErrorMessageI LoginR Msg.AuthError
$logDebugS "LDAP" $ tshow searchResults
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
| otherwise -> do
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
loginErrorMessageI LoginR Msg.AuthError
apDispatch _ _ = notFound apDispatch _ _ = notFound
apLogin toMaster = do apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm