diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index fab2eb322..3f9d02ca2 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! DummyLoginTitle: Development-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login -CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation +CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 0d74c98e5..fea6d250c 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,6 +1,7 @@ module Foundation.Yesod.Auth ( authenticate , upsertCampusUser + , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage ) where @@ -154,132 +155,16 @@ upsertCampusUser :: forall m. => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - - let - 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 - - userTelephone = decodeLdap ldapUserTelephone - userMobile = decodeLdap ldapUserMobile - userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer - userCompanyDepartment = decodeLdap ldapUserFraportAbteilung - - userAuthentication - | is _UpsertCampusUserLoginOther upsertMode - = error "Non-LDAP logins should only work for users that are already known" - | otherwise = AuthLDAP - userLastAuthentication = guardOn isLogin now - isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode - - userIdent <- if - | [bs] <- ldapMap !!! ldapUserPrincipalName - , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode - -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent - -> return userIdent' - | otherwise - -> throwM CampusUserInvalidIdent - - userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) - -> 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 - , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' - -> return $ Just userLdapPrimaryKey''' - | otherwise - -> return Nothing - - let - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userSex = Nothing - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , 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 - , userPinPassword = Nothing -- must be derived via AVS - , userPrefersPostal = False - , .. - } - userUpdate = [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 - UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserEmail =. userEmail - , UserLastLdapSynchronisation =. Just now - , UserLdapPrimaryKey =. userLdapPrimaryKey - , UserMobile =. userMobile - , UserTelephone =. userTelephone - , UserCompanyPersonalNumber =. userCompanyPersonalNumber - , UserCompanyDepartment =. userCompanyDepartment - ] ++ - [ UserLastAuthentication =. Just now | isLogin ] + userDefaultConf <- getsYesod $ view _appUserDefaults + (newUser@User{..},userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ - update userId [ UserDisplayName =. userDisplayName' ] + unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $ + update userId [ UserDisplayName =. userDisplayName ] let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' @@ -297,6 +182,136 @@ upsertCampusUser upsertMode ldapData = do return user +decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) +decodeUserTest mbIdent ldapData = do + now <- liftIO getCurrentTime + userDefaultConf <- getsYesod $ view _appUserDefaults + let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent + try $ decodeUser now userDefaultConf mode ldapData + + +decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) +decodeUser now UserDefaultConf{..} upsertMode ldapData = do + let + userTelephone = decodeLdap ldapUserTelephone + userMobile = decodeLdap ldapUserMobile + userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer + userCompanyDepartment = decodeLdap ldapUserFraportAbteilung + + userAuthentication + | is _UpsertCampusUserLoginOther upsertMode + = error "Non-LDAP logins should only work for users that are already known" + | otherwise = AuthLDAP + userLastAuthentication = guardOn isLogin now + isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode + + userIdent <- if + | [bs] <- ldapMap !!! ldapUserPrincipalName + , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs + , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode + -> return userIdent' + | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent + -> return userIdent' + | otherwise + -> throwM CampusUserInvalidIdent + + userEmail <- if + | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) + -> 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 + , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' + -> return $ Just userLdapPrimaryKey''' + | otherwise + -> return Nothing + + let + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userSex = Nothing + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Just now + , 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 + , userPinPassword = Nothing -- must be derived via AVS + , userPrefersPostal = False + , .. + } + userUpdate = [ + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + UserFirstName =. userFirstName + , UserSurname =. userSurname + , UserEmail =. userEmail + , UserLastLdapSynchronisation =. Just now + , UserLdapPrimaryKey =. userLdapPrimaryKey + , UserMobile =. userMobile + , UserTelephone =. userTelephone + , UserCompanyPersonalNumber =. userCompanyPersonalNumber + , UserCompanyDepartment =. userCompanyDepartment + ] ++ + [ UserLastAuthentication =. Just now | isLogin ] + return (newUser, userUpdate) + + where + 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 + 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 45c1f1bf7..13a40c501 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -8,9 +8,11 @@ module Handler.Admin.Ldap 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.Encoding as Text -- import qualified Data.Set as Set +import Foundation.Yesod.Auth (decodeUserTest) import Handler.Utils @@ -47,13 +49,18 @@ postAdminLdapR = do ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) - procFormPerson LdapQueryPerson{..} = do - ldapPool' <- getsYesod $ view _appLdapPool + 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 -> - campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + fmap join . for ldapPool' $ \ldapPool -> do + ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData + whenIsLeft eitherErr $ addMessageI Error + return ldapData + mbLdapData <- formResultMaybe presult procFormPerson