From ab096c649ca7c1850b9c50de0abef115d9cce039 Mon Sep 17 00:00:00 2001
From: Steven Leiva <leiva.steven@gmail.com>
Date: Fri, 12 Apr 2019 16:13:53 -0500
Subject: [PATCH] Introduce JSONResponse.

This data type allows us to return a domain type in our handlers, even
if we eventually want to send JSON to the client.

See: https://tech.freckle.com/2015/12/21/servant-style-handlers-for-yesod/
---
 yesod-core/ChangeLog.md              |  4 ++++
 yesod-core/src/Yesod/Core/Content.hs |  6 ++++++
 yesod-core/src/Yesod/Core/Types.hs   | 16 ++++++++++++++++
 3 files changed, 26 insertions(+)

diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 3e7f2836..0d851910 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 1.6.14
+
+* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
+
 ## 1.6.13
 
 * Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
diff --git a/yesod-core/src/Yesod/Core/Content.hs b/yesod-core/src/Yesod/Core/Content.hs
index 63633a8d..d9741d92 100644
--- a/yesod-core/src/Yesod/Core/Content.hs
+++ b/yesod-core/src/Yesod/Core/Content.hs
@@ -107,6 +107,8 @@ instance ToContent (ContentType, Content) where
     toContent = snd
 instance ToContent TypedContent where
     toContent (TypedContent _ c) = c
+instance ToContent (JSONResponse a) where
+    toContent (JSONResponse a) = toContent $ J.toEncoding a
 
 instance ToContent Css where
     toContent = toContent . renderCss
@@ -160,6 +162,8 @@ deriving instance ToContent RepJson
 instance HasContentType RepPlain where
     getContentType _ = typePlain
 deriving instance ToContent RepPlain
+instance HasContentType (JSONResponse a) where
+    getContentType _ = typeJson
 
 instance HasContentType RepXml where
     getContentType _ = typeXml
@@ -292,6 +296,8 @@ instance ToTypedContent [Char] where
     toTypedContent = toTypedContent . pack
 instance ToTypedContent Text where
     toTypedContent t = TypedContent typePlain (toContent t)
+instance ToTypedContent (JSONResponse a) where
+    toTypedContent c = TypedContent typeJson (toContent c)
 instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
     toTypedContent (DontFullyEvaluate a) =
         let TypedContent ct c = toTypedContent a
diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs
index 1d13e99a..a71e7690 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -8,8 +8,10 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
 module Yesod.Core.Types where
 
+import Data.Aeson (ToJSON)
 import qualified Data.ByteString.Builder            as BB
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
@@ -303,6 +305,20 @@ newtype RepXml = RepXml Content
 
 type ContentType = ByteString -- FIXME Text?
 
+-- | Wrapper around types so that Handlers can return a domain type, even when
+-- the data will eventually be encoded as JSON.
+-- Example usage in a type signature:
+--
+-- > postSignupR :: Handler (JSONResponse CreateUserResponse)
+--
+-- And in the implementation:
+--
+-- > return $ JSONResponse $ CreateUserResponse userId
+--
+-- @since 1.6.14
+data JSONResponse a where
+    JSONResponse :: ToJSON a => a -> JSONResponse a
+
 -- | Prevents a response body from being fully evaluated before sending the
 -- request.
 --