louter (empty) → 0.1.0.0
raw patch · 24 files changed
+4738/−0 lines, 24 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, conduit, conduit-extra, containers, hspec, http-client, http-client-tls, http-types, louter, mtl, optparse-applicative, random, regex-tdfa, scientific, text, transformers, unordered-containers, vector, wai, warp, yaml
Files
- LICENSE +21/−0
- README.md +361/−0
- app/CLI.hs +322/−0
- app/Main.hs +1129/−0
- louter.cabal +124/−0
- src/Louter/Backend/OpenAIToAnthropic.hs +164/−0
- src/Louter/Backend/OpenAIToGemini.hs +161/−0
- src/Louter/Client.hs +334/−0
- src/Louter/Client/Anthropic.hs +18/−0
- src/Louter/Client/Gemini.hs +18/−0
- src/Louter/Client/OpenAI.hs +24/−0
- src/Louter/Protocol/AnthropicConverter.hs +307/−0
- src/Louter/Protocol/AnthropicStreaming.hs +331/−0
- src/Louter/Protocol/GeminiConverter.hs +237/−0
- src/Louter/Protocol/GeminiStreaming.hs +271/−0
- src/Louter/Protocol/GeminiStreamingJsonArray.hs +103/−0
- src/Louter/Streaming/XMLStreamProcessor.hs +184/−0
- src/Louter/Streaming/XMLToolCallParser.hs +123/−0
- src/Louter/Types.hs +14/−0
- src/Louter/Types/Request.hs +178/−0
- src/Louter/Types/Response.hs +57/−0
- src/Louter/Types/Streaming.hs +107/−0
- src/Louter/Types/ToolFormat.hs +47/−0
- test/Spec.hs +103/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <<EOF+backends:+ llama-server:+ type: openai+ url: http://localhost:11211+ requires_auth: false+ model_mapping:+ gpt-4: qwen/qwen2.5-vl-7b+EOF++# Run+cabal run louter-server -- --config config.yaml --port 9000+```++Now send OpenAI/Anthropic/Gemini requests to `localhost:9000`.++**Test it:**+```bash+curl http://localhost:9000/v1/chat/completions \+ -H "Content-Type: application/json" \+ -d '{"model": "gpt-4", "messages": [{"role": "user", "content": "Hello!"}]}'+```++### As a Haskell Library++**Add to your project:**+```yaml+# package.yaml+dependencies:+ - louter+ - text+ - aeson+```++**Basic usage:**+```haskell+import Louter.Client+import Louter.Client.OpenAI (llamaServerClient)++main = do+ client <- llamaServerClient "http://localhost:11211"+ response <- chatCompletion client $+ defaultChatRequest "gpt-4" [Message RoleUser "Hello!"]+ print response+```++**Streaming:**+```haskell+import Louter.Client+import Louter.Types.Streaming+import System.IO (hFlush, stdout)++main = do+ client <- llamaServerClient "http://localhost:11211"+ let request = (defaultChatRequest "gpt-4"+ [Message RoleUser "Write a haiku"]) { reqStream = True }++ streamChatWithCallback client request $ \event -> 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.
+ app/CLI.hs view
@@ -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 []
+ app/Main.hs view
@@ -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+ ])
+ louter.cabal view
@@ -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
+ src/Louter/Backend/OpenAIToAnthropic.hs view
@@ -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
+ src/Louter/Backend/OpenAIToGemini.hs view
@@ -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
+ src/Louter/Client.hs view
@@ -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]
+ src/Louter/Client/Anthropic.hs view
@@ -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
+ src/Louter/Client/Gemini.hs view
@@ -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
+ src/Louter/Client/OpenAI.hs view
@@ -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
+ src/Louter/Protocol/AnthropicConverter.hs view
@@ -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 []
+ src/Louter/Protocol/AnthropicStreaming.hs view
@@ -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 }
+ src/Louter/Protocol/GeminiConverter.hs view
@@ -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 []
+ src/Louter/Protocol/GeminiStreaming.hs view
@@ -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
+ src/Louter/Protocol/GeminiStreamingJsonArray.hs view
@@ -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 ()
+ src/Louter/Streaming/XMLStreamProcessor.hs view
@@ -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 <tool_call> → Switch to InToolCall mode+-- 3. InToolCall mode: Buffer all content (do NOT emit)+-- 4. Detect </tool_call> → 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 "<tool_call>" `T.isInfixOf` chunk+ then handleToolCallStart state chunk+ else handleNormalText state chunk++ InToolCall ->+ if "</tool_call>" `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 <tool_call> appears, switch mode if found+handleNormalText :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent])+handleNormalText state chunk =+ case T.breakOn "<tool_call>" chunk of+ (before, rest) | T.null rest ->+ -- No <tool_call> found, emit entire chunk as text+ ( NormalText+ , ""+ , if T.null before then [] else [StreamContent before]+ )+ (before, rest) ->+ -- Found <tool_call>, emit text before it, start buffering+ let afterTag = T.drop (T.length "<tool_call>") 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 </tool_call> (end of tool call)+-- Parse accumulated XML and emit ToolCall event+handleToolCallEnd :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent])+handleToolCallEnd state chunk =+ case T.breakOn "</tool_call>" chunk of+ (before, rest) | T.null rest ->+ -- Should not happen (we checked </tool_call> 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 "</tool_call>") rest++ -- Parse the complete XML block+ parsedCalls = parseXMLToolCalls ("<tool_call>" <> completeXML <> "</tool_call>")++ -- 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 <tool_call> starts+handleToolCallStart :: XMLToolCallState -> Text -> (XMLMode, Text, [StreamEvent])+handleToolCallStart state chunk =+ case T.breakOn "<tool_call>" chunk of+ (before, rest) ->+ let afterTag = T.drop (T.length "<tool_call>") 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]
+ src/Louter/Streaming/XMLToolCallParser.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}++-- | XML Tool Call Parser for Qwen3-Coder format+--+-- Parses XML-formatted tool calls like:+-- @+-- <tool_call>+-- <function=WriteFile>+-- <parameter=file_path>test.txt</parameter>+-- <parameter=content>Hello World!</parameter>+-- </function>+-- </tool_call>+-- @+--+-- 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 <tool_call>...</tool_call> 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 "<tool_call>" text of+ (_, rest) | T.null rest -> reverse acc+ (_, rest) ->+ let afterOpen = T.drop (T.length "<tool_call>") rest+ in case T.breakOn "</tool_call>" afterOpen of+ (block, afterClose) | T.null afterClose -> reverse acc+ (block, afterClose) ->+ let remaining = T.drop (T.length "</tool_call>") 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 <function=NAME> tag+extractFunctionName :: Text -> Maybe Text+extractFunctionName block =+ let pattern = "<function=([^>]+)>" :: String+ matches = T.unpack block =~ pattern :: [[String]]+ in case matches of+ ((_ : name : _) : _) -> Just (T.pack name)+ _ -> Nothing++-- | Extract all parameters from <parameter=key>value</parameter> tags+extractParameters :: Text -> HM.HashMap Text Value+extractParameters block =+ let pattern = "<parameter=([^>]+)>([^<]*)</parameter>" :: 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 <tool_call>...</tool_call> 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 "<tool_call>" text of+ (before, rest) | T.null rest -> before+ (before, rest) ->+ case T.breakOn "</tool_call>" (T.drop (T.length "<tool_call>") rest) of+ (_, afterClose) | T.null afterClose -> before+ (_, afterClose) ->+ let remaining = T.drop (T.length "</tool_call>") 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+ }
+ src/Louter/Types.hs view
@@ -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
+ src/Louter/Types/Request.hs view
@@ -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]]
+ src/Louter/Types/Response.hs view
@@ -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
+ src/Louter/Types/Streaming.hs view
@@ -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
+ src/Louter/Types/ToolFormat.hs view
@@ -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 <tool_call> 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 = []+ }
+ test/Spec.hs view
@@ -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 = "<tool_call><function=WriteFile><parameter=file_path>test.txt</parameter><parameter=content>Hello World!</parameter></function></tool_call>"+ 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 = "<tool_call><function=CreateDirectory><parameter=path>/tmp/test</parameter></function></tool_call>\+ \<tool_call><function=WriteFile><parameter=file_path>/tmp/test/file.txt</parameter></function></tool_call>"+ 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 = "<tool_call><function=SetCount><parameter=count>42</parameter></function></tool_call>"+ 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 = "<tool_call><function=SetFlag><parameter=enabled>true</parameter></function></tool_call>"+ 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 "<function=WriteFile>" `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 <tool_call><function=Test></function></tool_call> 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 "<tool_call>" 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 <tool_call>...</tool_call> B <tool_call>...</tool_call> 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 "<tool_call>" 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"