diff --git a/models/auth.model b/models/auth.model index e8092fe57..69d0502b0 100644 --- a/models/auth.model +++ b/models/auth.model @@ -35,6 +35,7 @@ AuthSourceLdap UserAuth ident UserIdent -- Human-readable text uniquely identifying a user lastLogin UTCTime -- When did the corresponding User last authenticate using this entry? + lastSync UTCTime Maybe -- When was the corresponding User entry last synced with any external source? -- TODO rethink Primary ident UniqueAuthentication ident deriving Show Eq Ord Generic @@ -44,7 +45,7 @@ ExternalAuth ident UserIdent source AuthenticationSourceIdent -- Identifier of the external source in the config data Value "default='{}'::jsonb" -- Raw user data from external source - lastSync UTCTime -- When was the corresponding User entry last synced with this external source? + lastSync UTCTime -- When was the corresponding User entry last synced with this external source? -- TODO rethink UniqueExternalAuth ident source -- At most one entry of this user per source deriving Show Eq Ord Generic diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index df14e7de3..a076b389e 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -119,9 +119,9 @@ instance YesodPersistRunner UniWorX where getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) getDBRunner = UniWorX.getDBRunner' callStack - + instance YesodAuth UniWorX where - type AuthId UniWorX = UserId + type AuthId UniWorX = UserAuthId -- Where to send a user after successful login loginDest _ = NewsR @@ -172,6 +172,7 @@ instance YesodAuth UniWorX where BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken hoistMaybe bearerImpersonate +-- TODO: update? instance YesodAuthPersist UniWorX where getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User) getAuthEntity = liftHandler . runDBRead . get diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index ce7d466f4..c9794f73e 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1212,8 +1212,8 @@ pageActions (AdminUserR cID) = return , navRoute = UserPasswordR cID , navAccess' = NavAccessDB $ do uid <- decrypt cID - User{userAuthentication} <- get404 uid - return $ is _AuthPWHash userAuthentication + User{userIdent} <- get404 uid + existsBy $ UniqueInternalAuth userIdent , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 9d0ffeed8..b43320fbd 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -5,52 +5,57 @@ module Foundation.Yesod.Auth ( authenticate , ldapLookupAndUpsert - , upsertLdapUser, upsertAzureUser + , upsertUser , decodeLdapUserTest, decodeAzureUserTest - , CampusUserConversionException(..) + , UserConversionException(..) , updateUserLanguage ) where import Import.NoFoundation hiding (authenticate) -import Foundation.Type -import Foundation.Types -import Foundation.I18n - -import Handler.Utils.Profile -import Handler.Utils.LdapSystemFunctions -import Handler.Utils.Memcached -import Foundation.Authorization (AuthorizationCacheKey(..)) - -import Yesod.Auth.Message +import Auth.Dummy (apDummy) import Auth.LDAP import Auth.OAuth2 import Auth.PWHash (apHash) -import Auth.Dummy (apDummy) -import qualified Data.CaseInsensitive as CI import qualified Control.Monad.Catch as C (Handler(..)) -import qualified Ldap.Client as Ldap + +import qualified Data.ByteString as ByteString +import qualified Data.CaseInsensitive as CI +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import qualified Data.ByteString as ByteString -import qualified Data.Set as Set -import qualified Data.Map as Map import qualified Data.UUID as UUID +import Foundation.Authorization (AuthorizationCacheKey(..)) +import Foundation.I18n +import Foundation.Type +import Foundation.Types + +import Handler.Utils.LdapSystemFunctions +import Handler.Utils.Memcached +import Handler.Utils.Profile + +import qualified Ldap.Client as Ldap + +import Yesod.Auth.Message + authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , YesodAuth UniWorX, UserId ~ AuthId UniWorX + , YesodAuth UniWorX, UserAuthId ~ AuthId UniWorX ) - => Creds UniWorX -> m (AuthenticationResult UniWorX) + => Creds UniWorX + -> m (AuthenticationResult UniWorX) authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only now <- liftIO getCurrentTime + userAuthConf <- getsYesod $ view _appUserAuthConf let - uAuth = UniqueAuthentication $ CI.mk credsIdent + uAuth = UniqueExternalAuth $ CI.mk credsIdent upsertMode = creds ^? _upsertUserMode isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode @@ -68,46 +73,47 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend = return res excHandlers = - [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent + [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of + LdapUserNoResult -> do + $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent + LdapUserAmbiguous -> do + $logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do $logErrorS "Auth" $ tshow err mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError - , C.Handler $ \(cExc :: CampusUserConversionException) -> do + excRecovery . ServerError $ mr MsgInternalLoginError + -- TODO: handle azure exceptions or generalize LdapUserException + , C.Handler $ \(cExc :: UserConversionException) -> do $logErrorS "Auth" $ tshow cExc mr <- getMessageRender excRecovery . ServerError $ mr cExc ] + -- | Authenticate already existing ExternalUser entries only acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) acceptExisting = do res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth case res of - Authenticated uid - -> associateUserSchoolsByTerms uid + Authenticated euid + -> associateUserSchoolsByTerms euid _other -> return () case res of Authenticated uid - | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + | not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} + $logDebugS "Auth" $ tshow Creds{..} - userSourceConf <- getsYesod $ view _appUserSourceConf - flip catches excHandlers $ case userSourceConf of - UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) + flip catches excHandlers $ case userAuthConf of + UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf) | Just upsertMode' <- upsertMode -> do azureData <- azureUser azureConf Creds{..} $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData - UserSourceConfSingleSource (UserSourceLdap _) + UserAuthConfSingleSource (AuthSourceConfLdap _) | Just upsertMode' <- upsertMode -> do ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} @@ -117,16 +123,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend -> acceptExisting -data CampusUserConversionException - = CampusUserInvalidIdent - | CampusUserInvalidEmail - | CampusUserInvalidDisplayName - | CampusUserInvalidGivenName - | CampusUserInvalidSurname - | CampusUserInvalidTitle - -- | CampusUserInvalidMatriculation - | CampusUserInvalidFeaturesOfStudy Text - | CampusUserInvalidAssociatedSchools Text +data UserConversionException + = UserInvalidIdent + | UserInvalidEmail + | UserInvalidDisplayName + | UserInvalidGivenName + | UserInvalidSurname + | UserInvalidTitle + | UserInvalidFeaturesOfStudy Text + | UserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) @@ -138,17 +143,17 @@ _upsertUserMode mMode cs@Creds{..} | credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) where - setMode UpsertUserLoginAzure + setMode UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra? = cs{ credsPlugin = apAzure } - setMode UpsertUserLoginLdap + setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra? = cs{ credsPlugin = apLdap } - setMode (UpsertUserLoginDummy ident) + setMode UpsertUserLoginDummy{..} = cs{ credsPlugin = apDummy - , credsIdent = CI.original ident + , credsIdent = CI.original upsertUserIdent } - setMode (UpsertUserLoginOther ident) - = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) - , credsIdent = CI.original ident + setMode UpsertUserLoginOther{..} + = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure]) + , credsIdent = CI.original upsertUserIdent } setMode _ = cs @@ -165,27 +170,29 @@ ldapLookupAndUpsert :: forall m. -> SqlPersistT m (Entity User) ldapLookupAndUpsert ident = getsYesod (view _appLdapPool) >>= \case - Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." + Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." Just ldapPool -> ldapUser'' ldapPool ident >>= \case - Nothing -> throwM CampusUserNoResult + Nothing -> throwM LdapUserNoResult Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse --- | Upsert User DB according to given LDAP data (does not query LDAP itself) -upsertLdapUser :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -upsertLdapUser upsertMode ldapData = do +-- | Upsert ExternalUser DB according to given external source data (does not query source itself) +upsertUser :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> SqlPersistT m (Entity ExternalAuth) +upsertUser upsertMode = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? - oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] + oldUsers <- selectKeysList [ ExternalUserIdent ==. externalUserIdent newUser ] [] user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate @@ -220,55 +227,56 @@ upsertLdapUser upsertMode ldapData = do return user -- | Upsert User DB according to given Azure data (does not query Azure itself) --- TODO: maybe merge with upsertLdapUser -upsertAzureUser :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User) -upsertAzureUser upsertMode azureData = do - now <- liftIO getCurrentTime - userDefaultConf <- getsYesod $ view _appUserDefaults - - (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData - --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? - - oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] [] - - user@(Entity userId userRec) <- case oldUsers of - Just [oldUserId] -> updateGetEntity oldUserId userUpdate - _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate - unless (validDisplayName (newUser ^. _userTitle) - (newUser ^. _userFirstName) - (newUser ^. _userSurname) - (userRec ^. _userDisplayName)) $ - update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] - when (validEmail' (userRec ^. _userEmail)) $ do - let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] - ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ] - unless (null emUps) $ update userId emUps - -- Attempt to update ident, too: - unless (validEmail' (userRec ^. _userIdent)) $ - void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) - - let - userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' - userSystemFunctions' = do - (_k, v) <- azureData - -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way? - v' <- v - Right str <- return $ Text.decodeUtf8' v' - assertM' (not . Text.null) $ Text.strip str - - iforM_ userSystemFunctions $ \func preset -> do - memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) - if | preset -> void $ upsert (UserSystemFunction userId func False False) [] - | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - - return user +-- upsertAzureUser :: forall m. +-- ( MonadHandler m, HandlerSite m ~ UniWorX +-- , MonadCatch m +-- ) +-- => UpsertUserMode +-- -> [(Text, [ByteString])] +-- -> SqlPersistT m (Entity User) +-- upsertAzureUser upsertMode azureData = do +-- now <- liftIO getCurrentTime +-- userDefaultConf <- getsYesod $ view _appUserDefaults +-- +-- (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData +-- --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? +-- +-- oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] [] +-- +-- user@(Entity userId userRec) <- case oldUsers of +-- Just [oldUserId] -> updateGetEntity oldUserId userUpdate +-- _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate +-- unless (validDisplayName (newUser ^. _userTitle) +-- (newUser ^. _userFirstName) +-- (newUser ^. _userSurname) +-- (userRec ^. _userDisplayName)) $ +-- update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] +-- when (validEmail' (userRec ^. _userEmail)) $ do +-- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] +-- ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ] +-- unless (null emUps) $ update userId emUps +-- -- Attempt to update ident, too: +-- unless (validEmail' (userRec ^. _userIdent)) $ +-- void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) +-- +-- let +-- userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' +-- userSystemFunctions' = do +-- (_k, v) <- azureData +-- -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way? +-- v' <- v +-- Right str <- return $ Text.decodeUtf8' v' +-- assertM' (not . Text.null) $ Text.strip str +-- +-- iforM_ userSystemFunctions $ \func preset -> do +-- memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) +-- if | preset -> void $ upsert (UserSystemFunction userId func False False) [] +-- | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] +-- +-- return user decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) - => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) + => Maybe UserIdent -> Ldap.AttrList [] -> m (Either UserConversionException (User, [Update User])) decodeLdapUserTest mbIdent ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults @@ -276,107 +284,46 @@ decodeLdapUserTest mbIdent ldapData = do try $ decodeLdapUser now userDefaultConf mode ldapData decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) - => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (User, [Update User])) + => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either UserConversionException (User, [Update User])) decodeAzureUserTest mbIdent azureData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent try $ decodeAzureUser now userDefaultConf mode azureData -decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_) -decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do - let - userTelephone = decodeLdap ldapUserTelephone - userMobile = decodeLdap ldapUserMobile - userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer - userCompanyDepartment = decodeLdap ldapUserFraportAbteilung - - userAuthentication - | is _UpsertUserLoginOther upsertMode - = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") - | otherwise = AuthLDAP - userLastAuthentication = guardOn isLogin now - isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . 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 - , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode - -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertUserIdent - -> return userIdent' - | otherwise - -> throwM CampusUserInvalidIdent - - userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail - -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above! - -- -> return $ CI.mk userEmail - | otherwise - -> throwM CampusUserInvalidEmail - - userLdapPrimaryKey <- if +decodeLdapUser :: ( MonadThrow m + ) + => UTCTime -- ^ Now + -> UpsertUserMode + -> Ldap.AttrList [] -- ^ Raw LDAP data + -> m (ExternalAuth,_) -- ^ Data for new ExternalUser entry and updating existing ExternalUser entry +decodeLdapUser now upsertMode ldapData = do + externalAuthIdent <- if | [bs] <- ldapMap !!! ldapPrimaryKey - , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs - , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' - -> return $ Just userLdapPrimaryKey''' + , Right ldapPrimaryKey' <- Text.decodeUtf8' bs + , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey' + -> return ldapPrimaryKey'' | otherwise - -> return Nothing + -> throwM ExternalUserInvalidIdent + + let externalAuthData = encode ldapData + + externalAuthLastAuth <- if + | is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode + -> Nothing + | otherwise + -> Just now let - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userSex = Nothing - , userBirthday = Nothing - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , userAzurePrimaryKey = Nothing - , userLastAzureSynchronisation = Nothing - , 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 - , userPostLastUpdate = Nothing - , userPinPassword = Nothing -- must be derived via AVS - , userPrefersPostal = userDefaultPrefersPostal + newUser = ExternalAuth + { externalAuthSource = ldapSourceIdent + , externalAuthLastSync = now , .. } - userUpdate = - [ UserLastAuthentication =. Just now | isLogin ] ++ - [ UserEmail =. userEmail | validEmail' userEmail ] ++ - [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName - UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserLastLdapSynchronisation =. Just now - , UserLdapPrimaryKey =. userLdapPrimaryKey - , UserMobile =. userMobile - , UserTelephone =. userTelephone - , UserCompanyPersonalNumber =. userCompanyPersonalNumber - , UserCompanyDepartment =. userCompanyDepartment + userUpdate = + [ ExternalAuthIdent =. externalAuthIdent + , ExternalAuthData =. externalAuthData + , ExternalAuthLastSync =. now ] return (newUser, userUpdate) @@ -414,6 +361,133 @@ decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do -- | otherwise = throwM err -- where -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) +-- decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_) +-- decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do +-- let +-- userTelephone = decodeLdap ldapUserTelephone +-- userMobile = decodeLdap ldapUserMobile +-- userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer +-- userCompanyDepartment = decodeLdap ldapUserFraportAbteilung +-- +-- userAuthentication +-- | is _UpsertUserLoginOther upsertMode +-- = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") +-- | otherwise = AuthLDAP +-- userLastAuthentication = guardOn isLogin now +-- isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . 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 +-- , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode +-- -> return userIdent' +-- | Just userIdent' <- upsertMode ^? _upsertUserIdent +-- -> return userIdent' +-- | otherwise +-- -> throwM CampusUserInvalidIdent +-- +-- userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail +-- -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above! +-- -- -> return $ CI.mk userEmail +-- | otherwise +-- -> throwM CampusUserInvalidEmail +-- +-- -- TODO: ExternalUser +-- 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 +-- , userBirthday = Nothing +-- , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced +-- , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels +-- , userNotificationSettings = def +-- , userLanguages = Nothing +-- , userCsvOptions = def +-- , userTokensIssuedAfter = Nothing +-- , userCreated = 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 +-- , userPostLastUpdate = Nothing +-- , userPinPassword = Nothing -- must be derived via AVS +-- , userPrefersPostal = userDefaultPrefersPostal +-- , .. +-- } +-- userUpdate = +-- [ UserLastAuthentication =. Just now | isLogin ] ++ +-- [ UserEmail =. userEmail | validEmail' userEmail ] ++ +-- [ +-- -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName +-- UserFirstName =. userFirstName +-- , UserSurname =. userSurname +-- , UserMobile =. userMobile +-- , UserTelephone =. userTelephone +-- , UserCompanyPersonalNumber =. userCompanyPersonalNumber +-- , UserCompanyDepartment =. userCompanyDepartment +-- ] +-- return (newUser, userUpdate) +-- +-- where +-- ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString +-- ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) +-- +-- -- 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) decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_) decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do @@ -433,7 +507,7 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName userSurname = decodeAzure' azureUserSurname -- CampusUserInvalidSurname - userDisplayName <- decodeAzure1 azureUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName + userDisplayName <- decodeAzure1 azureUserDisplayName UserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) @@ -446,14 +520,14 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do | Just userIdent' <- upsertMode ^? _upsertUserIdent -> return userIdent' | otherwise - -> throwM CampusUserInvalidIdent + -> throwM UserInvalidIdent userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail -- -> return $ CI.mk userEmail | otherwise - -> throwM CampusUserInvalidEmail + -> throwM UserInvalidEmail -- TODO: use fromASCIIBytes / fromByteString? userAzurePrimaryKey <- if @@ -485,9 +559,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now - , userLastAzureSynchronisation = Just now - , userLdapPrimaryKey = Nothing - , userLastLdapSynchronisation = Nothing , userDisplayName = userDisplayName , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO @@ -504,8 +575,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 UserFirstName =. userFirstName , UserSurname =. userSurname - , UserLastAzureSynchronisation =. Just now - , UserAzurePrimaryKey =. userAzurePrimaryKey , UserMobile =. userMobile , UserTelephone =. userTelephone , UserCompanyPersonalNumber =. userCompanyPersonalNumber @@ -582,4 +651,4 @@ updateUserLanguage Nothing = runMaybeT $ do setRegisteredCookie CookieLang lang return lang -embedRenderMessage ''UniWorX ''CampusUserConversionException id +embedRenderMessage ''UniWorX ''UserConversionException id