{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module MCP.Server.Transport.Http
  ( -- * HTTP Transport
    HttpConfig(..)
  , transportRunHttp
  , defaultHttpConfig
  ) where

import           Control.Monad            (when)
import           Data.Aeson
import qualified Data.ByteString.Lazy     as BSL
import           Data.String              (IsString (fromString))
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as TE
import           Network.HTTP.Types
import qualified Network.Wai              as Wai
import qualified Network.Wai.Handler.Warp as Warp
import           System.IO                (hPutStrLn, stderr)

import           MCP.Server.Handlers
import           MCP.Server.JsonRpc
import           MCP.Server.Types

-- | HTTP transport configuration following MCP 2025-06-18 Streamable HTTP specification
data HttpConfig = HttpConfig
  { HttpConfig -> Int
httpPort     :: Int      -- ^ Port to listen on
  , HttpConfig -> String
httpHost     :: String   -- ^ Host to bind to (default "localhost")
  , HttpConfig -> String
httpEndpoint :: String   -- ^ MCP endpoint path (default "/mcp")
  , HttpConfig -> Bool
httpVerbose  :: Bool     -- ^ Enable verbose logging (default False)
  } deriving (Int -> HttpConfig -> ShowS
[HttpConfig] -> ShowS
HttpConfig -> String
(Int -> HttpConfig -> ShowS)
-> (HttpConfig -> String)
-> ([HttpConfig] -> ShowS)
-> Show HttpConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpConfig -> ShowS
showsPrec :: Int -> HttpConfig -> ShowS
$cshow :: HttpConfig -> String
show :: HttpConfig -> String
$cshowList :: [HttpConfig] -> ShowS
showList :: [HttpConfig] -> ShowS
Show, HttpConfig -> HttpConfig -> Bool
(HttpConfig -> HttpConfig -> Bool)
-> (HttpConfig -> HttpConfig -> Bool) -> Eq HttpConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HttpConfig -> HttpConfig -> Bool
== :: HttpConfig -> HttpConfig -> Bool
$c/= :: HttpConfig -> HttpConfig -> Bool
/= :: HttpConfig -> HttpConfig -> Bool
Eq)

-- | Default HTTP configuration
defaultHttpConfig :: HttpConfig
defaultHttpConfig :: HttpConfig
defaultHttpConfig = HttpConfig
  { httpPort :: Int
httpPort = Int
3000
  , httpHost :: String
httpHost = String
"localhost"
  , httpEndpoint :: String
httpEndpoint = String
"/mcp"
  , httpVerbose :: Bool
httpVerbose = Bool
False
  }

-- | Helper for conditional logging
logVerbose :: HttpConfig -> String -> IO ()
logVerbose :: HttpConfig -> String -> IO ()
logVerbose HttpConfig
config String
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HttpConfig -> Bool
httpVerbose HttpConfig
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg


-- | Transport-specific implementation for HTTP
transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()
transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()
transportRunHttp HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers = do
  let settings :: Settings
settings = HostPreference -> Settings -> Settings
Warp.setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString (String -> HostPreference) -> String -> HostPreference
forall a b. (a -> b) -> a -> b
$ HttpConfig -> String
httpHost HttpConfig
config) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                 Int -> Settings -> Settings
Warp.setPort (HttpConfig -> Int
httpPort HttpConfig
config) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                 Settings
Warp.defaultSettings

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting MCP HTTP server on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpConfig -> String
httpHost HttpConfig
config String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (HttpConfig -> Int
httpPort HttpConfig
config) String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpConfig -> String
httpEndpoint HttpConfig
config
  Settings -> Application -> IO ()
Warp.runSettings Settings
settings (HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Application
mcpApplication HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers)

-- | WAI Application for MCP over HTTP
mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Application
mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Application
mcpApplication HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers Request
req Response -> IO ResponseReceived
respond = do
  -- Log the request
  HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"HTTP " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Request -> ByteString
Wai.requestMethod Request
req) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawPathInfo Request
req)

  -- Check if this is our MCP endpoint
  if ByteString -> Text
TE.decodeUtf8 (Request -> ByteString
Wai.rawPathInfo Request
req) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack (HttpConfig -> String
httpEndpoint HttpConfig
config)
    then HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Application
handleMcpRequest HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers Request
req Response -> IO ResponseReceived
respond
    else Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status404 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"Not Found"

-- | Handle MCP requests according to Streamable HTTP specification
handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Application
handleMcpRequest HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers Request
req Response -> IO ResponseReceived
respond = do
  -- Check for mandatory MCP-Protocol-Version header (2025-06-18 requirement)
  case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"MCP-Protocol-Version" (Request -> ResponseHeaders
Wai.requestHeaders Request
req) of
    Maybe ByteString
Nothing -> do
      HttpConfig -> String -> IO ()
logVerbose HttpConfig
config String
"Request rejected: Missing MCP-Protocol-Version header"
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
        Status
status400
        [(HeaderName
"Content-Type", ByteString
"application/json")]
        (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Missing required MCP-Protocol-Version header" :: Text)])
    Just ByteString
headerValue -> 
      if ByteString -> Text
TE.decodeUtf8 ByteString
headerValue Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"2025-06-18" then do
        HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Request rejected: Invalid protocol version: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
headerValue
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
          Status
status400
          [(HeaderName
"Content-Type", ByteString
"application/json")]
          (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Unsupported protocol version. Server only supports 2025-06-18" :: Text)])
      else
        case Request -> ByteString
Wai.requestMethod Request
req of
          -- GET requests for endpoint discovery
          ByteString
"GET" -> do
            let discoveryResponse :: Value
discoveryResponse = [Pair] -> Value
object
                  [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= McpServerInfo -> Text
serverName McpServerInfo
serverInfo
                  , Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= McpServerInfo -> Text
serverVersion McpServerInfo
serverInfo
                  , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= McpServerInfo -> Text
serverInstructions McpServerInfo
serverInfo
                  , Key
"protocolVersion" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"2025-06-18" :: Text)
                  , Key
"capabilities" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                      [ Key
"tools" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object []
                      , Key
"prompts" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object []
                      , Key
"resources" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object []
                      ]
                  ]
            HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sending server discovery response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
discoveryResponse
            Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
              Status
status200
              [(HeaderName
"Content-Type", ByteString
"application/json"), (HeaderName
"Access-Control-Allow-Origin", ByteString
"*")]
              (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
discoveryResponse)

          -- POST requests for JSON-RPC messages
          ByteString
"POST" -> do
            -- Read request body
            body <- Request -> IO ByteString
Wai.strictRequestBody Request
req
            logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)
            handleJsonRpcRequest config serverInfo handlers body respond

          -- OPTIONS for CORS preflight
          ByteString
"OPTIONS" -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
            Status
status200
            [ (HeaderName
"Access-Control-Allow-Origin", ByteString
"*")
            , (HeaderName
"Access-Control-Allow-Methods", ByteString
"GET, POST, OPTIONS")
            , (HeaderName
"Access-Control-Allow-Headers", ByteString
"Content-Type, MCP-Protocol-Version")
            ]
            ByteString
""

          -- Unsupported methods
          ByteString
_ -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
            Status
status405
            [(HeaderName
"Content-Type", ByteString
"text/plain"), (HeaderName
"Allow", ByteString
"GET, POST, OPTIONS")]
            ByteString
"Method Not Allowed"

-- | Handle JSON-RPC request from HTTP body
handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
handleJsonRpcRequest :: HttpConfig
-> McpServerInfo
-> McpServerHandlers IO
-> ByteString
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
handleJsonRpcRequest HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers ByteString
body Response -> IO ResponseReceived
respond = do
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JSON parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
        Status
status400
        [(HeaderName
"Content-Type", ByteString
"application/json")]
        (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Invalid JSON" :: Text)])

    Right Value
jsonValue -> HttpConfig
-> McpServerInfo
-> McpServerHandlers IO
-> Value
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
handleSingleJsonRpc HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers Value
jsonValue Response -> IO ResponseReceived
respond

-- | Handle a single JSON-RPC message
handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
handleSingleJsonRpc :: HttpConfig
-> McpServerInfo
-> McpServerHandlers IO
-> Value
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
handleSingleJsonRpc HttpConfig
config McpServerInfo
serverInfo McpServerHandlers IO
handlers Value
jsonValue Response -> IO ResponseReceived
respond = do
  case Value -> Either String JsonRpcMessage
parseJsonRpcMessage Value
jsonValue of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JSON-RPC parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
        Status
status400
        [(HeaderName
"Content-Type", ByteString
"application/json")]
        (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Invalid JSON-RPC" :: Text)])

    Right JsonRpcMessage
message -> do
      HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Processing HTTP message: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (JsonRpcMessage -> String
getMessageSummary JsonRpcMessage
message)
      maybeResponse <- McpServerInfo
-> McpServerHandlers IO
-> JsonRpcMessage
-> IO (Maybe JsonRpcMessage)
forall (m :: * -> *).
MonadIO m =>
McpServerInfo
-> McpServerHandlers m
-> JsonRpcMessage
-> m (Maybe JsonRpcMessage)
handleMcpMessage McpServerInfo
serverInfo McpServerHandlers IO
handlers JsonRpcMessage
message

      case maybeResponse of
        Just JsonRpcMessage
responseMsg -> do
          let responseJson :: ByteString
responseJson = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcMessage -> Value
encodeJsonRpcMessage JsonRpcMessage
responseMsg
          HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sending HTTP response for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (JsonRpcMessage -> String
getMessageSummary JsonRpcMessage
message)
          Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
            Status
status200
            [(HeaderName
"Content-Type", ByteString
"application/json"), (HeaderName
"Access-Control-Allow-Origin", ByteString
"*")]
            ByteString
responseJson

        Maybe JsonRpcMessage
Nothing -> do
          HttpConfig -> String -> IO ()
logVerbose HttpConfig
config (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No response needed for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (JsonRpcMessage -> String
getMessageSummary JsonRpcMessage
message)
          -- For notifications, return 200 with empty JSON object (per MCP spec)
          Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS 
            Status
status200 
            [(HeaderName
"Content-Type", ByteString
"application/json"), (HeaderName
"Access-Control-Allow-Origin", ByteString
"*")] 
            ByteString
"{}"