Haskell Servant开发中两结构体共享部分内容时的惯用处理方式

针对这类「输入输出数据结构大部分字段重合，仅少量字段由服务端补充」的场景，Haskell生态下有两种非常成熟的惯用写法，从地道性和易用性分别说明：

方案1：参数化阶段标记类型（最符合Haskell惯用风格） #

核心是消除重复的字段定义，用类型参数标记数据所处的生命周期阶段（用户提交输入/服务端持久化输出），彻底避免给字段加撇号区分、逐字段拷贝的冗余代码。

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}

import Data.Aeson
import Data.Time (UTCTime)
import GHC.Generics
import Database.PostgreSQL.Simple.FromRow

-- 抽离所有阶段共有的字段，用独立的类型承载不同阶段的差异字段
data Msg inputMeta outputMeta = Msg
  { thread :: Int
  , dname :: String
  , contents :: String
  , inMeta :: inputMeta
  , outMeta :: outputMeta
  } deriving (Eq, Show, Generic)

-- 用户提交POST请求时，没有额外元数据，元数据字段用单元类型占位
type InputMsg = Msg () ()

-- 服务端存库/返回响应时，补充时间戳、IP两个字段
data ServerMeta = ServerMeta
  { stamp :: UTCTime
  , ip :: String
  } deriving (Eq, Show, Generic)
type OutputMsg = Msg () ServerMeta

-- 所有JSON、数据库实例都可以自动派生，只要简单配置aeson的字段映射规则，就能生成和你原有双类型完全一致的JSON结构，前端无感知
instance FromJSON InputMsg
instance ToJSON ServerMeta
instance ToJSON OutputMsg
instance FromRow OutputMsg

接口处理逻辑里不需要逐字段拷贝，只需要替换元数据字段即可：

-- POST接口处理逻辑
createMessage :: InputMsg -> Maybe String -> Handler APIMessage
createMessage inputMsg maybeRealIp = do
  currentTime <- liftIO getCurrentTime
  let clientIp = fromMaybe "127.0.0.1" maybeRealIp
      -- 公共字段完全不需要手动赋值，直接替换元数据部分
      persistedMsg = inputMsg { outMeta = ServerMeta currentTime clientIp }
  -- 后续存库、返回响应逻辑即可

这种写法的长期维护成本最低：后续新增公共字段时只需要修改一次Msg类型定义，不需要同时改输入、输出两个类型，也不会出现漏改字段映射的低级错误。

方案2：保留双类型，封装转换函数（改动成本最低） #

如果你暂时不想调整现有类型结构，至少要把两个类型之间的转换逻辑封装到统一函数里，不要在业务代码中散落逐字段赋值的代码，配合RecordWildCards扩展可以把冗余代码降到最低：

{-# LANGUAGE RecordWildCards #-}

-- 保留你原有的Msg、Msg'定义，只需要新增一个转换函数
toOutputMsg :: Msg -> UTCTime -> String -> Msg'
toOutputMsg Msg{..} stamp' ip' = Msg'{..}
  where
    thread' = thread
    dname' = dname
    contents' = contents

业务逻辑里直接调用该函数即可，不需要每次都手写三个公共字段的赋值：

createMessage msg maybeIp = do
  now <- liftIO getCurrentTime
  let clientIp = fromMaybe "unknown" maybeIp
      output = toOutputMsg msg now clientIp
  -- 后续逻辑

这种写法几乎不需要改动现有代码，只需要加一个几行的转换函数，就能避免后续改字段时漏改映射的问题。

额外的接口规范建议 #

你当前GET接口用ReqBody '[JSON] Int接收线程ID不符合HTTP语义规范，GET请求不应该携带请求体，建议改成路径捕获参数，更符合REST风格也更方便Servant路由处理：

type UserAPI = "messages" :> ReqBody '[JSON] Msg :> Header "X-Real-IP" String :> Post '[JSON] APIMessage
               :<|> "messages" :> Capture "threadId" Int :> Get '[JSON] [Msg']

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