-- 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 , ldapLookupAndUpsert -- TODO generalize , upsertUser , decodeUserTest , UserConversionException(..) , updateUserLanguage ) where import Import.NoFoundation hiding (authenticate) import Auth.Dummy (apDummy) import Auth.LDAP import Auth.OAuth2 import Auth.PWHash (apHash) 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 Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) import qualified Control.Monad.Catch as C (Handler(..)) -- import qualified Data.Aeson as Json (encode) 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 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, UserAuthId ~ AuthId 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 setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds) sess <- getSession $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" now <- liftIO getCurrentTime userAuthConf <- getsYesod $ view _appUserAuthConf let uAuth = UniqueAuthentication $ CI.mk credsIdent upsertMode = creds ^? _upsertUserMode isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode isOther = is (_Just . _UpsertUserLoginOther) 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 $ \(ldapExc :: LdapUserException) -> case ldapExc of LdapUserNoResult -> do $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound 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 MsgInternalLoginError , 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 MsgInternalLoginError , 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 _other -> return () case res of Authenticated uid | not isDummy -> res <$ update uid [ UserAuthLastLogin =. Just now ] _other -> return res $logDebugS "Auth" $ tshow Creds{..} flip catches excHandlers $ case userAuthConf of UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) | Just upsertMode' <- upsertMode -> do upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) | Just upsertMode' <- upsertMode -> do ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool upsertUserLdapData <- ldapUser ldapPool Creds{..} $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..} _other -> acceptExisting data UserConversionException = UserInvalidIdent | UserInvalidEmail | UserInvalidDisplayName | UserInvalidGivenName | UserInvalidSurname | UserInvalidTitle | UserInvalidFeaturesOfStudy Text | UserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) -- TODO: this is probably not a sane traversal anymore... _upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode _upsertUserMode mMode cs@Creds{..} | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent) | credsPlugin `elem` loginAPs = setMode <$> mMode (UpsertUserLogin credsPlugin) | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) where setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs = cs{ credsPlugin = upsertUserSource } setMode UpsertUserLoginDummy{..} = cs{ credsPlugin = apDummy , credsIdent = CI.original upsertUserIdent } setMode UpsertUserLoginOther{..} = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure]) , credsIdent = CI.original upsertUserIdent } setMode _ = cs loginAPs = [ apAzure, apLdap ] defaultOther = apHash -- TODO: generalize ldapLookupAndUpsert :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadMask m , MonadUnliftIO m ) => Text -> SqlPersistT m (Entity UserAuth) ldapLookupAndUpsert ident = getsYesod (view _appLdapPool) >>= \case Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." Just ldapPool@(upsertUserLdapConf, _) -> ldapUser'' ldapPool ident >>= \case Nothing -> throwM LdapUserNoResult Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..} -- | Upsert User and related auth in DB according to given external source data (does not query source itself) upsertUser :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => UpsertUserMode -> UpsertUserData -> SqlPersistT m (Entity UserAuth) upsertUser upsertMode upsertData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertData --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 <- selectKeysList [ UserIdent ==. userIdent newUser ] [] _user@(Entity userId userRec) <- case oldUsers of [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate -- sets display name -- TODO: use display name from external source, if possible unless (validDisplayName (newUser ^. _userTitle) (newUser ^. _userFirstName) (newUser ^. _userSurname) (userRec ^. _userDisplayName)) $ update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure) -- when (validEmail' (userRec ^. _userEmail)) $ do -- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] -- ++ [ UserAuthentication =. AuthLDAP | 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' = case upsertData of UpsertUserDataAzure{..} -> do (_k, v) <- upsertUserAzureData v' <- v Right str <- return $ Text.decodeUtf8' v' assertM' (not . Text.null) $ Text.strip str UpsertUserDataLdap{..} -> do (k, v) <- upsertUserLdapData guard $ k == ldapAffiliation 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] let (userAuthLastLogin, userAuthLastSync) = case upsertMode of UpsertUserSync{} -> (Nothing , Just now) UpsertUserGuessUser{} -> (Nothing , Nothing ) _other -> (Just now, Nothing ) userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $ [ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++ [ UserAuthLastSync =. Just lastSync | lastSync <- maybeToList userAuthLastSync ] return userAuth -- | Upsert User DB according to given Azure data (does not query Azure itself) -- 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 decodeUserTest :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => UpsertUserData -> m (Either UserConversionException (User, [Update User])) decodeUserTest decodeData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults try $ decodeUser now userDefaultConf decodeData decodeUser :: ( MonadThrow m ) => UTCTime -- ^ Now -> UserDefaultConf -> UpsertUserData -- ^ Raw source data -> m (User,_) -- ^ Data for new User entry and updating existing User entries decodeUser now UserDefaultConf{..} upsertData = do userIdent <- if | Just azureData <- mbAzureData , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName' -> return $ CI.mk azureUserPrincipalName'' | Just ldapData <- mbLdapData , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey' -> return $ CI.mk ldapPrimaryKey'' | otherwise -> throwM UserInvalidIdent let (userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages) | Just azureData <- mbAzureData = ( azureData `decodeAzure'` azureUserSurname , azureData `decodeAzure'` azureUserGivenName , azureData `decodeAzure'` azureUserDisplayName , CI.mk $ azureData `decodeAzure'` azureUserMail , azureData `decodeAzure` azureUserTelephone , azureData `decodeAzure` azureUserMobile , Nothing -- userCompanyPersonalNumber not contained in Azure response , Nothing -- userCompanyDepartment not contained in Azure response , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage ) | Just ldapData <- mbLdapData = ( ldapData `decodeLdap'` ldapUserSurname , ldapData `decodeLdap'` ldapUserFirstName , ldapData `decodeLdap'` ldapUserDisplayName , CI.mk $ ldapData `decodeLdap'` (Ldap.Attr "mail") -- TODO: use ldapUserEmail? , ldapData `decodeLdap` ldapUserTelephone , ldapData `decodeLdap` ldapUserMobile , ldapData `decodeLdap` ldapUserFraportPersonalnummer , ldapData `decodeLdap` ldapUserFraportAbteilung , Nothing -- userLanguage not contained in LDAP response ) | otherwise = error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!" 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 , userTitle = Nothing , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS , userPostAddress = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS , userPostLastUpdate = Nothing , userPinPassword = Nothing -- must be derived via AVS , userPrefersPostal = userDefaultPrefersPostal , .. } userUpdate = [ UserSurname =. userSurname , UserFirstName =. userFirstName -- , UserDisplayName =. userDisplayName -- not updated, since users are allowed to change their DisplayName , UserEmail =. userEmail , UserTelephone =. userTelephone , UserMobile =. userMobile , UserCompanyPersonalNumber =. userCompanyPersonalNumber , UserCompanyDepartment =. userCompanyDepartment ] return (newUser, userUpdate) where mbAzureData :: Maybe (Map Text [ByteString]) mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString mbLdapData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserLdapData upsertData -- ldapData = fmap (Map.fromListWith (++)) $ upsertData ^? _upsertUserLdapData . over _2 (filter $ not . ByteString.null) -- just returns Nothing on error, pure decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr decodeAzure' :: Map Text [ByteString] -> Text -> Text decodeAzure' azureData = fromMaybe "" . decodeAzure azureData decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData -- 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 ldapData attr err -- | (h:_) <- rights vs = return h -- | otherwise = throwM err -- where -- vs = Text.decodeUtf8' <$> (ldapData !!! 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) -- 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 -- let -- userTelephone = decodeAzure azureUserTelephone -- userMobile = decodeAzure azureUserMobile -- userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer -- userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung -- -- userAuthentication -- | is _UpsertUserLoginOther upsertMode -- = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") -- TODO throwM instead? -- | 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 UserInvalidDisplayName <&> 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 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 UserInvalidEmail -- -- -- 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 -- , 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 -- , 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 => UserAuthId -> SqlPersistT m () associateUserSchoolsByTerms uaid = do uid <- join $ fmap (fromMaybe $ error "associateUserSchoolsByTerms: No User for given UserAuthId!") . getKeyBy . UniqueUser . userAuthIdent <$> getJust uaid sfs <- selectList [StudyFeaturesUser ==. uid] [] forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] [] forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) -> void $ insertUnique UserSchool { userSchoolUser = uid , userSchoolSchool = schoolTermsSchool , userSchoolIsOptOut = False } updateUserLanguage :: ( MonadHandler m , HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX ) => Maybe Lang -> SqlPersistT m (Maybe Lang) updateUserLanguage (Just lang) = do unless (lang `elem` appLanguages) $ invalidArgs ["Unsupported language"] muid <- maybeAuthId for_ muid $ \uid -> do langs <- languages update uid [ UserLanguages =. Just (Languages $ lang : nubOrd (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ] setRegisteredCookie CookieLang lang return $ Just lang updateUserLanguage Nothing = runMaybeT $ do uid <- MaybeT maybeAuthId User{..} <- MaybeT $ get uid setLangs <- toList . selectLanguages appLanguages <$> languages highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped lang <- case (userLanguages', setLangs, highPrioSetLangs) of (_, _, hpl : _) -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ] (Just (l : _), _, _) -> return l (Nothing, l : _, _) -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ] (Just [], l : _, _) -> return l (_, [], _) -> mzero setRegisteredCookie CookieLang lang return lang embedRenderMessage ''UniWorX ''UserConversionException id