From 7f00455fbbed5f318ae3c5358f506767f446a2ab Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Aug 2022 16:54:36 +0200 Subject: [PATCH] refactor(ldap): correct invalid displaynames and improve ldap code --- src/Auth/LDAP.hs | 19 ++- src/Foundation/Yesod/Auth.hs | 112 ++++++++++-------- src/Handler/Utils/Profile.hs | 17 ++- .../Handler/SendNotification/Qualification.hs | 2 +- src/Utils.hs | 7 +- 5 files changed, 95 insertions(+), 62 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 75b8acfdb..e96b1a90d 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) @@ -13,6 +15,7 @@ module Auth.LDAP , ldapAffiliation , ldapUserMobile, ldapUserTelephone , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung + , ldapUserTitle ) where import Import.NoFoundation @@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg import Auth.LDAP.AD +-- allow Ldap.Attr usage as key for Data.Map +deriving newtype instance Ord Ldap.Attr + data CampusLogin = CampusLogin { campusIdent :: CI Text @@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat , Ldap.derefAliases Ldap.DerefAlways ] -ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr +ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName" ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" 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 ldapUserTelephone = Ldap.Attr "telephoneNumber" ldapUserMobile = Ldap.Attr "mobile" ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName" ldapUserFraportAbteilung = Ldap.Attr "department" -{- --outdated to be removed -ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" -ldapUserTitle = Ldap.Attr "title" -ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" -ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" -ldapSex = Ldap.Attr "schacGender" -ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" --} - ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| [ Ldap.Attr "userPrincipalName" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 25165ff0b..7e1f7afc5 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..)) import qualified Ldap.Client as Ldap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text --- import qualified Data.ByteString as ByteString +import qualified Data.ByteString as ByteString import qualified Data.Set as Set +import qualified Data.Map as Map -- import qualified Data.Conduit.Combinators as C -- import qualified Data.List as List ((\\)) - + -- import qualified Data.UUID as UUID -- import Data.ByteArray (convert) -- import Crypto.Hash (SHAKE128) @@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend _other -> acceptExisting - + data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail @@ -120,7 +121,7 @@ data CampusUserConversionException | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle - | CampusUserInvalidMatriculation + | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -155,22 +156,30 @@ upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - let - userEmail' = fold $ do - k' <- toList ldapUserEmail - (k, v) <- ldapData - guard $ k' == k - return v - -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration? - userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ] - userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] - userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] - userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] - userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] - userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ] - userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ] - userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ] - userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ] + let + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] + ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) + userEmail' :: [Ldap.AttrValue] + userEmail' = lookupSome ldapMap $ toList ldapUserEmail + userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString] + userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey + userIdent'' = ldapMap !!! ldapUserPrincipalName + userDisplayName'' = ldapMap !!! ldapUserDisplayName + -- userFirstName' = ldapMap !!! ldapUserFirstName + userSurname' = ldapMap !!! ldapUserSurname + userTitle' = ldapMap !!! ldapUserTitle + userTelephone' = ldapMap !!! ldapUserTelephone + userMobile' = ldapMap !!! ldapUserMobile + userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer + userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung + + -- TODO: continue here + 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 userAuthentication | is _UpsertCampusUserLoginOther upsertMode @@ -193,45 +202,55 @@ upsertCampusUser upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName' <- Text.decodeUtf8' bs - -> return userDisplayName' - | otherwise - -> throwM CampusUserInvalidDisplayName - userFirstName <- if - | [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwM CampusUserInvalidGivenName + userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName + --userFirstName <- if + -- | [bs] <- userFirstName' + -- , Right userFirstName <- Text.decodeUtf8' bs + -- -> return userFirstName + -- | otherwise + -- -> throwM CampusUserInvalidGivenName userSurname <- if | [bs] <- userSurname' , Right userSurname <- Text.decodeUtf8' bs -> return userSurname | otherwise -> throwM CampusUserInvalidSurname - userTelephone <- if + userTitle <- if + | [] <- userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userDisplayName' <- if + | [bs] <- userDisplayName'' + , Right userDisplayName1 <- Text.decodeUtf8' bs + , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1 + -> return userDisplayName2 + | otherwise + -> throwM CampusUserInvalidDisplayName + userTelephone <- if | [bs] <- userTelephone' - , Right userTelephone <- Text.decodeUtf8' bs + , Right userTelephone <- Text.decodeUtf8' bs -> return $ Just userTelephone | otherwise -> return Nothing - userMobile <- if + userMobile <- if | [bs] <- userMobile' - , Right userMobile <- Text.decodeUtf8' bs + , Right userMobile <- Text.decodeUtf8' bs -> return $ Just userMobile | otherwise -> return Nothing - userCompanyPersonalNumber <- if + userCompanyPersonalNumber <- if | [bs] <- userFraportPersonalnummer' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing - userCompanyDepartment <- if + userCompanyDepartment <- if | [bs] <- userFraportAbteilung' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing @@ -266,17 +285,16 @@ upsertCampusUser upsertMode ldapData = do , userLastLdapSynchronisation = Just now , userDisplayName = userDisplayName' , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userTitle = Nothing + , 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 , userPrefersPostal = False , .. } - userUpdate = [ + userUpdate = [ -- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserEmail =. userEmail + , UserSurname =. userSurname + , UserEmail =. userEmail , UserLastLdapSynchronisation =. Just now , UserLdapPrimaryKey =. userLdapPrimaryKey , UserMobile =. userMobile @@ -308,7 +326,7 @@ upsertCampusUser upsertMode ldapData = do if | preset -> void $ upsert (UserSystemFunction userId func False False) [] | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - return user + return user associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do @@ -322,7 +340,7 @@ associateUserSchoolsByTerms uid = do , userSchoolSchool = schoolTermsSchool , userSchoolIsOptOut = False } - + updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 6c0037b6e..ed3894955 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,5 +1,7 @@ module Handler.Utils.Profile - ( validDisplayName + ( checkDisplayName + , validDisplayName + , fixDisplayName ) where import Import.NoFoundation @@ -8,7 +10,18 @@ import qualified Data.Text as Text import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set +-- | 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 +-- | Like `validDisplayName` but may return an automatically corrected name +checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName +checkDisplayName mTitle fName sName (fixDisplayName -> dName) + | validDisplayName mTitle fName sName dName = Just dName + | otherwise = Nothing validDisplayName :: Maybe UserTitle -> UserFirstName @@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - fNameLetters = Set.fromList $ unpack fName sNameLetters = Set.fromList $ unpack sName dNameLetters = Set.fromList $ unpack dName - addLetters = Set.fromList [' ', ',', '.', '-'] + addLetters = Set.fromList [' ', '.', '-'] isAdd = (`Set.member` addLetters) splitAdd = Text.split isAdd diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d662a502d..bdbc06155 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -58,7 +58,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address pdfMeta = mkMeta [ toMeta "date" letterDate - , toMeta "lang" $ selectDeEn userLanguages -- select German or English, see Utils.Lang + , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "login" (lmsUserIdent & getLmsIdent) , toMeta "pin" lmsUserPin , toMeta "recipient" userDisplayName diff --git a/src/Utils.hs b/src/Utils.hs index d92f3f50f..9567d12c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -654,6 +654,11 @@ infixl 5 !!! (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v (!!!) m k = fromMaybe mempty $ Map.lookup k m +lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v +-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] +-- lookupSome m ks = ks >>= (m !!!) +lookupSome = (=<<) . (!!!) + groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v) groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l] @@ -888,7 +893,7 @@ actLeft (Left x) f = f x actLeft (Right y) _ = pure $ Right y -- | like monadic bind for 'Either', but wrapped in another monad --- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead +-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c) actRight (Left x) _ = pure $ Left x actRight (Right y) f = f y