4

我刚刚开始学习 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 但不确定如何解决类型或更惯用的方法。

4

2 回答 2

4

问题是返回值catchViolation存在于IOmonad 中，但text存在于 monad 中，这是一个建立在使用monad 转换器ActionT e IO之上的 monad。IOActionT

Monad 转换器为它们的基本 monad 添加了额外的功能。在 的情况下ActionT，它添加了诸如访问“构造中的响应”之类的内容（这就是text需要它的原因）。

一种可能的解决方案是使用textout of catchViolation. 取而代之的是， makecatchViolation返回一个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"

还有另一种解决方案，更强大但不那么直观。碰巧这ActionT是 MonadBaseControl. 这个类型类有一些方法可以让你将所有由 monad 转换器添加的“额外层”隐藏到基本 monad 的普通值中。然后，您可以将该值传递给一些接受回调的函数，例如catchViolation，然后“弹出”所有额外的层。

（这有点像为了通过海关或其他什么，将一个千斤顶按回它的盒子，然后让它再次弹出。）

它会是这样的：

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

我们正在使用控制效用函数。control为您提供了一个神奇的功能 ( RunInBase m b)，可以让您“将千斤顶放回盒子中”。也就是说，IO从一个值中构造一个值ActionT。然后将该值传递给catchViolation，并control负责解压缩结果中编码的层，最后带​​回完整的ActionTmonad。

于 2015-04-06T21:13:36.230 回答
0

谢谢你让我与Either保持一致。我在Control.Exception中找到了try ，它从 a 的 IO 创建了一个 Either：

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

我尝试从 PostgreSQL Simple 执行函数中给我一个[Either SqlError Int64] ，然后使用我在https://stackoverflow.com/找到的Control.Arrow.left使用 PostgreSQL Simple constraintViolation函数对左侧值进行映射一个/13504032/2658199。

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
于 2015-04-07T16:21:27.350 回答