From 83299bf1beb79c998d1c9fdd03a590f7dd2b0c15 Mon Sep 17 00:00:00 2001
From: Artem Chuprina <ran@silver.lasgalen.net>
Date: Tue, 9 Aug 2016 22:54:24 +0300
Subject: [PATCH] urlParamRenderOverride method for Yesod class

this method replaces urlRenderOverride because the latter lacks support for query string
---
 yesod-core/Yesod/Core/Class/Yesod.hs  | 30 ++++++++++++++++++++++++---
 yesod-core/Yesod/Core/Internal/Run.hs |  2 +-
 yesod-static/Yesod/EmbeddedStatic.hs  |  2 +-
 yesod-static/Yesod/Static.hs          |  2 +-
 4 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs
index 4f7d71a3..c5e5d8ca 100644
--- a/yesod-core/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/Yesod/Core/Class/Yesod.hs
@@ -10,8 +10,9 @@ import           Yesod.Core.Handler
 
 import           Yesod.Routes.Class
 
-import           Blaze.ByteString.Builder           (Builder)
-import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import           Blaze.ByteString.Builder           (Builder, toByteString)
+import           Blaze.ByteString.Builder.ByteString (copyByteString)
+import           Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
 import           Control.Arrow                      ((***), second)
 import           Control.Exception                  (bracket)
 #if __GLASGOW_HASKELL__ < 710
@@ -36,7 +37,7 @@ import           Data.Text.Lazy.Builder             (toLazyText)
 import           Data.Text.Lazy.Encoding            (encodeUtf8)
 import           Data.Word                          (Word64)
 import           Language.Haskell.TH.Syntax         (Loc (..))
-import           Network.HTTP.Types                 (encodePath)
+import           Network.HTTP.Types                 (encodePath, renderQueryText)
 import qualified Network.Wai                        as W
 import           Data.Default                       (def)
 import           Network.Wai.Parse                  (lbsBackEnd,
@@ -107,6 +108,28 @@ class RenderRoute site => Yesod site where
     urlRenderOverride :: site -> Route site -> Maybe Builder
     urlRenderOverride _ _ = Nothing
 
+    -- | Override the rendering function for a particular URL and query string
+    -- parameters. One use case for this is to offload static hosting to a
+    -- different domain name to avoid sending cookies.
+    -- 
+    -- For backward compatibility default implementation is in terms of
+    -- 'urlRenderOverride', probably ineffective
+    -- 
+    -- Since 1.4.23
+    urlParamRenderOverride :: site
+                           -> Route site
+                           -> [(T.Text, T.Text)] -- ^ query string
+                           -> Maybe Builder
+    urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route
+      where
+        addParams [] routeBldr = routeBldr
+        addParams nonEmptyParams routeBldr =
+            let routeBS = toByteString routeBldr
+                qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'
+                valueToMaybe t = if t == "" then Nothing else Just t
+                queryText = map (id *** valueToMaybe) nonEmptyParams
+            in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText
+
     -- | Determine if a request is authorized or not.
     --
     -- Return 'Authorized' if the request is authorized,
@@ -290,6 +313,7 @@ class RenderRoute site => Yesod site where
     yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a
     yesodWithInternalState _ _ = bracket createInternalState closeInternalState
     {-# INLINE yesodWithInternalState #-}
+{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
 
 -- | Default implementation of 'makeLogger'. Sends to stdout and
 -- automatically flushes on each write.
diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs
index b8ed115d..668e8604 100644
--- a/yesod-core/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/Yesod/Core/Internal/Run.hs
@@ -376,7 +376,7 @@ yesodRender y ar url params =
     fromMaybe
         (joinPath y ar ps
           $ params ++ params')
-        (urlRenderOverride y url)
+        (urlParamRenderOverride y url params)
   where
     (ps, params') = renderRoute url
 
diff --git a/yesod-static/Yesod/EmbeddedStatic.hs b/yesod-static/Yesod/EmbeddedStatic.hs
index 48634f3e..deec0235 100644
--- a/yesod-static/Yesod/EmbeddedStatic.hs
+++ b/yesod-static/Yesod/EmbeddedStatic.hs
@@ -33,7 +33,7 @@
 -- contains the created 'EmbeddedStatic'.
 --
 -- It is recommended that you serve static resources from a separate domain to save time
--- on transmitting cookies.  You can use 'urlRenderOverride' to do so, by redirecting
+-- on transmitting cookies.  You can use 'urlParamRenderOverride' to do so, by redirecting
 -- routes to this subsite to a different domain (but the same path) and then pointing the
 -- alternative domain to this server.  In addition, you might consider using a reverse
 -- proxy like varnish or squid to cache the static content, but the embedded content in
diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs
index 81da1be6..9ed71e27 100644
--- a/yesod-static/Yesod/Static.hs
+++ b/yesod-static/Yesod/Static.hs
@@ -19,7 +19,7 @@
 --
 -- In fact, in an ideal setup you'll serve your static files from
 -- a separate domain name to save time on transmitting
--- cookies. In that case, you may wish to use 'urlRenderOverride'
+-- cookies. In that case, you may wish to use 'urlParamRenderOverride'
 -- to redirect requests to this subsite to a separate domain
 -- name.
 --