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

chore(ldap): admin interface allows search by personal number

Browse Source
This commit is contained in:
Steffen Jost 2022-10-06 10:25:09 +02:00
parent 86b5f0f175
commit ef97e19522
2 changed files with 25 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Auth/LDAP.hs
View File

@ -86,7 +86,7 @@ ldapUserFirstName = Ldap.Attr "givenName"
ldapUserSurname = Ldap.Attr "sn"
ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
ldapUserTitle = Ldap.Attr "title" -- not used at Fraport
-- new
-- new
ldapUserTelephone = Ldap.Attr "telephoneNumber"
ldapUserMobile = Ldap.Attr "mobile"
ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
@ -173,7 +173,7 @@ newtype ADInvalidCredentials = ADInvalidCredentials ADError
isUnusualADError :: ADError -> Bool
isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure]
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
, RenderMessage (HandlerSite m) CampusMessage
@ -233,7 +233,7 @@ campusLogin pool mode = AuthPlugin{..}
loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
Right (Left bindErr) -> do
case bindErr of
Ldap.ResponseErrorCode _ _ _ errTxt ->
Ldap.ResponseErrorCode _ _ _ errTxt ->
$logInfoS apName [st|#{campusIdent}: #{errTxt}|]
_other -> return ()
$logDebugS apName "Invalid credentials"

42
src/Handler/Admin/Ldap.hs
View File

@ -6,7 +6,7 @@ module Handler.Admin.Ldap
) where
import Import
-- import qualified Control.Monad.State.Class as State
import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
@ -19,49 +19,51 @@ import Handler.Utils
import qualified Ldap.Client as Ldap
import Auth.LDAP
newtype LdapQueryPerson = LdapQueryPerson
{ ldapQueryIdent :: Text
data LdapQueryPerson = LdapQueryPerson
{ ldapQueryIdent :: Maybe Text
-- , ldapQueryName :: Maybe Text
-- , ldapQueryPNum :: Maybe Text
, ldapQueryPNum :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ LdapQueryPerson
<$> areq textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
<$> aopt textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
<*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
validateLdapQueryPerson = return () -- currently no tests needed
--LdapQueryPerson{..} <- State.get
--guardValidation MsgAvsQueryEmpty
--is _Just ldapQueryIdent ||
--is _Just ldapQueryName ||
--is _Just ldapQueryPNum
validateLdapQueryPerson = do
LdapQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $
is _Just ldapQueryIdent ||
-- is _Just ldapQueryName ||
is _Just ldapQueryPNum
getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR
getAdminLdapR = postAdminLdapR
postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
procFormPerson LdapQueryPerson{..} = do
procFormPerson LdapQueryPerson{..} = do
ldapPool' <- getsYesod $ view _appLdapPool
if isNothing ldapPool'
then addMessage Warning $ text2Html "LDAP Configuration missing."
else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser'' ldapPool FailoverUnlimited lqi
| Just lqn <- ldapQueryPNum -> campusUserMatr' ldapPool FailoverUnlimited lqn
| otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson
@ -73,7 +75,7 @@ postAdminLdapR = do
, formEncoding = penctype
}
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
-- TODO: use i18nWidgetFile instead if this is to become permanent