-- 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 , userLookupAndUpsert , upsertUser, maybeUpsertUser , decodeUserTest , DecodeUserException(..) , 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.ByteString as ByteString import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map import qualified Data.List.NonEmpty as NonEmpty (toList) import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , YesodAuth UniWorX, UserId ~ AuthId UniWorX ) => Creds UniWorX -> m (AuthenticationResult UniWorX) authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do $logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds) sess <- getSession $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only now <- liftIO getCurrentTime userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only 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 $ \(fExc :: FetchUserDataException) -> case fExc of FetchUserDataNoResult -> do $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent FetchUserDataAmbiguous -> do $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do $logErrorS "FetchUserException" $ tshow err mr <- getMessageRender excRecovery . ServerError $ mr MsgInternalLoginError , C.Handler $ \(dExc :: DecodeUserException) -> do $logErrorS "Auth" $ tshow dExc mr <- getMessageRender excRecovery . ServerError $ mr dExc ] 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 "Auth" $ tshow Creds{..} flip catches excHandlers $ if | not isDummy, not isOther , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case Just userData -> do $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData Authenticated . entityKey <$> upsertUser upsertMode' userData Nothing -> throwM FetchUserDataNoResult | otherwise -> acceptExisting data DecodeUserException = DecodeUserInvalidIdent | DecodeUserInvalidEmail | DecodeUserInvalidDisplayName | DecodeUserInvalidGivenName | DecodeUserInvalidSurname | DecodeUserInvalidTitle | DecodeUserInvalidFeaturesOfStudy Text | DecodeUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) _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 userLookupAndUpsert :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadMask m , MonadUnliftIO m ) => Text -> UpsertUserMode -> SqlPersistT m (Maybe (Entity User)) userLookupAndUpsert credsIdent mode = fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode data FetchUserDataException = FetchUserDataNoResult | FetchUserDataAmbiguous | FetchUserDataException deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) -- | Fetch user data with given credentials from external source(s) fetchUserData :: forall m site. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m , MonadMask m , MonadUnliftIO m ) => Creds site -> SqlPersistT m (Maybe (NonEmpty UpsertUserData)) fetchUserData Creds{..} = do userAuthConf <- getsYesod $ view _appUserAuthConf now <- liftIO getCurrentTime results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..} Left _ -> return Nothing AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent Nothing -> throwM FetchUserDataException -- insert ExternalUser entries for each fetched dataset whenIsJust results $ \ress -> forM_ ress $ \res -> do let externalUserLastSync = now (externalUserData, externalUserSource) = case res of UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId) UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost) externalUserUser <- if | UpsertUserDataAzure{..} <- res , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> second (filter (not . ByteString.null)) , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName -> return $ CI.mk azureUserPrincipalName' | UpsertUserDataLdap{..} <- res , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null)) , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey -> return $ CI.mk ldapPrimaryKey' | otherwise -> throwM DecodeUserInvalidIdent void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync] return results -- | Upsert User and related auth in DB according to given external source data (does not query source itself) maybeUpsertUser :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => UpsertUserMode -> Maybe (NonEmpty UpsertUserData) -> SqlPersistT m (Maybe (Entity User)) maybeUpsertUser _upsertMode Nothing = return Nothing maybeUpsertUser _upsertMode (Just 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 (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions' = concat $ upsertData <&> \case 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] return $ Just user upsertUser :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => UpsertUserMode -> NonEmpty UpsertUserData -> SqlPersistT m (Entity User) upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case Nothing -> error "upsertUser: No user result from maybeUpsertUser!" Just user -> return user decodeUser :: ( MonadThrow m ) => UTCTime -- ^ Now -> UserDefaultConf -> NonEmpty 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 DecodeUserInvalidIdent let (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages) | Just azureData <- mbAzureData = ( azureData `decodeAzure` azureUserSurname , azureData `decodeAzure` azureUserGivenName , azureData `decodeAzure` azureUserDisplayName , azureData `decodeAzure` azureUserMail , azureData `decodeAzure` azureUserTelephone , azureData `decodeAzure` azureUserMobile , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage ) | otherwise = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing ) (ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment) | Just ldapData <- mbLdapData = ( ldapData `decodeLdap` ldapUserSurname , ldapData `decodeLdap` ldapUserFirstName , ldapData `decodeLdap` ldapUserDisplayName , ldapData `decodeLdap` Ldap.Attr "mail" -- TODO: use ldapUserEmail? , ldapData `decodeLdap` ldapUserTelephone , ldapData `decodeLdap` ldapUserMobile , ldapData `decodeLdap` ldapUserFraportPersonalnummer , ldapData `decodeLdap` ldapUserFraportAbteilung ) | otherwise = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing ) -- TODO: throw on collisions? -- TODO: use user-auth precedence from app config when implementing multi-source support let userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail userTelephone = azureTelephone <|> ldapTelephone userMobile = azureMobile <|> ldapMobile userLanguages = azureLanguages userCompanyPersonalNumber = ldapCompanyPersonalNumber userCompanyDepartment = ldapCompanyDepartment 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 , 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 , userPasswordHash = Nothing , userLastAuthentication = Nothing , userCreated = now , userLastSync = Just now , .. } 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 , UserLastSync =. Just now ] return (newUser, userUpdate) where mbAzureData :: Maybe (Map Text [ByteString]) mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData -- 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) decodeUserTest :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => NonEmpty UpsertUserData -> m (Either DecodeUserException (User, [Update User])) decodeUserTest decodeData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults try $ decodeUser now userDefaultConf decodeData associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do 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 ''DecodeUserException id