restman-0.7.6.0: echo/Main.hs

{-# language OverloadedStrings #-}
-- | Standalone diagnostic echo server for local restman testing.
--
-- Accepts any HTTP request and responds with a JSON object reflecting
-- the method, path, query string, request headers, and body — identical
-- schema to the in-process 'HTTP.EchoServer' used by the test suite.
--
-- Usage:
--   stack run restman-echo --flag restman:echo-server
--   PORT=9000 stack run restman-echo --flag restman:echo-server
--
-- Every incoming request is pretty-printed to stdout, including a UTC
-- timestamp, so both sides of a request/response cycle can evaluate
-- what actually arrived.
module Main (main) where

import Data.Aeson (encode, object, (.=))
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import qualified Data.CaseInsensitive as CI
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (getCurrentTime)
import Network.HTTP.Types (status200)
import Network.Wai
  ( Application
  , rawPathInfo
  , rawQueryString
  , requestHeaders
  , requestMethod
  , responseLBS
  , strictRequestBody
  )
import Network.Wai.Handler.Warp (Port, run)
import System.Environment (lookupEnv)
import System.IO (hFlush, stdout)

-- | Build the echo payload — identical schema to HTTP.EchoServer.
buildPayload
    :: T.Text            -- ^ method
    -> T.Text            -- ^ path
    -> T.Text            -- ^ query string (including leading '?')
    -> Map T.Text T.Text -- ^ lowercased headers
    -> T.Text            -- ^ body
    -> BL.ByteString
buildPayload method path query hdrs body =
    encode $ object
        [ "method"  .= method
        , "path"    .= path
        , "query"   .= query
        , "headers" .= hdrs
        , "body"    .= body
        ]

-- | Log a received request to stdout in pretty-printed JSON, with a
-- UTC timestamp in the log entry (timestamp is *not* included in the
-- HTTP response body so the schema stays compatible with EchoServer).
logRequest
    :: T.Text            -- ^ method
    -> T.Text            -- ^ path
    -> T.Text            -- ^ query string
    -> Map T.Text T.Text -- ^ lowercased headers
    -> T.Text            -- ^ body
    -> IO ()
logRequest method path query hdrs body = do
    ts <- getCurrentTime
    let logEntry = encodePretty $ object
            [ "timestamp" .= show ts
            , "method"    .= method
            , "path"      .= path
            , "query"     .= query
            , "headers"   .= hdrs
            , "body"      .= body
            ]
    BLC8.putStrLn logEntry
    putStrLn "\x2192 200 OK"
    hFlush stdout

-- | WAI application: log the request then echo it back as compact JSON.
echoApp :: Application
echoApp req respond = do
    rawBody <- strictRequestBody req
    let method = TE.decodeUtf8 (requestMethod req)
        path = TE.decodeUtf8 (rawPathInfo req)
        query = TE.decodeUtf8 (rawQueryString req)
        hdrs = Map.fromList
                      [ (TE.decodeUtf8 (CI.foldedCase k), TE.decodeUtf8 v)
                      | (k, v) <- requestHeaders req
                      ] :: Map T.Text T.Text
        bodyTxt = TE.decodeUtf8 (BL.toStrict rawBody)
    logRequest method path query hdrs bodyTxt
    let payload = buildPayload method path query hdrs bodyTxt
    respond $ responseLBS status200
        [("Content-Type", "application/json")]
        payload

-- | Read PORT from the environment (default 8080) and run the server.
main :: IO ()
main = do
    portStr <- lookupEnv "PORT"
    let port = maybe 8080 read portStr :: Port
    putStrLn $ "restman-echo listening on port " <> show port
    putStrLn   "(press Ctrl-C to stop)\n"
    hFlush stdout
    run port echoApp