From 9b9370fed0f55098163b55d88aea5fd55ffd736c Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Dec 2023 15:06:39 +0000 Subject: [PATCH] feat(auth): WIP authorization function --- src/Auth/OAuth2.hs | 9 ++--- src/Foundation/Types.hs | 18 +++++++++- src/Foundation/Yesod/Auth.hs | 67 +++++++++++++++++++++++++----------- 3 files changed, 69 insertions(+), 25 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 30a75a206..9b4efdd5d 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Auth.OAuth2 -( OAuthUserException(..) +( AzureUserException(..) , oauth2MockServer , mockPluginName ) where @@ -18,11 +18,12 @@ import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2.Prelude -data OAuthUserException = OAuthUserError - | OAuthUserAmbiguous -- TODO +data AzureUserException = AzureUserError + | AzureUserNoResult + | AzureUserAmbiguous -- TODO deriving (Show, Eq, Generic) -instance Exception OAuthUserException +instance Exception AzureUserException ---------------------------------------- ---- OAuth2 development auth plugin ---- diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 786b943b0..252c1be26 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -6,6 +6,9 @@ module Foundation.Types ( UpsertCampusUserMode(..) , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser , _upsertCampusUserIdent + , UpsertAzureUserMode(..) + , _UpsertAzureUserLoginOAuth, _UpsertAzureUserLoginDummy, _UpsertAzureUserLoginOther, _UpsertAzureUserOAuthSync, _UpsertAzureUserGuessUser + , _upsertAzureUserIdent ) where import Import.NoFoundation @@ -21,3 +24,16 @@ data UpsertCampusUserMode makeLenses_ ''UpsertCampusUserMode makePrisms ''UpsertCampusUserMode + + +-- Azure users logging in via OAuth2 +data UpsertAzureUserMode + = UpsertAzureUserLoginOAuth + | UpsertAzureUserLoginDummy { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserLoginOther { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserOAuthSync { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserGuessUser + deriving (Eq, Ord, Read, Show, Generic) + +makeLenses_ ''UpsertAzureUserMode +makePrisms ''UpsertAzureUserMode diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index f394ee1f3..d01605495 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -25,6 +25,7 @@ import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message import Auth.LDAP +import Auth.OAuth2 import Auth.PWHash (apHash) import Auth.Dummy (apDummy) @@ -122,22 +123,22 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend -> acceptExisting --- | Authentication via OAuth 2 +-- | 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 "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode -- TODO adjust do OAuth + upsertMode = creds ^? _upsertAzureUserMode - isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server + isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -152,18 +153,18 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend excHandlers = [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + AzureUserNoResult -> do + $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + AzureUserAmbiguous -> do + $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do - $logErrorS "LDAP" $ tshow err + $logErrorS "OAuth" $ tshow err mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError - , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc + 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 ] @@ -181,12 +182,15 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - pool <- getsYesod $ view _appLdapPool {-(case credsPlugin of - "azureadv2" -> getsYesod $ view _appLdapPool -- TODO - mockPluginName -> getsYesod $ view _appLdapPool -- TODO - _ -> error "undefined" -- TODO - )-} + $logDebugS "oauth" $ tshow Creds{..} + -- TODO look user up in DB + -- If not in DB then put (maybe prompt for email) + -- If in DB but first time oauth then prompt for password & update entry + -- Now user should be in DB -> authenticated + flip catches excHandlers $ case upsertMode of + Just upsertMode' -> error $ show upsertMode' --TODO + Nothing -> error "nothing" --TODO + {-pool <- getsYesod $ view _appLdapPool flip catches excHandlers $ case pool of Just ldapPool | Just upsertMode' <- upsertMode -> do @@ -194,7 +198,7 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData _other - -> acceptExisting + -> acceptExisting-} @@ -231,6 +235,29 @@ _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 + + 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