Add guessApprootOr function

yesod-core/ChangeLog.md

@@ -1,6 +1,6 @@
 ## 1.4.16
 
-* Add `guessApproot`
+* Add `guessApproot` and `guessApprootOr`
 
 ## 1.4.15
 

yesod-core/Yesod/Core.hs

@@ -73,6 +73,7 @@ module Yesod.Core
     , defaultLayoutSub
       -- * Approot
     , guessApproot
+    , guessApprootOr
       -- * Misc
     , yesodVersion
     , yesodRender

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://"