3

如何在请求记录器中添加请求和响应正文的特定表示？我希望能够有一些typeclass可以让我实现这种表示。在Network.Wai.Middleware.RequestLogger.JSON我可以看到请求记录器是如何实现的。

formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders
formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =
  toLogStr (encode $
    object
      [ "request"  .= requestToJSON duration req reqBody
      , "response" .= object
        [ "status" .= statusCode status
        , "size"   .= resSize
        , "headers" .= responseHeadersToJSON resHeaders
        , "body"   .=
          if statusCode status >= 400
            then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res
            else Nothing
        ]
      , "time"     .= decodeUtf8With lenientDecode date
      ]) <> "\n"

requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value
requestToJSON duration req reqBody =
  object
    [ "method" .= decodeUtf8With lenientDecode (requestMethod req)
    , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)
    , "queryString" .= map queryItemToJSON (queryString req)
    , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)
    , "size" .= requestBodyLengthToJSON (requestBodyLength req)
    , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)
    , "remoteHost" .= sockToJSON (remoteHost req)
    , "httpVersion" .= httpVersionToJSON (httpVersion req)
    , "headers" .= requestHeadersToJSON (requestHeaders req)
    ]
  where
    rationalToDouble :: Rational -> Double
    rationalToDouble = fromRational

因此，如果我要收到请求：

new_user : { "email": "foo", "password": "bar" }

我只想通过电子邮件发送：

new_user : { "email": "foo", "password": "" }

我通过一些类型类来做到这一点：

class LogRepr body where
 toLogRepr :: body -> Value -- Some monoidal text  

instance LogRepr NewUser where
  toLogRepr nu = object
    [ "new_user" .= 
      object
        [ "email" .= email nu
        ]
    ]

这将允许我轻松使用我不想修改其默认行为的类型的 toJSON 和 FromJSON。是否也可以修改它，以便当我的应用程序像“消息”字段或“活动”字段一样运行时，我可以添加一些任意上下文。

4

0 回答 0