From 7d913b6feaa897ac2418de673889c8ccc752ded7 Mon Sep 17 00:00:00 2001
From: "William R. Arellano" <arellanowr@gmail.com>
Date: Tue, 31 Oct 2023 13:47:43 -0500
Subject: [PATCH] Add support for Relative Approots

Prior to this commit, individual providers did not handle
redirect-uri. They would set the field to `Nothing` and then
this library would build a callback using the app's url-renderer.

This means that apps had to use approot static, because such
redirect-uri's have to be absolute.

This minor change just respects any redirect-uri a provider has
set already. That mean that apps that must use a relative
approot can now use our library as long as they use a provider that
handles redirect-uri for them (ensuring it's absolute by whatever
means it can) ahead of our own callback construction.
---
 src/Yesod/Auth/OAuth2/Dispatch.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs
index 499a632..5d9ee53 100644
--- a/src/Yesod/Auth/OAuth2/Dispatch.hs
+++ b/src/Yesod/Auth/OAuth2/Dispatch.hs
@@ -105,14 +105,17 @@ withCallbackAndState
   -> Text
   -> m OAuth2
 withCallbackAndState name oauth2 csrf = do
-  uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
-  callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri
+  callback <- maybe defaultCallback pure $ oauth2RedirectUri oauth2
   pure
     oauth2
       { oauth2RedirectUri = Just callback
       , oauth2AuthorizeEndpoint =
           oauth2AuthorizeEndpoint oauth2 `withQuery` [("state", encodeUtf8 csrf)]
       }
+ where
+  defaultCallback = do
+    uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
+    maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri
 
 getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
 getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent