捕获Scotty / Haskell中的异常

时间:2015-04-06 16:04:24

标签: haskell scotty

我刚刚开始学习Haskell,并坚持如何处理Scotty中的异常。

我有以下基本功能。它获得一个JSON POST,将其转换为Haskell数据记录,从配置读取器获取postgres连接池,然后将记录插入到数据库中。

create :: ActionT Text ConfigM ()
create = do
    a :: Affiliate <- jsonData
    pool  <- lift $ asks pool
    _ <- liftIO $ catchViolation catcher $ withResource pool $ \conn ->
        PgSQL.execute conn "INSERT INTO affiliate (id, network, name, status) VALUES (?, ?, ?, ?)"
            (slug a, network a, name a, status a)
    let s = fromStrict $ unSlug $ slug a
    text $ "Created: " `T.append` s
where
    catcher e (UniqueViolation "mykey") = throw e --text "Error"
    catcher e _ = throw e

此函数编译正常,但是当我更改UniqueViolation以返回文本时,它无法编译。

catcher e (UniqueViolation "mykey") = text "Error"

给出的编译错误是:

Couldn't match type ‘ActionT e0 m0 ()’ with ‘IO Int64’
    Expected type: PgSQL.SqlError -> ConstraintViolation -> IO Int64
      Actual type: PgSQL.SqlError
               -> ConstraintViolation -> ActionT e0 m0 ()
In the first argument of ‘catchViolation’, namely ‘catcher’
In the expression: catchViolation catcher

catchViolation 来自Database.PostgreSQL.Simple.Errors并具有以下签名:

catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a 

我知道问题的一部分是它从PgSQL.execute获取IO Int64但是来自捕手的ActionT但不确定如何解决这些类型或更惯用的方法。

2 个答案:

答案 0 :(得分:4)

问题在于catchViolation的返回值存在于IO monad中,但text存在于ActionT e IO monad中,这是一个构建在monad上的monad IO使用ActionT monad变换器。

Monad变换器为其基础monad添加了额外的功能。在ActionT的情况下,它添加了诸如“对构造中的响应”的访问(这就是text需要它的原因)。

一种可能的解决方案是从text中使用catchViolation。相反,让catchViolation返回Either,然后在返回ActionT上下文后,在Either上进行模式匹配,以决定要做什么。类似的东西:

ei <- liftIO $ catchViolation catcher $ fmap Right $ withResource pool
case ei of
    Left str -> text str
    Right _ -> return ()
where 
    catcher e (UniqueViolation "mykey") = return $ Left "some error"
    catcher e _ = return $ Left "some other error"

还有另一个解决方案,更强大但不直观。恰好ActionTMonadBaseControl的一个实例。这个类型类有methods,可以让你将monad变换器添加的所有“额外层”隐藏到基本monad的普通值中。然后,您可以将该值传递给某些回调接受函数,如catchViolation,然后“弹出”所有额外的图层。

(这有点像将盒子里的插孔按回盒子以便通过海关或其他任何东西,然后让它再次弹出。)

这将是:

control $ \runInBase -> catchViolation 
     (\_ _ -> runInBase $ text "some error") 
     (runInBase $ liftIO $ withResource $ 
                .... all the query stuff goes here ...)

我们正在使用control实用程序功能。 control为您提供了一个神奇的功能(RunInBase m b),让您“将插孔插入盒子中”。也就是说,从IO中构造ActionT值。然后,您将该值传递给catchViolationcontrol负责取消结果中编码的图层,最后返回完整的ActionT monad。

答案 1 :(得分:0)

谢谢你用Either把我放在了正确的位置。我在Control.Exception中找到尝试,它从以下的IO创建一个Either:

try :: Exception e => IO a -> IO (Either e a) 

我尝试从PostgreSQL简单执行函数中给我一个 [SitherError Int64] ,然后使用{{3进行PostgreSQL简单constraintViolation函数对左值进行映射我在Control.Arrow.left找到了。

constraintViolation :: SqlError -> Maybe ConstraintViolation

left :: a b c -> a (Either b d) (Either c d) 

然后,我在

上给出了以下类型的模式匹配
Either (Maybe ConstraintViolation) Int64

通过以上所述,我提出了我对此感到满意的这一点,但不确定是否惯用或可以进一步改进?

create' :: ActionT Text ConfigM ()
create' = do
  a :: Affiliate <- jsonData
  pool  <- lift $ asks pool
  result <- liftIO $ E.try $ withResource pool $ \conn -> do
       PgSQL.execute conn "INSERT INTO affiliate (id, network, name, status) VALUES (?, ?, ?, ?)"
                (slug a, network a, name a, status a)
  let slugT = fromStrict $ unSlug $ slug a
  case left constraintViolation result of
    Right _ -> text $ "Created: " `T.append` slugT
    Left(Just(UniqueViolation "mykey")) -> text "Duplicate key"
    _ -> text "Fatal Error"

更新

在建议使用ViewPatterns之后,我已将之前的版本简化为以下版本。

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}

create :: ActionT Text ConfigM ()
create = do
    a :: A.Affiliate <- jsonData
    pool  <- lift $ asks pool
    result <- liftIO $ try $ withResource pool $ \conn ->
        PgSQL.execute conn "INSERT INTO affiliate (id, network, name, status) VALUES (?, ?, ?, ?)"
          (A.slug a, A.network a, A.name a, A.status a)
    let slugT = fromStrict $ unSlug $ A.slug a
    case result of
        Right _ -> text ("Created: " `T.append` slugT) >> status created201
        Left (constraintViolation -> Just (UniqueViolation _)) -> text (slugT `T.append` " already exists") >> status badRequest400
        Left e -> throw e