From 5d0a4567f33c10d02acba87522fb5f3a7f5ba529 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@fpcomplete.com>
Date: Tue, 13 Oct 2015 10:32:25 +0000
Subject: [PATCH] Add the guessApproot function (pinging @gregwebs)

---
 yesod-auth/openid.hs                 |  2 +-
 yesod-core/ChangeLog.md              |  4 ++++
 yesod-core/Yesod/Core.hs             |  2 ++
 yesod-core/Yesod/Core/Class/Yesod.hs | 17 +++++++++++++++++
 yesod-core/yesod-core.cabal          |  4 ++--
 5 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/yesod-auth/openid.hs b/yesod-auth/openid.hs
index dde5d800..f5d475ec 100644
--- a/yesod-auth/openid.hs
+++ b/yesod-auth/openid.hs
@@ -38,7 +38,7 @@ $nothing
 |]
 
 instance Yesod BID where
-    approot = ApprootStatic "http://localhost:3000"
+    approot = guessApproot
 
 instance YesodAuth BID where
     type AuthId BID = Text
diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index b876ce68..88ab727f 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,3 +1,7 @@
+## 1.4.16
+
+* Add `guessApproot`
+
 ## 1.4.15
 
 * mkYesod avoids using reify when it isn't necessary. This avoids needing to define the site type below the call to mkYesod.
diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
index 2a157ca5..b3a3cf7d 100644
--- a/yesod-core/Yesod/Core.hs
+++ b/yesod-core/Yesod/Core.hs
@@ -71,6 +71,8 @@ module Yesod.Core
     , MonadWidget (..)
     , getRouteToParent
     , defaultLayoutSub
+      -- * Approot
+    , guessApproot
       -- * Misc
     , yesodVersion
     , yesodRender
diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs
index 0f6408bd..47f4fb49 100644
--- a/yesod-core/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/Yesod/Core/Class/Yesod.hs
@@ -56,6 +56,7 @@ import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Control.Monad.Trans.Class (lift)
 import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Request
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -826,3 +827,19 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
   where
     line = show . fst . loc_start
     char = show . snd . loc_start
+
+-- | Guess the approot based on request headers. For more information, see
+-- "Network.Wai.Middleware.Approot"
+--
+-- In the case of headers being unavailable, it falls back to 'ApprootRelative'
+--
+-- Since 1.4.16
+guessApproot :: Approot site
+guessApproot = ApprootRequest $ \_master req ->
+    case W.requestHeaderHost req of
+        Nothing -> ""
+        Just host ->
+            (if Network.Wai.Request.appearsSecure req
+                then "https://"
+                else "http://")
+            `T.append` TE.decodeUtf8With TEE.lenientDecode host
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index 51ddcc0a..924e7c17 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.15
+version:         1.4.16
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -25,7 +25,7 @@ library
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
                    , wai                   >= 3.0
-                   , wai-extra             >= 3.0.5
+                   , wai-extra             >= 3.0.7
                    , bytestring            >= 0.9.1.4
                    , text                  >= 0.7
                    , template-haskell