diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Junji Hashimoto + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,361 @@ +# Louter + +Multi-protocol LLM proxy and Haskell client library. Connect to any LLM API (OpenAI, Anthropic, Gemini) using any SDK with automatic protocol translation. + +## Features + +- **Protocol Translation**: OpenAI ↔ Anthropic ↔ Gemini automatic conversion +- **Dual Usage**: Haskell library or standalone proxy server +- **Streaming**: Full SSE support with smart buffering +- **Function Calling**: Works across all protocols (JSON and XML formats) +- **Vision**: Multimodal image support +- **Flexible Auth**: Optional authentication for local vs cloud backends + +## Quick Start + +### As a Proxy Server + +```bash +# Install +git clone https://github.com/junjihashimoto/louter.git +cd louter +cabal build all + +# Configure +cat > config.yaml < case event of + StreamContent txt -> putStr txt >> hFlush stdout + StreamFinish reason -> putStrLn $ "\n[Done: " <> reason <> "]" + StreamError err -> putStrLn $ "[Error: " <> err <> "]" + _ -> pure () +``` + +**Function calling:** +```haskell +import Data.Aeson (object, (.=)) + +weatherTool = Tool + { toolName = "get_weather" + , toolDescription = Just "Get current weather" + , toolParameters = object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "location" .= object + [ "type" .= ("string" :: Text) ] + ] + , "required" .= (["location"] :: [Text]) + ] + } + +request = (defaultChatRequest "gpt-4" + [Message RoleUser "Weather in Tokyo?"]) + { reqTools = [weatherTool] + , reqToolChoice = ToolChoiceAuto + } +``` + +## Use Cases + +| Frontend | Backend | Use Case | +|----------|---------|----------| +| OpenAI SDK | Gemini API | Use OpenAI SDK with Gemini models | +| Anthropic SDK | Local llama-server | Use Claude Code with local models | +| Gemini SDK | OpenAI API | Use Gemini SDK with GPT models | +| Any SDK | Any Backend | Protocol-agnostic development | + +## Configuration + +**Local model** (no auth): +```yaml +backends: + local: + type: openai + url: http://localhost:11211 + requires_auth: false + model_mapping: + gpt-4: qwen/qwen2.5-vl-7b +``` + +**Cloud API** (with auth): +```yaml +backends: + openai: + type: openai + url: https://api.openai.com + requires_auth: true + api_key: "${OPENAI_API_KEY}" + model_mapping: + gpt-4: gpt-4-turbo-preview +``` + +**Multi-backend:** +```yaml +backends: + local: + type: openai + url: http://localhost:11211 + requires_auth: false + model_mapping: + gpt-3.5-turbo: qwen/qwen2.5-7b + + openai: + type: openai + url: https://api.openai.com + requires_auth: true + api_key: "${OPENAI_API_KEY}" + model_mapping: + gpt-4: gpt-4-turbo-preview +``` + +See [examples/](examples/) for more configurations. + +## API Types + +### Client Creation + +```haskell +-- Local llama-server (no auth) +import Louter.Client.OpenAI (llamaServerClient) +client <- llamaServerClient "http://localhost:11211" + +-- Cloud APIs (with auth) +import Louter.Client.OpenAI (openAIClient) +import Louter.Client.Anthropic (anthropicClient) +import Louter.Client.Gemini (geminiClient) + +client <- openAIClient "sk-..." +client <- anthropicClient "sk-ant-..." +client <- geminiClient "your-api-key" +``` + +### Request Types + +```haskell +-- ChatRequest +data ChatRequest = ChatRequest + { reqModel :: Text + , reqMessages :: [Message] + , reqTools :: [Tool] + , reqTemperature :: Maybe Float + , reqMaxTokens :: Maybe Int + , reqStream :: Bool + } + +-- Message +data Message = Message + { msgRole :: MessageRole -- RoleSystem | RoleUser | RoleAssistant + , msgContent :: Text + } + +-- Tool +data Tool = Tool + { toolName :: Text + , toolDescription :: Maybe Text + , toolParameters :: Value -- JSON schema + } +``` + +### Response Types + +```haskell +-- Non-streaming +chatCompletion :: Client -> ChatRequest -> IO (Either Text ChatResponse) + +data ChatResponse = ChatResponse + { respId :: Text + , respChoices :: [Choice] + , respUsage :: Maybe Usage + } + +-- Streaming +streamChatWithCallback :: Client -> ChatRequest -> (StreamEvent -> IO ()) -> IO () + +data StreamEvent + = StreamContent Text -- Response text + | StreamReasoning Text -- Thinking tokens + | StreamToolCall ToolCall -- Complete tool call (buffered) + , StreamFinish FinishReason + | StreamError Text +``` + +## Docker + +```bash +# Build +docker build -t louter . + +# Run with config +docker run -p 9000:9000 -v $(pwd)/config.yaml:/app/config.yaml louter + +# Or use docker-compose +docker-compose up +``` + +## Testing + +```bash +# Python SDK integration tests (43+ tests) +python tests/run_all_tests.py + +# Haskell unit tests +cabal test all +``` + +## Architecture + +``` +Client Request (Any Format) + ↓ +Protocol Converter + ↓ +Core IR (OpenAI-based) + ↓ +Backend Adapter + ↓ +LLM Backend (Any Format) +``` + +**Key Components:** +- **SSE Parser**: Incremental streaming with attoparsec +- **Smart Buffering**: Tool calls buffered until complete JSON +- **Type Safety**: Strict Haskell types throughout + +**Streaming Strategy:** +- **Content/Reasoning**: Stream immediately (real-time output) +- **Tool Calls**: Buffer until complete (valid JSON required) +- **State Machine**: Track tool call assembly by index + +## Proxy Examples + +### Use OpenAI SDK with Local Models + +```python +from openai import OpenAI + +client = OpenAI( + base_url="http://localhost:9000/v1", + api_key="not-needed" +) + +response = client.chat.completions.create( + model="gpt-4", # Routed to qwen/qwen2.5-vl-7b + messages=[{"role": "user", "content": "Hello!"}] +) +``` + +### Use Claude Code with Gemini + +```yaml +# config.yaml +backends: + gemini: + type: gemini + url: https://generativelanguage.googleapis.com + requires_auth: true + api_key: "${GEMINI_API_KEY}" + model_mapping: + claude-3-5-sonnet-20241022: gemini-2.0-flash +``` + +```bash +# Start proxy on Anthropic-compatible port +cabal run louter-server -- --config config.yaml --port 8000 + +# Configure Claude Code: +# API Endpoint: http://localhost:8000 +# Model: claude-3-5-sonnet-20241022 +``` + +## Monitoring + +**Health check:** +```bash +curl http://localhost:9000/health +``` + +**JSON-line logging:** +```bash +cabal run louter-server -- --config config.yaml --port 9000 2>&1 | jq . +``` + +## Troubleshooting + +**Connection refused:** +```bash +# Check backend is running +curl http://localhost:11211/v1/models +``` + +**Invalid API key:** +```bash +# Verify environment variable +echo $OPENAI_API_KEY +``` + +**Model not found:** +- Check `model_mapping` in config +- Frontend model (client requests) → Backend model (sent to API) + +## Examples + +See [examples/](examples/) for configuration examples and use cases. + +## License + +MIT License - see LICENSE file. diff --git a/app/CLI.hs b/app/CLI.hs new file mode 100644 --- /dev/null +++ b/app/CLI.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Interactive CLI for chatting with LLMs via Louter client API +-- Supports MCP (Model Context Protocol) for external tools and resources +module Main where + +import Control.Monad (forever, when, unless) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import Data.List (isPrefixOf) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Options.Applicative +import System.IO (hFlush, stdout, hSetBuffering, BufferMode(..)) +import System.Exit (exitSuccess) + +import Louter.Client +import Louter.Client.OpenAI +import Louter.Types.Request +import Louter.Types.Streaming + +-- | CLI configuration +data CLIConfig = CLIConfig + { cliBackendUrl :: Text + , cliModel :: Text + , cliApiKey :: Maybe Text + , cliMcpServers :: [Text] -- MCP server URLs/commands + , cliTemperature :: Double + , cliMaxTokens :: Int + , cliStreaming :: Bool + } deriving (Show) + +-- | MCP Tool definition +data MCPTool = MCPTool + { mcpToolName :: Text + , mcpToolDescription :: Text + , mcpToolServer :: Text + , mcpToolSchema :: Value + } deriving (Show) + +-- | CLI state +data CLIState = CLIState + { stateClient :: Client + , stateConfig :: CLIConfig + , stateHistory :: [Message] -- Conversation history + , stateMCPTools :: [MCPTool] -- Available MCP tools + } + +-- | Parse CLI arguments +cliParser :: Parser CLIConfig +cliParser = CLIConfig + <$> strOption + ( long "backend" + <> short 'b' + <> metavar "URL" + <> value "http://localhost:11211" + <> help "Backend LLM server URL (default: llama-server on 11211)" ) + <*> strOption + ( long "model" + <> short 'm' + <> metavar "MODEL" + <> value "gpt-oss" + <> help "Model name (default: gpt-oss)" ) + <*> optional (strOption + ( long "api-key" + <> short 'k' + <> metavar "KEY" + <> help "API key (if required)" )) + <*> many (strOption + ( long "mcp-server" + <> metavar "SERVER" + <> help "MCP server to connect (can specify multiple)" )) + <*> option auto + ( long "temperature" + <> short 't' + <> metavar "TEMP" + <> value 0.7 + <> help "Temperature (default: 0.7)" ) + <*> option auto + ( long "max-tokens" + <> metavar "TOKENS" + <> value 2000 + <> help "Max tokens (default: 2000)" ) + <*> switch + ( long "stream" + <> short 's' + <> help "Enable streaming responses" ) + +main :: IO () +main = do + config <- execParser opts + runCLI config + where + opts = info (cliParser <**> helper) + ( fullDesc + <> progDesc "Interactive CLI for LLMs with MCP support" + <> header "louter-cli - Chat with local/remote LLMs" ) + +-- | Run the interactive CLI +runCLI :: CLIConfig -> IO () +runCLI config@CLIConfig{..} = do + -- Initialize client + client <- llamaServerClient cliBackendUrl + + -- Initialize MCP tools + mcpTools <- initMCPServers cliMcpServers + + let initialState = CLIState + { stateClient = client + , stateConfig = config + , stateHistory = [] + , stateMCPTools = mcpTools + } + + -- Set unbuffered input for interactive experience + hSetBuffering stdout NoBuffering + + -- Print welcome message + printWelcome config mcpTools + + -- Start REPL + repl initialState + +-- | Print welcome message +printWelcome :: CLIConfig -> [MCPTool] -> IO () +printWelcome CLIConfig{..} mcpTools = do + TIO.putStrLn "╔═══════════════════════════════════════════════════════════╗" + TIO.putStrLn "║ Louter CLI - LLM Chat with MCP Support ║" + TIO.putStrLn "╚═══════════════════════════════════════════════════════════╝" + TIO.putStrLn "" + TIO.putStrLn $ "Backend: " <> cliBackendUrl + TIO.putStrLn $ "Model: " <> cliModel + TIO.putStrLn $ "Streaming: " <> (if cliStreaming then "enabled" else "disabled") + + unless (null mcpTools) $ do + TIO.putStrLn "" + TIO.putStrLn "MCP Tools available:" + mapM_ (\tool -> TIO.putStrLn $ " • " <> mcpToolName tool <> " - " <> mcpToolDescription tool) mcpTools + + TIO.putStrLn "" + TIO.putStrLn "Commands:" + TIO.putStrLn " /help - Show this help" + TIO.putStrLn " /clear - Clear conversation history" + TIO.putStrLn " /history - Show conversation history" + TIO.putStrLn " /tools - List available MCP tools" + TIO.putStrLn " /exit - Exit the CLI" + TIO.putStrLn "" + +-- | REPL loop +repl :: CLIState -> IO () +repl state = do + TIO.putStr "You: " + hFlush stdout + input <- TIO.getLine + + let inputText = T.strip input + + -- Handle commands + if T.null inputText + then repl state + else if "/" `T.isPrefixOf` inputText + then do + newState <- handleCommand inputText state + if T.toLower inputText == "/exit" + then pure () + else repl newState + else do + -- Handle regular chat message + newState <- handleMessage inputText state + repl newState + +-- | Handle special commands +handleCommand :: Text -> CLIState -> IO CLIState +handleCommand cmd state@CLIState{..} + | cmd == "/help" = do + printWelcome stateConfig stateMCPTools + pure state + + | cmd == "/clear" = do + TIO.putStrLn "Conversation history cleared." + pure state { stateHistory = [] } + + | cmd == "/history" = do + TIO.putStrLn "\nConversation History:" + mapM_ printMessage stateHistory + pure state + + | cmd == "/tools" = do + TIO.putStrLn "\nAvailable MCP Tools:" + if null stateMCPTools + then TIO.putStrLn " (none)" + else mapM_ (\tool -> TIO.putStrLn $ " • " <> mcpToolName tool <> " - " <> mcpToolDescription tool) stateMCPTools + pure state + + | cmd == "/exit" = do + TIO.putStrLn "Goodbye!" + pure state + + | otherwise = do + TIO.putStrLn $ "Unknown command: " <> cmd + TIO.putStrLn "Type /help for available commands" + pure state + +-- | Print a message +printMessage :: Message -> IO () +printMessage msg = do + let roleStr = case msgRole msg of + RoleUser -> "You" + RoleAssistant -> "Assistant" + RoleSystem -> "System" + RoleTool -> "Tool" + content = contentPartsToText (msgContent msg) + TIO.putStrLn $ roleStr <> ": " <> content + +-- | Convert ContentPart list to Text (for display) +contentPartsToText :: [ContentPart] -> Text +contentPartsToText parts = T.intercalate " " [txt | TextPart txt <- parts] + +-- | Handle a chat message +handleMessage :: Text -> CLIState -> IO CLIState +handleMessage userInput state@CLIState{..} = do + let CLIConfig{..} = stateConfig + userMessage = Message RoleUser [TextPart userInput] + newHistory = stateHistory ++ [userMessage] + + -- Build tools list from MCP tools + tools = map mcpToolToTool stateMCPTools + + request = ChatRequest + { reqModel = cliModel + , reqMessages = newHistory + , reqTools = tools + , reqToolChoice = ToolChoiceAuto + , reqTemperature = Just cliTemperature + , reqMaxTokens = Just cliMaxTokens + , reqStream = cliStreaming + } + + TIO.putStr "Assistant: " + hFlush stdout + + -- Make request + if cliStreaming + then do + -- Streaming response + assistantContent <- handleStreamingResponse stateClient request + TIO.putStrLn "" -- Newline after streaming + let assistantMessage = Message RoleAssistant [TextPart assistantContent] + pure state { stateHistory = newHistory ++ [assistantMessage] } + else do + -- Non-streaming response + result <- chatCompletion stateClient request + case result of + Left err -> do + TIO.putStrLn $ "Error: " <> err + pure state + Right response -> do + let content = case respChoices response of + (choice:_) -> choiceMessage choice + [] -> "" + TIO.putStrLn content + let assistantMessage = Message RoleAssistant [TextPart content] + pure state { stateHistory = newHistory ++ [assistantMessage] } + +-- | Handle streaming response +handleStreamingResponse :: Client -> ChatRequest -> IO Text +handleStreamingResponse client request = do + contentRef <- newIORef "" + + streamChatWithCallback client request $ \event -> do + case event of + StreamContent txt -> do + TIO.putStr txt + hFlush stdout + modifyIORef' contentRef (<> txt) + + StreamReasoning txt -> do + -- Show reasoning in different color if terminal supports it + TIO.putStr $ "[thinking: " <> txt <> "] " + hFlush stdout + + StreamToolCall toolCall -> do + TIO.putStrLn $ "\n[Tool call: " <> T.pack (show toolCall) <> "]" + -- TODO: Execute MCP tool call here + + StreamFinish reason -> do + pure () + + StreamError err -> do + TIO.putStrLn $ "\nError: " <> err + + readIORef contentRef + +-- | Convert MCP tool to Louter Tool +mcpToolToTool :: MCPTool -> Tool +mcpToolToTool MCPTool{..} = Tool + { toolName = mcpToolName + , toolDescription = Just mcpToolDescription + , toolParameters = mcpToolSchema + } + +-- | Initialize MCP servers +initMCPServers :: [Text] -> IO [MCPTool] +initMCPServers serverSpecs = do + -- TODO: Implement actual MCP protocol connection + -- For now, return empty list + -- In full implementation: + -- 1. Connect to each MCP server via stdio or HTTP+SSE + -- 2. Send 'tools/list' request + -- 3. Parse tool definitions + -- 4. Return as MCPTool list + + unless (null serverSpecs) $ do + TIO.putStrLn "Note: MCP support is placeholder - not yet fully implemented" + TIO.putStrLn "Will connect to:" + mapM_ (\spec -> TIO.putStrLn $ " - " <> spec) serverSpecs + + pure [] diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,1129 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Louter proxy server executable +-- Routes requests between different LLM protocols using raw WAI +module Main where + +import Control.Applicative ((<|>)) +import Control.Monad (foldM, forM_, unless, when, join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Builder (Builder, byteString) +import Data.Conduit ((.|), runConduit, await) +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashMap.Lazy as HML +import Data.List (sortBy) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client (Manager, withResponse, brRead) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp (run) +import Options.Applicative +import System.IO (hFlush, stdout) +import System.Random (randomIO) +import Data.Word (Word64) +import Text.Printf (printf) +import qualified Data.Yaml as Yaml + +import Louter.Client (Client, Backend(..), newClient, chatCompletion, streamChat) +import Louter.Client.OpenAI (llamaServerClient, openAIClientWithUrl) +import Louter.Client.Anthropic (anthropicClientWithUrl) +import Louter.Client.Gemini (geminiClientWithUrl) +import Louter.Types.Request (ChatRequest(..), Message(..), MessageRole(..), ContentPart(..), Tool(..), ToolChoice(..)) +import Louter.Types.Streaming (StreamEvent(..)) +import Louter.Types.ToolFormat (XMLToolCallState, initialXMLState) +import Louter.Protocol.AnthropicConverter +import Louter.Protocol.AnthropicStreaming +import Louter.Protocol.GeminiConverter +import Louter.Protocol.GeminiStreaming +import Louter.Protocol.GeminiStreamingJsonArray +import Louter.Streaming.XMLStreamProcessor (processXMLStream, finalizeXMLState) +import Louter.Backend.OpenAIToAnthropic +import Louter.Backend.OpenAIToGemini + +-- | Server configuration from CLI +data ServerConfig = ServerConfig + { serverPort :: Int + , serverConfigFile :: FilePath + } deriving (Show) + +-- | Application state +data AppState = AppState + { appClients :: Map Text Client -- backend name -> client + , appConfig :: Config -- loaded from TOML + , appPort :: Int + , appManager :: Manager -- HTTP client manager for direct proxying + } + +-- | Backend type enumeration +data BackendType + = BackendTypeOpenAI -- OpenAI-compatible (including llama-server) + | BackendTypeAnthropic -- Anthropic Claude API + | BackendTypeGemini -- Google Gemini API + deriving (Show, Eq) + +instance Yaml.FromJSON BackendType where + parseJSON = Yaml.withText "BackendType" $ \t -> case t of + "openai" -> pure BackendTypeOpenAI + "anthropic" -> pure BackendTypeAnthropic + "gemini" -> pure BackendTypeGemini + other -> fail $ "Unknown backend type: " <> T.unpack other + +-- | Simplified config (will expand later) +data Config = Config + { configBackends :: Map Text BackendConfig + } deriving (Show) + +instance Yaml.FromJSON Config where + parseJSON = Yaml.withObject "Config" $ \obj -> do + backends <- obj Yaml..: "backends" + pure $ Config backends + +data BackendConfig = BackendConfig + { backendType :: BackendType + , backendUrl :: Text + , backendApiKey :: Maybe Text + , backendRequiresAuth :: Bool + , backendModelMapping :: Map Text Text -- frontend model -> backend model + , backendToolFormat :: Text -- "json" (default) or "xml" (Qwen3-Coder) + } deriving (Show) + +instance Yaml.FromJSON BackendConfig where + parseJSON = Yaml.withObject "BackendConfig" $ \obj -> do + btype <- obj Yaml..: "type" + url <- obj Yaml..: "url" + apiKey <- obj Yaml..:? "api_key" + reqAuth <- obj Yaml..: "requires_auth" + modelMap <- obj Yaml..:? "model_mapping" Yaml..!= Map.empty + toolFmt <- obj Yaml..:? "tool_format" Yaml..!= "json" + pure $ BackendConfig btype url apiKey reqAuth modelMap toolFmt + +-- | Load config from YAML file +loadConfig :: FilePath -> IO Config +loadConfig path = do + result <- Yaml.decodeFileEither path + case result of + Left err -> do + putStrLn $ "Error loading config from " <> path <> ":" + putStrLn $ " " <> show err + putStrLn "Using default config with llama-server (no auth)" + -- Return default config as fallback + pure $ Config + { configBackends = Map.fromList + [("llama-server", BackendConfig + { backendType = BackendTypeOpenAI + , backendUrl = "http://localhost:11211" + , backendApiKey = Nothing + , backendRequiresAuth = False + , backendModelMapping = Map.empty + , backendToolFormat = "json" + })] + } + Right cfg -> pure cfg + +-- | CLI parser +serverConfigParser :: Parser ServerConfig +serverConfigParser = ServerConfig + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> value 9000 + <> help "Port to listen on" ) + <*> strOption + ( long "config" + <> short 'c' + <> metavar "FILE" + <> value "config.toml" + <> help "Configuration file" ) + +-- | Main entry point +main :: IO () +main = do + ServerConfig{..} <- execParser opts + putStrLn $ "Louter proxy server starting on port " <> show serverPort + putStrLn $ "Using config file: " <> serverConfigFile + + -- Load config from TOML file + config <- loadConfig serverConfigFile + + -- Initialize clients and HTTP manager + clients <- initClients config + manager <- HTTP.newManager tlsManagerSettings + + let appState = AppState + { appClients = clients + , appConfig = config + , appPort = serverPort + , appManager = manager + } + + putStrLn $ "Initialized " <> show (Map.size clients) <> " backend client(s)" + putStrLn $ "Server ready on http://localhost:" <> show serverPort + putStrLn "" + + -- Start server + run serverPort (application appState) + where + opts = info (serverConfigParser <**> helper) + ( fullDesc + <> progDesc "Multi-protocol LLM proxy server" + <> header "louter-server - protocol converter for LLM APIs" ) + +-- | Initialize backend clients from config +initClients :: Config -> IO (Map Text Client) +initClients Config{..} = do + let backends = Map.toList configBackends + clients <- mapM initBackend backends + return $ Map.fromList clients + where + initBackend :: (Text, BackendConfig) -> IO (Text, Client) + initBackend (name, BackendConfig{..}) = do + client <- case backendType of + BackendTypeOpenAI -> + if backendRequiresAuth + then case backendApiKey of + Just key -> openAIClientWithUrl key backendUrl + Nothing -> error $ "Backend '" <> T.unpack name <> "' requires authentication but no api_key provided" + else llamaServerClient backendUrl + + BackendTypeAnthropic -> + case backendApiKey of + Just key -> anthropicClientWithUrl key backendUrl + Nothing -> error $ "Backend '" <> T.unpack name <> "' (Anthropic) requires authentication but no api_key provided" + + BackendTypeGemini -> + case backendApiKey of + Just key -> geminiClientWithUrl key backendUrl + Nothing -> error $ "Backend '" <> T.unpack name <> "' (Gemini) requires authentication but no api_key provided" + + return (name, client) + +-- | Generate a trace ID for request tracking +generateTraceId :: IO Text +generateTraceId = do + rnd <- randomIO :: IO Word64 + return $ T.pack $ printf "trace-%016x" rnd + +-- | Log event in JSON line format +logEvent :: Text -> Text -> Value -> IO () +logEvent traceId eventType details = do + let logLine = object + [ "trace_id" .= traceId + , "event" .= eventType + , "details" .= details + ] + BS8.putStrLn (BL.toStrict $ encode logLine) + hFlush stdout + +-- | Main WAI application with manual routing +application :: AppState -> Application +application state req respond = do + -- Generate trace ID for this request + traceId <- generateTraceId + + let path = pathInfo req + method = requestMethod req + pathStr = T.intercalate "/" path + + -- Log incoming request in JSON line format + logEvent traceId "request_received" $ object + [ "method" .= TE.decodeUtf8 method + , "path" .= pathStr + , "query" .= TE.decodeUtf8 (rawQueryString req) + ] + + case (method, path) of + -- Health check + ("GET", ["health"]) -> + healthHandler state req respond + + -- OpenAI API + ("POST", ["v1", "chat", "completions"]) -> + openAIChatHandler state req respond + + -- Anthropic API + ("POST", ["v1", "messages"]) -> + anthropicMessagesHandler state req respond + + -- Gemini API - list models + ("GET", ["v1beta", "models"]) -> + geminiListModelsHandler state req respond + + -- Gemini API - model actions (generate/stream) + ("POST", "v1beta" : "models" : modelPath) -> + geminiModelActionHandler traceId state modelPath req respond + + -- Diagnostics + ("GET", ["api", "diagnostics"]) -> + diagnosticsHandler state req respond + + -- Default 404 + _ -> do + logEvent traceId "not_found" $ object + [ "method" .= TE.decodeUtf8 method + , "path" .= pathStr + , "available_endpoints" .= + [ "/health" :: Text + , "/v1/chat/completions" + , "/v1/messages" + , "/v1beta/models" + , "/v1beta/models/:model:streamGenerateContent" + , "/v1beta/models/:model:generateContent" + ] + ] + respond $ responseLBS status404 + [("Content-Type", "application/json")] + (encode $ object + [ "error" .= object + [ "code" .= (404 :: Int) + , "message" .= ("Requested entity was not found." :: Text) + , "status" .= ("NOT_FOUND" :: Text) + ] + ]) + +-- | /health endpoint +healthHandler :: AppState -> Application +healthHandler _state _req respond = + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode $ object + [ "status" .= ("ok" :: Text) + , "service" .= ("louter" :: Text) + ]) + +-- | /v1/chat/completions - OpenAI endpoint +-- Routes to appropriate backend based on configuration +openAIChatHandler :: AppState -> Application +openAIChatHandler state req respond = do + -- Read request body + body <- strictRequestBody req + + case eitherDecode body of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Invalid request: " <> T.pack err :: Text)]) + + Right openAIReq -> do + -- Get first backend (for now - TODO: support backend selection via model name) + case Map.toList (configBackends $ appConfig state) of + [] -> respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("No backend configured" :: Text)]) + + ((backendName, backendCfg):_) -> do + -- Check if streaming is requested + let isStreaming = getStreamFlag openAIReq + + -- Route based on backend type + case backendType backendCfg of + BackendTypeOpenAI -> + -- Direct OpenAI-compatible backend (no conversion needed) + if isStreaming + then handleOpenAIStreamingToOpenAI state backendCfg openAIReq respond + else handleOpenAINonStreamingToOpenAI state backendCfg openAIReq respond + + BackendTypeAnthropic -> + -- OpenAI frontend → Anthropic backend (needs conversion) + if isStreaming + then handleOpenAIStreamingToAnthropic state backendCfg openAIReq respond + else handleOpenAINonStreamingToAnthropic state backendCfg openAIReq respond + + BackendTypeGemini -> + -- OpenAI frontend → Gemini backend (needs conversion) + if isStreaming + then handleOpenAIStreamingToGemini state backendCfg openAIReq respond + else handleOpenAINonStreamingToGemini state backendCfg openAIReq respond + +-- ============================================================================== +-- OpenAI Frontend → OpenAI Backend (Direct, No Conversion) +-- ============================================================================== + +-- | OpenAI → OpenAI non-streaming +handleOpenAINonStreamingToOpenAI :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAINonStreamingToOpenAI state backendCfg openAIReq respond = do + let url = T.unpack $ backendUrl backendCfg <> "/v1/chat/completions" + + -- Create backend request (pass-through, no conversion) + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Make synchronous request + response <- HTTP.httpLbs req' (appManager state) + respond $ responseLBS (HTTP.responseStatus response) + [("Content-Type", "application/json")] + (HTTP.responseBody response) + +-- | OpenAI → OpenAI streaming +handleOpenAIStreamingToOpenAI :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAIStreamingToOpenAI state backendCfg openAIReq respond = do + let url = T.unpack $ backendUrl backendCfg <> "/v1/chat/completions" + + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Check if backend uses XML tool format (Qwen3-Coder) + let usesXML = backendToolFormat backendCfg == "xml" + + let sseResponse = responseStream status200 + [ ("Content-Type", "text/event-stream") + , ("Cache-Control", "no-cache") + , ("Connection", "keep-alive") + ] $ \write flush -> do + withResponse req' (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + if usesXML + then streamWithXMLProcessing write flush body + else streamPassThrough write flush body + + respond sseResponse + where + -- Pass-through streaming (no XML processing) + streamPassThrough write flush body = do + let loop = do + chunk <- brRead body + if BS.null chunk + then pure () + else do + write (byteString chunk) + flush + loop + loop + + -- XML processing streaming (buffer and convert tool calls) + streamWithXMLProcessing write flush body = do + let loop xmlState = do + chunk <- brRead body + if BS.null chunk + then do + -- End of stream - finalize XML state + let finalEvents = finalizeXMLState xmlState + forM_ finalEvents $ \event -> do + write (byteString $ eventToSSE event) + flush + else do + -- Process chunk through XML parser + let chunkText = TE.decodeUtf8 chunk + let (newState, events) = processXMLStream xmlState chunkText + -- Emit converted events as OpenAI SSE + forM_ events $ \event -> do + write (byteString $ eventToSSE event) + flush + loop newState + loop initialXMLState + +-- ============================================================================== +-- OpenAI Frontend → Anthropic Backend (Requires Conversion) +-- ============================================================================== + +-- | OpenAI → Anthropic non-streaming +handleOpenAINonStreamingToAnthropic :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAINonStreamingToAnthropic state backendCfg openAIReq respond = do + -- Convert OpenAI request to Anthropic format (reverse of anthropicToOpenAI) + case openAIToAnthropic openAIReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right anthropicReq -> do + let url = T.unpack $ backendUrl backendCfg <> "/v1/messages" + + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode anthropicReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + response <- HTTP.httpLbs req' (appManager state) + + -- Convert Anthropic response back to OpenAI format + case eitherDecode (HTTP.responseBody response) of + Left err -> respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Failed to parse Anthropic response: " <> T.pack err :: Text)]) + + Right anthropicResp -> do + let openAIResp = anthropicToOpenAIResponse anthropicResp + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode openAIResp) + +-- | OpenAI → Anthropic streaming +handleOpenAIStreamingToAnthropic :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAIStreamingToAnthropic state backendCfg openAIReq respond = do + case openAIToAnthropic openAIReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right anthropicReq -> do + let url = T.unpack $ backendUrl backendCfg <> "/v1/messages" + + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode anthropicReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Stream and convert Anthropic SSE → OpenAI SSE + let sseResponse = responseStream status200 + [ ("Content-Type", "text/event-stream") + , ("Cache-Control", "no-cache") + , ("Connection", "keep-alive") + ] $ \write flush -> do + withResponse req' (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + -- TODO: Convert Anthropic SSE events to OpenAI SSE format + -- For now, pass through (will need proper conversion) + convertAnthropicToOpenAIStream write flush body + + respond sseResponse + +-- ============================================================================== +-- OpenAI Frontend → Gemini Backend (Requires Conversion) +-- ============================================================================== + +-- | OpenAI → Gemini non-streaming +handleOpenAINonStreamingToGemini :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAINonStreamingToGemini state backendCfg openAIReq respond = do + -- Convert OpenAI request to Gemini format (reverse of geminiToOpenAI) + case openAIToGemini openAIReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right (modelName, geminiReq) -> do + let url = T.unpack $ backendUrl backendCfg <> "/v1beta/models/" <> modelName <> ":generateContent" + + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode geminiReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + response <- HTTP.httpLbs req' (appManager state) + + -- Convert Gemini response back to OpenAI format + case eitherDecode (HTTP.responseBody response) of + Left err -> respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Failed to parse Gemini response: " <> T.pack err :: Text)]) + + Right geminiResp -> do + let openAIResp = geminiToOpenAIResponse geminiResp + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode openAIResp) + +-- | OpenAI → Gemini streaming +handleOpenAIStreamingToGemini :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleOpenAIStreamingToGemini state backendCfg openAIReq respond = do + case openAIToGemini openAIReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right (modelName, geminiReq) -> do + let url = T.unpack $ backendUrl backendCfg <> "/v1beta/models/" <> modelName <> ":streamGenerateContent" + + req <- HTTP.parseRequest ("POST " <> url) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode geminiReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Stream and convert Gemini SSE → OpenAI SSE + let sseResponse = responseStream status200 + [ ("Content-Type", "text/event-stream") + , ("Cache-Control", "no-cache") + , ("Connection", "keep-alive") + ] $ \write flush -> do + withResponse req' (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + -- TODO: Convert Gemini SSE events to OpenAI SSE format + -- For now, pass through (will need proper conversion) + convertGeminiToOpenAIStream write flush body + + respond sseResponse + +-- | Convert StreamEvent to SSE format +eventToSSE :: StreamEvent -> BS.ByteString +eventToSSE event = case event of + StreamContent txt -> + "data: " <> BL.toStrict (encode $ object + [ "choices" .= [object + [ "delta" .= object ["content" .= txt] + , "index" .= (0 :: Int) + ]] + ]) <> "\n\n" + + StreamReasoning txt -> + "data: " <> BL.toStrict (encode $ object + [ "choices" .= [object + [ "delta" .= object ["reasoning" .= txt] + , "index" .= (0 :: Int) + ]] + ]) <> "\n\n" + + StreamToolCall toolCall -> + "data: " <> BL.toStrict (encode $ object + [ "choices" .= [object + [ "delta" .= object ["tool_calls" .= [toolCall]] + , "index" .= (0 :: Int) + ]] + ]) <> "\n\n" + + StreamFinish reason -> + "data: " <> BL.toStrict (encode $ object + [ "choices" .= [object + [ "finish_reason" .= reason + , "index" .= (0 :: Int) + ]] + ]) <> "\n\n" + + StreamError err -> + "data: " <> BL.toStrict (encode $ object ["error" .= err]) <> "\n\n" + +-- | Extract stream flag from OpenAI request +getStreamFlag :: Value -> Bool +getStreamFlag (Object obj) = case HM.lookup "stream" obj of + Just (Bool b) -> b + _ -> False +getStreamFlag _ = False + +-- | Parse OpenAI request to ChatRequest +parseOpenAIRequest :: Value -> Either Text ChatRequest +parseOpenAIRequest (Object obj) = do + -- Extract model + model <- case HM.lookup "model" obj of + Just (String m) -> Right m + _ -> Left "Missing or invalid 'model' field" + + -- Extract messages + messages <- case HM.lookup "messages" obj of + Just (Array msgs) -> parseMessages (V.toList msgs) + _ -> Left "Missing or invalid 'messages' field" + + -- Extract optional fields + let temperature = case HM.lookup "temperature" obj of + Just (Number n) -> Just (realToFrac n) + _ -> Nothing + + let maxTokens = case HM.lookup "max_tokens" obj of + Just (Number n) -> Just (floor n) + _ -> Nothing + + let stream = case HM.lookup "stream" obj of + Just (Bool b) -> b + _ -> False + + -- Extract tools (if any) + tools <- case HM.lookup "tools" obj of + Just (Array ts) -> parseTools (V.toList ts) + _ -> Right [] + + Right ChatRequest + { reqModel = model + , reqMessages = messages + , reqTools = tools + , reqToolChoice = ToolChoiceAuto + , reqTemperature = temperature + , reqMaxTokens = maxTokens + , reqStream = stream + } +parseOpenAIRequest _ = Left "Request must be a JSON object" + +-- | Parse messages array +parseMessages :: [Value] -> Either Text [Message] +parseMessages = mapM parseMessage + where + parseMessage :: Value -> Either Text Message + parseMessage (Object obj) = do + role <- case HM.lookup "role" obj of + Just (String "system") -> Right RoleSystem + Just (String "user") -> Right RoleUser + Just (String "assistant") -> Right RoleAssistant + Just (String "tool") -> Right RoleTool + _ -> Left "Invalid or missing 'role' field" + + content <- case HM.lookup "content" obj of + Just (String c) -> Right [TextPart c] + _ -> Left "Invalid or missing 'content' field" + + Right Message { msgRole = role, msgContent = content } + parseMessage _ = Left "Message must be a JSON object" + +-- | Parse tools array +parseTools :: [Value] -> Either Text [Tool] +parseTools = mapM parseTool + where + parseTool :: Value -> Either Text Tool + parseTool (Object obj) = do + -- OpenAI tools format: { "type": "function", "function": { ... } } + function <- case HM.lookup "function" obj of + Just (Object fn) -> Right fn + _ -> Left "Missing or invalid 'function' field" + + name <- case HM.lookup "name" function of + Just (String n) -> Right n + _ -> Left "Missing or invalid function 'name'" + + let description = case HM.lookup "description" function of + Just (String d) -> Just d + _ -> Nothing + + parameters <- case HM.lookup "parameters" function of + Just params -> Right params + _ -> Left "Missing 'parameters' field" + + Right Tool + { toolName = name + , toolDescription = description + , toolParameters = parameters + } + parseTool _ = Left "Tool must be a JSON object" + +-- | /v1/messages - Anthropic endpoint +anthropicMessagesHandler :: AppState -> Application +anthropicMessagesHandler state req respond = do + -- Read request body + body <- strictRequestBody req + + case eitherDecode body of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Invalid Anthropic request: " <> T.pack err :: Text)]) + + Right anthropicReq -> do + -- Get first backend (for now - TODO: support backend selection via model name) + case Map.toList (configBackends $ appConfig state) of + [] -> respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("No backend configured" :: Text)]) + + ((backendName, backendCfg):_) -> do + -- Check if streaming + let isStreaming = getAnthropicStreamFlag anthropicReq + + if isStreaming + then handleAnthropicStreaming state backendCfg anthropicReq respond + else handleAnthropicNonStreaming state backendCfg anthropicReq respond + +-- | Get Anthropic stream flag +getAnthropicStreamFlag :: Value -> Bool +getAnthropicStreamFlag (Object obj) = case HM.lookup "stream" obj of + Just (Bool b) -> b + _ -> False +getAnthropicStreamFlag _ = False + +-- | Handle Anthropic streaming request +handleAnthropicStreaming :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleAnthropicStreaming state backendCfg anthropicReq respond = do + -- Convert Anthropic request to OpenAI format + case anthropicToOpenAI anthropicReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right openAIReq -> do + -- Make request to backend + let backendUrlStr = T.unpack (backendUrl backendCfg) <> "/v1/chat/completions" + + req <- HTTP.parseRequest ("POST " <> backendUrlStr) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Stream response and convert OpenAI SSE → Anthropic SSE + let sseResponse = responseStream status200 + [ ("Content-Type", "text/event-stream") + , ("Cache-Control", "no-cache") + , ("Connection", "keep-alive") + ] $ \write flush -> do + withResponse req' (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + -- Convert OpenAI chunks to Anthropic events + convertOpenAIToAnthropic write flush body + + respond sseResponse + +-- | Handle Anthropic non-streaming request +handleAnthropicNonStreaming :: AppState -> BackendConfig -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleAnthropicNonStreaming state backendCfg anthropicReq respond = do + case anthropicToOpenAI anthropicReq of + Left err -> respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right openAIReq -> do + let backendUrlStr = T.unpack (backendUrl backendCfg) <> "/v1/chat/completions" + + req <- HTTP.parseRequest ("POST " <> backendUrlStr) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + response <- HTTP.httpLbs req' (appManager state) + + -- Convert OpenAI response to Anthropic format + case eitherDecode (HTTP.responseBody response) of + Left err -> respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Failed to parse backend response: " <> T.pack err :: Text)]) + + Right openAIResp -> do + let anthropicResp = openAIResponseToAnthropic openAIResp + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode anthropicResp) + +-- Anthropic conversion functions and streaming now imported from library modules + +-- ============================================================================== +-- Gemini API Handlers +-- ============================================================================== + +-- | Handle Gemini streaming request +-- Supports two formats based on ?alt= parameter: +-- - alt=sse (default): Server-Sent Events format +-- - alt=json: JSON array format +handleGeminiStreaming :: Text -> AppState -> BackendConfig -> Text -> Value -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleGeminiStreaming traceId state backendCfg modelName geminiReq req respond = do + -- Detect streaming format from query parameter + let queryParams = queryString req + altParam = lookup "alt" queryParams + streamFormat :: BS.ByteString + streamFormat = case altParam of + Just (Just "json") -> "json" + Just (Just "sse") -> "sse" + _ -> "sse" -- Default to SSE for backward compatibility + + logEvent traceId "stream_format_detected" $ object + [ "format" .= TE.decodeUtf8 streamFormat + , "alt_param" .= (TE.decodeUtf8 <$> join altParam :: Maybe Text) + ] + + case geminiToOpenAI modelName True geminiReq of + Left err -> do + logEvent traceId "gemini_to_openai_error" $ object + [ "error" .= err + , "model" .= modelName + ] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right openAIReq -> do + -- Create backend HTTP request + let backendUrlStr = T.unpack (backendUrl backendCfg) <> "/v1/chat/completions" + + -- Log converted OpenAI request + logEvent traceId "openai_request" $ object + [ "backend_url" .= backendUrlStr + , "request" .= openAIReq + , "streaming" .= True + , "format" .= TE.decodeUtf8 streamFormat + ] + + backendReq <- HTTP.parseRequest ("POST " <> backendUrlStr) + let backendReq' = backendReq + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Choose response format based on alt= parameter + case streamFormat of + "json" -> handleJsonArrayStreaming traceId backendReq' state respond + _ -> handleSSEStreaming traceId backendReq' state respond + +-- | Handle SSE format streaming (default) +handleSSEStreaming :: Text -> HTTP.Request -> AppState -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleSSEStreaming traceId backendReq state respond = do + let streamResponse = responseStream status200 + [ ("Content-Type", "text/event-stream; charset=utf-8") + , ("Cache-Control", "no-cache") + , ("Connection", "keep-alive") + ] $ \write flush -> do + withResponse backendReq (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + statusCode = HTTP.responseStatus backendResp + + -- Log backend response status + logEvent traceId "backend_response" $ object + [ "status" .= show statusCode + , "streaming" .= True + , "format" .= ("sse" :: Text) + ] + + -- Convert OpenAI SSE to Gemini SSE + convertOpenAIToGeminiStream write flush body + + logEvent traceId "streaming_started" $ object + [ "status" .= ("ok" :: Text) + , "format" .= ("sse" :: Text) + ] + respond streamResponse + +-- | Handle JSON array format streaming (alt=json) +-- Streams an incremental JSON array: [{"candidates":[...]},{"candidates":[...]},...] +handleJsonArrayStreaming :: Text -> HTTP.Request -> AppState -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleJsonArrayStreaming traceId backendReq state respond = do + let streamResponse = responseStream status200 + [ ("Content-Type", "application/json; charset=utf-8") + , ("Cache-Control", "no-cache") + ] $ \write flush -> do + withResponse backendReq (appManager state) $ \backendResp -> do + let body = HTTP.responseBody backendResp + statusCode = HTTP.responseStatus backendResp + + -- Log backend response status + logEvent traceId "backend_response" $ object + [ "status" .= show statusCode + , "streaming" .= True + , "format" .= ("json" :: Text) + ] + + -- Convert OpenAI SSE to Gemini JSON array (incremental) + convertOpenAIToGeminiJsonArray write flush body + + logEvent traceId "streaming_started" $ object + [ "status" .= ("ok" :: Text) + , "format" .= ("json" :: Text) + ] + respond streamResponse + +-- | Handle Gemini non-streaming request +handleGeminiNonStreaming :: Text -> AppState -> BackendConfig -> Text -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleGeminiNonStreaming traceId state backendCfg modelName geminiReq respond = do + case geminiToOpenAI modelName False geminiReq of + Left err -> do + logEvent traceId "gemini_to_openai_error" $ object + [ "error" .= err + , "model" .= modelName + ] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right openAIReq -> do + -- Create backend HTTP request + let backendUrlStr = T.unpack (backendUrl backendCfg) <> "/v1/chat/completions" + + -- Log converted OpenAI request + logEvent traceId "openai_request" $ object + [ "backend_url" .= backendUrlStr + , "request" .= openAIReq + , "streaming" .= False + ] + + req <- HTTP.parseRequest ("POST " <> backendUrlStr) + let req' = req + { HTTP.requestBody = HTTP.RequestBodyLBS (encode openAIReq) + , HTTP.requestHeaders = [("Content-Type", "application/json")] + } + + -- Make synchronous request + httpResp <- HTTP.httpLbs req' (appManager state) + let responseBody' = HTTP.responseBody httpResp + statusCode = HTTP.responseStatus httpResp + + -- Log backend response status + logEvent traceId "backend_response" $ object + [ "status" .= show statusCode + , "body_length" .= BL.length responseBody' + ] + + -- Convert OpenAI response to Gemini format + case eitherDecode responseBody' of + Left err -> do + logEvent traceId "backend_parse_error" $ object + [ "error" .= T.pack err + , "body_preview" .= T.take 200 (TE.decodeUtf8 (BL.toStrict responseBody')) + ] + respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Failed to parse backend response: " <> T.pack err :: Text)]) + + Right openAIResp -> do + logEvent traceId "response_success" $ object + [ "status" .= ("ok" :: Text) + ] + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode $ openAIResponseToGemini openAIResp) + +-- | Handle Gemini countTokens request +handleCountTokens :: Text -> AppState -> BackendConfig -> Text -> Value -> (Response -> IO ResponseReceived) -> IO ResponseReceived +handleCountTokens traceId state backendCfg modelName geminiReq respond = do + -- Log countTokens request + logEvent traceId "count_tokens_request" $ object + [ "model" .= modelName + , "request" .= geminiReq + ] + + case geminiToOpenAI modelName False geminiReq of + Left err -> do + logEvent traceId "gemini_to_openai_error" $ object ["error" .= err] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= err]) + + Right openAIReq -> do + -- Estimate tokens from the OpenAI request + let totalTokens = estimateTokensFromRequest openAIReq + + -- Log token count result + logEvent traceId "count_tokens_result" $ object + [ "model" .= modelName + , "total_tokens" .= totalTokens + ] + + -- Return Gemini countTokens response format + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode $ object ["totalTokens" .= totalTokens]) + +-- | Estimate tokens from an OpenAI request +-- Simple heuristic: ~4 characters per token +estimateTokensFromRequest :: Value -> Int +estimateTokensFromRequest (Object obj) = + let messagesTokens = case HM.lookup "messages" obj of + Just (Array msgs) -> sum $ map estimateTokensFromMessage (V.toList msgs) + _ -> 0 + toolsTokens = case HM.lookup "tools" obj of + Just (Array tools) -> sum $ map estimateTokensFromValue (V.toList tools) + _ -> 0 + in max 1 (messagesTokens + toolsTokens) +estimateTokensFromRequest _ = 1 + +-- | Estimate tokens from a single message +estimateTokensFromMessage :: Value -> Int +estimateTokensFromMessage (Object msg) = + case HM.lookup "content" msg of + Just (String txt) -> estimateTokensFromText txt + Just val -> estimateTokensFromValue val + Nothing -> 0 +estimateTokensFromMessage _ = 0 + +-- | Estimate tokens from text +estimateTokensFromText :: Text -> Int +estimateTokensFromText txt = max 1 ((T.length txt + 3) `div` 4) + +-- | Estimate tokens from any JSON value +estimateTokensFromValue :: Value -> Int +estimateTokensFromValue (String txt) = estimateTokensFromText txt +estimateTokensFromValue (Array arr) = sum $ map estimateTokensFromValue (V.toList arr) +estimateTokensFromValue (Object obj) = sum $ map estimateTokensFromValue (HM.elems obj) +estimateTokensFromValue _ = 1 + +-- Gemini conversion functions and streaming now imported from library modules + +-- | /v1beta/models - Gemini list models +geminiListModelsHandler :: AppState -> Application +geminiListModelsHandler _state _req respond = + respond $ responseLBS status501 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Gemini list models not yet implemented" :: Text)]) + +-- | /v1beta/models/:model:action - Gemini model actions +geminiModelActionHandler :: Text -> AppState -> [Text] -> Application +geminiModelActionHandler traceId state modelPath req respond = do + -- Parse model and action from path + -- Path format: ["model-name:streamGenerateContent"] or ["model-name:generateContent"] + case modelPath of + [] -> do + logEvent traceId "error" $ object ["message" .= ("Missing model path" :: Text)] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Missing model path" :: Text)]) + + (fullPath:_) -> do + -- Split on ':' to get model and action + let parts = T.splitOn ":" fullPath + case parts of + [modelName, action] -> do + -- Read request body + body <- strictRequestBody req + + -- Log incoming Gemini request + case eitherDecode body of + Left err -> do + logEvent traceId "request_parse_error" $ object + [ "error" .= T.pack err + , "body_size" .= BL.length body + ] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Invalid Gemini request: " <> T.pack err :: Text)]) + + Right geminiReq -> do + -- Get first backend (for now - TODO: support backend selection via model name) + case Map.toList (configBackends $ appConfig state) of + [] -> do + logEvent traceId "error" $ object ["message" .= ("No backend configured" :: Text)] + respond $ responseLBS status500 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("No backend configured" :: Text)]) + + ((backendName, backendCfg):_) -> do + -- Log parsed Gemini request + logEvent traceId "gemini_request_parsed" $ object + [ "model" .= modelName + , "action" .= action + , "request" .= geminiReq + ] + + case action of + "streamGenerateContent" -> handleGeminiStreaming traceId state backendCfg modelName geminiReq req respond + "generateContent" -> handleGeminiNonStreaming traceId state backendCfg modelName geminiReq respond + "countTokens" -> handleCountTokens traceId state backendCfg modelName geminiReq respond + _ -> do + logEvent traceId "error" $ object + [ "message" .= ("Unsupported action" :: Text) + , "action" .= action + ] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Unsupported action: " <> action :: Text)]) + + _ -> do + logEvent traceId "error" $ object + [ "message" .= ("Invalid model path format" :: Text) + , "path" .= fullPath + ] + respond $ responseLBS status400 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Invalid model path format" :: Text)]) + +-- | /api/diagnostics endpoint +diagnosticsHandler :: AppState -> Application +diagnosticsHandler state _req respond = + respond $ responseLBS status200 + [("Content-Type", "application/json")] + (encode $ object + [ "status" .= ("ok" :: Text) + , "backends" .= Map.keys (appClients state) + , "port" .= appPort state + ]) diff --git a/louter.cabal b/louter.cabal new file mode 100644 --- /dev/null +++ b/louter.cabal @@ -0,0 +1,124 @@ +cabal-version: 3.0 +name: louter +version: 0.1.0.0 +synopsis: Multi-protocol LLM router and client library +description: Protocol converter library that lets your application connect to any LLM API + (OpenAI, Gemini, Anthropic) with automatic protocol translation, SSE streaming, + and function call buffering. Use as library or run as proxy server. +license: MIT +license-file: LICENSE +author: Junji Hashimoto +maintainer: junji.hashimoto@gmail.com +category: Web +build-type: Simple + +extra-doc-files: README.md + +library + exposed-modules: + -- Client API (use as library) + Louter.Client + Louter.Client.OpenAI + Louter.Client.Gemini + Louter.Client.Anthropic + -- Core protocol conversion (server-side converters, reused by client) + Louter.Protocol.AnthropicConverter + Louter.Protocol.AnthropicStreaming + Louter.Protocol.GeminiConverter + Louter.Protocol.GeminiStreaming + Louter.Protocol.GeminiStreamingJsonArray + -- Backend protocol conversions (for multi-backend support) + Louter.Backend.OpenAIToAnthropic + Louter.Backend.OpenAIToGemini + -- XML tool format support (Qwen3-Coder) + Louter.Streaming.XMLToolCallParser + Louter.Streaming.XMLStreamProcessor + -- Types + Louter.Types + Louter.Types.Request + Louter.Types.Response + Louter.Types.Streaming + Louter.Types.ToolFormat + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , aeson >=2.0 && <3.0 + , bytestring >=0.11 && <1.0 + , http-client >=0.7 && <1.0 + , http-client-tls >=0.3 && <1.0 + , http-types >=0.12 && <1.0 + , text >=2.0 && <3.0 + , containers >=0.6 && <1.0 + , transformers >=0.5 && <1.0 + , conduit >=1.3 && <2.0 + , conduit-extra >=1.3 && <2.0 + , mtl >=2.2 && <3.0 + , scientific >=0.3 && <1.0 + , unordered-containers >=0.2 && <1.0 + , vector >=0.13 && <1.0 + , warp >=3.3 && <4.0 + , wai >=3.2 && <4.0 + , regex-tdfa >=1.3 && <2.0 + +executable louter-server + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , louter + , optparse-applicative >=0.17 && <1.0 + , yaml >=0.11 && < 1.0 + , aeson + , bytestring + , text + , wai + , warp + , http-types + , http-client + , http-client-tls + , containers + , unordered-containers + , conduit + , transformers + , mtl + , vector + , random >=1.2 && <2.0 + +executable louter-cli + main-is: CLI.hs + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , louter + , optparse-applicative >=0.17 && <1.0 + , aeson + , bytestring + , text + , http-client + , http-client-tls + , containers + +test-suite louter-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , louter + , hspec >=2.10 + , QuickCheck >=2.14 + , aeson + , bytestring + , text + , unordered-containers diff --git a/src/Louter/Backend/OpenAIToAnthropic.hs b/src/Louter/Backend/OpenAIToAnthropic.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Backend/OpenAIToAnthropic.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | OpenAI ↔ Anthropic protocol conversion +-- Used when OpenAI frontend needs to communicate with Anthropic backend +module Louter.Backend.OpenAIToAnthropic + ( -- * Request Conversion + openAIToAnthropic + , openAIMessageToAnthropic + -- * Response Conversion + , anthropicToOpenAIResponse + , convertAnthropicToOpenAIStream + ) where + +import Data.Aeson (Value(..), object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder, byteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client (brRead) + +-- | Convert OpenAI request to Anthropic request format +openAIToAnthropic :: Value -> Either Text Value +openAIToAnthropic (Object obj) = do + -- Extract required fields from OpenAI format + model <- case HM.lookup "model" obj of + Just (String m) -> Right m + _ -> Left "Missing 'model' field" + + messages <- case HM.lookup "messages" obj of + Just (Array msgs) -> Right $ V.toList msgs + _ -> Left "Missing 'messages' field" + + -- Convert to Anthropic format (inverse of anthropicToOpenAI) + let anthropicMessages = map openAIMessageToAnthropic messages + maxTokens = case HM.lookup "max_tokens" obj of + Just (Number n) -> Just (floor n :: Int) + _ -> Just 1024 -- Default + + temperature = HM.lookup "temperature" obj + stream = case HM.lookup "stream" obj of + Just (Bool b) -> b + _ -> False + + Right $ object $ + [ "model" .= model + , "messages" .= anthropicMessages + , "max_tokens" .= maxTokens + , "stream" .= stream + ] ++ (case temperature of Just t -> ["temperature" .= t]; Nothing -> []) + +openAIToAnthropic _ = Left "Request must be a JSON object" + +-- | Convert OpenAI message to Anthropic message format +openAIMessageToAnthropic :: Value -> Value +openAIMessageToAnthropic (Object msg) = + let role = case HM.lookup "role" msg of + Just (String r) -> r + _ -> "user" + + content = case HM.lookup "content" msg of + -- Simple string content + Just (String c) -> String c + + -- Array of content parts (multimodal: text + images) + Just (Array parts) -> + let convertedParts = map convertPart (V.toList parts) + convertPart (Object part) = case HM.lookup "type" part of + -- Text part: {"type": "text", "text": "..."} + Just (String "text") -> case HM.lookup "text" part of + Just (String txt) -> object ["type" .= ("text" :: Text), "text" .= txt] + _ -> object [] + + -- Image part: {"type": "image_url", "image_url": {"url": "data:..."}} + Just (String "image_url") -> case HM.lookup "image_url" part of + Just (Object imgUrlObj) -> case HM.lookup "url" imgUrlObj of + Just (String dataUrl) -> + -- Parse data URL: "data:image/png;base64,..." + let (mediaType, base64Data) = parseDataUrl dataUrl + in object + [ "type" .= ("image" :: Text) + , "source" .= object + [ "type" .= ("base64" :: Text) + , "media_type" .= mediaType + , "data" .= base64Data + ] + ] + _ -> object [] + _ -> object [] + + _ -> object [] + convertPart _ = object [] + in Array (V.fromList convertedParts) + + _ -> String "" + + in object ["role" .= role, "content" .= content] + where + -- Parse data URL: "data:image/png;base64,iVBORw0..." → ("image/png", "iVBORw0...") + parseDataUrl :: Text -> (Text, Text) + parseDataUrl url = + case T.stripPrefix "data:" url of + Just rest -> case T.breakOn ";base64," rest of + (mediaType, base64Part) -> case T.stripPrefix ";base64," base64Part of + Just base64Data -> (mediaType, base64Data) + Nothing -> ("image/png", "") -- Fallback + _ -> ("image/png", "") + Nothing -> ("image/png", "") + +openAIMessageToAnthropic other = other + +-- | Convert Anthropic response to OpenAI response format +anthropicToOpenAIResponse :: Value -> Value +anthropicToOpenAIResponse (Object anthropicResp) = + let content = case HM.lookup "content" anthropicResp of + Just (Array contentBlocks) | not (V.null contentBlocks) -> + case V.head contentBlocks of + Object block -> case HM.lookup "text" block of + Just (String txt) -> txt + _ -> "" + _ -> "" + _ -> "" + + finishReason :: Text + finishReason = case HM.lookup "stop_reason" anthropicResp of + Just (String "end_turn") -> "stop" + Just (String "max_tokens") -> "length" + Just (String "tool_use") -> "tool_calls" + _ -> "stop" + + in object + [ "id" .= ("chatcmpl-" <> "123" :: Text) + , "object" .= ("chat.completion" :: Text) + , "created" .= (1234567890 :: Int) + , "model" .= ("gpt-4" :: Text) + , "choices" .= [object + [ "index" .= (0 :: Int) + , "message" .= object + [ "role" .= ("assistant" :: Text) + , "content" .= content + ] + , "finish_reason" .= finishReason + ]] + ] +anthropicToOpenAIResponse _ = object [] + +-- | Convert Anthropic SSE stream to OpenAI SSE format +convertAnthropicToOpenAIStream :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +convertAnthropicToOpenAIStream write flush bodyReader = do + -- TODO: Implement proper Anthropic → OpenAI SSE conversion + -- For now, just pass through (will need to parse Anthropic events and convert) + let loop = do + chunk <- brRead bodyReader + if BS.null chunk + then pure () + else do + -- Simple pass-through for now + write (byteString chunk) + flush + loop + loop diff --git a/src/Louter/Backend/OpenAIToGemini.hs b/src/Louter/Backend/OpenAIToGemini.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Backend/OpenAIToGemini.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | OpenAI ↔ Gemini protocol conversion +-- Used when OpenAI frontend needs to communicate with Gemini backend +module Louter.Backend.OpenAIToGemini + ( -- * Request Conversion + openAIToGemini + , openAIMessageToGemini + -- * Response Conversion + , geminiToOpenAIResponse + , convertGeminiToOpenAIStream + ) where + +import Data.Aeson (Value(..), object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder, byteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client (brRead) + +-- | Convert OpenAI request to Gemini request format +-- Returns (model_name, gemini_request_body) +openAIToGemini :: Value -> Either Text (Text, Value) +openAIToGemini (Object obj) = do + -- Extract model name + model <- case HM.lookup "model" obj of + Just (String m) -> Right m + _ -> Left "Missing 'model' field" + + messages <- case HM.lookup "messages" obj of + Just (Array msgs) -> Right $ V.toList msgs + _ -> Left "Missing 'messages' field" + + -- Convert to Gemini format (inverse of geminiToOpenAI) + let geminiContents = map openAIMessageToGemini messages + temperature = HM.lookup "temperature" obj + maxTokens = HM.lookup "max_tokens" obj + + geminiReq = object $ + [ "contents" .= geminiContents + ] ++ (case temperature of + Just t -> ["generationConfig" .= object ["temperature" .= t]] + Nothing -> []) + ++ (case maxTokens of + Just m -> ["generationConfig" .= object ["maxOutputTokens" .= m]] + Nothing -> []) + + Right (model, geminiReq) + +openAIToGemini _ = Left "Request must be a JSON object" + +-- | Convert OpenAI message to Gemini message format +openAIMessageToGemini :: Value -> Value +openAIMessageToGemini (Object msg) = + let role = case HM.lookup "role" msg of + Just (String "assistant") -> "model" + Just (String r) -> r + _ -> "user" + + parts = case HM.lookup "content" msg of + -- Simple string content + Just (String c) -> [object ["text" .= c]] + + -- Array of content parts (multimodal: text + images) + Just (Array contentParts) -> + map convertPart (V.toList contentParts) + + _ -> [object ["text" .= ("" :: Text)]] + + convertPart (Object part) = case HM.lookup "type" part of + -- Text part: {"type": "text", "text": "..."} + Just (String "text") -> case HM.lookup "text" part of + Just (String txt) -> object ["text" .= txt] + _ -> object [] + + -- Image part: {"type": "image_url", "image_url": {"url": "data:..."}} + Just (String "image_url") -> case HM.lookup "image_url" part of + Just (Object imgUrlObj) -> case HM.lookup "url" imgUrlObj of + Just (String dataUrl) -> + -- Parse data URL: "data:image/png;base64,..." + let (mediaType, base64Data) = parseDataUrl dataUrl + in object + [ "inlineData" .= object + [ "mimeType" .= mediaType + , "data" .= base64Data + ] + ] + _ -> object [] + _ -> object [] + + _ -> object [] + convertPart _ = object [] + + -- Parse data URL: "data:image/png;base64,iVBORw0..." → ("image/png", "iVBORw0...") + parseDataUrl :: Text -> (Text, Text) + parseDataUrl url = + case T.stripPrefix "data:" url of + Just rest -> case T.breakOn ";base64," rest of + (mediaType, base64Part) -> case T.stripPrefix ";base64," base64Part of + Just base64Data -> (mediaType, base64Data) + Nothing -> ("image/png", "") + _ -> ("image/png", "") + Nothing -> ("image/png", "") + + in object ["role" .= role, "parts" .= parts] +openAIMessageToGemini other = other + +-- | Convert Gemini response to OpenAI response format +geminiToOpenAIResponse :: Value -> Value +geminiToOpenAIResponse (Object geminiResp) = + let content = case HM.lookup "candidates" geminiResp of + Just (Array candidates) | not (V.null candidates) -> + case V.head candidates of + Object candidate -> case HM.lookup "content" candidate of + Just (Object contentObj) -> case HM.lookup "parts" contentObj of + Just (Array parts) | not (V.null parts) -> + case V.head parts of + Object part -> case HM.lookup "text" part of + Just (String txt) -> txt + _ -> "" + _ -> "" + _ -> "" + _ -> "" + _ -> "" + _ -> "" + + in object + [ "id" .= ("chatcmpl-" <> "123" :: Text) + , "object" .= ("chat.completion" :: Text) + , "created" .= (1234567890 :: Int) + , "model" .= ("gpt-4" :: Text) + , "choices" .= [object + [ "index" .= (0 :: Int) + , "message" .= object + [ "role" .= ("assistant" :: Text) + , "content" .= content + ] + , "finish_reason" .= ("stop" :: Text) + ]] + ] +geminiToOpenAIResponse _ = object [] + +-- | Convert Gemini SSE stream to OpenAI SSE format +convertGeminiToOpenAIStream :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +convertGeminiToOpenAIStream write flush bodyReader = do + -- TODO: Implement proper Gemini → OpenAI SSE conversion + -- For now, just pass through (will need to parse Gemini events and convert) + let loop = do + chunk <- brRead bodyReader + if BS.null chunk + then pure () + else do + -- Simple pass-through for now + write (byteString chunk) + flush + loop + loop diff --git a/src/Louter/Client.hs b/src/Louter/Client.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Client.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | High-level client API for Louter +-- This module uses the same proven converters as the proxy server +-- +-- Key Design: The client library reuses server-side protocol converters +-- for maximum reliability (no code duplication). +-- +-- Example usage: +-- @ +-- import Louter.Client +-- import Louter.Client.OpenAI (llamaServerClient) +-- +-- main = do +-- client <- llamaServerClient "http://localhost:11211" +-- response <- chatCompletion client $ defaultChatRequest "gpt-oss" +-- [Message RoleUser "Hello!"] +-- print response +-- @ +module Louter.Client + ( -- * Client Configuration + Client + , Backend(..) + , newClient + -- * Simple API + , chatCompletion + , streamChat + -- * Streaming with Callbacks + , StreamCallback + , streamChatWithCallback + -- * Re-exports from Types + , module Louter.Types.Request + , module Louter.Types.Response + , module Louter.Types.Streaming + ) where + +import Control.Monad (foldM) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value(..), encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import Data.Conduit ((.|), runConduit, ConduitT, yield, await) +import qualified Data.Conduit.List as CL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (hContentType, hAuthorization) +import Network.HTTP.Types.Header (RequestHeaders) + +-- Import server-side converters (proven, tested code) +import Louter.Protocol.AnthropicConverter +import Louter.Protocol.GeminiConverter +import Louter.Types.Request +import Louter.Types.Response +import Louter.Types.Streaming + +-- | Client configuration +data Client = Client + { clientManager :: Manager + , clientBackend :: Backend + } + +-- | Backend configuration +data Backend + = BackendOpenAI + { backendApiKey :: Text + , backendBaseUrl :: Maybe Text + , backendRequiresAuth :: Bool + } + | BackendGemini + { backendApiKey :: Text + , backendBaseUrl :: Maybe Text + , backendRequiresAuth :: Bool + } + | BackendAnthropic + { backendApiKey :: Text + , backendBaseUrl :: Maybe Text + , backendRequiresAuth :: Bool + } + +-- | Create a new client +newClient :: Backend -> IO Client +newClient backend = do + manager <- newManager tlsManagerSettings + pure $ Client manager backend + +-- | Non-streaming chat completion +chatCompletion :: Client -> ChatRequest -> IO (Either Text ChatResponse) +chatCompletion client req = do + let req' = req { reqStream = False } + result <- makeRequest client req' + case result of + Left err -> pure $ Left err + Right respBody -> + case parseBackendResponse (clientBackend client) respBody of + Left err -> pure $ Left $ "Failed to parse response: " <> T.pack err + Right resp -> pure $ Right resp + +-- | Streaming chat with conduit +streamChat :: Client -> ChatRequest -> ConduitT () StreamEvent IO () +streamChat client req = do + let req' = req { reqStream = True } + -- For now, just make the request and parse simple events + -- TODO: Implement proper streaming when we have tested server-side streaming + result <- liftIO $ makeRequest client req' + case result of + Left err -> yield (StreamError err) + Right _respBody -> do + -- Placeholder: just return a finish event + -- Real implementation would parse SSE stream + yield (StreamFinish "stop") + +-- | Type alias for streaming callbacks +type StreamCallback = StreamEvent -> IO () + +-- | Streaming chat with callback +streamChatWithCallback :: Client -> ChatRequest -> StreamCallback -> IO () +streamChatWithCallback client req callback = do + runConduit $ streamChat client req .| CL.mapM_ (liftIO . callback) + +-- | Make HTTP request to backend +makeRequest :: Client -> ChatRequest -> IO (Either Text BL.ByteString) +makeRequest Client{..} chatReq = do + let backend = clientBackend + + -- Convert ChatRequest to backend-specific format using server converters + case convertRequestToBackend backend chatReq of + Left err -> pure $ Left err + Right (url, body, headers) -> do + req <- parseRequest (T.unpack url) + let req' = req + { method = "POST" + , requestBody = RequestBodyLBS body + , requestHeaders = headers + } + + response <- httpLbs req' clientManager + pure $ Right $ responseBody response + +-- | Convert ChatRequest to backend-specific format +-- This reuses the server-side converters +convertRequestToBackend :: Backend -> ChatRequest -> Either Text (Text, BL.ByteString, RequestHeaders) +convertRequestToBackend backend chatReq = + case backend of + BackendOpenAI{..} -> do + let url = case backendBaseUrl of + Just u -> u <> "/v1/chat/completions" + Nothing -> "https://api.openai.com/v1/chat/completions" + + -- Build OpenAI request format + messagesJson = map (\msg -> object + [ "role" .= msgRole msg + , "content" .= msgContent msg + ]) (reqMessages chatReq) + + requestBody = encode $ object + [ "model" .= reqModel chatReq + , "messages" .= messagesJson + , "tools" .= if null (reqTools chatReq) then Nothing else Just (reqTools chatReq) + , "temperature" .= reqTemperature chatReq + , "max_tokens" .= reqMaxTokens chatReq + , "stream" .= reqStream chatReq + ] + + headers = [(hContentType, "application/json")] + ++ if backendRequiresAuth + then [(hAuthorization, TE.encodeUtf8 $ "Bearer " <> backendApiKey)] + else [] + + Right (url, requestBody, headers) + + BackendAnthropic{..} -> do + let url = case backendBaseUrl of + Just u -> u <> "/v1/messages" + Nothing -> "https://api.anthropic.com/v1/messages" + + -- Convert to Anthropic format (reverse of what anthropicToOpenAI does) + let anthropicMessages = map chatMessageToAnthropic (reqMessages chatReq) + anthropicTools = map chatToolToAnthropic (reqTools chatReq) + + requestBody = encode $ object $ + [ "model" .= reqModel chatReq + , "messages" .= anthropicMessages + , "max_tokens" .= reqMaxTokens chatReq + , "stream" .= reqStream chatReq + ] ++ (if null anthropicTools then [] else ["tools" .= anthropicTools]) + ++ (case reqTemperature chatReq of Just t -> ["temperature" .= t]; Nothing -> []) + + headers = [(hContentType, "application/json")] + ++ if backendRequiresAuth + then [(hAuthorization, TE.encodeUtf8 $ "Bearer " <> backendApiKey)] + else [] + + Right (url, requestBody, headers) + + BackendGemini{..} -> do + let url = case backendBaseUrl of + Just u -> u <> "/v1beta/models/" <> reqModel chatReq <> ":generateContent" + Nothing -> "https://generativelanguage.googleapis.com/v1beta/models/" + <> reqModel chatReq <> ":generateContent" + + -- Convert to Gemini format (reverse of what geminiToOpenAI does) + let geminiContents = map chatMessageToGemini (reqMessages chatReq) + geminiTools = if null (reqTools chatReq) + then [] + else [object ["functionDeclarations" .= map chatToolToGemini (reqTools chatReq)]] + + requestBody = encode $ object $ + [ "contents" .= geminiContents + ] ++ (if null geminiTools then [] else ["tools" .= geminiTools]) + ++ (case reqTemperature chatReq of + Just t -> ["generationConfig" .= object ["temperature" .= t]] + Nothing -> []) + ++ (case reqMaxTokens chatReq of + Just m -> ["generationConfig" .= object ["maxOutputTokens" .= m]] + Nothing -> []) + + headers = [(hContentType, "application/json")] + ++ if backendRequiresAuth + then [(hAuthorization, TE.encodeUtf8 $ "Bearer " <> backendApiKey)] + else [] + + Right (url, requestBody, headers) + +-- | Parse backend response into ChatResponse +parseBackendResponse :: Backend -> BL.ByteString -> Either String ChatResponse +parseBackendResponse backend respBody = + case backend of + BackendOpenAI{..} -> parseOpenAIResponse respBody + BackendAnthropic{..} -> parseAnthropicResponse respBody + BackendGemini{..} -> parseGeminiResponse respBody + +-- | Parse OpenAI format response +parseOpenAIResponse :: BL.ByteString -> Either String ChatResponse +parseOpenAIResponse body = do + obj <- eitherDecode body + case obj of + Object o -> do + respId <- case HM.lookup "id" o of + Just (String i) -> Right i + _ -> Right "unknown" + + respModel <- case HM.lookup "model" o of + Just (String m) -> Right m + _ -> Right "unknown" + + choices <- case HM.lookup "choices" o of + Just (Array cs) -> Right $ V.toList cs + _ -> Left "Missing choices" + + parsedChoices <- mapM parseOpenAIChoice choices + + pure $ ChatResponse respId respModel parsedChoices Nothing + + _ -> Left "Expected object" + +parseOpenAIChoice :: Value -> Either String Choice +parseOpenAIChoice (Object choice) = do + index <- case HM.lookup "index" choice of + Just (Number n) -> Right (floor n) + _ -> Right 0 + + message <- case HM.lookup "message" choice of + Just (Object msg) -> case HM.lookup "content" msg of + Just (String txt) -> Right txt + _ -> Right "" + _ -> Right "" + + let finishReason = case HM.lookup "finish_reason" choice of + Just (String "stop") -> Just FinishStop + Just (String "length") -> Just FinishLength + Just (String "tool_calls") -> Just FinishToolCalls + _ -> Nothing + + pure $ Choice index message finishReason + +parseOpenAIChoice _ = Left "Expected choice object" + +-- | Parse Anthropic format response (uses converter) +parseAnthropicResponse :: BL.ByteString -> Either String ChatResponse +parseAnthropicResponse body = do + obj <- eitherDecode body + -- Use anthropicToOpenAI converter, then parse as OpenAI + case anthropicToOpenAI obj of + Left err -> Left (T.unpack err) + Right openAIFormat -> parseOpenAIResponse (encode openAIFormat) + +-- | Parse Gemini format response (uses converter) +parseGeminiResponse :: BL.ByteString -> Either String ChatResponse +parseGeminiResponse body = do + obj <- eitherDecode body + -- Use geminiToOpenAI converter, then parse as OpenAI + case geminiToOpenAI "unknown" False obj of -- False = non-streaming + Left err -> Left (T.unpack err) + Right openAIFormat -> parseOpenAIResponse (encode openAIFormat) + +-- Helper conversions for Anthropic +chatMessageToAnthropic :: Message -> Value +chatMessageToAnthropic msg = object + [ "role" .= msgRole msg + , "content" .= msgContent msg + ] + +chatToolToAnthropic :: Tool -> Value +chatToolToAnthropic tool = object $ + [ "name" .= toolName tool + ] ++ (case toolDescription tool of Just d -> ["description" .= d]; Nothing -> []) + ++ ["input_schema" .= toolParameters tool] + +-- Helper conversions for Gemini +chatMessageToGemini :: Message -> Value +chatMessageToGemini msg = + let role = case msgRole msg of + RoleAssistant -> "model" + RoleUser -> "user" + _ -> "user" -- Default for system/tool + parts = [object ["text" .= msgContent msg]] + in object + [ "role" .= (role :: Text) + , "parts" .= parts + ] + +chatToolToGemini :: Tool -> Value +chatToolToGemini tool = object $ + [ "name" .= toolName tool + ] ++ (case toolDescription tool of Just d -> ["description" .= d]; Nothing -> []) + ++ ["parametersJsonSchema" .= toolParameters tool] diff --git a/src/Louter/Client/Anthropic.hs b/src/Louter/Client/Anthropic.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Client/Anthropic.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Anthropic-specific client helpers +module Louter.Client.Anthropic + ( anthropicClient + , anthropicClientWithUrl + ) where + +import Data.Text (Text) +import Louter.Client (Backend(..), Client, newClient) + +-- | Create an Anthropic client with API key (requires authentication) +anthropicClient :: Text -> IO Client +anthropicClient apiKey = newClient $ BackendAnthropic apiKey Nothing True + +-- | Create an Anthropic client with custom base URL (requires authentication) +anthropicClientWithUrl :: Text -> Text -> IO Client +anthropicClientWithUrl apiKey baseUrl = newClient $ BackendAnthropic apiKey (Just baseUrl) True diff --git a/src/Louter/Client/Gemini.hs b/src/Louter/Client/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Client/Gemini.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Gemini-specific client helpers +module Louter.Client.Gemini + ( geminiClient + , geminiClientWithUrl + ) where + +import Data.Text (Text) +import Louter.Client (Backend(..), Client, newClient) + +-- | Create a Gemini client with API key (requires authentication) +geminiClient :: Text -> IO Client +geminiClient apiKey = newClient $ BackendGemini apiKey Nothing True + +-- | Create a Gemini client with custom base URL (requires authentication) +geminiClientWithUrl :: Text -> Text -> IO Client +geminiClientWithUrl apiKey baseUrl = newClient $ BackendGemini apiKey (Just baseUrl) True diff --git a/src/Louter/Client/OpenAI.hs b/src/Louter/Client/OpenAI.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Client/OpenAI.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | OpenAI-specific client helpers +module Louter.Client.OpenAI + ( openAIClient + , openAIClientWithUrl + , llamaServerClient + ) where + +import Data.Text (Text) +import Louter.Client (Backend(..), Client, newClient) + +-- | Create an OpenAI client with API key (requires authentication) +openAIClient :: Text -> IO Client +openAIClient apiKey = newClient $ BackendOpenAI apiKey Nothing True + +-- | Create an OpenAI client with custom base URL (requires authentication) +openAIClientWithUrl :: Text -> Text -> IO Client +openAIClientWithUrl apiKey baseUrl = newClient $ BackendOpenAI apiKey (Just baseUrl) True + +-- | Create a client for llama-server (no authentication required) +-- Example: llamaServerClient "http://localhost:11211" +llamaServerClient :: Text -> IO Client +llamaServerClient baseUrl = newClient $ BackendOpenAI "" (Just baseUrl) False diff --git a/src/Louter/Protocol/AnthropicConverter.hs b/src/Louter/Protocol/AnthropicConverter.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Protocol/AnthropicConverter.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Anthropic <-> OpenAI Protocol Converter +-- This module handles bidirectional conversion between Anthropic and OpenAI formats +module Louter.Protocol.AnthropicConverter + ( -- * Request Conversion (Anthropic -> OpenAI) + anthropicToOpenAI + , convertAnthropicMessageToOpenAI + , convertAnthropicToolsToOpenAI + , isAnthropicToolResult + , isAnthropicToolUse + , convertAnthropicToolResultToOpenAI + , convertAnthropicToolUseToOpenAI + + -- * Response Conversion (OpenAI -> Anthropic) + , openAIResponseToAnthropic + , convertOpenAIToolCallToAnthropic + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V + +-- ============================================================================ +-- Request Conversion: Anthropic -> OpenAI +-- ============================================================================ + +-- | Convert Anthropic request to OpenAI format +anthropicToOpenAI :: Value -> Either Text Value +anthropicToOpenAI (Object obj) = do + -- Extract messages + messages <- case HM.lookup "messages" obj of + Just (Array msgs) -> Right $ V.toList msgs + _ -> Left "Missing 'messages' field" + + -- Convert messages to OpenAI format + let convertedMessages = map convertAnthropicMessageToOpenAI messages + + -- Extract max_tokens + let maxTokens = case HM.lookup "max_tokens" obj of + Just (Number n) -> Just (floor n :: Int) + _ -> Nothing + + -- Extract optional fields + let temperature = case HM.lookup "temperature" obj of + Just (Number n) -> Just (realToFrac n :: Double) + _ -> Nothing + + let model = case HM.lookup "model" obj of + Just (String m) -> m + _ -> "gpt-4" + + -- Extract system message if present and prepend to messages + let systemMsg = case HM.lookup "system" obj of + Just (String sys) -> [object ["role" .= ("system" :: Text), "content" .= sys]] + _ -> [] + + -- Extract tools if present and convert to OpenAI format + let tools = case HM.lookup "tools" obj of + Just (Array ts) -> Just (convertAnthropicToolsToOpenAI (V.toList ts)) + _ -> Nothing + + -- Extract stream flag (default to False for Anthropic) + let streamFlag = case HM.lookup "stream" obj of + Just (Bool b) -> b + _ -> False + + Right $ object $ + [ "model" .= model + , "messages" .= (systemMsg ++ convertedMessages) + , "max_tokens" .= maxTokens + , "temperature" .= temperature + , "stream" .= streamFlag + ] ++ case tools of + Just t -> ["tools" .= t] + Nothing -> [] + +anthropicToOpenAI _ = Left "Request must be a JSON object" + +-- | Convert Anthropic message to OpenAI format +convertAnthropicMessageToOpenAI :: Value -> Value +convertAnthropicMessageToOpenAI (Object msg) = + let role = case HM.lookup "role" msg of + Just (String r) -> r + _ -> "user" + + content = case HM.lookup "content" msg of + Just c -> c + _ -> String "" + + in case content of + -- Simple text content + String text -> object ["role" .= role, "content" .= text] + + -- Array of content blocks (may include tool_result, tool_use, or text) + Array blocks -> + let contentBlocks = V.toList blocks + hasToolResult = any isAnthropicToolResult contentBlocks + hasToolUse = any isAnthropicToolUse contentBlocks + in + if hasToolResult + then convertAnthropicToolResultToOpenAI contentBlocks + else if hasToolUse + then convertAnthropicToolUseToOpenAI role contentBlocks + else + -- Regular text/image blocks - convert to OpenAI format + let convertedContent = map convertContentBlock contentBlocks + convertContentBlock (Object block) = + case HM.lookup "type" block of + Just (String "text") -> case HM.lookup "text" block of + Just (String txt) -> object ["type" .= ("text" :: Text), "text" .= txt] + _ -> object [] + Just (String "image") -> case HM.lookup "source" block of + Just (Object source) -> + let mediaType = case HM.lookup "media_type" source of + Just (String mt) -> mt + _ -> "image/png" + imageData = case HM.lookup "data" source of + Just (String dat) -> dat + _ -> "" + dataUrl = "data:" <> mediaType <> ";base64," <> imageData + in object + [ "type" .= ("image_url" :: Text) + , "image_url" .= object ["url" .= dataUrl] + ] + _ -> object [] + _ -> object [] + convertContentBlock _ = object [] + in if length convertedContent == 1 && isSimpleText (head convertedContent) + then object ["role" .= role, "content" .= extractText (head convertedContent)] + else object ["role" .= role, "content" .= convertedContent] + where + isSimpleText (Object obj) = HM.lookup "type" obj == Just (String "text") + isSimpleText _ = False + extractText (Object obj) = case HM.lookup "text" obj of + Just (String txt) -> txt + _ -> "" + extractText _ = "" + + _ -> object ["role" .= role, "content" .= content] + +convertAnthropicMessageToOpenAI other = other + +-- | Check if content block is a tool_result +isAnthropicToolResult :: Value -> Bool +isAnthropicToolResult (Object block) = + case HM.lookup "type" block of + Just (String "tool_result") -> True + _ -> False +isAnthropicToolResult _ = False + +-- | Check if content block is a tool_use +isAnthropicToolUse :: Value -> Bool +isAnthropicToolUse (Object block) = + case HM.lookup "type" block of + Just (String "tool_use") -> True + _ -> False +isAnthropicToolUse _ = False + +-- | Convert Anthropic tool_result to OpenAI tool message +convertAnthropicToolResultToOpenAI :: [Value] -> Value +convertAnthropicToolResultToOpenAI blocks = + case [block | block@(Object _) <- blocks, isAnthropicToolResult block] of + (Object toolResult:_) -> + let toolUseId = case HM.lookup "tool_use_id" toolResult of + Just (String tid) -> tid + _ -> "unknown" + resultContent = case HM.lookup "content" toolResult of + Just (String c) -> c + Just other -> TE.decodeUtf8 (BL.toStrict $ encode other) + _ -> "" + in object + [ "role" .= ("tool" :: Text) + , "content" .= resultContent + , "tool_call_id" .= toolUseId + ] + _ -> object ["role" .= ("tool" :: Text), "content" .= ("" :: Text)] + +-- | Convert Anthropic tool_use to OpenAI assistant message with tool_calls +convertAnthropicToolUseToOpenAI :: Text -> [Value] -> Value +convertAnthropicToolUseToOpenAI role blocks = + let textParts = [txt | Object block <- blocks, + HM.lookup "type" block == Just (String "text"), + Just (String txt) <- [HM.lookup "text" block]] + textContent = if null textParts then Nothing else Just (T.concat textParts) + + toolCalls = [convertToolUseBlock block | block@(Object _) <- blocks, isAnthropicToolUse block] + + in object $ + [ "role" .= role ] ++ + [ "content" .= tc | Just tc <- [textContent] ] ++ + [ "tool_calls" .= toolCalls | not (null toolCalls) ] + where + convertToolUseBlock (Object block) = + let toolId = case HM.lookup "id" block of + Just (String tid) -> tid + _ -> "call_unknown" + toolName = case HM.lookup "name" block of + Just (String n) -> n + _ -> "unknown" + toolInput = case HM.lookup "input" block of + Just inp -> encode inp + _ -> "{}" + in object + [ "id" .= toolId + , "type" .= ("function" :: Text) + , "function" .= object + [ "name" .= toolName + , "arguments" .= TE.decodeUtf8 (BL.toStrict toolInput) + ] + ] + convertToolUseBlock _ = object [] + +-- | Convert Anthropic tools to OpenAI format +convertAnthropicToolsToOpenAI :: [Value] -> [Value] +convertAnthropicToolsToOpenAI = map convertTool + where + convertTool (Object tool) = + let name = HM.lookup "name" tool + description = HM.lookup "description" tool + inputSchema = HM.lookup "input_schema" tool + in object + [ "type" .= ("function" :: Text) + , "function" .= object + ([ "name" .= n | Just n <- [name] ] ++ + [ "description" .= d | Just d <- [description] ] ++ + [ "parameters" .= s | Just s <- [inputSchema] ]) + ] + convertTool other = other + +-- ============================================================================ +-- Response Conversion: OpenAI -> Anthropic (Non-Streaming) +-- ============================================================================ + +-- | Convert OpenAI non-streaming response to Anthropic format +openAIResponseToAnthropic :: Value -> Value +openAIResponseToAnthropic (Object openAIResp) = + let (content, stopReason) = case HM.lookup "choices" openAIResp of + Just (Array choices) | not (V.null choices) -> + case V.head choices of + Object choice -> + let finishReason = case HM.lookup "finish_reason" choice of + Just (String "tool_calls") -> "tool_use" + Just (String "stop") -> "end_turn" + Just (String "length") -> "max_tokens" + _ -> "end_turn" + in case HM.lookup "message" choice of + Just (Object msg) -> + let textContent = case HM.lookup "content" msg of + Just (String txt) | not (T.null txt) -> + [object ["type" .= ("text" :: Text), "text" .= txt]] + _ -> [] + + toolContent = case HM.lookup "tool_calls" msg of + Just (Array tcs) -> map convertOpenAIToolCallToAnthropic (V.toList tcs) + _ -> [] + + allContent = textContent ++ toolContent + in (allContent, finishReason) + _ -> ([], "end_turn") + _ -> ([], "end_turn") + _ -> ([], "end_turn") + in object + [ "id" .= ("msg_1" :: Text) + , "type" .= ("message" :: Text) + , "role" .= ("assistant" :: Text) + , "content" .= content + , "model" .= ("claude-3-haiku-20240307" :: Text) + , "stop_reason" .= (stopReason :: Text) + , "usage" .= object + [ "input_tokens" .= (10 :: Int) + , "output_tokens" .= (10 :: Int) + ] + ] +openAIResponseToAnthropic _ = object [] + +-- | Convert OpenAI tool_call to Anthropic tool_use content block +convertOpenAIToolCallToAnthropic :: Value -> Value +convertOpenAIToolCallToAnthropic (Object tc) = + let toolId = case HM.lookup "id" tc of + Just (String tid) -> tid + _ -> "tool_unknown" + + (toolName, toolArgs) = case HM.lookup "function" tc of + Just (Object func) -> + let name = case HM.lookup "name" func of + Just (String n) -> n + _ -> "unknown" + args = case HM.lookup "arguments" func of + Just (String a) -> case eitherDecode (BL.fromStrict $ TE.encodeUtf8 a) of + Right val -> val + Left _ -> object [] + _ -> object [] + in (name, args) + _ -> ("unknown", object []) + in object + [ "type" .= ("tool_use" :: Text) + , "id" .= toolId + , "name" .= toolName + , "input" .= toolArgs + ] +convertOpenAIToolCallToAnthropic _ = object [] diff --git a/src/Louter/Protocol/AnthropicStreaming.hs b/src/Louter/Protocol/AnthropicStreaming.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Protocol/AnthropicStreaming.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Anthropic Streaming Protocol Handler +-- Converts OpenAI SSE stream to Anthropic SSE format with stateful tool call buffering +module Louter.Protocol.AnthropicStreaming + ( -- * State Types + AnthropicStreamState(..) + , AnthropicToolCallState(..) + + -- * Main Streaming Function + , convertOpenAIToAnthropic + + -- * Internal Functions (exported for testing) + , streamAnthropicDeltas + , processOpenAILineToAnthropicStateful + , processAnthropicChoice + , processAnthropicToolCalls + , processAnthropicSingleToolCall + , emitAnthropicToolCalls + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (foldM, forM_, unless, when) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Builder (Builder, byteString) +import qualified Data.HashMap.Strict as HMS +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP +import System.IO (hPutStrLn, stderr, hFlush) + +-- ============================================================================ +-- State Types +-- ============================================================================ + +-- | Tool call state for Anthropic streaming +data AnthropicToolCallState = AnthropicToolCallState + { anthropicToolCallId :: Maybe Text + , anthropicToolCallName :: Maybe Text + , anthropicToolCallArgs :: Text -- Accumulated arguments string + } deriving (Show) + +-- | Anthropic streaming state +data AnthropicStreamState = AnthropicStreamState + { anthropicToolCalls :: HMS.HashMap Int AnthropicToolCallState + , anthropicContentBlockStarted :: Bool + , anthropicCurrentIndex :: Int + } deriving (Show) + +-- ============================================================================ +-- Main Streaming Function +-- ============================================================================ + +-- | Convert OpenAI SSE stream to Anthropic SSE format +convertOpenAIToAnthropic :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +convertOpenAIToAnthropic write flush bodyReader = do + -- Send message_start event + write (byteString $ BS8.pack "event: message_start\ndata: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_1\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-3-haiku-20240307\",\"stop_reason\":null,\"usage\":{\"input_tokens\":10,\"output_tokens\":0}}}\n\n") + flush + + -- Stream with stateful tool call tracking + let initialState = AnthropicStreamState HMS.empty False 0 + streamAnthropicDeltas write flush bodyReader initialState + +-- ============================================================================ +-- Streaming Loop +-- ============================================================================ + +-- | Stream Anthropic deltas with tool call state management +streamAnthropicDeltas :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> AnthropicStreamState -> IO () +streamAnthropicDeltas write flush bodyReader initialState = loop BS.empty initialState + where + loop acc state = do + chunk <- HTTP.brRead bodyReader + if BS.null chunk + then finalize state + else do + let combined = acc <> chunk + lines' = BS.split (fromIntegral $ fromEnum '\n') combined + case lines' of + [] -> loop BS.empty state + [incomplete] -> loop incomplete state + _ -> do + let (completeLines, rest) = (init lines', last lines') + newState <- foldM (processOpenAILineToAnthropicStateful write flush) state completeLines + loop rest newState + + finalize state = do + -- Close any open content blocks + when (anthropicContentBlockStarted state) $ do + write (byteString $ BS8.pack $ "event: content_block_stop\ndata: {\"type\":\"content_block_stop\",\"index\":" ++ show (anthropicCurrentIndex state) ++ "}\n\n") + flush + + -- Send message_delta with stop_reason + write (byteString $ BS8.pack "event: message_delta\ndata: {\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":10}}\n\n") + flush + + -- Send message_stop + write (byteString $ BS8.pack "event: message_stop\ndata: {\"type\":\"message_stop\"}\n\n") + flush + +-- ============================================================================ +-- SSE Line Processing +-- ============================================================================ + +-- | Process a single OpenAI SSE line and convert to Anthropic format (stateful) +processOpenAILineToAnthropicStateful :: (Builder -> IO ()) -> IO () -> AnthropicStreamState -> BS.ByteString -> IO AnthropicStreamState +processOpenAILineToAnthropicStateful write flush state line + | BS.isPrefixOf "data: " line = do + let jsonText = TE.decodeUtf8 $ BS.drop 6 line + if jsonText == "[DONE]" + then pure state -- Don't send [DONE] in Anthropic format + else case eitherDecode (BL.fromStrict $ TE.encodeUtf8 jsonText) of + Right (Object openAIChunk) -> do + -- Extract choices + case HM.lookup "choices" openAIChunk of + Just (Array choices) | not (V.null choices) -> do + case V.head choices of + Object choice -> processAnthropicChoice write flush state choice openAIChunk + _ -> pure state + _ -> pure state + _ -> pure state + | otherwise = pure state + +-- ============================================================================ +-- Choice Processing +-- ============================================================================ + +-- | Process a single choice and update Anthropic state +processAnthropicChoice :: (Builder -> IO ()) -> IO () -> AnthropicStreamState -> Object -> Object -> IO AnthropicStreamState +processAnthropicChoice write flush state choice _openAIChunk = do + let finishReason = case HM.lookup "finish_reason" choice of + Just (String reason) -> Just reason + _ -> Nothing + + case HM.lookup "delta" choice of + Just (Object delta) -> do + -- Check for text content + let hasContent = HM.member "content" delta + let hasToolCalls = HM.member "tool_calls" delta + + newState <- if hasContent + then do + -- Start text content block if not started + unless (anthropicContentBlockStarted state) $ do + let idx = anthropicCurrentIndex state + let startEvent = object + [ "type" .= ("content_block_start" :: Text) + , "index" .= idx + , "content_block" .= object + [ "type" .= ("text" :: Text) + , "text" .= ("" :: Text) + ] + ] + write (byteString $ BS8.pack "event: content_block_start\ndata: " <> BL.toStrict (encode startEvent) <> BS8.pack "\n\n") + flush + + -- Send content delta + case HM.lookup "content" delta of + Just (String content) -> do + let idx = anthropicCurrentIndex state + let deltaEvent = object + [ "type" .= ("content_block_delta" :: Text) + , "index" .= idx + , "delta" .= object + [ "type" .= ("text_delta" :: Text) + , "text" .= content + ] + ] + write (byteString $ BS8.pack "event: content_block_delta\ndata: " <> BL.toStrict (encode deltaEvent) <> BS8.pack "\n\n") + flush + _ -> pure () + + pure $ state { anthropicContentBlockStarted = True } + + else if hasToolCalls + then processAnthropicToolCalls write flush state delta finishReason + else pure state + + -- Handle finish_reason + finalState <- case finishReason of + Just "tool_calls" -> do + -- Close text block if open before emitting tool calls + stateAfterText <- if anthropicContentBlockStarted newState + then do + let idx = anthropicCurrentIndex newState + write (byteString $ BS8.pack $ "event: content_block_stop\ndata: {\"type\":\"content_block_stop\",\"index\":" ++ show idx ++ "}\n\n") + flush + -- Increment index after closing text block + pure newState { anthropicContentBlockStarted = False, anthropicCurrentIndex = anthropicCurrentIndex newState + 1 } + else pure newState + -- Emit buffered tool calls + emitAnthropicToolCalls write flush stateAfterText + + Just _ -> + -- Close text content block if open + if anthropicContentBlockStarted newState + then do + let idx = anthropicCurrentIndex newState + write (byteString $ BS8.pack $ "event: content_block_stop\ndata: {\"type\":\"content_block_stop\",\"index\":" ++ show idx ++ "}\n\n") + flush + -- Increment index after closing text block + pure newState { anthropicContentBlockStarted = False, anthropicCurrentIndex = anthropicCurrentIndex newState + 1 } + else pure newState + + Nothing -> pure newState + + pure finalState + + _ -> pure state + +-- ============================================================================ +-- Tool Call Processing +-- ============================================================================ + +-- | Process tool calls delta and buffer them +processAnthropicToolCalls :: (Builder -> IO ()) -> IO () -> AnthropicStreamState -> Object -> Maybe Text -> IO AnthropicStreamState +processAnthropicToolCalls _write _flush state delta _finishReason = do + case HM.lookup "tool_calls" delta of + Just (Array toolCallsArray) -> do + foldM (processAnthropicSingleToolCall _write _flush) state (V.toList toolCallsArray) + _ -> pure state + +-- | Process a single tool call fragment +processAnthropicSingleToolCall :: (Builder -> IO ()) -> IO () -> AnthropicStreamState -> Value -> IO AnthropicStreamState +processAnthropicSingleToolCall _write _flush state (Object tcDelta) = do + let tcIndex = case HM.lookup "index" tcDelta of + Just (Number n) -> floor n :: Int + _ -> 0 + + let tcId = case HM.lookup "id" tcDelta of + Just (String i) -> Just i + _ -> Nothing + + let tcFunc = HM.lookup "function" tcDelta + + let tcName = case tcFunc of + Just (Object f) -> case HM.lookup "name" f of + Just (String n) -> Just n + _ -> Nothing + _ -> Nothing + + let tcArgs = case tcFunc of + Just (Object f) -> case HM.lookup "arguments" f of + Just (String a) -> a + _ -> "" + _ -> "" + + -- Update state + let currentTc = HMS.lookupDefault (AnthropicToolCallState Nothing Nothing "") tcIndex (anthropicToolCalls state) + let updatedTc = AnthropicToolCallState + { anthropicToolCallId = tcId <|> anthropicToolCallId currentTc + , anthropicToolCallName = tcName <|> anthropicToolCallName currentTc + , anthropicToolCallArgs = anthropicToolCallArgs currentTc <> tcArgs + } + let newToolCalls = HMS.insert tcIndex updatedTc (anthropicToolCalls state) + + pure $ state { anthropicToolCalls = newToolCalls } + +processAnthropicSingleToolCall _ _ state _ = pure state + +-- | Emit buffered tool calls as Anthropic tool_use blocks +emitAnthropicToolCalls :: (Builder -> IO ()) -> IO () -> AnthropicStreamState -> IO AnthropicStreamState +emitAnthropicToolCalls write flush state = do + let toolCallsList = HMS.toList (anthropicToolCalls state) + let sortedToolCalls = sortBy (comparing fst) toolCallsList + + forM_ sortedToolCalls $ \(tcIndex, tcState) -> do + case (anthropicToolCallId tcState, anthropicToolCallName tcState) of + (Just toolId, Just toolName) -> do + -- Log tool call for debugging + hPutStrLn stderr $ "[Anthropic] Emitting tool_use: id=" <> T.unpack toolId + <> ", name=" <> T.unpack toolName + <> ", args=" <> T.unpack (anthropicToolCallArgs tcState) + hFlush stderr + + -- Parse arguments as JSON + let argsJson = case eitherDecode (BL.fromStrict $ TE.encodeUtf8 (anthropicToolCallArgs tcState)) of + Right val -> val + Left _ -> object [] + + -- Calculate content block index (after text blocks) + let blockIndex = anthropicCurrentIndex state + tcIndex + + -- Send content_block_start + -- IMPORTANT: tool_use content_block must include empty input object + let startEvent = object + [ "type" .= ("content_block_start" :: Text) + , "index" .= blockIndex + , "content_block" .= object + [ "type" .= ("tool_use" :: Text) + , "id" .= toolId + , "name" .= toolName + , "input" .= object [] -- Empty input object required by Anthropic spec + ] + ] + write (byteString $ BS8.pack "event: content_block_start\ndata: " <> BL.toStrict (encode startEvent) <> BS8.pack "\n\n") + flush + + -- Send input_json_delta + -- partial_json should be the raw JSON string, not re-encoded + let deltaEvent = object + [ "type" .= ("content_block_delta" :: Text) + , "index" .= blockIndex + , "delta" .= object + [ "type" .= ("input_json_delta" :: Text) + , "partial_json" .= anthropicToolCallArgs tcState + ] + ] + write (byteString $ BS8.pack "event: content_block_delta\ndata: " <> BL.toStrict (encode deltaEvent) <> BS8.pack "\n\n") + flush + + -- Send content_block_stop + let stopEvent = object + [ "type" .= ("content_block_stop" :: Text) + , "index" .= blockIndex + ] + write (byteString $ BS8.pack "event: content_block_stop\ndata: " <> BL.toStrict (encode stopEvent) <> BS8.pack "\n\n") + flush + + _ -> pure () + + pure $ state { anthropicCurrentIndex = anthropicCurrentIndex state + length sortedToolCalls } diff --git a/src/Louter/Protocol/GeminiConverter.hs b/src/Louter/Protocol/GeminiConverter.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Protocol/GeminiConverter.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Gemini <-> OpenAI Protocol Converter +-- This module handles bidirectional conversion between Gemini and OpenAI formats +module Louter.Protocol.GeminiConverter + ( -- * Request Conversion (Gemini -> OpenAI) + geminiToOpenAI + , convertGeminiContentToMessage + , convertGeminiToolsToOpenAI + + -- * Response Conversion (OpenAI -> Gemini) + , openAIResponseToGemini + ) where + +import Data.Aeson (Value(..), Object, encode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V + +-- ============================================================================ +-- Request Conversion: Gemini -> OpenAI +-- ============================================================================ + +-- | Convert Gemini request to OpenAI format +geminiToOpenAI :: Text -> Bool -> Value -> Either Text Value +geminiToOpenAI modelName streaming (Object obj) = do + -- Extract contents array + contents <- case HM.lookup "contents" obj of + Just (Array cs) -> Right $ V.toList cs + _ -> Left "Missing 'contents' field" + + -- Convert contents to OpenAI messages + messages <- mapM convertGeminiContentToMessage contents + + -- Extract system instruction if present + let systemMsg = case HM.lookup "systemInstruction" obj of + Just (Object sysInst) -> case HM.lookup "parts" sysInst of + Just (Array parts) | not (V.null parts) -> + case V.head parts of + Object part -> case HM.lookup "text" part of + Just (String txt) -> [object ["role" .= ("system" :: Text), "content" .= txt]] + _ -> [] + _ -> [] + _ -> [] + _ -> [] + + -- Extract generation config + let temperature = case HM.lookup "generationConfig" obj of + Just (Object cfg) -> HM.lookup "temperature" cfg + _ -> Nothing + + let maxTokens = case HM.lookup "generationConfig" obj of + Just (Object cfg) -> HM.lookup "maxOutputTokens" cfg + _ -> Nothing + + -- Extract tools + let tools = case HM.lookup "tools" obj of + Just (Array ts) -> Just $ V.toList ts + _ -> Nothing + + Right $ object $ + [ "model" .= modelName + , "messages" .= (systemMsg ++ messages) + , "stream" .= streaming + ] ++ (case temperature of Just t -> ["temperature" .= t]; Nothing -> []) + ++ (case maxTokens of Just m -> ["max_tokens" .= m]; Nothing -> []) + ++ (case tools of Just t -> ["tools" .= convertGeminiToolsToOpenAI t]; Nothing -> []) + +geminiToOpenAI _ _ _ = Left "Request must be a JSON object" + +-- | Convert Gemini content to OpenAI message +convertGeminiContentToMessage :: Value -> Either Text Value +convertGeminiContentToMessage (Object content) = do + role <- case HM.lookup "role" content of + Just (String r) -> Right r + _ -> Right "user" -- Default to user + + -- Convert Gemini roles to OpenAI roles + -- Gemini uses "model", OpenAI uses "assistant" + let openAIRole = if role == "model" then "assistant" else role + + parts <- case HM.lookup "parts" content of + Just (Array ps) -> Right $ V.toList ps + _ -> Left "Missing 'parts' in content" + + -- Check if any part is a functionResponse (tool result) + let hasFunctionResponse = any isFunctionResponse parts + + if hasFunctionResponse && not (null parts) + then do + -- Convert function response to OpenAI tool message format + -- Gemini can have multiple function responses in one message + let toolMessages = map convertFunctionResponsePart (filter isFunctionResponse parts) + -- For now, return the first tool message (OpenAI expects one tool result per message) + case toolMessages of + (msg:_) -> Right msg + [] -> Left "Function response part missing required fields" + else do + -- Regular text/image content - convert to OpenAI format + let convertedParts = map convertPart parts + convertPart (Object part) + -- Text part: {"text": "..."} + | Just (String txt) <- HM.lookup "text" part = + object ["type" .= ("text" :: Text), "text" .= txt] + + -- Image part: {"inlineData": {"mimeType": "...", "data": "..."}} + | Just (Object inlineData) <- HM.lookup "inlineData" part = + let mimeType = case HM.lookup "mimeType" inlineData of + Just (String mt) -> mt + _ -> "image/png" + imageData = case HM.lookup "data" inlineData of + Just (String dat) -> dat + _ -> "" + dataUrl = "data:" <> mimeType <> ";base64," <> imageData + in object + [ "type" .= ("image_url" :: Text) + , "image_url" .= object ["url" .= dataUrl] + ] + + -- Unknown part type + | otherwise = object [] + convertPart _ = object [] + + Right $ case convertedParts of + -- Single text part - simplify to string + [part] | isSimpleText part -> object + [ "role" .= openAIRole + , "content" .= extractText part + ] + -- Multiple parts or has images - use array format + _ -> object + [ "role" .= openAIRole + , "content" .= filter (not . isEmptyObject) convertedParts + ] + where + -- Helper functions for vision content + isSimpleText (Object obj) = HM.lookup "type" obj == Just (String "text") + isSimpleText _ = False + + extractText (Object obj) = case HM.lookup "text" obj of + Just (String txt) -> txt + _ -> "" + extractText _ = "" + + isEmptyObject (Object obj) = HM.null obj + isEmptyObject _ = False + + -- Helper functions for function responses + isFunctionResponse (Object part) = HM.member "functionResponse" part + isFunctionResponse _ = False + + convertFunctionResponsePart (Object part) = + case HM.lookup "functionResponse" part of + Just (Object funcResp) -> + let funcName = case HM.lookup "name" funcResp of + Just (String n) -> n + _ -> "unknown" + funcResult = case HM.lookup "response" funcResp of + Just resp -> encode resp + _ -> "{}" + -- Generate a tool_call_id (in real Gemini API, this would come from the original call) + -- For now, use the function name as ID + toolCallId = funcName <> "_result" + in object + [ "role" .= ("tool" :: Text) + , "content" .= TE.decodeUtf8 (BL.toStrict funcResult) + , "tool_call_id" .= toolCallId + ] + _ -> object [] + convertFunctionResponsePart _ = object [] + +convertGeminiContentToMessage _ = Left "Content must be a JSON object" + +-- | Convert Gemini tools to OpenAI format +convertGeminiToolsToOpenAI :: [Value] -> [Value] +convertGeminiToolsToOpenAI = concatMap convertTool + where + convertTool (Object tool) = + case HM.lookup "functionDeclarations" tool of + Just (Array funcs) -> map (\func -> object + [ "type" .= ("function" :: Text) + , "function" .= convertFunctionDeclaration func + ]) (V.toList funcs) + _ -> [] + convertTool _ = [] + + -- Convert Gemini function declaration to OpenAI format + -- Rename "parametersJsonSchema" to "parameters" + convertFunctionDeclaration (Object funcObj) = + let renamedObj = case HM.lookup "parametersJsonSchema" funcObj of + Just params -> HM.insert "parameters" params (HM.delete "parametersJsonSchema" funcObj) + Nothing -> funcObj + in Object renamedObj + convertFunctionDeclaration other = other + +-- ============================================================================ +-- Response Conversion: OpenAI -> Gemini (Non-Streaming) +-- ============================================================================ + +-- | Convert OpenAI non-streaming response to Gemini format +openAIResponseToGemini :: Value -> Value +openAIResponseToGemini (Object openAIResp) = + let candidates = case HM.lookup "choices" openAIResp of + Just (Array choices) | not (V.null choices) -> + V.toList $ V.map convertChoice choices + _ -> [] + in object + [ "candidates" .= candidates + , "usageMetadata" .= object + [ "promptTokenCount" .= (0 :: Int) + , "candidatesTokenCount" .= (0 :: Int) + , "totalTokenCount" .= (0 :: Int) + ] + ] + where + convertChoice (Object choice) = + let message = case HM.lookup "message" choice of + Just (Object m) -> m + _ -> HM.empty + finishReason = HM.lookup "finish_reason" choice + content = HM.lookup "content" message + parts = case content of + Just (String txt) -> [object ["text" .= txt]] + _ -> [] + in object $ + [ "content" .= object + [ "parts" .= parts + , "role" .= ("model" :: Text) + ] + ] ++ (case finishReason of + Just r -> ["finishReason" .= r] + Nothing -> []) + convertChoice _ = object [] +openAIResponseToGemini _ = object [] diff --git a/src/Louter/Protocol/GeminiStreaming.hs b/src/Louter/Protocol/GeminiStreaming.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Protocol/GeminiStreaming.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Gemini Streaming Protocol Handler +-- Converts OpenAI SSE stream to Gemini newline-delimited JSON format +module Louter.Protocol.GeminiStreaming + ( -- * State Types + ToolCallState(..) + + -- * Main Streaming Functions + , convertOpenAIToGeminiStream + , streamGeminiDeltas + + -- * Internal Functions (exported for testing) + , processOpenAILineToGeminiStateful + , processToolCallChunk + , openAIChunkToGemini + ) where + +import Control.Monad (foldM) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Builder (Builder, byteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP + +-- ============================================================================ +-- State Types +-- ============================================================================ + +-- | State for tracking tool call arguments during streaming +data ToolCallState = ToolCallState + { toolCallId :: Maybe Text + , toolCallName :: Maybe Text + , toolCallArgs :: Text -- Accumulated arguments string + } deriving (Show) + +-- ============================================================================ +-- Main Streaming Functions +-- ============================================================================ + +-- | Convert OpenAI SSE stream to Gemini newline-delimited JSON format +convertOpenAIToGeminiStream :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +convertOpenAIToGeminiStream write flush bodyReader = do + streamGeminiDeltas write flush bodyReader + +-- | Stream Gemini deltas from OpenAI response +streamGeminiDeltas :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +streamGeminiDeltas write flush bodyReader = loop BS.empty (ToolCallState Nothing Nothing "") + where + loop acc toolState = do + chunk <- HTTP.brRead bodyReader + if BS.null chunk + then pure () + else do + let combined = acc <> chunk + lines' = BS.split (fromIntegral $ fromEnum '\n') combined + case lines' of + [] -> loop BS.empty toolState + [incomplete] -> loop incomplete toolState + _ -> do + let (completeLines, rest) = (init lines', last lines') + newToolState <- foldM (processOpenAILineToGeminiStateful write flush) toolState completeLines + loop rest newToolState + +-- ============================================================================ +-- SSE Line Processing +-- ============================================================================ + +-- | Process a single OpenAI SSE line with state tracking for tool calls +processOpenAILineToGeminiStateful :: (Builder -> IO ()) -> IO () -> ToolCallState -> BS.ByteString -> IO ToolCallState +processOpenAILineToGeminiStateful write flush toolState line + | BS.isPrefixOf "data: " line = do + let jsonText = TE.decodeUtf8 $ BS.drop 6 line + if jsonText == "[DONE]" + then pure toolState -- Gemini doesn't send [DONE] + else case eitherDecode (BL.fromStrict $ TE.encodeUtf8 jsonText) of + Right (Object openAIChunk) -> do + -- Check if this chunk contains tool_calls + let hasToolCalls = case HM.lookup "choices" openAIChunk of + Just (Array choices) | not (V.null choices) -> + case V.head choices of + Object choice -> case HM.lookup "delta" choice of + Just (Object delta) -> HM.member "tool_calls" delta + _ -> False + _ -> False + _ -> False + + -- Check if this is a finish_reason = "tool_calls" chunk with buffered state + let finishReason = case HM.lookup "choices" openAIChunk of + Just (Array choices) | not (V.null choices) -> + case V.head choices of + Object choice -> HM.lookup "finish_reason" choice + _ -> Nothing + _ -> Nothing + hasBufferedToolCall = toolCallName toolState /= Nothing + + if hasToolCalls + then do + -- Process tool call and update state + (newState, maybeGeminiChunk) <- processToolCallChunk toolState openAIChunk + case maybeGeminiChunk of + Just geminiChunk -> do + write (byteString $ BS8.pack "data: " <> BL.toStrict (encode geminiChunk) <> BS8.pack "\n\n") + flush + Nothing -> pure () + pure newState + else if finishReason == Just (String "tool_calls") && hasBufferedToolCall + then do + -- Emit buffered tool call + (newState, maybeGeminiChunk) <- processToolCallChunk toolState openAIChunk + case maybeGeminiChunk of + Just geminiChunk -> do + write (byteString $ BS8.pack "data: " <> BL.toStrict (encode geminiChunk) <> BS8.pack "\n\n") + flush + Nothing -> pure () + pure newState + else do + -- Regular text/reasoning chunk + let geminiChunk = openAIChunkToGemini openAIChunk + write (byteString $ BS8.pack "data: " <> BL.toStrict (encode geminiChunk) <> BS8.pack "\n\n") + flush + pure toolState + _ -> pure toolState + | otherwise = pure toolState + +-- ============================================================================ +-- Tool Call Processing +-- ============================================================================ + +-- | Process tool call chunk, accumulating arguments until complete +processToolCallChunk :: ToolCallState -> HM.KeyMap Value -> IO (ToolCallState, Maybe Value) +processToolCallChunk state openAIChunk = do + let choices = case HM.lookup "choices" openAIChunk of + Just (Array cs) | not (V.null cs) -> V.head cs + _ -> Object HM.empty + delta = case choices of + Object choice -> case HM.lookup "delta" choice of + Just (Object d) -> d + _ -> HM.empty + _ -> HM.empty + toolCalls = case HM.lookup "tool_calls" delta of + Just (Array tcs) | not (V.null tcs) -> Just $ V.head tcs + _ -> Nothing + finishReason = case choices of + Object choice -> HM.lookup "finish_reason" choice + _ -> Nothing + + -- Check if we should emit based on finish_reason, even without new tool_calls + case finishReason of + Just (String "tool_calls") | toolCallName state /= Nothing -> do + -- Arguments are complete, emit the buffered function call + let parsedArgs = case eitherDecode (BL.fromStrict $ TE.encodeUtf8 (toolCallArgs state)) of + Right val -> val + Left _ -> object [] + geminiChunk = object + [ "candidates" .= [object + [ "content" .= object + [ "parts" .= [object $ + [ "functionCall" .= object + ([ "name" .= n | Just n <- [toolCallName state] ] ++ + [ "args" .= parsedArgs ]) + ] ++ [ "id" .= i | Just i <- [toolCallId state] ]] + , "role" .= ("model" :: Text) + ] + , "finishReason" .= ("tool_calls" :: Text) + ]] + , "usageMetadata" .= object + [ "promptTokenCount" .= (0 :: Int) + , "candidatesTokenCount" .= (0 :: Int) + , "totalTokenCount" .= (0 :: Int) + ] + ] + -- Reset state for next tool call + pure (ToolCallState Nothing Nothing "", Just geminiChunk) + _ -> do + -- Process new tool_calls delta if present + case toolCalls of + Just (Object tc) -> do + let tcId = case HM.lookup "id" tc of + Just (String i) -> Just i + _ -> Nothing + tcFunc = case HM.lookup "function" tc of + Just (Object f) -> f + _ -> HM.empty + funcName = case HM.lookup "name" tcFunc of + Just (String n) -> Just n + _ -> Nothing + funcArgs = case HM.lookup "arguments" tcFunc of + Just (String args) -> args + _ -> "" + + -- Update state with new information + let newId = case tcId of Just i -> Just i; Nothing -> toolCallId state + newName = case funcName of Just n -> Just n; Nothing -> toolCallName state + newArgs = toolCallArgs state <> funcArgs + + -- Still accumulating, don't emit yet + pure (ToolCallState newId newName newArgs, Nothing) + _ -> pure (state, Nothing) + +-- ============================================================================ +-- Chunk Conversion +-- ============================================================================ + +-- | Convert OpenAI chunk to Gemini chunk +openAIChunkToGemini :: HM.KeyMap Value -> Value +openAIChunkToGemini openAIChunk = + let candidates = case HM.lookup "choices" openAIChunk of + Just (Array choices) | not (V.null choices) -> + V.toList $ V.map convertChoice choices + _ -> [] + in object + [ "candidates" .= candidates + , "usageMetadata" .= object + [ "promptTokenCount" .= (0 :: Int) + , "candidatesTokenCount" .= (0 :: Int) + , "totalTokenCount" .= (0 :: Int) + ] + ] + where + convertChoice (Object choice) = + let delta = case HM.lookup "delta" choice of + Just (Object d) -> d + _ -> HM.empty + finishReason = HM.lookup "finish_reason" choice + -- Extract text from either content or reasoning + textParts = case (HM.lookup "content" delta, HM.lookup "reasoning" delta) of + (Just (String txt), _) -> [object ["text" .= txt]] + (_, Just (String txt)) -> [object ["text" .= txt]] + _ -> [] + -- Extract tool calls and convert to Gemini functionCall format + toolCallParts = case HM.lookup "tool_calls" delta of + Just (Array toolCalls) -> V.toList $ V.map convertToolCall toolCalls + _ -> [] + parts = textParts ++ toolCallParts + in object $ + [ "content" .= object + [ "parts" .= parts + , "role" .= ("model" :: Text) + ] + ] ++ (case finishReason of + Just r -> ["finishReason" .= r] + Nothing -> []) + convertChoice _ = object [] + + -- Convert OpenAI tool_call to Gemini functionCall part + convertToolCall (Object tc) = + let tcId = HM.lookup "id" tc + tcFunc = case HM.lookup "function" tc of + Just (Object f) -> f + _ -> HM.empty + funcName = HM.lookup "name" tcFunc + funcArgs = HM.lookup "arguments" tcFunc + in object $ + [ "functionCall" .= object + ([ "name" .= fname | Just fname <- [funcName] ] ++ + [ "args" .= parseArgs args | Just args <- [funcArgs] ]) + ] ++ [ "id" .= tid | Just tid <- [tcId] ] + convertToolCall _ = object [] + + -- Parse function arguments string to JSON object + parseArgs (String argsStr) = case eitherDecode (BL.fromStrict $ TE.encodeUtf8 argsStr) of + Right val -> val + Left _ -> object [] + parseArgs other = other diff --git a/src/Louter/Protocol/GeminiStreamingJsonArray.hs b/src/Louter/Protocol/GeminiStreamingJsonArray.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Protocol/GeminiStreamingJsonArray.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Gemini Streaming Protocol Handler - JSON Array Format +-- Converts OpenAI SSE stream to Gemini JSON array format (alt=json) +-- +-- Gemini supports two streaming formats: +-- 1. SSE (alt=sse): "data: {...}\n\ndata: {...}\n\n" - Handled by GeminiStreaming +-- 2. JSON Array (alt=json): "[{...}, {...}]" - Handled by this module +-- +-- JSON Array Format Semantics: +-- - Stream begins with "[" +-- - Each response chunk is emitted as a JSON object +-- - Elements are separated by "," +-- - Stream ends with "]" +-- - Example: [{"candidates":[...]},{"candidates":[...]},{"candidates":[...]}] +-- +-- The stream is INCREMENTAL - elements appear one at a time, not as a complete array. +module Louter.Protocol.GeminiStreamingJsonArray + ( convertOpenAIToGeminiJsonArray + ) where + +import Control.Monad (foldM) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value(..), Object, encode, eitherDecode, object, (.=)) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Builder (Builder, byteString, lazyByteString, char8) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Client as HTTP + +import Louter.Protocol.GeminiStreaming (ToolCallState(..), processOpenAILineToGeminiStateful, openAIChunkToGemini) + +-- | Convert OpenAI SSE stream to Gemini JSON array format +-- Format: [ +-- {"candidates":[...]}, +-- {"candidates":[...]}, +-- ... +-- ] +convertOpenAIToGeminiJsonArray :: (Builder -> IO ()) -> IO () -> HTTP.BodyReader -> IO () +convertOpenAIToGeminiJsonArray write flush bodyReader = do + -- Track if we've emitted the opening "[" + isFirstRef <- newIORef True + toolStateRef <- newIORef (ToolCallState Nothing Nothing "") + + -- Emit opening bracket + write (char8 '[') + flush + + -- Process all SSE events and emit incrementally + let loop acc = do + chunk <- HTTP.brRead bodyReader + if BS.null chunk + then do + -- End of stream - emit closing bracket + write (char8 ']') + flush + else do + let combined = acc <> chunk + lines' = BS.split (fromIntegral $ fromEnum '\n') combined + case lines' of + [] -> loop BS.empty + [incomplete] -> loop incomplete + _ -> do + let (completeLines, rest) = (init lines', last lines') + -- Process each line and emit chunks incrementally + mapM_ (processLineAndEmit isFirstRef toolStateRef write flush) completeLines + loop rest + + loop BS.empty + +-- | Process a single SSE line and emit Gemini chunk incrementally +-- Emits: "," separator (if not first) followed by the JSON object and newline +processLineAndEmit :: IORef Bool -> IORef ToolCallState -> (Builder -> IO ()) -> IO () -> BS.ByteString -> IO () +processLineAndEmit isFirstRef toolStateRef write flush line + | BS.isPrefixOf "data: " line = do + let jsonText = TE.decodeUtf8 $ BS.drop 6 line + if jsonText == "[DONE]" + then pure () -- Skip [DONE] marker + else case eitherDecode (BL.fromStrict $ TE.encodeUtf8 jsonText) of + Right (Object openAIChunk) -> do + -- Convert OpenAI chunk to Gemini format + let geminiChunk = openAIChunkToGemini openAIChunk + + -- Emit comma separator if not first element + isFirst <- readIORef isFirstRef + if isFirst + then writeIORef isFirstRef False + else do + write (char8 ',') + write (char8 '\n') + + -- Emit the Gemini chunk as JSON followed by newline + write (lazyByteString $ encode geminiChunk) + write (char8 '\n') + flush + _ -> pure () + | otherwise = pure () diff --git a/src/Louter/Streaming/XMLStreamProcessor.hs b/src/Louter/Streaming/XMLStreamProcessor.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Streaming/XMLStreamProcessor.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | XML Stream Processor for Qwen3-Coder streaming responses +-- +-- Implements state machine for parsing XML tool calls during streaming: +-- 1. NormalText mode: Emit text chunks normally +-- 2. Detect → Switch to InToolCall mode +-- 3. InToolCall mode: Buffer all content (do NOT emit) +-- 4. Detect → Parse XML → Emit ToolCall event → Back to NormalText +-- +-- This ensures XML tags are not sent to frontend and tool calls are complete. +module Louter.Streaming.XMLStreamProcessor + ( processXMLStream + , processXMLChunk + , finalizeXMLState + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM +import Data.Aeson (Value) +import Louter.Types.ToolFormat + ( XMLMode(..) + , XMLToolCallState(..) + ) +import Louter.Streaming.XMLToolCallParser + ( parseXMLToolCalls + , convertToToolCall + ) +import Louter.Types.Streaming + ( StreamEvent(..) + , DeltaType(..) + , ToolCall(..) + ) + +-- | Process a single text chunk from SSE stream +-- Returns updated state and list of events to emit to frontend +processXMLStream :: XMLToolCallState -> Text -> (XMLToolCallState, [StreamEvent]) +processXMLStream state chunk = + let + -- Detect mode transitions based on XML tags in chunk + (newMode, bufferUpdate, events) = case xmlMode state of + NormalText -> + if "" `T.isInfixOf` chunk + then handleToolCallStart state chunk + else handleNormalText state chunk + + InToolCall -> + if "" `T.isInfixOf` chunk + then handleToolCallEnd state chunk + else handleToolCallBuffer state chunk + + newState = state + { xmlMode = newMode + , xmlBuffer = bufferUpdate + } + in (newState, events) + +-- | Handle text chunk in NormalText mode +-- Check if appears, switch mode if found +handleNormalText :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent]) +handleNormalText state chunk = + case T.breakOn "" chunk of + (before, rest) | T.null rest -> + -- No found, emit entire chunk as text + ( NormalText + , "" + , if T.null before then [] else [StreamContent before] + ) + (before, rest) -> + -- Found , emit text before it, start buffering + let afterTag = T.drop (T.length "") rest + in ( InToolCall + , afterTag -- Start buffering from after opening tag + , if T.null before then [] else [StreamContent before] + ) + +-- | Handle text chunk while in InToolCall mode (buffering) +-- Accumulate all content until closing tag +handleToolCallBuffer :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent]) +handleToolCallBuffer state chunk = + let newBuffer = xmlBuffer state <> chunk + in ( InToolCall + , newBuffer + , [] -- Do NOT emit anything while buffering + ) + +-- | Handle text chunk containing (end of tool call) +-- Parse accumulated XML and emit ToolCall event +handleToolCallEnd :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent]) +handleToolCallEnd state chunk = + case T.breakOn "" chunk of + (before, rest) | T.null rest -> + -- Should not happen (we checked exists) + ( InToolCall + , xmlBuffer state <> chunk + , [] + ) + (before, rest) -> + -- Complete the buffer with content before closing tag + let completeXML = xmlBuffer state <> before + afterTag = T.drop (T.length "") rest + + -- Parse the complete XML block + parsedCalls = parseXMLToolCalls ("" <> completeXML <> "") + + -- Convert to ToolCall events + toolCallEvents = case parsedCalls of + [] -> [] -- No valid tool calls found + calls -> + let existingCount = length (xmlExtractedCalls state) + toolCalls = zipWith convertToToolCall [existingCount..] calls + in map StreamToolCall toolCalls + + -- Emit any text after closing tag (if in NormalText now) + textEvent = if T.null afterTag then [] else [StreamContent afterTag] + + -- Update extracted calls list + newExtractedCalls = xmlExtractedCalls state ++ parsedCalls + + in ( NormalText -- Back to normal mode + , "" -- Clear buffer + , toolCallEvents ++ textEvent + ) + +-- | Handle transition when starts +handleToolCallStart :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent]) +handleToolCallStart state chunk = + case T.breakOn "" chunk of + (before, rest) -> + let afterTag = T.drop (T.length "") rest + textEvent = if T.null before then [] else [StreamContent before] + in ( InToolCall + , afterTag + , textEvent + ) + +-- | Process a DeltaType from OpenAI backend +-- This integrates with existing streaming pipeline +processXMLChunk :: XMLToolCallState -> DeltaType -> (XMLToolCallState, [StreamEvent]) +processXMLChunk state deltaType = + case deltaType of + -- Only process ContentDelta - other types pass through + ContentDelta text -> + processXMLStream state text + + -- Reasoning content also needs XML processing (Qwen may put XML here) + ReasoningDelta text -> + let (newState, events) = processXMLStream state text + -- Convert StreamContent back to StreamReasoning + reasoningEvents = map convertToReasoning events + in (newState, reasoningEvents) + + -- Pass through all other delta types unchanged + RoleDelta _role -> + -- Role deltas don't emit events in current StreamEvent type + (state, []) + + ToolCallDelta _fragment -> + -- This shouldn't happen with XML backends, but handle it + (state, []) -- Tool calls come from XML parsing, not deltas + + FinishDelta reason -> + (state, [StreamFinish reason]) + + EmptyDelta -> + (state, []) + +-- | Convert StreamContent to StreamReasoning +convertToReasoning :: StreamEvent -> StreamEvent +convertToReasoning (StreamContent text) = StreamReasoning text +convertToReasoning other = other + +-- | Finalize XML state at end of stream +-- Emit any remaining buffered content as incomplete tool call warning +finalizeXMLState :: XMLToolCallState -> [StreamEvent] +finalizeXMLState state = + case xmlMode state of + NormalText -> [] -- Clean finish + InToolCall -> + -- Incomplete tool call - emit warning or error + if T.null (xmlBuffer state) + then [] + else [StreamError $ "Incomplete XML tool call: " <> xmlBuffer state] diff --git a/src/Louter/Streaming/XMLToolCallParser.hs b/src/Louter/Streaming/XMLToolCallParser.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Streaming/XMLToolCallParser.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | XML Tool Call Parser for Qwen3-Coder format +-- +-- Parses XML-formatted tool calls like: +-- @ +-- +-- +-- test.txt +-- Hello World! +-- +-- +-- @ +-- +-- Converts to OpenAI ToolCall format for uniform handling +module Louter.Streaming.XMLToolCallParser + ( parseXMLToolCalls + , extractFunctionName + , extractParameters + , stripXMLToolCallTags + , convertToToolCall + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.HashMap.Strict as HM +import Data.Aeson (Value(..), decode, object, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Text.Regex.TDFA ((=~)) +import Data.Maybe (mapMaybe, fromMaybe) +import Louter.Types.Streaming (ToolCall(..)) + +-- | Parse all XML tool calls from text content +-- Returns list of (function_name, parameters_map) +parseXMLToolCalls :: Text -> [(Text, HM.HashMap Text Value)] +parseXMLToolCalls content = + let toolCallBlocks = extractToolCallBlocks content + in mapMaybe parseToolCallBlock toolCallBlocks + +-- | Extract all ... blocks from text +-- Uses manual splitting to avoid regex complexity with nested tags +extractToolCallBlocks :: Text -> [Text] +extractToolCallBlocks content = extractBlocks content [] + where + extractBlocks :: Text -> [Text] -> [Text] + extractBlocks text acc + | T.null text = reverse acc + | otherwise = + case T.breakOn "" text of + (_, rest) | T.null rest -> reverse acc + (_, rest) -> + let afterOpen = T.drop (T.length "") rest + in case T.breakOn "" afterOpen of + (block, afterClose) | T.null afterClose -> reverse acc + (block, afterClose) -> + let remaining = T.drop (T.length "") afterClose + in extractBlocks remaining (block : acc) + +-- | Parse a single tool call block +parseToolCallBlock :: Text -> Maybe (Text, HM.HashMap Text Value) +parseToolCallBlock block = do + functionName <- extractFunctionName block + let parameters = extractParameters block + return (functionName, parameters) + +-- | Extract function name from tag +extractFunctionName :: Text -> Maybe Text +extractFunctionName block = + let pattern = "]+)>" :: String + matches = T.unpack block =~ pattern :: [[String]] + in case matches of + ((_ : name : _) : _) -> Just (T.pack name) + _ -> Nothing + +-- | Extract all parameters from value tags +extractParameters :: Text -> HM.HashMap Text Value +extractParameters block = + let pattern = "]+)>([^<]*)" :: String + matches = T.unpack block =~ pattern :: [[String]] + pairs = [(T.pack key, parseValue (T.pack value)) | (_ : key : value : _) <- matches] + in HM.fromList pairs + +-- | Parse parameter value with type detection +-- Attempts to parse as JSON first (for numbers, booleans, objects) +-- Falls back to string if JSON parsing fails +parseValue :: Text -> Value +parseValue text = + let trimmed = T.strip text + -- Try parsing as JSON + jsonResult = decode (BL.fromStrict $ TE.encodeUtf8 trimmed) :: Maybe Value + in case jsonResult of + Just val -> val + Nothing -> String trimmed -- Fallback to string + +-- | Remove all ... tags from text +-- Keeps surrounding text content intact +stripXMLToolCallTags :: Text -> Text +stripXMLToolCallTags content = T.strip $ removeBlocks content + where + removeBlocks :: Text -> Text + removeBlocks text = + case T.breakOn "" text of + (before, rest) | T.null rest -> before + (before, rest) -> + case T.breakOn "" (T.drop (T.length "") rest) of + (_, afterClose) | T.null afterClose -> before + (_, afterClose) -> + let remaining = T.drop (T.length "") afterClose + in before <> " " <> removeBlocks remaining + +-- | Convert parsed XML tool call to ToolCall format +-- Uses the Louter.Types.Streaming.ToolCall structure +convertToToolCall :: Int -> (Text, HM.HashMap Text Value) -> ToolCall +convertToToolCall index (functionName, parameters) = + ToolCall + { toolCallId = "call_" <> T.pack (show index) + , toolCallName = functionName + , toolCallArguments = Object $ KM.fromHashMapText parameters + } diff --git a/src/Louter/Types.hs b/src/Louter/Types.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Types.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Core types for the Louter library +module Louter.Types + ( -- * Re-exports + module Louter.Types.Request + , module Louter.Types.Response + , module Louter.Types.Streaming + ) where + +import Louter.Types.Request +import Louter.Types.Response +import Louter.Types.Streaming diff --git a/src/Louter/Types/Request.hs b/src/Louter/Types/Request.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Types/Request.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Request types (Protocol-Agnostic Internal Representation) +-- All protocol-specific requests convert TO this format +module Louter.Types.Request + ( ChatRequest(..) + , Message(..) + , MessageRole(..) + , ContentPart(..) + , Tool(..) + , ToolChoice(..) + , defaultChatRequest + ) where + +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.=), object) +import Data.Aeson.KeyMap (lookup) +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Prelude hiding (lookup) + +-- | Protocol-agnostic chat request (Internal Representation) +-- Inspired by OpenAI's format but owned by Louter +data ChatRequest = ChatRequest + { reqModel :: !Text -- ^ Model name (e.g., "gpt-4", "gemini-pro") + , reqMessages :: ![Message] -- ^ Conversation messages + , reqTools :: ![Tool] -- ^ Available tools/functions + , reqToolChoice :: !ToolChoice -- ^ How to choose tools + , reqTemperature :: !(Maybe Double) -- ^ Sampling temperature + , reqMaxTokens :: !(Maybe Int) -- ^ Maximum tokens to generate + , reqStream :: !Bool -- ^ Whether to stream response + } deriving (Show, Eq, Generic) + +instance FromJSON ChatRequest +instance ToJSON ChatRequest + +-- | Default request with sensible defaults +defaultChatRequest :: Text -> [Message] -> ChatRequest +defaultChatRequest model msgs = ChatRequest + { reqModel = model + , reqMessages = msgs + , reqTools = [] + , reqToolChoice = ToolChoiceAuto + , reqTemperature = Nothing + , reqMaxTokens = Nothing + , reqStream = False + } + +-- | Content part (text, image, etc.) +data ContentPart + = TextPart !Text + | ImagePart + { imageMediaType :: !Text -- ^ MIME type (e.g., "image/png") + , imageData :: !Text -- ^ Base64-encoded image data + } + deriving (Show, Eq, Generic) + +instance ToJSON ContentPart where + toJSON (TextPart txt) = object + [ "type" .= ("text" :: Text) + , "text" .= txt + ] + toJSON (ImagePart mediaType dataB64) = object + [ "type" .= ("image_url" :: Text) + , "image_url" .= object + [ "url" .= ("data:" <> mediaType <> ";base64," <> dataB64) + ] + ] + +instance FromJSON ContentPart where + parseJSON (Object obj) = case lookup "type" obj of + Just (String "text") -> case lookup "text" obj of + Just (String txt) -> pure $ TextPart txt + _ -> fail "Missing text field" + Just (String "image_url") -> case lookup "image_url" obj of + Just (Object imgObj) -> case lookup "url" imgObj of + Just (String url) -> pure $ TextPart url -- Simplified for now + _ -> fail "Missing url in image_url" + _ -> fail "Missing image_url object" + _ -> fail "Unknown content part type" + parseJSON _ = fail "Expected object for ContentPart" + +-- | Message in a conversation +data Message = Message + { msgRole :: !MessageRole + , msgContent :: ![ContentPart] -- ^ Changed from Text to [ContentPart] + } deriving (Show, Eq, Generic) + +instance FromJSON Message where + parseJSON (Object obj) = do + role <- case lookup "role" obj of + Just r -> parseJSON r + Nothing -> fail "Missing role" + content <- case lookup "content" obj of + -- Support both string and array format + Just (String txt) -> pure [TextPart txt] + Just (Array arr) -> mapM parseJSON (V.toList arr) + _ -> fail "Missing or invalid content" + pure $ Message role content + parseJSON _ = fail "Expected object for Message" + +instance ToJSON Message where + toJSON (Message role content) = object + [ "role" .= role + , "content" .= case content of + [TextPart txt] -> String txt -- Simplify single text to string + parts -> toJSON parts -- Multiple parts as array + ] + +-- | Message role +data MessageRole + = RoleSystem + | RoleUser + | RoleAssistant + | RoleTool + deriving (Show, Eq) + +instance FromJSON MessageRole where + parseJSON (String "system") = pure RoleSystem + parseJSON (String "user") = pure RoleUser + parseJSON (String "assistant") = pure RoleAssistant + parseJSON (String "tool") = pure RoleTool + parseJSON _ = fail "Invalid role" + +instance ToJSON MessageRole where + toJSON role = case role of + RoleSystem -> String "system" + RoleUser -> String "user" + RoleAssistant -> String "assistant" + RoleTool -> String "tool" + +-- | Tool/Function definition +data Tool = Tool + { toolName :: !Text -- ^ Function name + , toolDescription :: !(Maybe Text) -- ^ Description + , toolParameters :: !Value -- ^ JSON Schema for parameters + } deriving (Show, Eq, Generic) + +instance FromJSON Tool + +instance ToJSON Tool where + toJSON t = object + [ "type" .= ("function" :: Text) + , "function" .= object + [ "name" .= toolName t + , "description" .= toolDescription t + , "parameters" .= toolParameters t + ] + ] + +-- | How to choose which tool to call +data ToolChoice + = ToolChoiceAuto -- ^ Let model decide + | ToolChoiceNone -- ^ Don't call any tools + | ToolChoiceRequired -- ^ Must call at least one tool + | ToolChoiceSpecific !Text -- ^ Call specific tool + deriving (Show, Eq) + +instance FromJSON ToolChoice where + parseJSON (String "auto") = pure ToolChoiceAuto + parseJSON (String "none") = pure ToolChoiceNone + parseJSON (String "required") = pure ToolChoiceRequired + parseJSON (Object obj) = case lookup "type" obj of + Just (String "function") -> case lookup "function" obj of + Just (Object fn) -> case lookup "name" fn of + Just (String name) -> pure $ ToolChoiceSpecific name + _ -> fail "Missing name in function" + _ -> fail "Missing function object" + _ -> fail "Unknown tool choice type" + parseJSON _ = fail "Invalid tool choice" + +instance ToJSON ToolChoice where + toJSON choice = case choice of + ToolChoiceAuto -> String "auto" + ToolChoiceNone -> String "none" + ToolChoiceRequired -> String "required" + ToolChoiceSpecific name -> object ["type" .= ("function" :: Text), "function" .= object ["name" .= name]] diff --git a/src/Louter/Types/Response.hs b/src/Louter/Types/Response.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Types/Response.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Response types (Protocol-Agnostic Internal Representation) +-- All protocol-specific responses convert FROM this format +module Louter.Types.Response + ( ChatResponse(..) + , Choice(..) + , FinishReason(..) + , Usage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | Protocol-agnostic chat response +data ChatResponse = ChatResponse + { respId :: !Text -- ^ Response ID + , respModel :: !Text -- ^ Model used + , respChoices :: ![Choice] -- ^ Response choices + , respUsage :: !(Maybe Usage) -- ^ Token usage + } deriving (Show, Eq, Generic) + +instance FromJSON ChatResponse +instance ToJSON ChatResponse + +-- | A single response choice +data Choice = Choice + { choiceIndex :: !Int + , choiceMessage :: !Text -- ^ Response text (or empty if tool call) + , choiceFinishReason :: !(Maybe FinishReason) + } deriving (Show, Eq, Generic) + +instance FromJSON Choice +instance ToJSON Choice + +-- | Why the model stopped generating +data FinishReason + = FinishStop -- ^ Natural stop + | FinishLength -- ^ Hit max tokens + | FinishToolCalls -- ^ Called a tool + | FinishContentFilter -- ^ Content filtered + deriving (Show, Eq, Generic) + +instance FromJSON FinishReason +instance ToJSON FinishReason + +-- | Token usage statistics +data Usage = Usage + { usagePromptTokens :: !Int + , usageCompletionTokens :: !Int + , usageTotalTokens :: !Int + } deriving (Show, Eq, Generic) + +instance FromJSON Usage +instance ToJSON Usage diff --git a/src/Louter/Types/Streaming.hs b/src/Louter/Types/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Types/Streaming.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Streaming-specific types for SSE parsing and delta classification +-- These types are protocol-agnostic and form the Internal Representation (IR) +module Louter.Types.Streaming + ( -- * SSE Chunk Types + SSEChunk(..) + -- * Delta Types (Protocol-Agnostic IR) + , DeltaType(..) + , ToolCallFragment(..) + -- * Stream State + , StreamState(..) + , ToolCallState(..) + , emptyStreamState + -- * Output Events + , StreamEvent(..) + , ToolCall(..) + ) where + +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text.Lazy.Builder as TB +import GHC.Generics (Generic) + +-- | Server-Sent Event chunk (protocol-agnostic) +-- All protocols (OpenAI, Gemini, Anthropic) parse to this +data SSEChunk + = SSEData + { sseData :: !Text -- ^ JSON payload after "data: " + , sseEvent :: Maybe Text -- ^ Optional event type + } + | SSEDone -- ^ [DONE] marker or end-of-stream + deriving (Show, Eq, Generic) + +-- | Classification of delta content types (Internal Representation) +-- Different types require different buffering strategies +data DeltaType + = ReasoningDelta !Text -- ^ Thinking tokens (stream immediately) + | ContentDelta !Text -- ^ Response text (stream immediately) + | ToolCallDelta !ToolCallFragment -- ^ Function call (buffer until complete) + | RoleDelta !Text -- ^ Role assignment (pass through) + | FinishDelta !Text -- ^ finish_reason (pass through) + | EmptyDelta -- ^ Empty delta {} + deriving (Show, Eq, Generic) + +-- | Incremental fragment of a tool call +-- Represents a piece of a streaming function call +data ToolCallFragment = ToolCallFragment + { tcfIndex :: !Int -- ^ Tool call index (for parallel calls) + , tcfId :: !(Maybe Text) -- ^ Tool call ID (only in first chunk) + , tcfName :: !(Maybe Text) -- ^ Function name (only in first chunk) + , tcfArguments :: !(Maybe Text) -- ^ JSON fragment + } deriving (Show, Eq, Generic) + +instance FromJSON ToolCallFragment +instance ToJSON ToolCallFragment + +-- | State machine for streaming processing +-- Tracks ongoing tool calls and buffers their arguments +data StreamState = StreamState + { ssToolCalls :: !(Map Int ToolCallState) -- ^ Active tool calls by index + , ssMessageId :: !Text -- ^ Current message ID + } deriving (Show, Eq, Generic) + +-- | State of a single tool call being assembled +data ToolCallState = ToolCallState + { tcsId :: !Text -- ^ Tool call ID + , tcsName :: !Text -- ^ Function name + , tcsArguments :: !TB.Builder -- ^ Accumulated JSON arguments + , tcsComplete :: !Bool -- ^ Whether JSON is complete + } deriving (Show, Generic) + +-- Manual Eq instance since Builder doesn't have Eq +instance Eq ToolCallState where + a == b = tcsId a == tcsId b + && tcsName a == tcsName b + && tcsComplete a == tcsComplete b + +-- | Create empty initial state +emptyStreamState :: Text -> StreamState +emptyStreamState msgId = StreamState + { ssToolCalls = Map.empty + , ssMessageId = msgId + } + +-- | High-level events emitted to the user (Protocol-Agnostic) +-- These are what applications receive, regardless of backend protocol +data StreamEvent + = StreamContent !Text -- ^ Text content chunk + | StreamReasoning !Text -- ^ Reasoning/thinking chunk + | StreamToolCall !ToolCall -- ^ Complete tool call (buffered) + | StreamFinish !Text -- ^ Stream finished with reason + | StreamError !Text -- ^ Error occurred + deriving (Show, Eq, Generic) + +-- | Complete tool call with validated JSON arguments +data ToolCall = ToolCall + { toolCallId :: !Text + , toolCallName :: !Text + , toolCallArguments :: !Value -- ^ Parsed JSON arguments + } deriving (Show, Eq, Generic) + +instance FromJSON ToolCall +instance ToJSON ToolCall diff --git a/src/Louter/Types/ToolFormat.hs b/src/Louter/Types/ToolFormat.hs new file mode 100644 --- /dev/null +++ b/src/Louter/Types/ToolFormat.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tool format types for backend configuration +-- Supports both JSON (OpenAI/Anthropic/Gemini) and XML (Qwen) tool calling formats +module Louter.Types.ToolFormat + ( ToolFormat(..) + , XMLMode(..) + , XMLToolCallState(..) + , initialXMLState + ) where + +import Data.Text (Text) +import qualified Data.HashMap.Strict as HM +import Data.Aeson (Value) + +-- | Tool call format supported by backend +data ToolFormat + = ToolFormatJSON -- ^ Standard OpenAI JSON format (default) + | ToolFormatXML -- ^ Qwen3-Coder XML format + deriving (Show, Eq) + +-- | XML parsing state machine mode +data XMLMode + = NormalText -- ^ Emitting regular text chunks + | InToolCall -- ^ Buffering XML content inside tags + deriving (Show, Eq) + +-- | State for XML tool call streaming parser +data XMLToolCallState = XMLToolCallState + { xmlMode :: XMLMode + -- ^ Current parsing mode (NormalText or InToolCall) + , xmlBuffer :: Text + -- ^ Accumulated XML content (only used in InToolCall mode) + , xmlAccumulatedText :: Text + -- ^ Regular text content accumulated (outside tool calls) + , xmlExtractedCalls :: [(Text, HM.HashMap Text Value)] + -- ^ Completed tool calls: (function_name, parameters) + } deriving (Show, Eq) + +-- | Initial XML parsing state +initialXMLState :: XMLToolCallState +initialXMLState = XMLToolCallState + { xmlMode = NormalText + , xmlBuffer = "" + , xmlAccumulatedText = "" + , xmlExtractedCalls = [] + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Test suite for louter +module Main (main) where + +import Test.Hspec +import Test.QuickCheck +import qualified Data.HashMap.Strict as HM +import Data.Aeson (Value(..)) +import Data.Text (Text) +import qualified Data.Text as T + +import Louter.Streaming.XMLToolCallParser +import Louter.Types.Streaming (ToolCall(..)) + +main :: IO () +main = hspec $ do + describe "XML Tool Call Parser" $ do + describe "parseXMLToolCalls" $ do + it "parses a simple XML tool call" $ do + let xmlInput = "test.txtHello World!" + let result = parseXMLToolCalls xmlInput + length result `shouldBe` 1 + case result of + [(name, params)] -> do + name `shouldBe` "WriteFile" + HM.lookup "file_path" params `shouldBe` Just (String "test.txt") + HM.lookup "content" params `shouldBe` Just (String "Hello World!") + _ -> expectationFailure "Should parse exactly one tool call" + + it "parses multiple tool calls" $ do + let xmlInput = "/tmp/test\ + \/tmp/test/file.txt" + let result = parseXMLToolCalls xmlInput + length result `shouldBe` 2 + + it "handles empty input" $ do + let result = parseXMLToolCalls "" + result `shouldBe` [] + + it "handles text without tool calls" $ do + let result = parseXMLToolCalls "Just some regular text" + result `shouldBe` [] + + it "preserves number types" $ do + let xmlInput = "42" + let result = parseXMLToolCalls xmlInput + case result of + [(_, params)] -> + HM.lookup "count" params `shouldBe` Just (Number 42) + _ -> expectationFailure "Should parse tool call with number" + + it "preserves boolean types" $ do + let xmlInput = "true" + let result = parseXMLToolCalls xmlInput + case result of + [(_, params)] -> + HM.lookup "enabled" params `shouldBe` Just (Bool True) + _ -> expectationFailure "Should parse tool call with boolean" + + describe "extractFunctionName" $ do + it "extracts function name from XML" $ do + extractFunctionName "" `shouldBe` Just "WriteFile" + + it "returns Nothing for invalid format" $ do + extractFunctionName "no function here" `shouldBe` Nothing + + describe "stripXMLToolCallTags" $ do + it "removes XML tool call tags from text" $ do + let input = "Before After" + let result = stripXMLToolCallTags input + -- Should contain "Before" and "After" with XML removed + T.isInfixOf "Before" result `shouldBe` True + T.isInfixOf "After" result `shouldBe` True + T.isInfixOf "" result `shouldBe` False + + it "keeps text without tool calls unchanged" $ do + let input = "No tool calls here" + stripXMLToolCallTags input `shouldBe` input + + it "handles multiple tool calls" $ do + let input = "A ... B ... C" + let result = stripXMLToolCallTags input + -- Should contain A, B, C with XML removed + T.isInfixOf "A" result `shouldBe` True + T.isInfixOf "B" result `shouldBe` True + T.isInfixOf "C" result `shouldBe` True + T.isInfixOf "" result `shouldBe` False + + describe "convertToToolCall" $ do + it "converts parsed XML to ToolCall structure" $ do + let params = HM.fromList [("file_path", String "test.txt"), ("content", String "data")] + let toolCall = convertToToolCall 0 ("WriteFile", params) + toolCallId toolCall `shouldBe` "call_0" + toolCallName toolCall `shouldBe` "WriteFile" + + it "generates unique IDs for multiple tool calls" $ do + let params1 = HM.fromList [("path", String "/tmp")] + let params2 = HM.fromList [("name", String "file.txt")] + let tc1 = convertToToolCall 0 ("Func1", params1) + let tc2 = convertToToolCall 1 ("Func2", params2) + toolCallId tc1 `shouldBe` "call_0" + toolCallId tc2 `shouldBe` "call_1"