Proof-of-concept HTTP client request logging for Haskell

http-client-logger.hs

#!/usr/bin/env stack
{- stack
  --resolver lts-18.27
  --install-ghc runghc
  --package aeson
  --package containers
  --package http-client
  --package http-types
  --package monad-logger
  --package text
  --package uuid
-}

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -Wall #-}

import Control.Monad.Logger
import Data.Aeson
import Data.List (find)
import Network.HTTP.Client

import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8
import qualified Data.CaseInsensitive as CI
import qualified Data.Map.Strict as Map
import qualified Data.Text.Encoding as Text
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

main :: IO ()
main = do
  logger <- runStderrLoggingT askLoggerIO

  let logInfoIO :: Value -> IO ()
      logInfoIO =
        flip runLoggingT logger
          . logInfoN
          . Text.decodeUtf8
          . Lazy.Char8.toStrict
          . encode

  manager <- newManager $ addRequestLogging logInfoIO defaultManagerSettings
  _ <- flip httpLbs manager =<< parseRequest "http://httpbin.org/get"
  _ <- flip httpLbs manager =<< parseRequest "http://httpbin.org/get"
  _ <- flip httpLbs manager =<< parseRequest "POST http://httpbin.org/post"
  putStrLn "-----------------------------------\nOK"

addRequestLogging :: (Value -> IO ()) -> ManagerSettings -> ManagerSettings
addRequestLogging logIO settings =
  settings
    { managerModifyRequest = \request -> do
        -- This is a bit of a hack because 'managerModifyRequest' gets run twice.
        -- We check to see if we have a magic header. If we do, we do nothing.
        -- If we don't, we add log the request and then add the magic header.
        -- This trick helps us avoid logging the request twice.
        case find ((httpReqLogIdHeaderKey ==) . fst) (requestHeaders request) of
          Just _ -> pure request
          Nothing -> do
            uuid <- UUID.nextRandom
            logIO $
              object
                [ ( "http-client-request"
                  , object
                      [ ("id", toJSON uuid)
                      , ("request", requestToJSON request)
                      ]
                  )
                ]
            pure request
              { requestHeaders =
                  ( httpReqLogIdHeaderKey, UUID.toASCIIBytes uuid )
                  : requestHeaders request
              }
    }
  where
  httpReqLogIdHeaderKey = "__HTTP-REQ-LOG-ID"

requestToJSON :: Request -> Value
requestToJSON request =
  object
    [ ("host"            , toJSON $ Char8.unpack $ host request)
    , ("port"            , toJSON $ port request)
    , ("secure"          , toJSON $ secure request)
    , ("requestHeaders"  , toJSON requestHeadersMap)
    , ("path"            , toJSON $ Char8.unpack $ path request)
    , ("queryString"     , toJSON $ Char8.unpack $ queryString request)
    , ("method"          , toJSON $ Char8.unpack $ method request)
    , ("proxy"           , toJSON $ show <$> proxy request)
    , ("redirectCount"   , toJSON $ redirectCount request)
    , ("responseTimeout" , toJSON $ show $ responseTimeout request)
    , ("requestVersion"  , toJSON $ show $ requestVersion request)
    ]
  where
  requestHeadersMap =
    Map.fromList $ flip map (requestHeaders request) \(k, v) ->
      (Char8.unpack $ CI.original k, Char8.unpack v)