haskell - 在 Haskell (DynamoDB) 中动态更新数据库记录

Question

我现在正在使用 Haskell 开发 DynamoDB。我很难动态更新记录。

例如，我有这样的数据:

data Order
  = Order
      { _orderId     :: Text
      , _orderUserId :: Text
      , _orderStatus :: OrderStatus
      , _orderAddress :: Text
      , _orderEmail :: Email
      }
  deriving (Show)

然后我想要一个动态查询，您可以在其中传递要更新的字段和值。

因此，在 Typescript 中，它看起来像:

update: (payload: Partial<Order>) => Promise<Order>

然后我可以这样做:

orderRepository.update({orderStatus: "Delivered", orderAddress: "updated address"})

在 Haskell 中，我使用 amazonka-dynamodb图书馆。如果我想更新订单状态，我可以这样写:

data UpdatePayload
  = UpdatePayload
      { _payloadOrderStatus  :: Maybe OrderStatus
      , _payloadOrderAddress :: Maybe Text
      , _payloadOrderEmail   :: Maybe Email
      } 
  deriving (Show, Generic) -- and ToJSON

newtype Email = Email {
  _rawEmail::Text
} deriving (Show, Generic) -- and ToJSON

data OrderStatus = Pending | Paid | Processed | Delivered deriving (Show, Read, Generic, ToJSON)

updateStatus :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> UpdatePayload -> m ()
updateStatus orderId payload = do
  res <- handleReq =<< req
  pPrint res
 where
  req = do
    tableName <- asks (^. configTableName)
    return
      $  updateItem tableName
      &  uiKey
      .~ keys
      &  uiUpdateExpression
      ?~ expression
      &  uiExpressionAttributeNames
      .~ attrNames
      &  uiExpressionAttributeValues
      .~ values
  keys =
    mapFromList [("orderId", attributeValue & avS .~ Just orderId)]
  expression     = "SET #orderStatus = :orderStatus"
  attrNames      = mapFromList [("#orderStatus", "orderStatus")]
  values         = mapFromList [(":orderStatus", attributeValue & avS .~ (tshow <$> payload ^. orderStatus))]

但是当我需要更新地址时，我不想进行新的查询。

我能想到的使其动态化的一种方法是使用 HashMap 并传递键和值进行更新，就像 Typescript 示例一样。

如果是uiExpressionAttributeNames，它看起来像

getExpression :: Map Text (Maybe a) -> Text
getExpression = foldl (\exp key -> exp ++ " #" ++ key ++ "= :" ++ key) "SET " . keys

但是，对于 uiExpressionAttributeValues，我需要使用模式匹配来映射每个值。

getUpdateValues :: Map Text (Maybe a) -> Map Text AttributeValue
getUpdateValues = foldl helper Map.empty . Map.assocs
    where
        helper acc ("status", val) = insertMap ":orderStatus" (attributeValue & avS .~ val) acc
        helper ...
        helper ...

然后，由于 avS .~ val，我得到了编译错误，其中 val 应该是文本，但实际上是 a.. .

getExpression 和getUpdateValues 看起来都很丑，后者不会被编译。有没有更简洁的方法来解决这个问题？

Answer 1

UpdateExpression 中的

SET 表达式如下所示，可以通过连接 Text 生成:

"SET " <field-name> "= :" <field-name>

您现在应该能够为 DynamoDB 中的订单记录编写这个单一的、类型更松散的更新函数，它采用文本属性名称:

updateOrder :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> Text -> Text  -> m ()
updateOrder orderId name value = do
  res <- handleReq =<< req
  pPrint res
 where
  req = do
    tableName <- asks (^. configTableName)
    return
      $ updateItem table
      &  uiKey
      .~ key
      &  uiUpdateExpression
      ?~ expression
      &  uiExpressionAttributeValues
      .~ values
    where
      expression = "SET " <> Text.tail name <> " = " <> name
      values     = Map.fromList [(name, attributeValue & avS ?~ value)]

然后编写适应它的强类型 setter :

updateUserId :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> UpdatePayload -> m ()
updateUserId orderId payload =
  updateOrder orderId ":orderUserId"
    $ payload ^. orderUserId

updateStatus :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> UpdatePayload -> m ()
updateStatus orderId payload =
  updateOrder orderId ":orderStatus"
    $ tshow <$> payload ^. orderStatus

updateAddress :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> UpdatePayload -> m ()
updateAddress orderId payload =
  updateOrder orderId ":orderAddress"
    $ payload ^. orderAddress

updateEmail :: (MonadReader Config m, MonadUnliftIO m, MonadCatch m) e => Text -> UpdatePayload -> m ()
updateEmail orderId payload =
  updateOrder orderId ":orderEmail"
    $ getEmail <$> payload ^. orderEmail

-- Assumes this
newtype Email = Email { getEmail :: Text }

为什么要删除 uiExpressionAttributeNames？

uiExpressionAttributeNames 在这里没有用。它有不同的用途:

ExpressionAttributeNames

One or more substitution tokens for attribute names in an expression. The following are some use cases for using ExpressionAttributeNames:

1. To access an attribute whose name conflicts with a DynamoDB reserved word.

2. To create a placeholder for repeating occurrences of an attribute name in an expression.

3. To prevent special characters in an attribute name from being misinterpreted in an expression.

这是我写的一个 SSCCE，展示了确实有效的总体思路:

{-# LANGUAGE OverloadedStrings #-}
module Lib2 where

import           Control.Lens
import           Control.Monad.IO.Class
import           Control.Monad.Trans.AWS
import           Data.ByteString         (ByteString)
import           Data.HashMap.Strict     (HashMap, fromList)
import qualified Data.HashMap.Strict     as Map
import           Data.Text               (Text)
import qualified Data.Text               as Text
import qualified Data.Text.IO            as Text
import           Network.AWS.DynamoDB
import           System.IO

upsertItem :: Region
              -- ^ Region to operate in.
           -> Bool
              -- ^ Whether to use HTTPS (ie. SSL).
           -> ByteString
              -- ^ The hostname to connect to.
           -> Int
              -- ^ The port number to connect to.
           -> Text
              -- ^ The table to insert the item into.
           -> HashMap Text AttributeValue
              -- ^ The key name-value pairs that constitute the primary key.
           -> HashMap Text AttributeValue
              -- ^ The attribute name-value pairs that constitute an item.
           -> IO UpdateItemResponse
upsertItem region secure host port table key item = do
    lgr <- newLogger Debug stdout
    env <- newEnv Discover <&> set envLogger lgr

    -- Specify a custom DynamoDB endpoint to communicate with:
    let dynamo = setEndpoint secure host port dynamoDB

    runResourceT . runAWST env . within region $ do
        -- Scoping the endpoint change using 'reconfigure':
        reconfigure dynamo $ do
            say $ "Updating item in table '"
               <> table
               <> "' with attribute names: "
               <> Text.intercalate ", " (Map.keys item)
            -- Insert the new item into the specified table:
            send $ updateItem table
                   &  uiKey
                   .~ key
                   &  uiUpdateExpression
                   ?~ expression
                   &  uiExpressionAttributeValues
                   .~ values
   where
     expression     = "SET " <> Text.intercalate ", " setOperations
     setOperations  = fmap (\item -> Text.tail item <> " = " <> item) (Map.keys item)
     values         = item

upsertField :: Region
              -- ^ Region to operate in.
           -> Bool
              -- ^ Whether to use HTTPS (ie. SSL).
           -> ByteString
              -- ^ The hostname to connect to.
           -> Int
              -- ^ The port number to connect to.
           -> Text
              -- ^ The table to insert the item into.
           -> HashMap Text AttributeValue
              -- ^ The key name-value pairs that constitute the primary key.
           -> Text
              -- ^ The attribute name.
           -> Text
              -- ^ The attribute value.
           -> IO UpdateItemResponse
upsertField region secure host port table key name value = do
    lgr <- newLogger Debug stdout
    env <- newEnv Discover <&> set envLogger lgr

    -- Specify a custom DynamoDB endpoint to communicate with:
    let dynamo = setEndpoint secure host port dynamoDB

    runResourceT . runAWST env . within region $ do
        -- Scoping the endpoint change using 'reconfigure':
        reconfigure dynamo $ do
            -- Insert the new item into the specified table:
            send $ updateItem table
                   &  uiKey
                   .~ key
                   &  uiUpdateExpression
                   ?~ expression
                   &  uiExpressionAttributeValues
                   .~ values
   where
     expression     = "SET " <> Text.tail name <> " = " <> name
     values         = Map.fromList [(name, attributeValue & avS ?~ value)]

say :: MonadIO m => Text -> m ()
say = liftIO . Text.putStrLn