diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 2bd046479..47e210866 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Steffen Jost ,David Mosbach +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Steffen Jost , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Yesod.Auth ( authenticate - , oAuthenticate - , ldapLookupAndUpsert - , upsertCampusUser - , decodeUserTest + -- , ldapLookupAndUpsert + , upsertLdapUser, upsertAzureUser + , decodeLdapUserTest, decodeAzureUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage ) where @@ -37,19 +36,8 @@ 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.Conduit.Combinators as C - --- import qualified Data.List as List ((\\)) - --- import qualified Data.UUID as UUID --- import Data.ByteArray (convert) --- import Crypto.Hash (SHAKE128) --- import qualified Data.Binary as Binary - --- import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.Utils as E - --- import Crypto.Hash.Conduit (sinkHash) +import qualified Data.List.PointedList as PointedList +import qualified Data.UUID as UUID authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX @@ -58,15 +46,16 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX ) => Creds UniWorX -> m (AuthenticationResult UniWorX) authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do - $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only + now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode + upsertMode = creds ^? _upsertUserMode - isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode + isOther = is (_Just . _UpsertUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -82,17 +71,17 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend excHandlers = [ C.Handler $ \case CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do - $logErrorS "LDAP" $ tshow err + $logErrorS "Auth" $ tshow err mr <- getMessageRender excRecovery . ServerError $ mr MsgInternalLdapError , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc + $logErrorS "Auth" $ tshow cExc mr <- getMessageRender excRecovery . ServerError $ mr cExc ] @@ -110,92 +99,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - ldapPool' <- getsYesod $ view _appLdapPool + $logDebugS "auth" $ tshow Creds{..} - flip catches excHandlers $ case ldapPool' of - Just ldapPool + userdbConf <- getsYesod $ view _appUserDbConf + flip catches excHandlers $ case userdbConf of + UserDbSingleSource (UserDbAzureAdV2 azureConf) | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} - $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData + azureData <- oauth2User azureConf Creds{..} + $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData + Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData + UserDbSingleSource (UserDbLdap _) + | Just upsertMode' <- upsertMode -> do + -- TODO WIP + ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool + ldapConf <- mkFailover $ PointedList.singleton ldapPool + ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} + $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData + Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData _other -> acceptExisting --- | Authentication via AzureADv2 / OAuth 2 -oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX - , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , YesodAuth UniWorX, UserId ~ AuthId UniWorX - ) - => Creds UniWorX -> m (AuthenticationResult UniWorX) -oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do - $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" - now <- liftIO getCurrentTime - - let - uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertAzureUserMode - - isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server - isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode - - excRecovery res - | isDummy || isOther - = do - case res of - UserError err -> addMessageI Error err - ServerError err -> addMessage Error $ toHtml err - _other -> return () - acceptExisting - | otherwise - = return res - - excHandlers = - [ C.Handler $ \case - AzureUserNoResult -> do - $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - AzureUserAmbiguous -> do - $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "OAuth" $ tshow err - mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from? - , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not? - $logErrorS "OAuth" $ tshow cExc - mr <- getMessageRender - excRecovery . ServerError $ mr cExc - ] - - acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) - acceptExisting = do - res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - case res of - Authenticated uid - -> associateUserSchoolsByTerms uid - _other - -> return () - case res of - Authenticated uid - | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] - _other -> return res - - $logDebugS "oauth" $ tshow creds - -- TODO If user not in DB then put - pool <- getsYesod $ view _appLdapPool - flip catches excHandlers $ case pool of - Just ldapPool - | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode creds - $logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData - Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData - _other - -> acceptExisting - - - data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail @@ -209,19 +133,23 @@ data CampusUserConversionException deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) -_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode -_upsertCampusUserMode mMode cs@Creds{..} - | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent) - | credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap - | otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent) + +_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode +_upsertUserMode mMode cs@Creds{..} + | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent) + | credsPlugin == apAzure = setMode <$> mMode UpsertUserLoginAzure + | credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap + | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) where - setMode UpsertCampusUserLoginLdap + setMode UpsertUserLoginAzure + = cs{ credsPlugin = apAzure } + setMode UpsertUserLoginLdap = cs{ credsPlugin = apLdap } - setMode (UpsertCampusUserLoginDummy ident) + setMode (UpsertUserLoginDummy ident) = cs{ credsPlugin = apDummy , credsIdent = CI.original ident } - setMode (UpsertCampusUserLoginOther ident) + setMode (UpsertUserLoginOther ident) = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) , credsIdent = CI.original ident } @@ -230,73 +158,28 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash -_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode -_upsertAzureUserMode mMode cs@Creds{..} - | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent) - | credsPlugin == "azureadv2" = setMode <$> mMode UpsertAzureUserLoginOAuth - | otherwise = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent) - where - setMode UpsertAzureUserLoginOAuth - = cs{ credsPlugin = "azureadv2" } - setMode (UpsertAzureUserLoginDummy ident) - = cs{ credsPlugin = mockPluginName - , credsIdent = CI.original ident - } - setMode (UpsertAzureUserLoginOther ident) - = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2") - , credsIdent = CI.original ident - } - setMode _ = cs +-- TODO: rewrite +-- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) +-- ldapLookupAndUpsert ident = +-- getsYesod (view _appLdapPool) >>= \case +-- Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." +-- Just ldapPool -> +-- campusUser'' ldapPool campusUserFailoverMode ident >>= \case +-- Nothing -> throwM CampusUserNoResult +-- Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse - defaultOther = apHash - - - -ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) -ldapLookupAndUpsert ident = - getsYesod (view _appLdapPool) >>= \case - Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." - Just ldapPool -> - campusUser'' ldapPool campusUserFailoverMode ident >>= \case - Nothing -> throwM CampusUserNoResult - Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse - - -upsertAzureUser :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant -upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode) - where - toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode - toCampus UpsertAzureUserLoginOAuth = UpsertCampusUserLoginLdap - toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u - toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u - toCampus (UpsertAzureUserOAuthSync u) = UpsertCampusUserLdapSync u - toCampus UpsertAzureUserGuessUser = UpsertCampusUserGuessUser - - -{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP! -upsertCampusUserByCn :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadThrow m - ) - => Text -> SqlPersistT m (Entity User) -upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] --} -- | Upsert User DB according to given LDAP data (does not query LDAP itself) -upsertCampusUser :: forall m. +upsertLdapUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadCatch m ) - => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -upsertCampusUser upsertMode ldapData = do + => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) +upsertLdapUser upsertMode ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults - (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData + (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 ] [] @@ -333,17 +216,72 @@ upsertCampusUser upsertMode ldapData = do return user -decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) +-- | 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 + +decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) -decodeUserTest mbIdent ldapData = do +decodeLdapUserTest mbIdent ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults - let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent - try $ decodeUser now userDefaultConf mode ldapData + let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent + try $ decodeLdapUser now userDefaultConf mode ldapData +decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (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 -decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) -decodeUser now UserDefaultConf{..} upsertMode ldapData = do +decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_) +decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone userMobile = decodeLdap ldapUserMobile @@ -351,11 +289,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userCompanyDepartment = decodeLdap ldapUserFraportAbteilung userAuthentication - | is _UpsertCampusUserLoginOther upsertMode + | 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 (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode + isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName @@ -368,9 +306,9 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userIdent <- if | [bs] <- ldapMap !!! ldapUserPrincipalName , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode + , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent + | Just userIdent' <- upsertMode ^? _upsertUserIdent -> return userIdent' | otherwise -> throwM CampusUserInvalidIdent @@ -412,6 +350,8 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do , 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 @@ -425,7 +365,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do [ UserLastAuthentication =. Just now | isLogin ] ++ [ UserEmail =. userEmail | validEmail' userEmail ] ++ [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName UserFirstName =. userFirstName , UserSurname =. userSurname , UserLastLdapSynchronisation =. Just now @@ -472,6 +412,123 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do -- where -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) +decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_) +decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do + let + userTelephone = decodeAzure azureUserTelephone + userMobile = decodeAzure azureUserMobile + userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer + userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung + + userAuthentication + | is _UpsertUserLoginOther upsertMode + = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") + | otherwise = AuthAzure + userLastAuthentication = guardOn isLogin now + isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode + + 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 <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) + + userIdent <- if + | [bs] <- azureMap !!! azureUserPrincipalName + , 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 + -- -> return $ CI.mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + + -- TODO: use fromASCIIBytes / fromByteString? + userAzurePrimaryKey <- if + | [bs] <- azureMap !!! azurePrimaryKey + , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs + , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey'' + , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey''' + -> return $ Just userAzurePrimaryKey'''' + | 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 -- TODO: decode and parse preferredLanguages + , 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 + , 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; see line 272 + UserFirstName =. userFirstName + , UserSurname =. userSurname + , UserLastAzureSynchronisation =. Just now + , UserAzurePrimaryKey =. userAzurePrimaryKey + , UserMobile =. userMobile + , UserTelephone =. userTelephone + , UserCompanyPersonalNumber =. userCompanyPersonalNumber + , UserCompanyDepartment =. userCompanyDepartment + ] + return (newUser, userUpdate) + + where + azureMap :: Map.Map Text [ByteString] + azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null)) + + -- just returns Nothing on error, pure + decodeAzure :: Text -> Maybe Text + decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr + + decodeAzure' :: Text -> Text + decodeAzure' = fromMaybe "" . decodeAzure + + -- 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 + decodeAzure1 attr err + | (h:_) <- rights vs = return h + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (azureMap !!! attr) + associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do @@ -486,6 +543,7 @@ associateUserSchoolsByTerms uid = do , userSchoolIsOptOut = False } + updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX