Deep strict evaluation of Response

Without this change, Happstack's `failResponse` is not always sent.
For instance:

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

This server tries to send a string, but can't because the string's
value is bottom.  Before this change, the server replies with status
200 and empty content, while outputting "HTTP request failed with:
Maybe.fromJust: Nothing" to stderr.  This is because the response is
only evaluated into WHNF inside the exception handler in Handler.hs,
and the exception is caught by the surrounding catch block in
Listen.hs.  After this change, the server replies with status 500 and
the `failResponse` page.

It's possible that this slows down the Happstack server.  Some parts
of the Response object may be evaluated but not needed.  Strictly
evaluating the response at a finer level might be necessary.

Additionally, with NFData Response, clients can call `deepseq`
themselves on the response object in order to catch any bottom values
that it contains, log them and display a custom error page:

    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)

Let me know if you want to merge in this patch.  I'll be using it in
my own applications for sure, unless it proves to cause any
problems. :)

Author: negatratoron

happstack-server.cabal

@@ -79,6 +79,7 @@ Library
                        blaze-html             >= 0.5  && < 0.10,
                        bytestring,
                        containers,
+                       deepseq,
                        directory,
                        exceptions,
                        extensible-exceptions,

src/Happstack/Server/Internal/Handler.hs

@@ -10,6 +10,7 @@ import qualified Paths_happstack_server as Paths
 import qualified Data.Version as DV
 import Control.Applicative (pure)
 import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar)
+import Control.DeepSeq (deepseq)
 import Control.Exception.Extensible as E
 import Control.Monad
 import Data.List(elemIndex)
@@ -83,7 +84,7 @@ rloop timeoutIO mlog host handler inputStr
                      let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u)
                                   (queryInput u) bodyInputRef cookies v headers bodyRef host
 
-                     let ioseq act = act >>= \x -> x `seq` return x
+                     let ioseq act = act >>= \x -> x `deepseq` return x
 
                      (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req))
                          `E.catches` [ Handler $ \(e::EscapeHTTP)      -> throwIO e -- need to handle this higher up

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{}  =