2

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

どこが間違っていますか？

4

2 に答える 2

2

別の回答者は、過度の怠惰が問題であると指摘しています。Control.DeepSeqを使用して式を正規形に評価してから、それを修正することができますtry。

関数を次のように変更します

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、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

コピーペーストの完全なコード:

{-# 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
于 2016-03-03T16:14:01.803 に答える