CODEWITHSUNDEEP
haskellexceptionhappstack
Alexander Razorenov
Alexander Razorenov

Reputation: 265

Catching exceptions from pure functions in happstack

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?

Upvotes: 2

Views: 153

Answers (2)

user2407038
user2407038

Reputation: 14598

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

Upvotes: 2

zakyggaps
zakyggaps

Reputation: 3080

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.

Upvotes: 3

Related Questions