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?

Why are you throwing exceptions from pure code? Yes, you *can*, but it's usually a bad idea. It's much easier to see exactly what's going on if you avoid doing that. Stick to `Either` or `ExceptT` in pure code and throw exceptions only with `throwIO` or similar as necessary. — dfeuer, Mar 03 '16 at 21:37

zakyggaps · Answer 1 · 2016-03-03T15:23:22.730

3

It's because of the lazyness of return and toResponse. On the line

tryIO mf io = do result <- liftIO $ try io

somethingWrong is not evaluated at all, while your exception is some levels deeper (inside a lazy bytestring inside the Response), resulting it escaped the try in tryIO and be raised latter unhandled. Usually errors in pure codes may only be caught where it's evaluated to NF, in your case on top of main.

edited Mar 03 '16 at 15:23

answered Mar 03 '16 at 14:54

zakyggaps

3,070
2
15
25

@AlexanderRazorenov The best solution is not to throw exceptions in pure code. Or you can catch it where it's evaluated. Despite the nice use of Generics in the other answer, I don't really think forcing `io` to NF in `tryIO` is a good idea. Imagine what may `io` be: reading a huge file, waiting for a long request from the other side of earth, etc. Forcing a (which supposed to be) lazy IO action can result surprising, even nasty consequences. – zakyggaps Mar 04 '16 at 11:28
You are right: The best solution is not to throw exceptions in pure code. But it's not always possible. "Real life is not the same as true world" – Alexander Razorenov Mar 10 '16 at 09:43

user2407038 · Accepted Answer · 2016-03-09T13:11:29.373

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

I've tried your full code - it works good, but exception handler is not evaluated and I get standard happstack error page. — Alexander Razorenov, Mar 09 '16 at 09:56
@AlexanderRazorenov Indeed there was a mistake in the code. Should be fixed now - I definitely actually tried the code this time. It displays the error as json - `{"res":"","err":"Something goes wrong!"}`. — user2407038, Mar 09 '16 at 13:12

Catching exceptions from pure functions in happstack

2 Answers2