From 692773326a0b162fa656ff574f191b1439789bc1 Mon Sep 17 00:00:00 2001
From: Paul Rouse <pgr@doynton.org>
Date: Tue, 13 Oct 2015 15:00:02 +0100
Subject: [PATCH] Add guessApprootOr function

---
 yesod-core/ChangeLog.md              |  2 +-
 yesod-core/Yesod/Core.hs             |  1 +
 yesod-core/Yesod/Core/Class/Yesod.hs | 15 +++++++++++++--
 3 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 88ab727f..d84a662c 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,6 +1,6 @@
 ## 1.4.16
 
-* Add `guessApproot`
+* Add `guessApproot` and `guessApprootOr`
 
 ## 1.4.15
 
diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
index b3a3cf7d..c6a327d6 100644
--- a/yesod-core/Yesod/Core.hs
+++ b/yesod-core/Yesod/Core.hs
@@ -73,6 +73,7 @@ module Yesod.Core
     , defaultLayoutSub
       -- * Approot
     , guessApproot
+    , guessApprootOr
       -- * Misc
     , yesodVersion
     , yesodRender
diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs
index 47f4fb49..30226f12 100644
--- a/yesod-core/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/Yesod/Core/Class/Yesod.hs
@@ -835,9 +835,20 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
 --
 -- Since 1.4.16
 guessApproot :: Approot site
-guessApproot = ApprootRequest $ \_master req ->
+guessApproot = guessApprootOr ApprootRelative
+
+-- | Guess the approot based on request headers, with fall back to the
+-- specified 'AppRoot'.
+--
+-- Since 1.4.16
+guessApprootOr :: Approot site -> Approot site
+guessApprootOr fallback = ApprootRequest $ \_master req ->
     case W.requestHeaderHost req of
-        Nothing -> ""
+        Nothing -> case fallback of
+                       ApprootRelative  -> ""
+                       ApprootStatic t  -> t
+                       ApprootMaster f  -> f _master
+                       ApprootRequest f -> f _master req
         Just host ->
             (if Network.Wai.Request.appearsSecure req
                 then "https://"