From a91f85ff38e5e04b61311bd0332e06ce19af72f9 Mon Sep 17 00:00:00 2001
From: patrick brisbin <pbrisbin@gmail.com>
Date: Tue, 13 Feb 2018 09:10:04 -0500
Subject: [PATCH] Improve error message for invalid Approots

Closes #87
---
 src/Yesod/Auth/OAuth2/Dispatch.hs | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs
index e47f5f8..8cdfd43 100644
--- a/src/Yesod/Auth/OAuth2/Dispatch.hs
+++ b/src/Yesod/Auth/OAuth2/Dispatch.hs
@@ -8,7 +8,7 @@ module Yesod.Auth.OAuth2.Dispatch
     , dispatchAuthRequest
     ) where
 
-import Control.Exception.Safe (tryIO)
+import Control.Exception.Safe (throwString, tryIO)
 import Control.Monad (unless)
 import Data.Monoid ((<>))
 import Data.Text (Text)
@@ -79,9 +79,17 @@ withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2
 withCallbackAndState name oauth2 csrf = do
     let url = PluginR name ["callback"]
     render <- getParentUrlRender
-    return oauth2
-        -- FIXME: an invalid AppRoot can blow this up
-        { oauthCallback = Just $ unsafeFromText $ render url
+    let callbackText = render url
+
+    callback <- maybe
+        (throwString
+            $ "Invalid callback URI: "
+            <> T.unpack callbackText
+            <> ". Not using an absolute Approot?"
+        ) pure $ fromText callbackText
+
+    pure oauth2
+        { oauthCallback = Just callback
         , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2
             `withQuery` [("state", encodeUtf8 csrf)]
         }