From bd7ad4158ba23c7e5bb264ee760bc43d32116be5 Mon Sep 17 00:00:00 2001
From: Jefferson Carpenter <jeffersoncarpenter2@gmail.com>
Date: Thu, 9 Nov 2017 01:06:43 -0600
Subject: [PATCH] Enable deep strict evaluation of Response objects

Consider this server: it attempts to return a string with status 200,
however the string's value is `undefined`.

    import Control.Monad.Catch (SomeException, handle)

    main :: IO ()
    main = do
      let sendResponse = ok $ toResponse (fromJust Nothing :: String)
      simpleHTTP nullConf (handle errorPage sendResponse)
      where
        errorPage :: SomeException -> ServerPart Response
        errorPage _ = (internalServerError $ toResponse "Custom error page!")

On each request, this server replies with "200 OK" with no
content (even though philosophically there was a clear internal server
error, and furthermore there is an error handler present).  At least
it outputs "HTTP request failed with: Maybe.fromJust: Nothing" to
stderr.

This patch makes it possible to deeply strictly evaluate Response
objects before sending the HTTP response.  Then errors like these can
be caught and an error page shown.  The application can be changed to
something like this:

    import Control.DeepSeq (deepseq)
    import Control.Monad.Catch (SomeException, handle)

    handleServerPartError :: ServerPart Response -> ServerPart Response
    handleServerPartError s = handle errorPage $ do
      res <- s
      deepseq res (return res)
      where
        errorPage :: SomeException -> ServerPart Response
        errorPage _ = (internalServerError $ toResponse "Custom error page!")

    main :: IO ()
    main = do
      let sendResponse = ok $ toResponse (fromJust Nothing :: String)
      simpleHTTP nullConf (handleServerPartError sendResponse)

Which deeply, strictly evaluates the Response, revealing the
`undefined` that is present and displaying the custom error page.

Not all requests (streaming videos, for example) can or should be
deeply strictly evaluated before being sent to the client.  However,
for requests like those, the client often knows not to fully trust the
200 status code of the response, and likely has some error handling
built in if the response data does not stream in in the expected
format.  For most HTTP requests, the status code can be trusted, and
client applications should not need to have any special handling.
---
 happstack-server.cabal                 |  1 +
 src/Happstack/Server/Internal/Types.hs | 12 +++++++-----
 2 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/happstack-server.cabal b/happstack-server.cabal
index 2be3a89..6407905 100644
--- a/happstack-server.cabal
+++ b/happstack-server.cabal
@@ -79,6 +79,7 @@ Library
                        blaze-html             >= 0.5  && < 0.10,
                        bytestring,
                        containers,
+                       deepseq,
                        directory,
                        exceptions,
                        extensible-exceptions,
diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs
index fc413d3..04b1f90 100644
--- a/src/Happstack/Server/Internal/Types.hs
+++ b/src/Happstack/Server/Internal/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances, DeriveAnyClass, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, RankNTypes #-}
 
 module Happstack.Server.Internal.Types
     (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),
@@ -20,6 +20,7 @@ module Happstack.Server.Internal.Types
     ) where
 
 
+import Control.DeepSeq (NFData)
 import Control.Exception (Exception, SomeException)
 import Control.Monad.Error (Error(strMsg))
 import Control.Monad.Trans (MonadIO(liftIO))
@@ -40,6 +41,7 @@ import Data.List
 import Data.Word  (Word, Word8, Word16, Word32, Word64)
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as Lazy
+import GHC.Generics (Generic)
 import Happstack.Server.SURI
 import Data.Char (toLower)
 import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )
@@ -155,7 +157,7 @@ data HeaderPair = HeaderPair
     { hName :: ByteString     -- ^ header name
     , hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)
     }
-    deriving (Read,Show)
+    deriving (Read,Show,Generic,NFData)
 
 -- | a Map of HTTP headers
 --
@@ -171,12 +173,12 @@ data Length
     = ContentLength             -- ^ automatically add a @Content-Length@ header to the 'Response'
     | TransferEncodingChunked   -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding
     | NoContentLength           -- ^ do not set @Content-Length@ or @chunked@ output encoding.
-      deriving (Eq, Ord, Read, Show, Enum)
+      deriving (Eq, Ord, Read, Show, Enum, Generic, NFData)
 
 -- | Result flags
 data RsFlags = RsFlags
     { rsfLength :: Length
-    } deriving (Show,Read,Typeable)
+    } deriving (Show,Read,Typeable,Generic,NFData)
 
 -- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@.
 nullRsFlags :: RsFlags
@@ -222,7 +224,7 @@ data Response
                 , sfOffset    :: Integer   -- ^ offset to start at
                 , sfCount     :: Integer    -- ^ number of bytes to send
                 }
-      deriving (Typeable)
+      deriving (Generic, NFData, Typeable)
 
 instance Show Response where
     showsPrec _ res@Response{}  =