如何锁定Controller上的动作以顺序而非并行处理IHP竞价服务的投标请求

方案1：数据库悲观行锁（推荐，业务实现成本最低） #

这个方案通过数据库层面的锁机制实现串行处理，不需要额外依赖，适配绝大多数竞价场景的并发需求：

• 首先创建单条记录型表bid_settings，核心字段包含auction_id（竞价活动ID，多场竞价场景用）、current_highest_price（当前最高有效投标价），每个竞价活动对应表内唯一一条记录。
• 处理投标请求时先开启事务，使用SELECT ... FOR UPDATE语法锁定对应竞价活动的bid_settings记录，此时其他同活动的投标请求会阻塞等待锁释放，天然实现串行处理逻辑。
• 锁获取成功后读取当前最高价格，和用户提交的价格比对：
  • 价格符合要求：保存投标记录，更新bid_settings的最高价格字段，提交事务后锁自动释放。
  • 价格不符合要求：直接回滚事务，锁自动释放，返回驳回信息。

IHP 代码示例：

action SubmitBidAction auctionId = do
  bidPrice <- param @Double "price"
  userId <- currentUserId
  
  result <- withTransaction $ do
    -- 锁定对应竞价的最高价格记录，其他请求将在此处阻塞直到锁释放
    Just bidSetting <- query @BidSetting
      |> filterWhere (#auctionId, auctionId)
      |> forUpdate
      |> fetchOne
    
    if bidPrice > get #currentHighestPrice bidSetting
      then do
        -- 保存有效投标记录
        newRecord @Bid
          |> set #auctionId auctionId
          |> set #userId userId
          |> set #price bidPrice
          |> set #isValid True
          |> createRecord
        -- 更新最高投标价
        bidSetting
          |> set #currentHighestPrice bidPrice
          |> updateRecord
        pure $ Right "投标成功"
      else pure $ Left "投标价格需高于当前最高有效价格"
  
  case result of
    Right msg -> renderJson ["success" .= msg]
    Left err -> renderJson ["error" .= err]

方案2：STM实现（适合高并发场景） #

如果并发量极高，不想依赖数据库锁可以使用GHC原生STM实现，IHP运行时天然支持STM能力：

• 在应用启动阶段初始化一个TVar结构，类型为TVar (Map AuctionId Double)，用来存储所有活跃竞价的当前最高投标价，挂载到IHP的全局应用状态中。
• 处理投标请求时在STM事务内操作TVar：STM会自动处理冲突重试，保证所有操作的原子性、隔离性，天然满足串行处理要求。
• 注意需要配合异步任务队列将投标数据持久化到数据库，避免服务重启丢失数据。

IHP 代码示例：
首先在Web/Types.hs扩展应用状态定义：

data App = App
  { appConfig :: AppConfig
  , -- 保留原有默认字段
  , currentHighestBids :: TVar (Map (Id Auction) Double)
  }

在Main.hs的应用初始化逻辑中初始化TVar：

main = runApp $ do
  -- 从数据库加载所有活跃竞价的当前最高价格，初始化TVar
  initialBidMap <- query @BidSetting
    |> filterWhere (#isActive, True)
    |> fetch
    |> map (\setting -> (get #auctionId setting, get #currentHighestPrice setting))
    |> Map.fromList
    |> newTVarIO
  pure App { currentHighestBids = initialBidMap, .. }

请求处理逻辑：

action SubmitBidAction auctionId = do
  bidPrice <- param @Double "price"
  userId <- currentUserId
  bidsVar <- asks #currentHighestBids
  
  result <- atomically $ do
    bidMap <- readTVar bidsVar
    let currentHighest = Map.findWithDefault 0 auctionId bidMap
    if bidPrice > currentHighest
      then do
        writeTVar bidsVar (Map.insert auctionId bidPrice bidMap)
        -- 异步写入数据库持久化
        liftIO $ enqueueJob (SaveBidJob auctionId userId bidPrice)
        pure $ Right "投标成功"
      else pure $ Left "投标价格需高于当前最高有效价格"
  
  case result of
    Right msg -> renderJson ["success" .= msg]
    Left err -> renderJson ["error" .= err]

内容的提问来源于stack exchange，提问作者amitaibu