-- SPDX-FileCopyrightText: 2023 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 , CampusUserConversionException(..) , campusUserFailoverMode, 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.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.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.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) 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" $ "\a\27[31m" <> tshow creds <> "\27[0m" now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent upsertMode = creds ^? _upsertCampusUserMode isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode isOther = is (_Just . _UpsertCampusUserLoginOther) 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 CampusUserNoResult -> do $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent CampusUserAmbiguous -> do $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do $logErrorS "LDAP" $ tshow err mr <- getMessageRender excRecovery . ServerError $ mr MsgInternalLdapError , C.Handler $ \(cExc :: CampusUserConversionException) -> do $logErrorS "LDAP" $ 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 "auth" $ tshow Creds{..} ldapPool' <- getsYesod $ view _appLdapPool flip catches excHandlers $ case ldapPool' of Just ldapPool | Just upsertMode' <- upsertMode -> do ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData Authenticated . entityKey <$> upsertCampusUser 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 | CampusUserInvalidDisplayName | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle -- | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text 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) where setMode UpsertCampusUserLoginLdap = cs{ credsPlugin = apLdap } setMode (UpsertCampusUserLoginDummy ident) = cs{ credsPlugin = apDummy , credsIdent = CI.original ident } setMode (UpsertCampusUserLoginOther ident) = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) , credsIdent = CI.original ident } setMode _ = cs 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 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. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadCatch m ) => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser 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 ] [] 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 =. 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' = do (k, v) <- ldapData 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 user decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) decodeUserTest mbIdent ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent try $ decodeUser now userDefaultConf mode ldapData decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) decodeUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone userMobile = decodeLdap ldapUserMobile userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer userCompanyDepartment = decodeLdap ldapUserFraportAbteilung userAuthentication | is _UpsertCampusUserLoginOther upsertMode = 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 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 _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode -> return userIdent' | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent -> 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 | [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 , userLastLdapSynchronisation = Just now , userDisplayName = userDisplayName , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , 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 , UserLastLdapSynchronisation =. Just now , UserLdapPrimaryKey =. userLdapPrimaryKey , 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) 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 campusUserFailoverMode :: FailoverMode campusUserFailoverMode = FailoverUnlimited embedRenderMessage ''UniWorX ''CampusUserConversionException id