捕獲Scotty / Haskell中的異常

Question

我剛剛開始學習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但不確定如何解決這些類型或更慣用的方法。

Answer 1

問題是catchViolation的返回值存在於IO monad中，但是text存在於ActionT e IO monad中，這是一個使用ActionT monad轉換器在IO上ActionT monad。

Monad變換器為其基礎monad添加了額外的功能。 在ActionT的情況下，它添加了諸如訪問“構造中的響應”之類的東西（這就是text需要它的原因）。

一種可能的解決方案是將text的使用從catchViolation 。 相反，make 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"

還有另一個解決方案，更強大但不直觀。 它發生ActionT就是一個實例MonadBaseControl 。 這個類型類有一些方法可以讓你將monad變換器添加的所有“額外層”隱藏到基本monad的普通值中。 然后，您可以將該值傳遞給某些回調接受函數，如catchViolation ，然后“彈出”所有額外的圖層。

（這有點像將盒子插入其盒子中以便通過海關或其他任何東西，然后讓它再次彈出。）

它會是這樣的：

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

我們正在使用控制實用程序功能。 control為您提供了一個神奇的功能（ RunInBase mb ），讓您“將插孔插入盒子中”。 也就是說，從ActionT構造一個IO值。 然后，您將該值傳遞給catchViolation ，並且control負責取消結果中編碼的圖層，最后返回完整的ActionT monad。

Answer 2

謝謝你讓我與Either一致 。 我發現在Control.Exception中嘗試從一個IO創建一個Either：

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

我使用嘗試從PostgreSQL簡單執行函數給我一個[Either SqlError Int64] ，然后使用Control.Arrow.left在PostpsSQL Simple constraintViolation函數上做左側值的映射，我在https://stackoverflow.com/找到a / 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