从 happstack 中的纯函数中捕获异常

Question

我找不到真正的方法来捕获 happstack 应用程序中纯函数抛出的异常。我已经尝试过这个解决方案。当 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