From 4419245e17c3c8e40e8be76e2d2e30ab0f74e3ce Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Sep 2022 15:42:55 +0200 Subject: [PATCH] refactor(ldap): make ldap response parsing way more lenient --- src/Foundation/Yesod/Auth.hs | 71 +++++++++++++++++++----------------- src/Handler/Admin/Ldap.hs | 10 +++-- src/Handler/Profile.hs | 2 + src/Handler/Utils/Profile.hs | 9 ++++- src/Utils.hs | 5 +++ templates/ldap.hamlet | 14 ++++--- 6 files changed, 68 insertions(+), 43 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index fea6d250c..5496155c1 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -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] [] diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 13a40c501..9f305fb37 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -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") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b014a6a4e..2d75f2ac1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 $ diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 082048456..7732d66af 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 7c565484b..c9043998e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index a02df7d65..0b5873a55 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -3,9 +3,13 @@ LDAP Person Search: ^{personForm} $maybe answers <- mbLdapData -
+

Antwort: # -
- $forall (lk, lv) <- answers -
#{show lk} -
#{show (fmap Text.decodeUtf8' lv)} +
+ $forall (lk, lv) <- answers +
+ #{show lk} +
+ UTF8: #{presentUtf8 lv} + — + Latin: #{presentLatin1 lv}