在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

另一位回答者表示過度懶惰是個問題。在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 

Answer 2

這是因爲return和toResponse的懶惰。 上線

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

somethingWrong是不是在所有的評估，而你的例外是一些更深層次（響應內懶惰字節字符串內），導致它在tryIO逃過try和提高後者未處理。通常在純代碼中的錯誤可能只在被評估爲NF的情況下才會被捕獲，在你的情況下，在main之上。