从 happstack 中的纯函数捕获异常

Question

我找不到真正的方法来捕获 happstack 应用程序中纯函数抛出的异常。我试过了 this solution。当 IO 函数抛出异常时它工作得很好。但是当纯函数抛出异常时它无法处理它。我的代码：

{-# 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

我哪里错了？

Answer 1

是因为return和toResponse的懒惰。在线

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

somethingWrong 根本没有被评估，而你的异常更深一些（在响应内的惰性字节串内），导致它在 tryIO 中逃脱了 try 并且是提出后者未处理。通常纯代码中的错误可能只会在它被评估为 NF 的地方被捕获，在你的情况下，在 main.

之上

Answer 2

另一位回答者指出过度懒惰是问题所在。您可以通过在 try 之前使用 Control.DeepSeq 将表达式计算为正常形式来修复它。

将函数更改为

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 具有类型 NFData a => a -> a 并在返回之前简单地将其参数计算为正常形式。

Response 似乎没有 NFData 实例，但在泛型的帮助下，这很容易修复：

{-# 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

复制粘贴的完整代码：

{-# 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

从 happstack 中的纯函数捕获异常

Catching exceptions from pure functions in happstack

haskell

exception-handling

happstack