Catching exceptions from pure functions in happstack

Question

I can't find true way to catch exceptions throwed by pure functions in happstack application. I've tried this solution. It works well when exception throwed by IO function. But when pure function throw exception it can't handle it. My code:

{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Prelude hiding(catch)
import Control.Monad    (msum, mzero, join)
import Control.Monad.IO.Class(liftIO)
import Happstack.Server
import Text.JSON.Generic
import qualified Data.ByteString.Char8 as B

import Control.Exception

data Res = Res {res :: String, err :: String} deriving (Data, Typeable)

evaluateIt :: Res
evaluateIt = throw (ErrorCall "Something goes wrong!")

somethingWrong :: IO Response
somethingWrong = return $ toResponse $ encodeJSON $ evaluateIt

errorHandler :: SomeException -> ServerPart Response
errorHandler e = ok $ setHeaderBS (B.pack "Content-Type") (B.pack "application/json") $ toResponse $ encodeJSON $ Res {err = show e, res = ""}

indexHTML = tryIO (Just errorHandler) somethingWrong

main :: IO ()
main = do
    simpleHTTP nullConf $ msum [ indexHTML ]

tryIO :: Maybe (SomeException -> ServerPart Response)
         -> IO a
         -> ServerPart a
tryIO mf io = do result <- liftIO $ try io
                 case (result) of Right good -> return good
                                  Left exception -> handle exception mf
      where handle exception (Just handler) = escape $ handler exception
            handle _ Nothing = mzero

Where am I wrong?

Answer 1

Another answerer has indicated that excess laziness is the issue. You can fix it by using Control.DeepSeq to evaluate the expression to normal form before trying it.

Change the function to

import Control.DeepSeq  

...

tryIO :: NFData a => Maybe (SomeException -> ServerPart Response) -> IO a -> ServerPart a
tryIO mf io = do 
  result <- liftIO $ io >>= try . return . force 
  ...

force has type NFData a => a -> a and simply evaluates its argument to normal form before returning it.

It doesn't seem like Response has an NFData instance, but this is fairly easy to fix, with the help of Generics:

{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} 

...

import Control.DeepSeq 
import GHC.Generics 

...

deriving instance Generic Response 
deriving instance Generic RsFlags 
deriving instance Generic HeaderPair 
deriving instance Generic Length  
instance NFData Response 
instance NFData RsFlags 
instance NFData HeaderPair 
instance NFData Length 

---

Full code for copy paste:

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} 

module Main where

import Prelude hiding(catch)
import Control.Monad    (msum, mzero, join)
import Control.Monad.IO.Class(liftIO)
import Happstack.Server
import Text.JSON.Generic
import qualified Data.ByteString.Char8 as B
import Control.DeepSeq 
import GHC.Generics 

import Control.Exception

data Res = Res {res :: String, err :: String} deriving (Data, Typeable)

evaluateIt :: Res
evaluateIt = throw (ErrorCall "Something goes wrong!")

somethingWrong :: IO Response
somethingWrong = return $ toResponse $ encodeJSON $ evaluateIt

errorHandler :: SomeException -> ServerPart Response
errorHandler e = ok $ setHeaderBS (B.pack "Content-Type") (B.pack "application/json") $ toResponse $ encodeJSON $ Res {err = show e, res = ""}

indexHTML = tryIO (Just errorHandler) somethingWrong

main :: IO ()
main = do
    simpleHTTP nullConf $ msum [ indexHTML ]

deriving instance Generic Response 
deriving instance Generic RsFlags 
deriving instance Generic HeaderPair 
deriving instance Generic Length  
instance NFData Response 
instance NFData RsFlags 
instance NFData HeaderPair 
instance NFData Length 

tryIO :: NFData a => Maybe (SomeException -> ServerPart Response) -> IO a -> ServerPart a
tryIO mf io = do 
  result <- liftIO $ try $ io >>= \x -> x `deepseq` return x 
  case (result) of 
    Right good -> return good
    Left exception -> handle exception mf

    where handle exception (Just handler) = escape $ handler exception
          handle _ Nothing = mzero