From aca5a79de26ac4ae552b9359a60fd9f081013bb0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 7 Mar 2024 05:38:39 +0100 Subject: [PATCH] chore(auth): implement fetchUserData, generalized version of azureUser and ldapUser --- src/Auth/LDAP.hs | 2 + src/Auth/OAuth2.hs | 68 +++++++---- src/Foundation/Yesod/Auth.hs | 223 +++++++++++++++++++++-------------- 3 files changed, 182 insertions(+), 111 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index f14e60683..036d40b17 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -116,6 +116,7 @@ ldapUserEmail = Ldap.Attr "mail" :| ] +-- TODO: deprecate in favour of FetchUserDataException data LdapUserException = LdapUserLdapError LdapPoolError | LdapUserNoResult | LdapUserAmbiguous @@ -182,6 +183,7 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ld -- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey +-- TODO: deprecate in favour of fetchUserData ldapUser :: ( MonadMask m , MonadUnliftIO m --, MonadLogger m diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 6d3847104..8d217cbf3 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -7,7 +7,7 @@ module Auth.OAuth2 ( apAzure , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage - , azureUser, azureUser' + -- , azureUser, azureUser' , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous , apAzureMock , azureMockServer @@ -15,7 +15,7 @@ module Auth.OAuth2 , refreshOAuth2Token ) where -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import Data.Maybe (fromJust) import Data.Text @@ -33,6 +33,7 @@ apAzure :: Text apAzure = "AzureADv2" +-- TODO: deprecate in favour of FetchUserDataException data AzureUserException = AzureUserError | AzureUserNoResult | AzureUserAmbiguous @@ -56,28 +57,49 @@ azureUserPreferredLanguage = "preferredLanguage" -- | User lookup in Microsoft Graph with given credentials -azureUser :: ( MonadMask m - , MonadHandler m - ) - => AzureConf - -> Creds site - -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) -azureUser _conf Creds{..} = fmap throwLeft . runExceptT $ do - results <- queryOAuth2User @[(Text, [ByteString])] credsIdent - case results of - Left _ -> throwE AzureUserNoResult - Right [res] -> return res - Right _multiple -> throwE AzureUserAmbiguous +-- TODO: deprecate in favour of fetchUserData +-- azureUser :: ( MonadMask m +-- , MonadHandler m +-- -- , HandlerSite m ~ site +-- -- , BackendCompatible SqlBackend (YesodPersistBackend site) +-- -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend +-- -- , YesodPersist site +-- -- , PersistUniqueWrite (YesodPersistBackend site) +-- ) +-- => AzureConf +-- -> Creds site +-- -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) +-- azureUser AzureConf{..} Creds{..} = fmap throwLeft . runExceptT $ do +-- now <- liftIO getCurrentTime +-- results <- queryOAuth2User @[(Text, [ByteString])] credsIdent +-- case results of +-- Right [res] -> do +-- -- void . liftHandler . runDB $ upsert ExternalUser +-- -- { externalUserUser = error "no userid" -- TODO: use azureUserPrimaryKey once UserIdent is referenced instead of UserId +-- -- , externalUserSource = AuthSourceIdAzure azureConfClientId +-- -- , externalUserData = toJSON res +-- -- , externalUserLastSync = now +-- -- } +-- -- [ ExternalUserData =. toJSON res +-- -- , ExternalUserLastSync =. now +-- -- ] +-- return res +-- Right _multiple -> throwE AzureUserAmbiguous +-- Left _ -> throwE AzureUserNoResult -- | User lookup in Microsoft Graph with given user -azureUser' :: ( MonadMask m - , MonadHandler m - ) - => AzureConf - -> User - -> m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])]) -azureUser' conf User{userIdent} - = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) []) +-- azureUser' :: ( MonadMask m +-- , MonadHandler m +-- , HandlerSite m ~ site +-- , BaseBackend (YesodPersistBackend site) ~ SqlBackend +-- , YesodPersist site +-- , PersistUniqueWrite (YesodPersistBackend site) +-- ) +-- => AzureConf +-- -> User +-- -> ReaderT (YesodPersistBackend site) m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])]) +-- azureUser' conf User{userIdent} +-- = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) []) ---------------------------------------- @@ -183,7 +205,7 @@ refreshOAuth2Token (_, rToken) url secure clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID" clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET" return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")] - else return $ ("scope", "ID Profile") : body + else return $ scopeParam " " ["ID","Profile"] : body $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) case eResult of diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 69a967e00..bb65f2115 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,7 +4,7 @@ module Foundation.Yesod.Auth ( authenticate - , ldapLookupAndUpsert -- TODO generalize + -- , ldapLookupAndUpsert -- TODO: remove in favour of fetchUserData , upsertUser , decodeUserTest , UserConversionException(..) @@ -35,6 +35,7 @@ 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 @@ -55,7 +56,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only now <- liftIO getCurrentTime - userAuthConf <- getsYesod $ view _appUserAuthConf + userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only let @@ -77,27 +78,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend = return res excHandlers = - -- TODO: merge ldap and azure exception types - [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of - LdapUserNoResult -> do - $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent + [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of + FetchUserDataNoResult -> do + $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent - LdapUserAmbiguous -> do - $logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent + FetchUserDataAmbiguous -> do + $logWarnS "FetchUserException" $ "Multiple User 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 + $logErrorS "FetchUserException" $ tshow err mr <- getMessageRender excRecovery . ServerError $ mr MsgInternalLoginError , C.Handler $ \(cExc :: UserConversionException) -> do @@ -123,22 +112,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend flip catches excHandlers $ if | not isDummy, not isOther - , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf + -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf , Just upsertMode' <- upsertMode -> do - upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} - $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData - Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} - | not isDummy, not isOther - , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf - , 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{..} + userData <- fetchUserData upsertMode' Creds{..} + $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData + Authenticated . entityKey <$> upsertUser upsertMode' userData + -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} + -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} + -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData + -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} + -- | not isDummy, not isOther + -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf + -- , 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{..} | otherwise -> acceptExisting +-- TODO: rename to DecodeUserException (associate with function!) data UserConversionException = UserInvalidIdent | UserInvalidEmail @@ -175,33 +169,75 @@ _upsertUserMode mMode cs@Creds{..} defaultOther = apHash --- TODO: generalize -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 $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." - Just ldapPool@(upsertUserLdapConf, _) -> - ldapUser'' ldapPool ident >>= \case - Nothing -> throwM LdapUserNoResult - Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..} +data FetchUserDataException + = FetchUserDataNoResult + | FetchUserDataAmbiguous + | FetchUserDataException + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Exception) + +-- TODO: deprecate in favour of fetchUserData +-- 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 $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." +-- Just ldapPool -> +-- ldapUser'' ldapPool ident >>= \case +-- Nothing -> throwM LdapUserNoResult +-- Just ldapData -> upsertUser UpsertUserGuessUser ldapData + + +-- | Fetch user data with given credentials from external source(s) +fetchUserData :: forall m site. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> Creds site + -> SqlPersistT m (NonEmpty UpsertUserData) +fetchUserData upsertMode creds@Creds{..} = do + userAuthConf <- getsYesod $ view _appUserAuthConf + now <- liftIO getCurrentTime + + results :: NonEmpty UpsertUserData <- case userAuthConf of + UserAuthConfSingleSource{..} -> fmap throwLeft . runExceptT $ case userAuthConfSingleSource of + AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do + queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case + Right upsertUserAzureData -> return UpsertUserDataAzure{..} + Left _ -> throwE FetchUserDataNoResult + AuthSourceConfLdap LdapConf{..} -> do + ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool + UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds + + -- insert ExternalUser entries for each fetched dataset + forM_ results $ \res -> + let externalUserUser = error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId + externalUserLastSync = now + (externalUserData, externalUserSource) = case res of + UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId) + UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost) + in void . liftHandler . runDB $ 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) upsertUser :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertUserMode - -> UpsertUserData - -> SqlPersistT m (Entity User) + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> NonEmpty UpsertUserData + -> SqlPersistT m (Entity User) upsertUser _upsertMode upsertData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults @@ -234,7 +270,7 @@ upsertUser _upsertMode upsertData = do let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' - userSystemFunctions' = case upsertData of + userSystemFunctions' = concat $ upsertData <&> \case UpsertUserDataAzure{..} -> do (_k, v) <- upsertUserAzureData v' <- v @@ -259,7 +295,7 @@ decodeUser :: ( MonadThrow m ) => UTCTime -- ^ Now -> UserDefaultConf - -> UpsertUserData -- ^ Raw source data + -> NonEmpty UpsertUserData -- ^ Raw source data -> m (User,_) -- ^ Data for new User entry and updating existing User entries decodeUser now UserDefaultConf{..} upsertData = do userIdent <- if @@ -275,35 +311,47 @@ decodeUser now UserDefaultConf{..} upsertData = do -> throwM UserInvalidIdent let - (userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages) + (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages) | 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 + = ( 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 - = error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!" + = ( 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 @@ -349,10 +397,9 @@ decodeUser now UserDefaultConf{..} upsertData = do where mbAzureData :: Maybe (Map Text [ByteString]) - mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData + mbAzureData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList 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) + mbLdapData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData -- just returns Nothing on error, pure decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text @@ -360,10 +407,10 @@ decodeUser now UserDefaultConf{..} upsertData = do 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 + -- 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 @@ -393,7 +440,7 @@ decodeUserTest :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) - => UpsertUserData + => NonEmpty UpsertUserData -> m (Either UserConversionException (User, [Update User])) decodeUserTest decodeData = do now <- liftIO getCurrentTime