diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 3d32db6f7..2dec06d63 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,7 +4,7 @@ module Foundation.Yesod.Auth ( authenticate - -- , ldapLookupAndUpsert -- TODO: remove in favour of fetchUserData + , userLookupAndUpsert , upsertUser , decodeUserTest , UserConversionException(..) @@ -114,7 +114,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy, not isOther -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf , Just upsertMode' <- upsertMode -> do - userData <- fetchUserData upsertMode' Creds{..} + userData <- fetchUserData Creds{..} $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData Authenticated . entityKey <$> upsertUser upsertMode' userData -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} @@ -169,6 +169,19 @@ _upsertUserMode mMode cs@Creds{..} defaultOther = apHash +userLookupAndUpsert :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadMask m + , MonadUnliftIO m + ) + => Text + -> UpsertUserMode + -> SqlPersistT m (Entity User) +userLookupAndUpsert credsIdent mode = + fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= upsertUser mode + + data FetchUserDataException = FetchUserDataNoResult | FetchUserDataAmbiguous @@ -176,24 +189,6 @@ data 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 @@ -202,10 +197,9 @@ fetchUserData :: forall m site. , MonadMask m , MonadUnliftIO m ) - => UpsertUserMode - -> Creds site + => Creds site -> SqlPersistT m (NonEmpty UpsertUserData) -fetchUserData _upsertMode creds@Creds{..} = do +fetchUserData creds@Creds{..} = do userAuthConf <- getsYesod $ view _appUserAuthConf now <- liftIO getCurrentTime