Dynamically update database record in Haskell (DynamoDB)

Question

I'm working on DynamoDB with Haskell now. I have a hard time updating records dynamically.

For example, I have data like:

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

Then I would like to have a dynamic query where you can pass fields and values to be updated.

So, in Typescript, it would look like:

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

Then I can do like:

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

In Haskell, I'm using amazonka-dynamodb library. If I want to update order status I can write like:

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))]

But I don't want to make a new query when I need to update the address for instance.

One way I can think of to make it dynamic is to use a hash map and pass keys and values to update, in the same way as the Typescript example.

If it is for uiExpressionAttributeNames, it would look like

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

However, for uiExpressionAttributeValues, I need to map each value with pattern matching.

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

Then, I get compile error because of avS .~ val, where val is expected to be Text but actually is a...

Both getExpression and getUpdateValues look quite ugly and the latter wouldn't be compiled. Is there any cleaner way to solve this problem?

Answer 1

SET expressions in UpdateExpression look like this and can be generated by concatenating Texts:

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

You should now be able to write this single, more loosely-typed update function for your Order records in DynamoDB that takes a Text attribute name:

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)]

And then write strongly typed setters that adapt to it:

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 }

Why did I remove uiExpressionAttributeNames?

uiExpressionAttributeNames isn't useful here. It has a different purpose:

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.

Here's an SSCCE I wrote demonstrating the general idea that does definitely work:

{-# 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