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

refactor(ldap): make ldap response parsing way more lenient

Browse Source
This commit is contained in:
Steffen Jost 2022-09-15 15:42:55 +02:00
parent 4d375e7680
commit 4419245e17
6 changed files with 68 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -206,6 +206,14 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
userLastAuthentication = guardOn isLogin now
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
userIdent <- if
| [bs] <- ldapMap !!! ldapUserPrincipalName
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
@ -221,13 +229,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
-> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName
userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname
userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle
userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
(maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@ -256,7 +258,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Just now
, userDisplayName = userDisplayName'
, userDisplayName = userDisplayName
, userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
@ -283,35 +285,38 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-- only accept a single result, throw error otherwise
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
decodeLdap1 attr err
| [bs] <- ldapMap !!! attr
, Right t <- Text.decodeUtf8' bs
= return t
| otherwise = throwM err
-- accept multiple successful decodings, ignoring all others
decodeLdapN attr err
| t@(_:_) <- rights vs
= return $ Text.unwords t
| otherwise = throwM err
where
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- accept any successful decoding or empty; only throw an error if all decodings fail
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
decodeLdap' attr err
| [] <- vs = return Nothing
| (h:_) <- rights vs = return $ Just h
| otherwise = throwM err
where
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- just returns Nothing on error, pure
decodeLdap :: Ldap.Attr -> Maybe Text
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
decodeLdap' :: Ldap.Attr -> Text
decodeLdap' = fromMaybe "" . decodeLdap
-- accept the first successful decoding or empty; only throw an error if all decodings fail
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
-- decodeLdap' attr err
-- | [] <- vs = return Nothing
-- | (h:_) <- rights vs = return $ Just h
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- only accepts the first successful decoding, ignoring all others, but failing if there is none
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
decodeLdap1 attr err
| (h:_) <- rights vs = return h
| otherwise = throwM err
where
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- accept and merge one or more successful decodings, ignoring all others
-- decodeLdapN attr err
-- | t@(_:_) <- rights vs
-- = return $ Text.unwords t
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
associateUserSchoolsByTerms uid = do
sfs <- selectList [StudyFeaturesUser ==. uid] []

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

@ -9,7 +9,7 @@ import Import
-- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
-- import qualified Data.Text as Text
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest)
@ -57,8 +57,8 @@ postAdminLdapR = do
else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
whenIsLeft eitherErr $ addMessageI Error
decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
@ -72,6 +72,10 @@ postAdminLdapR = do
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
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
$(widgetFile "ldap")

2
src/Handler/Profile.hs
View File

@ -439,7 +439,9 @@ validateSettings :: User -> FormValidator SettingsForm Handler ()
validateSettings User{..} = do
userDisplayName' <- use _stgDisplayName
guardValidation MsgUserDisplayNameInvalid $
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName'
userPinPassword' <- use _stgPinPassword
guardValidation MsgPDFPasswordInvalid $

9
src/Handler/Utils/Profile.hs
View File

@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT
import qualified Data.MultiSet as MultiSet
import qualified Data.Set as Set
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
stripFold :: Text -> Text
stripFold = Text.toCaseFold . Text.strip
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
fixDisplayName :: UserDisplayName -> UserDisplayName
fixDisplayName udn =
let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn
in Text.strip $ firstnames <> Text.cons ' ' surname
in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname
-- | Like `validDisplayName` but may return an automatically corrected name
checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle
-> UserSurname
-> UserDisplayName
-> Bool
validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName)
validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName)
= and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags]
, sName `Text.isInfixOf` dName
, all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName
@ -53,6 +57,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
isAdd = (`Set.member` addLetters)
splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool

5
src/Utils.hs
View File

@ -275,6 +275,11 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace)
-- | strip leading and trailing whitespace and make case insensitive
-- also helps to avoid the need to import just for CI.mk
stripCI :: Text -> CI Text
stripCI = CI.mk . Text.strip
citext2lower :: CI Text -> Text
citext2lower = Text.toLower . CI.original

14
templates/ldap.hamlet
View File

@ -3,9 +3,13 @@
LDAP Person Search:
^{personForm}
$maybe answers <- mbLdapData
<dl>
<h1>
Antwort: #
<dl>
$forall (lk, lv) <- answers
<dt>#{show lk}
<dd>#{show (fmap Text.decodeUtf8' lv)}
<dl .deflist>
$forall (lk, lv) <- answers
<dt>
#{show lk}
<dd>
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}