diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,34 +1,57 @@ -# Revision history for ollama-haskell - -## 0.1.3.0 -- 2025-03-25 - -* Added options, tools and tool_calls fields in chat and generate. -* Exported EmbeddingResponse. -* Added Format argument in chat and generate function for structured output. - -## 0.1.2.0 -- 2024-11-20 - -* Added hostUrl and responseTimeOut options in generate function. -* Added hostUrl and responseTimeOut options in chat function. +# Changelog -## 0.1.1.3 -- 2024-11-08 +All notable changes to `ollama-haskell` will be documented in this file. +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to [PVP (Haskell Package Versioning Policy)](https://pvp.haskell.org/). -* Increase response timeout to 15 minutes -* Added encodeImage utility function that converts image filePath to base64 image data. -* Added generateJson and chatJson. High level function to return response in Haskell type. +--- -## 0.1.0.3 -- 2024-11-05 +## [0.4.0.0] - 2026-08-20 -* Moving to stack instead of cabal. +### Added +- **Model Context Protocol (MCP) Integration (`Ollama.MCP`)**: + - Full bidirectional integration with the Hackage `mcp-server` package (`mcp-server >= 0.2 && < 0.3`). + - Seamless conversion between Ollama function calling definitions (`Tool`, `ToolCall`) and MCP definitions (`ToolDefinition`, `ArgumentDefinition`, `Content`, `McpSchema`). + - Bridge functions: `toolToMcpDefinition`, `mcpDefinitionToTool`, `toolCallToMcpArgs`, `mcpContentToToolOutput`. + - Re-exported MCP server runners (`runMcpServerStdio`, `runMcpServerHttp`, `runMcpServerHttpWithConfig`). + - Dedicated unit test suite in `Test.Ollama.Unit.MCP`. +- **Automatic JSON Schema Derivation (`Ollama.Types.Format.SchemaDerive`)**: + - Typeclasses `ToSchema` and `ToJsonType` enabling generic derivation of JSON schemas directly from Haskell record types via `GHC.Generics`. + - Smart handling of optional fields (`Maybe a` omitted from `required`), nested records (`JObject`), lists (`JArray`), and simple sum enums (`string` enum). + - Helper functions `schemaFor` and `formatFor` for effortless integration with `chat` / `generate` structured outputs. + - Dedicated unit test suite in `Test.Ollama.Unit.SchemaDerive`. +- **Configurable Client Timeout**: + - Support for custom request timeout intervals in `OllamaClientConfig` (`configTimeout`). -## 0.1.0.2 -- 2024-10-18 +### Changed +- **PVP Compliance & Upper Bounds**: + - Added strict upper bounds for `network-uri` (`>= 2.6 && < 2.8`) and `mcp-server` (`>= 0.2 && < 0.3`). + - Upgraded Stack resolvers and snapshot dependencies (`lts-21.25`, `lts-22.44`, `lts-23.28`, `lts-24.52`, `nightly`). -* Increased response timeout time for chat function. +--- -## 0.1.0.1 -- 2024-10-18 +## [0.3.0.0] - 2026-08-04 -* Renaming Lib.hs to OllamaExamples.hs as it was conflicting `Lib.hs` name +### Added +- **`OllamaClient` Core**: Thread-safe client handle with automatic connection manager lifecycle management (`newClient`, `defaultClient`, `clientFromEnv`, `withClient`). +- **First-Class Streaming Pipeline**: `conduit`-based response streaming (`chatStream`, `generateStream`, `pullStream`, `pushStream`, `createModelStream`). +- **Stream Combinators**: `collectStream` and `foldStream` in `Ollama.Streaming`. +- **Structured Output DSL**: Type-safe `SchemaBuilder` DSL in `Ollama.Types.Format.SchemaBuilder` (`|+`, `|++`, `|!`, `|!!`) for constructing JSON Schemas. +- **Thinking / Reasoning Models Support**: `Think` ADT (`ThinkEnabled`, `ThinkDisabled`, `ThinkLevel`) and `ThinkingLevel` (`ThinkLow`, `ThinkMedium`, `ThinkHigh`, `ThinkMax`) supporting models such as `qwen3.5` and `deepseek-r1`. +- **Function / Tool Calling**: `Tool`, `FunctionDef`, `FunctionParameters`, `ToolCall`, and `toolResultMessage` helper. +- **Environment Resolution**: Automatic `OLLAMA_HOST` parsing and normalization in `clientFromEnv` supporting `host:port`, `http://host:port`, and bare `host`. +- **Authorization & Headers**: Support for `OLLAMA_API_KEY` bearer tokens and custom `configHeaders`. +- **Configurable Resilience**: `RetryPolicy` ADT (`NoRetry`, `ConstantRetry`, `ExponentialRetry`), lifecycle callbacks (`configOnStart`, `configOnSuccess`, `configOnError`), and structured logger `configLogger`. +- **Token Throughput Metrics**: Metrics helpers `chatEvalTokensPerSecond`, `chatPromptEvalTokensPerSecond`, `evalTokensPerSecond`, `promptEvalTokensPerSecond`, `tokensPerSecond`. +- **Testing Infrastructure**: Built-in mock testing module `Ollama.Testing` (`newMockClient`, `withMockClient`, `mockGenerateResponse`, `mockChatResponse`, `mockEmbedResponse`, `mockListModelsResponse`). +- **Conversation Store**: Transactional STM-backed `InMemoryStore` and `ConversationStore` typeclass. +- **New API Endpoints**: `Ollama.API.Embed` (`/api/embed`), `Ollama.API.Blobs` (`/api/blobs`), `Ollama.API.Ps` (`/api/ps`), `Ollama.API.Version` (`/api/version`). +- **Benchmark Suite**: Criterion/tasty-bench suite in `bench/Main.hs` measuring serialization and throughput. -## 0.1.0.0 -- YYYY-mm-dd +### Changed +- **MonadIO / MonadUnliftIO Polymorphism**: All API functions use `MonadIO m =>` / `MonadUnliftIO m =>` signatures instead of dual `*M` variants. +- **Typed Newtypes**: `ModelName`, `Digest`, `Base64Image`, `Duration`, `Version` replace primitive string types. +- **Unified Error Type**: `OllamaError` sum type with structured constructors and `Exception` instance. -* First version. Released on an unsuspecting world. +### Deprecated +- `embeddings` endpoint (`/api/embeddings`) marked deprecated in favor of `/api/embed`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,74 +1,182 @@ -# Ollama-haskell +# ollama-haskell -**ollama-haskell** is an unofficial Haskell binding for [Ollama](https://ollama.com), similar to [`ollama-python`](https://github.com/ollama/ollama-python). +[![Hackage](https://img.shields.io/hackage/v/ollama-haskell.svg)](https://hackage.haskell.org/package/ollama-haskell) +[![MIT License](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) -This library allows you to interact with Ollama, a tool that lets you run large language models (LLMs) locally, from within your Haskell projects. +Industry-grade, feature-complete, modern Haskell client library for the [Ollama](https://ollama.com) local LLM engine. -## Examples +## Features +- **Client-Centric Architecture**: Thread-safe `OllamaClient` handle with connection pooling and resource management (`newClient`, `defaultClient`, `clientFromEnv`, `withClient`). +- **First-Class Streaming**: `conduit`-based response streaming (`chatStream`, `generateStream`, `pullStream`, `pushStream`, `createModelStream`). +- **Model Context Protocol (MCP) Bridge**: Bidirectional integration with `mcp-server` for converting between Ollama tools and MCP tools, running MCP servers via stdio or HTTP (`Ollama.MCP`). +- **Generic JSON Schema Derivation**: Automatically derive JSON schemas from Haskell data types via `GHC.Generics` with `ToSchema` and `formatFor`. +- **Complete API Surface**: Text generation, chat completions, vector embeddings, model management (list, show, copy, delete, pull, push, create), and system endpoints. +- **Structured Outputs DSL**: Powerful `SchemaBuilder` DSL (`|+`, `|++`, `|!`, `|!!`) for type-safe JSON Schema structured responses. +- **Function / Tool Calling**: Full support for tool definitions (`Tool`), tool calls (`ToolCall`), and execution results (`toolResultMessage`). +- **Thinking Models Support**: Native support for reasoning models (`qwen3.5`, `deepseek-r1`) with `Think` / `ThinkingLevel` types. +- **Environment & Auth Integration**: Robust URL normalization for `OLLAMA_HOST` and bearer token support for `OLLAMA_API_KEY`. +- **Configurable Resilience**: Flexible retry policies (`NoRetry`, `ConstantRetry`, `ExponentialRetry`), custom timeouts, lifecycle callbacks, and structured logging. +- **Conversation Store**: Transactional STM-backed `InMemoryStore` and `ConversationStore` typeclass for managing multi-turn chat sessions. +- **SDK Comparison Matrix**: Detailed feature comparison against Python, JS/TS, and Go SDKs in [doc/COMPARISON.md](doc/COMPARISON.md). + +--- + +## Installation + +Add `ollama-haskell` to your `.cabal` file: + +```cabal +build-depends: + base >= 4.17 && < 5 + , ollama-haskell >= 0.4.0.0 +``` + +Or using Stack in `package.yaml`: + +```yaml +dependencies: + - ollama-haskell >= 0.4.0.0 +``` + +--- + +## Quick Start (5 Lines) + ```haskell -{-# LANGUAGE OverloadedStrings #-} -module Lib where +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text.IO qualified as TIO +import Ollama -import Ollama (GenerateOps(..), defaultGenerateOps, generate) +main :: IO () +main = do + client <- defaultClient + res <- chat client $ chatRequest "qwen3.5:2b" (userMessage "Why is the sky blue?" :| []) + case res of + Left err -> print err + Right resp -> mapM_ (TIO.putStrLn . messageContent) (crMessage resp) +``` +--- + +## Streaming Responses with Conduit + +Stream LLM responses token-by-token as they generate: + +```haskell +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text.IO qualified as TIO +import Ollama + main :: IO () main = do - void $ - generate - defaultGenerateOps - { modelName = "llama3.2" - , prompt = "what is functional programming?" - , stream = Just (T.putStr . Ollama.response_, pure ()) - } + client <- defaultClient + let req = chatRequest "qwen3.5:2b" (userMessage "Count from 1 to 5." :| []) + + -- Stream chunks directly into stdout or collect them + chunks <- collectStream (chatStream client req) + mapM_ (TIO.putStr . maybe "" messageContent . crMessage) chunks + putStrLn "" ``` -### Output +--- -```bash -ghci> import Lib -ghci> main +## Function & Tool Calling -Whether Haskell is a "good" language depends on what you're looking for in a programming language and your personal preferences. Here are some points to consider: +Define function signatures and let the LLM execute structured tool calls: -**Pros:** +```haskell +import Data.List.NonEmpty (NonEmpty ((:|))) +import Ollama -1. **Strongly typed**: Haskell's type system ensures that you catch errors early, which leads to fewer bugs and easier maintenance. -2. **Functional programming paradigm**: Haskell encourages declarative coding, making it easier to reason about code and write correct programs. -3. **Garbage collection**: Haskell handles memory management automatically, freeing you from worries about manual memory deallocation. +calculatorTool :: Tool +calculatorTool = Tool "function" $ FunctionDef + { fnName = "add" + , fnDescription = Just "Add two numbers" + , fnParameters = Just (FunctionParameters "object" Nothing (Just ["a", "b"]) Nothing Nothing Nothing) + , fnStrict = Just True + } + +main :: IO () +main = do + client <- defaultClient + let req = (chatRequest "qwen3.5:2b" (userMessage "What is 40 + 2?" :| [])) + { chatTools = Just [calculatorTool] } + res <- chat client req + case res of + Left err -> print err + Right resp -> print (crMessage resp) ``` -You can find practical examples demonstrating how to use the library in the `examples/OllamaExamples.hs` file. +--- -## Prerequisite +## Structured Outputs (JSON Schema DSL) -Make sure you have [Ollama](https://ollama.com) installed and running on your local machine. You can download it from [here](https://ollama.com/download). +Enforce structured JSON output formats using `SchemaBuilder`: -## How to Use It +```haskell +import Data.Text.IO qualified as TIO +import Ollama +import Ollama.Types.Format.SchemaBuilder -1. Include the `ollama-haskell` package in your `.cabal` file: - ```cabal - build-depends: - base >= 4.7 && < 5, - ollama-haskell - ``` +personSchema :: Schema +personSchema = buildSchema $ emptyObject + |+ ("name", JString) + |+ ("age", JInteger) + |! "name" -3. Import the `Ollama` module and start integrating with your local LLM. +main :: IO () +main = do + client <- defaultClient + let req = (generateRequest "qwen3.5:2b" "Generate a person profile.") + { genFormat = Just (SchemaFormat personSchema) } + res <- generate client req + case res of + Left err -> print err + Right resp -> TIO.putStrLn (grResponse resp) +``` -## Future Updates +--- -- [x] Improve documentation -- [x] Add tests. -- [x] Add examples. -- [x] Add CI/CD pipeline. -- [ ] `options` parameter in `generate`. +## Environment Variables & Configuration -Stay tuned for future updates and improvements! +Construct a client using environment variables (`OLLAMA_HOST`, `OLLAMA_API_KEY`): -## Author +```haskell +main :: IO () +main = do + client <- clientFromEnv + -- Automatically connects to OLLAMA_HOST with optional Authorization: Bearer header + ... +``` -This library is developed and maintained by [Tushar](https://github.com/tusharad). Feel free to reach out for any questions or suggestions! +Or configure custom retry policies and loggers: -## Contributions +```haskell +customConfig :: OllamaClientConfig +customConfig = defaultConfig + { configBaseUrl = "http://my-ollama-server:11434" + , configTimeout = 120 + , configRetry = ExponentialRetry 3 1 -- 3 retries with exponential backoff + , configLogger = Just (\level msg -> putStrLn $ "[" <> show level <> "] " <> show msg) + } -Contributions are welcome! If you'd like to improve the library, please submit a pull request or open an issue. Whether it's fixing bugs, adding new features, or improving documentation, all contributions are greatly appreciated. +main :: IO () +main = withClient customConfig $ \client -> do + ... +``` + +--- + +## Documentation & SDK Comparison + +- [doc/COMPARISON.md](doc/COMPARISON.md) — SDK Feature Matrix comparing `ollama-haskell` with Python, JS/TS, and Go SDKs. +- [CONTRIBUTING.md](CONTRIBUTING.md) — Development setup, testing guidelines, and code style. +- [CHANGELOG.md](CHANGELOG.md) — Release notes and changelog. +- [Hackage Documentation](https://hackage.haskell.org/package/ollama-haskell) — Full Haddock reference. + +--- + +## License + +MIT © 2024–2026 Tushar Adhatrao diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Main +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Benchmark suite for Ollama client JSON serialization and URL normalization operations. + +@since 1.0.0.0 +-} +module Main (main) where + +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy (ByteString) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Ollama.API.Chat (ChatRequest, ChatResponse, chatRequest) +import Ollama.API.Embed (EmbedRequest, EmbedResponse, embedRequest) +import Ollama.API.Generate (GenerateRequest, GenerateResponse, generateRequest) +import Ollama.API.Models.Create (CreateRequest, defaultCreateRequest) +import Ollama.Testing (mockChatResponse, mockEmbedResponse, mockGenerateResponse) +import Ollama.Types.Common (ModelName (..)) +import Ollama.Types.Message (userMessage) +import Test.Tasty.Bench (bench, bgroup, defaultMain, whnf) + +main :: IO () +main = + defaultMain + [ bgroup + "JSON Encoding" + [ bench "GenerateRequest" $ whnf encode sampleGenerateRequest + , bench "ChatRequest" $ whnf encode sampleChatRequest + , bench "EmbedRequest" $ whnf encode sampleEmbedRequest + , bench "CreateRequest" $ whnf encode sampleCreateRequest + ] + , bgroup + "JSON Decoding" + [ bench "GenerateResponse" $ whnf (decode @GenerateResponse) sampleGenerateBytes + , bench "ChatResponse" $ whnf (decode @ChatResponse) sampleChatBytes + , bench "EmbedResponse" $ whnf (decode @EmbedResponse) sampleEmbedBytes + ] + ] + +sampleGenerateRequest :: GenerateRequest +sampleGenerateRequest = generateRequest (ModelName "llama3.2") "Why is the sky blue?" + +sampleChatRequest :: ChatRequest +sampleChatRequest = chatRequest (ModelName "llama3.2") (userMessage "Hello, world!" :| []) + +sampleEmbedRequest :: EmbedRequest +sampleEmbedRequest = embedRequest (ModelName "nomic-embed-text") ["Hello", "World", "Vector"] + +sampleCreateRequest :: CreateRequest +sampleCreateRequest = defaultCreateRequest (ModelName "custom-llama") + +sampleGenerateBytes :: ByteString +sampleGenerateBytes = encode $ mockGenerateResponse (ModelName "llama3.2") "Sky is blue" + +sampleChatBytes :: ByteString +sampleChatBytes = encode $ mockChatResponse (ModelName "llama3.2") "Hello there" + +sampleEmbedBytes :: ByteString +sampleEmbedBytes = encode $ mockEmbedResponse (ModelName "nomic") [[0.1, 0.2]] diff --git a/examples/AllFeatures.hs b/examples/AllFeatures.hs new file mode 100644 --- /dev/null +++ b/examples/AllFeatures.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Main +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Comprehensive example demonstrating all v1.0 features of ollama-haskell: + * Client builder with env resolution, custom headers, & retry policies + * Conduit-based response streaming + * Thinking / reasoning model integration + * Function / tool calling + * Structured JSON schema output + * Vector embeddings & token throughput metrics + * Transactional STM conversation storage + +@since 1.0.0.0 +-} +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Ollama + +fastOptions :: Maybe ModelOptions +fastOptions = Just (defaultOptions {optNumPredict = Just 20}) + +main :: IO () +main = do + putStrLn "==========================================================" + putStrLn " ollama-haskell v1.0 — All Features Showcase Example" + putStrLn "==========================================================" + + -- 1. Client Builder with env vars, custom headers, & Exponential Retry Policy + putStrLn "\n[1] Initializing client..." + let customConfig = + defaultConfig + { configRetry = ExponentialRetry 3 1 + , configHeaders = [("X-Custom-Client", "ollama-haskell-v1.0")] + } + client <- newClient customConfig + putStrLn "Client initialized with ExponentialRetry policy." + + -- 2. System Inspection + putStrLn "\n[2] System Engine Version..." + verRes <- getVersion client + case verRes of + Left err -> putStrLn $ "Error fetching version: " <> show err + Right ver -> putStrLn $ "Ollama Engine Version: " <> T.unpack (unVersion ver) + + putStrLn "\n[3] Listing Local Models..." + modelsRes <- listModels client + case modelsRes of + Left err -> putStrLn $ "Error listing models: " <> show err + Right (ListResponse ms) -> do + putStrLn $ "Found " <> show (length ms) <> " installed models:" + mapM_ (\m -> putStrLn $ " - " <> T.unpack (unModelName (miName m))) ms + + let model = "qwen3.5:2b" + + -- 4. Conduit-Based Streaming Chat + putStrLn $ "\n[4] Streaming Chat with Conduit (" <> T.unpack (unModelName model) <> ")..." + let streamReq = + (chatRequest model (userMessage "Count from 1 to 5." :| [])) + { chatOptions = fastOptions + , chatThink = Just ThinkDisabled + } + putStr "Response stream: " + chunks <- collectStream (chatStream client streamReq) + mapM_ + ( \c -> case crMessage c of + Just msg -> putStr (T.unpack (messageContent msg)) + Nothing -> pure () + ) + chunks + putStrLn "" + + -- 5. Non-Streaming Chat with Token Throughput Metrics + putStrLn "\n[5] Non-Streaming Chat & Token Metrics..." + let chatReq = + ( chatRequest + model + (systemMessage "You are a concise assistant." :| [userMessage "Explain gravity in one sentence."]) + ) + { chatOptions = fastOptions + , chatThink = Just ThinkDisabled + } + chatRes <- chat client chatReq + case chatRes of + Left err -> putStrLn $ "Chat error: " <> show err + Right resp -> do + case crMessage resp of + Just msg -> putStrLn $ "Answer: " <> T.unpack (messageContent msg) + Nothing -> putStrLn "No message returned." + case chatEvalTokensPerSecond resp of + Just tps -> putStrLn $ "Generation Speed: " <> show tps <> " tokens/sec" + Nothing -> pure () + + -- 6. Thinking / Reasoning Model Integration + putStrLn "\n[6] Generation with Thinking Mode..." + let thinkReq = + (generateRequest model "What is 15 * 14?") + { genThink = Just (ThinkLevel ThinkMedium) + , genOptions = fastOptions + } + thinkRes <- generate client thinkReq + case thinkRes of + Left err -> putStrLn $ "Generate error: " <> show err + Right resp -> putStrLn $ "Result: " <> T.unpack (grResponse resp) + + -- 7. Tool / Function Calling + putStrLn "\n[7] Tool / Function Calling..." + let calcTool = + Tool + { toolType = "function" + , toolFunction = + FunctionDef + { fnName = "calculator" + , fnDescription = Just "Perform basic math calculations" + , fnParameters = + Just + FunctionParameters + { fpType = "object" + , fpProperties = Nothing + , fpRequired = Just ["expression"] + , fpAdditionalProperties = Nothing + , fpDescription = Nothing + , fpEnum = Nothing + } + , fnStrict = Just True + } + } + toolReq = + (chatRequest model (userMessage "Calculate 42 * 8" :| [])) + { chatTools = Just [calcTool] + , chatOptions = fastOptions + , chatThink = Just ThinkDisabled + } + toolRes <- chat client toolReq + case toolRes of + Left err -> putStrLn $ "Tool chat error: " <> show err + Right resp -> case crMessage resp of + Just msg -> case messageToolCalls msg of + Just calls -> putStrLn $ "Model requested tool execution: " <> show calls + Nothing -> putStrLn $ "Response: " <> T.unpack (messageContent msg) + Nothing -> putStrLn "No message returned." + + -- 8. Vector Embeddings + putStrLn "\n[8] Vector Embeddings..." + let embReq = embedRequest model ["Haskell AI development", "Ollama LLM client"] + embRes <- embed client embReq + case embRes of + Left err -> putStrLn $ "Embed error: " <> show err + Right resp -> putStrLn $ "Generated " <> show (length (erEmbeddings resp)) <> " embedding vectors." + + -- 9. Transactional Conversation Store + putStrLn "\n[9] STM Conversation Store..." + store <- initInMemoryStore + now <- getCurrentTime + let convId = "demo-session-42" + session = + Conversation + convId + [systemMessage "Context saved.", userMessage "Favorite language is Haskell."] + model + now + now + saveConversationInMemory store session + retrieved <- loadConversationInMemory store convId + case retrieved of + Just c -> + putStrLn $ + "Successfully loaded conversation [" + <> T.unpack (conversationId c) + <> "] with " + <> show (length (messages c)) + <> " messages." + Nothing -> putStrLn "Failed to load conversation." + + closeClient client + putStrLn "\n==========================================================" + putStrLn " Showcase Completed Successfully!" + putStrLn "==========================================================" diff --git a/examples/BasicChat.hs b/examples/BasicChat.hs new file mode 100644 --- /dev/null +++ b/examples/BasicChat.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text.IO qualified as TIO +import Ollama + +main :: IO () +main = do + client <- defaultClient + let opts = Just (defaultOptions {optNumPredict = Just 20}) + req = + (chatRequest "qwen3.5:2b" (userMessage "Why is the sky blue?" :| [])) + { chatOptions = opts + , chatThink = Just ThinkDisabled + } + res <- chat client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> case crMessage resp of + Just msg -> TIO.putStrLn $ "Response: " <> messageContent msg + Nothing -> putStrLn "No content returned" diff --git a/examples/Embeddings.hs b/examples/Embeddings.hs new file mode 100644 --- /dev/null +++ b/examples/Embeddings.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Ollama + +main :: IO () +main = do + client <- defaultClient + let req = embedRequest "qwen3.5:2b" ["Hello world", "Haskell LLM integration"] + res <- embed client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> putStrLn $ "Generated " <> show (length $ erEmbeddings resp) <> " embeddings." diff --git a/examples/ModelManagement.hs b/examples/ModelManagement.hs new file mode 100644 --- /dev/null +++ b/examples/ModelManagement.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Ollama + +main :: IO () +main = do + client <- defaultClient + res <- listModels client + case res of + Left err -> putStrLn $ "Error listing models: " <> show err + Right (ListResponse ms) -> do + putStrLn "Installed Models:" + mapM_ (print . miName) ms diff --git a/examples/StreamingChat.hs b/examples/StreamingChat.hs new file mode 100644 --- /dev/null +++ b/examples/StreamingChat.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text.IO qualified as TIO +import Ollama + +main :: IO () +main = do + client <- defaultClient + let opts = Just (defaultOptions {optNumPredict = Just 20}) + req = + (chatRequest "qwen3.5:2b" (userMessage "Count from 1 to 5." :| [])) + { chatOptions = opts + , chatThink = Just ThinkDisabled + } + chunks <- collectStream (chatStream client req) + mapM_ (TIO.putStr . maybe "" messageContent . crMessage) chunks + putStrLn "" diff --git a/examples/StructuredOutput.hs b/examples/StructuredOutput.hs new file mode 100644 --- /dev/null +++ b/examples/StructuredOutput.hs @@ -0,0 +1,37 @@ +module Main (main) where + +import Data.Aeson (FromJSON, eitherDecode) +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import GHC.Generics (Generic) +import Ollama + +-- | Define your type and derive 'ToSchema'. That's it — no manual schema needed. +data Person = Person + { name :: Text + , age :: Int + } + deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToSchema) + +main :: IO () +main = do + client <- defaultClient + let opts = Just (defaultOptions {optNumPredict = Just 20}) + req = + (generateRequest "qwen3.5:2b" "Generate a person profile.") + { genFormat = Just (formatFor @Person) + , genOptions = opts + , genThink = Just ThinkDisabled + } + res <- generate client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> do + TIO.putStrLn $ "Raw response:\n" <> grResponse resp + -- Decode into our typed Person + case eitherDecode (TLE.encodeUtf8 . TL.fromStrict $ grResponse resp) of + Left decErr -> putStrLn $ "Decode error: " <> decErr + Right person -> putStrLn $ "Parsed: " <> show (person :: Person) diff --git a/examples/ToolCalling.hs b/examples/ToolCalling.hs new file mode 100644 --- /dev/null +++ b/examples/ToolCalling.hs @@ -0,0 +1,41 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Ollama + +calculatorTool :: Tool +calculatorTool = + Tool + { toolType = "function" + , toolFunction = + FunctionDef + { fnName = "add" + , fnDescription = Just "Add two numbers" + , fnParameters = + Just + FunctionParameters + { fpType = "object" + , fpProperties = Nothing + , fpRequired = Just ["a", "b"] + , fpAdditionalProperties = Nothing + , fpDescription = Nothing + , fpEnum = Nothing + } + , fnStrict = Just True + } + } + +main :: IO () +main = do + client <- defaultClient + let opts = Just (defaultOptions {optNumPredict = Just 20}) + req = + (chatRequest "qwen3.5:2b" (userMessage "What is 25 + 17?" :| [])) + { chatTools = Just [calculatorTool] + , chatOptions = opts + , chatThink = Just ThinkDisabled + } + res <- chat client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> print (crMessage resp) diff --git a/ollama-haskell.cabal b/ollama-haskell.cabal --- a/ollama-haskell.cabal +++ b/ollama-haskell.cabal @@ -1,91 +1,245 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.37.0. --- --- see: https://github.com/sol/hpack - -name: ollama-haskell -version: 0.1.3.0 -synopsis: Haskell bindings for ollama. -description: Ollama client for Haskell -category: Web -homepage: https://github.com/tusharad/ollama-haskell#readme -bug-reports: https://github.com/tusharad/ollama-haskell/issues -author: tushar -maintainer: tusharadhatrao@gmail.com -copyright: 2024 tushar -license: MIT -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - CHANGELOG.md +cabal-version: 3.0 +name: ollama-haskell +version: 0.4.0.0 +synopsis: Industry-grade Haskell client for Ollama local LLMs +description: + A type-safe Haskell client for interacting with + locally-running LLMs via the Ollama HTTP API. Supports chat, + text generation, embeddings, model management, streaming via + conduit, structured outputs, tool calling, Model Context Protocol (MCP), + and generic JSON schema derivation. +category: Web, AI, Network +license: MIT +license-file: LICENSE +author: Tushar Adhatrao +maintainer: tusharadhatrao@gmail.com +copyright: 2024-2026 Tushar Adhatrao +homepage: https://github.com/tusharad/ollama-haskell +bug-reports: https://github.com/tusharad/ollama-haskell/issues +tested-with: GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.4 +stability: stable +extra-doc-files: + README.md + CHANGELOG.md source-repository head type: git location: https://github.com/tusharad/ollama-haskell +flag integration-tests + description: Build and run integration tests (requires running Ollama server) + default: False + manual: True + +common warnings + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +common lang + default-language: GHC2021 + default-extensions: + StrictData + DerivingStrategies + DeriveGeneric + DeriveAnyClass + GeneralizedNewtypeDeriving + OverloadedStrings + ImportQualifiedPost + TypeApplications + RecordWildCards + NamedFieldPuns + LambdaCase + MultiWayIf + ScopedTypeVariables + BangPatterns + library + import: warnings, lang + hs-source-dirs: src exposed-modules: - Data.Ollama.Chat - Data.Ollama.Common.Types - Data.Ollama.Common.Utils - Data.Ollama.Copy - Data.Ollama.Create - Data.Ollama.Delete - Data.Ollama.Embeddings - Data.Ollama.Generate - Data.Ollama.List - Data.Ollama.Ps - Data.Ollama.Pull - Data.Ollama.Push - Data.Ollama.Show - Ollama + Ollama + Ollama.Client + Ollama.Client.Config + Ollama.API.Generate + Ollama.API.Chat + Ollama.API.Embed + Ollama.API.Models + Ollama.API.Models.Create + Ollama.API.Models.Pull + Ollama.API.Models.Push + Ollama.API.Blobs + Ollama.API.Ps + Ollama.API.Version + Ollama.Types + Ollama.Types.Message + Ollama.Types.Tool + Ollama.Types.Model + Ollama.Types.Options + Ollama.Types.Format + Ollama.Types.Format.SchemaBuilder + Ollama.Types.Format.SchemaDerive + Ollama.Types.Common + Ollama.Error + Ollama.Streaming + Ollama.Testing + Ollama.Conversation + Ollama.MCP other-modules: - Paths_ollama_haskell - hs-source-dirs: - src - default-extensions: - ImportQualifiedPost - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + Ollama.Client.Internal build-depends: - aeson - , base >=4.7 && <5 - , base64-bytestring - , bytestring - , containers - , directory - , filepath - , http-client - , http-types - , text - , time - default-language: Haskell2010 + aeson >= 2.0 && < 3 + , base >= 4.17 && < 5 + , bytestring >= 0.10 && < 0.13 + , case-insensitive >= 1.2 && < 1.3 + , conduit >= 1.3 && < 1.4 + , conduit-extra >= 1.3 && < 1.4 + , containers >= 0.6 && < 0.9 + , hashable >= 1.4 && < 1.6 + , http-client >= 0.6 && < 0.8 + , http-client-tls >= 0.2 && < 0.5 + , http-types >= 0.7 && < 0.13 + , mtl >= 2.2 && < 3 + , retry >= 0.9 && < 0.10 + , resourcet >= 1.3 && < 1.4 + , stm >= 2.5 && < 3 + , text >= 2.0 && < 3 + , time >= 1.11 && < 2 + , unliftio-core >= 0.2 && < 0.3 + , mcp-server >= 0.2 && < 0.3 test-suite ollama-haskell-test + import: warnings, lang type: exitcode-stdio-1.0 + hs-source-dirs: test main-is: Main.hs other-modules: - Paths_ollama_haskell - hs-source-dirs: - test - default-extensions: - ImportQualifiedPost - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + Test.Ollama.Unit.Types + Test.Ollama.Unit.Error + Test.Ollama.Unit.Config + Test.Ollama.Unit.SchemaBuilder + Test.Ollama.Unit.SchemaDerive + Test.Ollama.Unit.Testing + Test.Ollama.Property.Arbitrary + Test.Ollama.Property.Roundtrip + Test.Ollama.Golden.Chat + Test.Ollama.Golden.Generate + Test.Ollama.Golden.Embed + Test.Ollama.Golden.Models + Test.Ollama.Unit.MCP build-depends: - aeson - , base >=4.7 && <5 - , base64-bytestring + base + , ollama-haskell + , aeson , bytestring , containers - , directory - , filepath - , http-client - , http-types + , mcp-server + , QuickCheck >= 2.14 + , tasty >= 1.5 + , tasty-golden >= 2.3 + , tasty-hunit + , tasty-quickcheck >= 0.10 + , text + , time + , conduit + +test-suite ollama-haskell-integration + import: warnings, lang + type: exitcode-stdio-1.0 + hs-source-dirs: test-integration + main-is: Main.hs + if !flag(integration-tests) + buildable: False + build-depends: + base , ollama-haskell - , silently + , aeson , tasty , tasty-hunit , text , time - default-language: Haskell2010 + +benchmark ollama-haskell-bench + import: warnings, lang + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: + base + , ollama-haskell + , aeson + , bytestring + , tasty >= 1.5 + , tasty-bench >= 0.3 + , text + +executable ollama-example-basic-chat + import: warnings, lang + main-is: BasicChat.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-streaming-chat + import: warnings, lang + main-is: StreamingChat.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-tool-calling + import: warnings, lang + main-is: ToolCalling.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + +executable ollama-example-structured-output + import: warnings, lang + main-is: StructuredOutput.hs + hs-source-dirs: examples + build-depends: + aeson + , base + , ollama-haskell + , text + +executable ollama-example-embeddings + import: warnings, lang + main-is: Embeddings.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + +executable ollama-example-model-management + import: warnings, lang + main-is: ModelManagement.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + +executable ollama-example-all-features + import: warnings, lang + main-is: AllFeatures.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + , time + diff --git a/src/Data/Ollama/Chat.hs b/src/Data/Ollama/Chat.hs deleted file mode 100644 --- a/src/Data/Ollama/Chat.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Ollama.Chat - ( -- * Chat APIs - chat - , chatJson - , Message (..) - , Role (..) - , defaultChatOps - , ChatOps (..) - , ChatResponse (..) - , Format (..) - , schemaFromType - ) where - -import Control.Exception (try) -import Data.Aeson -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe, isNothing) -import Data.Ollama.Common.Utils as CU -import Data.Ollama.Common.Types (Format(..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time (UTCTime) -import GHC.Generics -import GHC.Int (Int64) -import Network.HTTP.Client -import qualified Data.Aeson.KeyMap as HM - --- | Enumerated roles that can participate in a chat. -data Role = System | User | Assistant | Tool - deriving (Show, Eq) - -instance ToJSON Role where - toJSON System = String "system" - toJSON User = String "user" - toJSON Assistant = String "assistant" - toJSON Tool = String "tool" - -instance FromJSON Role where - parseJSON (String "system") = pure System - parseJSON (String "user") = pure User - parseJSON (String "assistant") = pure Assistant - parseJSON (String "tool") = pure Tool - parseJSON _ = fail "Invalid Role value" - --- TODO : Add tool_calls parameter - --- | Represents a message within a chat, including its role and content. -data Message = Message - { role :: Role - -- ^ The role of the entity sending the message (e.g., 'User', 'Assistant'). - , content :: Text - -- ^ The textual content of the message. - , images :: Maybe [Text] - -- ^ Optional list of base64 encoded images that accompany the message. - , tool_calls :: Maybe [Value] - -- ^ a list of tools in JSON that the model wants to use - -- ^ Since 0.1.3.0 - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - --- TODO: Add Options parameter -data ChatOps = ChatOps - { chatModelName :: Text - -- ^ The name of the chat model to be used. - , messages :: NonEmpty Message - -- ^ A non-empty list of messages forming the conversation context. - , tools :: Maybe [Value] - -- ^ Optional tools that may be used in the chat. - , format :: Maybe Format - -- ^ An optional format for the chat response (json or JSON schema). - -- ^ Since 0.1.3.0 - , stream :: Maybe (ChatResponse -> IO (), IO ()) - -- ^ Optional streaming functions where the first handles each chunk of the response, and the second flushes the stream. - , keepAlive :: Maybe Text - -- ^ Optional text to specify keep-alive behavior. - , hostUrl :: Maybe Text - -- ^ Override default Ollama host url. Default url = "http://127.0.0.1:11434" - , responseTimeOut :: Maybe Int - -- ^ Override default response timeout in minutes. Default = 15 minutes - , options :: Maybe Value - -- ^ additional model parameters listed in the documentation for the Modelfile such as temperature - -- ^ Since 0.1.3.0 - } - -instance Show ChatOps where - show (ChatOps {chatModelName = m, messages = ms, tools = t, format = f, keepAlive = ka}) = - let messagesStr = show (toList ms) - toolsStr = show t - formatStr = show f - keepAliveStr = show ka - in T.unpack m - ++ "\nMessages:\n" - ++ messagesStr - ++ "\n" - ++ toolsStr - ++ "\n" - ++ formatStr - ++ "\n" - ++ keepAliveStr - -instance Eq ChatOps where - (==) a b = - chatModelName a == chatModelName b - && messages a == messages b - && tools a == tools b - && format a == format b - && keepAlive a == keepAlive b - -data ChatResponse = ChatResponse - { model :: Text - -- ^ The name of the model that generated this response. - , createdAt :: UTCTime - -- ^ The timestamp when the response was created. - , message :: Maybe Message - -- ^ The message content of the response, if any. - , done :: Bool - -- ^ Indicates whether the chat process has completed. - , totalDuration :: Maybe Int64 - -- ^ Optional total duration in milliseconds for the chat process. - , loadDuration :: Maybe Int64 - -- ^ Optional load duration in milliseconds for loading the model. - , promptEvalCount :: Maybe Int64 - -- ^ Optional count of prompt evaluations during the chat process. - , promptEvalDuration :: Maybe Int64 - -- ^ Optional duration in milliseconds for evaluating the prompt. - , evalCount :: Maybe Int64 - -- ^ Optional count of evaluations during the chat process. - , evalDuration :: Maybe Int64 - -- ^ Optional duration in milliseconds for evaluations during the chat process. - } - deriving (Show, Eq) - -instance ToJSON ChatOps where - toJSON (ChatOps model_ messages_ tools_ format_ stream_ keepAlive_ _ _ options) = - object - [ "model" .= model_ - , "messages" .= messages_ - , "tools" .= tools_ - , "format" .= format_ - , "stream" .= if isNothing stream_ then Just False else Just True - , "keep_alive" .= keepAlive_ - , "options" .= options - ] - -instance FromJSON ChatResponse where - parseJSON = withObject "ChatResponse" $ \v -> - ChatResponse - <$> v .: "model" - <*> v .: "created_at" - <*> v .: "message" - <*> v .: "done" - <*> v .:? "total_duration" - <*> v .:? "load_duration" - <*> v .:? "prompt_eval_count" - <*> v .:? "prompt_eval_duration" - <*> v .:? "eval_count" - <*> v .:? "eval_duration" - -{- | -A default configuration for initiating a chat with a model. -This can be used as a starting point and modified as needed. - -Example: - -> let ops = defaultChatOps { chatModelName = "customModel" } -> chat ops --} -defaultChatOps :: ChatOps -defaultChatOps = - ChatOps - { chatModelName = "llama3.2" - , messages = Message User "What is 2+2?" Nothing Nothing :| [] - , tools = Nothing - , format = Nothing - , stream = Nothing - , keepAlive = Nothing - , hostUrl = Nothing - , responseTimeOut = Nothing - , options = Nothing - } - -{- | -Initiates a chat session with the specified 'ChatOps' configuration and returns either -a 'ChatResponse' or an error message. - -This function sends a request to the Ollama chat API with the given options. - -Example: - -> let ops = defaultChatOps -> result <- chat ops -> case result of -> Left errorMsg -> putStrLn ("Error: " ++ errorMsg) -> Right response -> print response - -To request a JSON format response: - -> let ops = defaultChatOps { format = Just JsonFormat } -> result <- chat ops - -To request a structured output with a JSON schema: - -> import Data.Aeson (object, (.=)) -> let ops = defaultChatOps { format = Just (SchemaFormat schema) } -> result <- chat ops --} -chat :: ChatOps -> IO (Either String ChatResponse) -chat cOps = do - let url = fromMaybe defaultOllamaUrl (hostUrl cOps) - responseTimeout = fromMaybe 15 (responseTimeOut cOps) - manager <- - newManager - defaultManagerSettings -- Setting response timeout to 5 minutes, since llm takes time - { managerResponseTimeout = responseTimeoutMicro (responseTimeout * 60 * 1000000) - } - eInitialRequest <- try $ parseRequest $ T.unpack (url <> "/api/chat") :: IO (Either HttpException Request) - case eInitialRequest of - Left e -> return $ Left $ "Failed to parse host url: " <> show e - Right initialRequest -> do - let reqBody = cOps - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - eRes <- - try (withResponse request manager $ handleRequest cOps) :: - IO (Either HttpException (Either String ChatResponse)) - case eRes of - Left e -> return $ Left $ "HTTP error occured: " <> show e - Right r -> do - return r - -handleRequest :: ChatOps -> Response BodyReader -> IO (Either String ChatResponse) -handleRequest cOps response = do - let streamResponse sendChunk flush = do - bs <- brRead $ responseBody response - if BS.null bs - then putStrLn "" >> pure (Left "") - else do - let eRes = eitherDecode (BSL.fromStrict bs) :: Either String ChatResponse - case eRes of - Left e -> pure (Left e) - Right r -> do - _ <- sendChunk r - _ <- flush - if done r then pure (Left "") else streamResponse sendChunk flush - let genResponse op = do - bs <- brRead $ responseBody response - if BS.null bs - then do - let eRes = eitherDecode (BSL.fromStrict op) :: Either String ChatResponse - case eRes of - Left e -> pure (Left e) - Right r -> pure (Right r) - else genResponse (op <> bs) - case stream cOps of - Nothing -> genResponse "" - Just (sendChunk, flush) -> streamResponse sendChunk flush - -{- | - chatJson is a higher level function that takes ChatOps (similar to chat) and also takes - a Haskell type (that has To and From JSON instance) and returns the response in provided type. - - This function simply calls chat with extra prompt appended to it, telling LLM to return the - response in certain JSON format and serializes the response. This function will be helpful when you - want to use the LLM to do something programmatic. - - Note: This function predates the format parameter in the API. For new code, consider using - the `format` parameter with a SchemaFormat instead, which leverages the model's native - JSON output capabilities. - - For Example: - > let expectedJsonStrucutre = Example { - > sortedList = ["sorted List here"] - > , wasListAlreadSorted = False - > } - > let msg0 = Ollama.Message User "Sort given list: [4, 2 , 3, 67]. Also tell whether list was already sorted or not." Nothing - > eRes3 <- - > chatJson - > defaultChatOps - > { Chat.chatModelName = "llama3.2" - > , Chat.messages = msg0 :| [] - > } - > expectedJsonStrucutre - > (Just 2) - > print eRes3 - Output: - > Example {sortedList = ["1","2","3","4"], wasListAlreadSorted = False} - -Note: While Passing the type, construct the type that will help LLM understand the field better. - For example, in the above example, the sortedList's value is written as "Sorted List here". This - will help LLM understand context better. - - You can also provide number of retries in case the LLM field to return the response in correct JSON - in first attempt. --} -chatJson :: - (FromJSON jsonResult, ToJSON jsonResult) => - ChatOps -> - -- | Haskell type that you want your result in - jsonResult -> - -- | Max retries - Maybe Int -> - IO (Either String jsonResult) -chatJson cOps@ChatOps {..} jsonStructure mMaxRetries = do - -- For models that support the format parameter, use that directly - --let jsonSchema = encode jsonStructure - let useNativeFormat = False -- Set to True to use the native format parameter when appropriate - - if useNativeFormat - then do - let formattedOps = cOps { format = Just (SchemaFormat (Object $ HM.fromList [("schema", Object $ HM.fromList [("type", String "object")])])) } - chatResponse <- chat formattedOps - case chatResponse of - Left err -> return $ Left err - Right r -> do - let mMessage = message r - case mMessage of - Nothing -> return $ Left "Something went wrong" - Just res -> case decode (BSL.fromStrict . T.encodeUtf8 $ content res) of - Nothing -> return $ Left "Decoding Failed :(" - Just resultInType -> return $ Right resultInType - else do - -- Fall back to the original implementation using prompts - let lastMessage = NonEmpty.last messages - jsonHelperPrompt = - "You are an AI that returns only JSON object. \n" - <> "* Your output should be a JSON object that matches the following schema: \n" - <> T.decodeUtf8 (BSL.toStrict $ encode jsonStructure) - <> content lastMessage - <> "\n" - <> "# How to treat the task:\n" - <> "* Stricly follow the schema for the output.\n" - <> "* Never return anything other than a JSON object.\n" - <> "* Do not talk to the user.\n" - chatResponse <- - chat - cOps - { messages = - NonEmpty.fromList $ - lastMessage {content = jsonHelperPrompt} : NonEmpty.init messages - } - case chatResponse of - Left err -> return $ Left err - Right r -> do - let mMessage = message r - case mMessage of - Nothing -> return $ Left "Something went wrong" - Just res -> do - case decode (BSL.fromStrict . T.encodeUtf8 $ content res) of - Nothing -> do - case mMaxRetries of - Nothing -> return $ Left "Decoding Failed :(" - Just n -> if n < 1 then return $ Left "Decoding Failed :(" else chatJson cOps jsonStructure (Just (n - 1)) - Just resultInType -> return $ Right resultInType - --- | Helper function to create a JSON schema from a Haskell type -schemaFromType :: ToJSON a => a -> BSL.ByteString -schemaFromType = encode -- This is a simplified version; a real implementation would generate a JSON Schema - -{- | - Example usage of 'Ollama.chat' with a JSON schema format and options field. - - The first example sends a message requesting a JSON response conforming to a given schema. - The second example uses an alternative JSON format (here, @JsonFormat@). - - >>> import Data.Aeson (Value, object, (.=)) - >>> import Data.List.NonEmpty (NonEmpty(..)) - >>> import Ollama (defaultChatOps, Message(..), SchemaFormat, JsonFormat) - >>> let x :: Value - ... x = object [ "type" .= ("object" :: String) - ... , "properties" .= object [ "age" .= object ["type" .= ("integer" :: String)] ] - ... ] - >>> let msg = Message User "Ollama is 22 years old and is busy saving the world. Respond using JSON" Nothing - >>> let opts = object ["option" .= ("some value" :: String)] - >>> res <- chat defaultChatOps - ... { chatModelName = "llama3.2" - ... , messages = msg :| [] - ... , format = Just (SchemaFormat x) - ... , options = opts - ... } - >>> print (message res) - Just (Message {role = Assistant, content = "{\n \"age\": 22\n}", images = Nothing}) - >>> res2 <- chat defaultChatOps - ... { chatModelName = "llama3.2" - ... , messages = msg :| [] - ... , format = Just JsonFormat - ... , options = object ["option" .= ("other value" :: String)] - ... } - >>> print (message res2) - Just (Message {role = Assistant, content = "{ \"Name\": \"Ollama\", \"Age\": 22, \"Occupation\": \"World Savior\", \"Goals\": [\"Save humanity from alien invasion\", \"Unite warring nations\", \"Protect the environment\"] }", images = Nothing}) --} diff --git a/src/Data/Ollama/Common/Types.hs b/src/Data/Ollama/Common/Types.hs deleted file mode 100644 --- a/src/Data/Ollama/Common/Types.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Common.Types - ( ModelDetails (..) - , OllamaClient (..) - , Format (..) - ) where - -import Data.Aeson -import Data.Text (Text) - -data ModelDetails = ModelDetails - { parentModel :: Maybe Text - , format :: Text - , familiy :: Text - , families :: [Text] - , parameterSize :: Text - , quantizationLevel :: Text - } - deriving (Eq, Show) - -instance FromJSON ModelDetails where - parseJSON = withObject "ModelDetails" $ \v -> - ModelDetails - <$> v .: "parent_model" - <*> v .: "format" - <*> v .: "family" - <*> v .:? "families" .!= [] - <*> v .: "parameter_size" - <*> v .: "quantization_level" - -newtype OllamaClient = OllamaClient - { host :: Text - } - deriving (Eq, Show) - - -{-| -E.g SchemaFormat -{ - "type": "object", - "properties": { - "age": { - "type": "integer" - }, - "available": { - "type": "boolean" - } - }, - "required": [ - "age", - "available" - ] - } -|-} --- | Format specification for the chat output --- | Since 0.1.3.0 -data Format = JsonFormat | SchemaFormat Value - deriving (Show, Eq) - -instance ToJSON Format where - toJSON JsonFormat = String "json" - toJSON (SchemaFormat schema) = schema diff --git a/src/Data/Ollama/Common/Utils.hs b/src/Data/Ollama/Common/Utils.hs deleted file mode 100644 --- a/src/Data/Ollama/Common/Utils.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Common.Utils (defaultOllamaUrl, OllamaClient (..), encodeImage) where - -import Control.Exception (IOException, try) -import Data.ByteString qualified as BS -import Data.ByteString.Base64 qualified as Base64 -import Data.Char (toLower) -import Data.Ollama.Common.Types -import Data.Text (Text) -import Data.Text.Encoding qualified as TE -import System.Directory -import System.FilePath - -defaultOllamaUrl :: Text -defaultOllamaUrl = "http://127.0.0.1:11434" - -supportedExtensions :: [String] -supportedExtensions = [".jpg", ".jpeg", ".png"] - -safeReadFile :: FilePath -> IO (Either IOException BS.ByteString) -safeReadFile = try . BS.readFile - -asPath :: FilePath -> IO (Maybe BS.ByteString) -asPath filePath = do - exists <- doesFileExist filePath - if exists - then either (const Nothing) Just <$> safeReadFile filePath - else return Nothing - -isSupportedExtension :: FilePath -> Bool -isSupportedExtension path = map toLower (takeExtension path) `elem` supportedExtensions - -{- | - encodeImage is a utility function that takes an image file path (jpg, jpeg, png) and - returns the image data in Base64 encoded format. Since GenerateOps' images field - expects image data in base64. It is helper function that we are providing out of the box. --} -encodeImage :: FilePath -> IO (Maybe Text) -encodeImage filePath = do - if not (isSupportedExtension filePath) - then return Nothing - else do - maybeContent <- asPath filePath - return $ fmap (TE.decodeUtf8 . Base64.encode) maybeContent diff --git a/src/Data/Ollama/Copy.hs b/src/Data/Ollama/Copy.hs deleted file mode 100644 --- a/src/Data/Ollama/Copy.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Copy - ( -- * Copy Model API - copyModel - ) where - -import Control.Monad (when) -import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics -import Network.HTTP.Client -import Network.HTTP.Types.Status (status404) - --- TODO: Add Options parameter --- TODO: Add Context parameter -data CopyModelOps = CopyModelOps - { source :: Text - , destination :: Text - } - deriving (Show, Eq, Generic, ToJSON) - --- | Copy model from source to destination -copyModel :: - -- | Source model - Text -> - -- | Destination model - Text -> - IO () -copyModel - source_ - destination_ = - do - let url = CU.defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/copy") - let reqBody = - CopyModelOps - { source = source_ - , destination = destination_ - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - response <- httpLbs request manager - when - (responseStatus response == status404) - (putStrLn "Source Model does not exist") diff --git a/src/Data/Ollama/Create.hs b/src/Data/Ollama/Create.hs deleted file mode 100644 --- a/src/Data/Ollama/Create.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Create - ( -- * Create Model API - createModel - , createModelOps - ) where - -import Control.Monad (unless) -import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Network.HTTP.Client - --- TODO: Add Options parameter --- TODO: Add Context parameter -data CreateModelOps = CreateModelOps - { name :: Text - , modelFile :: Maybe Text - , stream :: Maybe Bool - , path :: Maybe FilePath - } - deriving (Show, Eq) - --- TODO: Add Context Param -newtype CreateModelResp = CreateModelResp {status :: Text} - deriving (Show, Eq) - -instance ToJSON CreateModelOps where - toJSON - ( CreateModelOps - name_ - modelFile_ - stream_ - path_ - ) = - object - [ "name" .= name_ - , "modelfile" .= modelFile_ - , "stream" .= stream_ - , "path" .= path_ - ] - -instance FromJSON CreateModelResp where - parseJSON = withObject "CreateModelResp" $ \v -> - CreateModelResp - <$> v .: "status" - -{- | Create a new model either from ModelFile or Path -Please note, if you specify both ModelFile and Path, ModelFile will be used. --} -createModelOps :: - -- | Model Name - Text -> - -- | Model File - Maybe Text -> - -- | Stream - Maybe Bool -> - -- | Path - Maybe FilePath -> - IO () -createModelOps - modelName - modelFile_ - stream_ - path_ = - do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/create") - let reqBody = - CreateModelOps - { name = modelName - , modelFile = modelFile_ - , stream = stream_ - , path = path_ - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - withResponse request manager $ \response -> do - let go = do - bs <- brRead $ responseBody response - let eRes = - eitherDecode (BSL.fromStrict bs) :: - Either String CreateModelResp - case eRes of - Left err -> do - putStrLn $ "Error: " <> err - Right res -> do - unless - (status res /= "success") - ( do - T.putStr $ status res - go - ) - go - -{- | Create a new model -| Please note, if you specify both ModelFile and Path, ModelFile will be used. --} -createModel :: - -- | Model Name - Text -> - -- | Model File - Maybe Text -> - -- | Path - Maybe FilePath -> - IO () -createModel modelName modelFile_ = - createModelOps - modelName - modelFile_ - Nothing diff --git a/src/Data/Ollama/Delete.hs b/src/Data/Ollama/Delete.hs deleted file mode 100644 --- a/src/Data/Ollama/Delete.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Delete - ( -- * Delete downloaded Models - deleteModel - ) where - -import Control.Monad (when) -import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU -import Data.Text (Text) -import Data.Text qualified as T -import Network.HTTP.Client -import Network.HTTP.Types.Status (status404) - --- TODO: Add Options parameter --- TODO: Add Context parameter -newtype DeleteModelReq = DeleteModelReq {name :: Text} - deriving newtype (Show, Eq, ToJSON) - --- | Delete a model -deleteModel :: - -- | Model name - Text -> - IO () -deleteModel modelName = - do - let url = CU.defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/delete") - let reqBody = - DeleteModelReq {name = modelName} - request = - initialRequest - { method = "DELETE" - , requestBody = RequestBodyLBS $ encode reqBody - } - response <- httpLbs request manager - when - (responseStatus response == status404) - (putStrLn "Model does not exist") diff --git a/src/Data/Ollama/Embeddings.hs b/src/Data/Ollama/Embeddings.hs deleted file mode 100644 --- a/src/Data/Ollama/Embeddings.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Embeddings - ( -- * Embedding API - embedding - , embeddingOps - , EmbeddingOps (..) - , EmbeddingResp (..) - ) where - -import Data.Aeson -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import Network.HTTP.Client -import Control.Exception (try) -import Data.ByteString.Lazy.Char8 (ByteString) - --- TODO: Add Options parameter -data EmbeddingOps = EmbeddingOps - { model :: Text - , input :: Text - , truncate :: Maybe Bool - , keepAlive :: Maybe Text - } - deriving (Show, Eq) - -data EmbeddingResp = EmbeddingResp - { model :: Text - , embedding_ :: [[Float]] - } - deriving (Show, Eq) - -instance FromJSON EmbeddingResp where - parseJSON = withObject "EmbeddingResp" $ \v -> EmbeddingResp - <$> v .: "model" - <*> v .: "embeddings" - -instance ToJSON EmbeddingOps where - toJSON (EmbeddingOps model_ input_ truncate' keepAlive_) = - object - [ "model" .= model_ - , "input" .= input_ - , "truncate" .= truncate' - , "keep_alive" .= keepAlive_ - ] - --- TODO: Add Options parameter - --- | Embedding API -embeddingOps :: - -- | Model - Text -> - -- | Input - Text -> - -- | Truncate - Maybe Bool -> - -- | Keep Alive - Maybe Text -> - IO (Either String EmbeddingResp) -embeddingOps modelName input_ mTruncate mKeepAlive = do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - --einitialRequest <- parseRequest $ T.unpack (url <> "/api/embed") - eInitialRequest <- - try $ parseRequest $ T.unpack (url <> "/api/embed") :: IO (Either HttpException Request) - case eInitialRequest of - Left e -> do - return $ Left $ show e - Right initialRequest -> do - let reqBody = - EmbeddingOps - { model = modelName - , input = input_ - , truncate = mTruncate - , keepAlive = mKeepAlive - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - eResp <- try $ httpLbs request manager :: IO (Either HttpException (Response ByteString)) - case eResp of - Left err -> return $ Left (show err) - Right resp -> - case decode (responseBody resp) of - Nothing -> return $ Left $ "Couldn't decode response: " <> show (responseBody resp) - Just r -> return $ Right r - --- Higher level binding that only takes important params - --- | Embedding API -embedding :: - -- | Model - Text -> - -- | Input - Text -> - IO (Either String EmbeddingResp) -embedding modelName input_ = - embeddingOps modelName input_ Nothing Nothing diff --git a/src/Data/Ollama/Generate.hs b/src/Data/Ollama/Generate.hs deleted file mode 100644 --- a/src/Data/Ollama/Generate.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Ollama.Generate - ( -- * Generate Texts - generate - , defaultGenerateOps - , generateJson - , GenerateOps (..) - , GenerateResponse (..) - ) where - -import Control.Exception (try) -import Data.Aeson -import Data.ByteString.Char8 qualified as BS -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Maybe -import Data.Ollama.Common.Utils as CU -import Data.Ollama.Common.Types (Format(..)) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Data.Time (UTCTime) -import GHC.Int (Int64) -import Network.HTTP.Client - --- TODO: Add Options parameter --- TODO: Add Context parameter - -{- | - Input type for generate functions. This data type represents all possible configurations - that you can pass to the Ollama generate API. - - Example: - - > let ops = GenerateOps - > { modelName = "llama3.2" - > , prompt = "What is the meaning of life?" - > , suffix = Nothing - > , images = Nothing - > , format = Just "text" - > , system = Nothing - > , template = Nothing - > , stream = Nothing - > , raw = Just False - > , keepAlive = Just "yes" - > } --} -data GenerateOps = GenerateOps - { modelName :: Text - -- ^ The name of the model to be used for generation. - , prompt :: Text - -- ^ The prompt text that will be provided to the model for generating a response. - , suffix :: Maybe Text - -- ^ An optional suffix to append to the generated text. - , images :: Maybe [Text] - -- ^ Optional list of base64 encoded images to include with the request. - , format :: Maybe Format - -- ^ An optional format specifier for the response. - -- ^ Since 0.1.3.0 - , system :: Maybe Text - -- ^ Optional system text that can be included in the generation context. - , template :: Maybe Text - -- ^ An optional template to format the response. - , stream :: Maybe (GenerateResponse -> IO (), IO ()) - -- ^ An optional streaming function where the first function handles each chunk of response, and the second flushes the stream. - , raw :: Maybe Bool - -- ^ An optional flag to return the raw response. - , keepAlive :: Maybe Text - -- ^ Optional text to specify keep-alive behavior. - , hostUrl :: Maybe Text - -- ^ Override default Ollama host url. Default url = "http://127.0.0.1:11434" - , responseTimeOut :: Maybe Int - -- ^ Override default response timeout in minutes. Default = 15 minutes - , options :: Maybe Value - -- ^ additional model parameters listed in the documentation for the Modelfile such as temperature - -- ^ Since 0.1.3.0 - } - -instance Show GenerateOps where - show GenerateOps {..} = - "GenerateOps { " - <> "model : " - <> T.unpack modelName - <> ", prompt : " - <> T.unpack prompt - <> ", suffix : " - <> show suffix - <> ", images : " - <> show images - <> ", format : " - <> show format - <> ", system : " - <> show system - <> ", template : " - <> show template - <> ", stream : " - <> "Stream functions" - <> ", raw : " - <> show raw - <> ", keepAlive : " - <> show keepAlive - <> ", options : " - <> show options - -instance Eq GenerateOps where - (==) a b = - modelName a == modelName b - && prompt a == prompt b - && suffix a == suffix b - && images a == images b - && format a == format b - && system a == system b - && template a == template b - && raw a == raw b - && keepAlive a == keepAlive b - && options a == options b - --- TODO: Add Context Param - -{- | -Result type for generate function containing the model's response and meta-information. --} -data GenerateResponse = GenerateResponse - { model :: Text - -- ^ The name of the model that generated the response. - , createdAt :: UTCTime - -- ^ The timestamp when the response was created. - , response_ :: Text - -- ^ The generated response from the model. - , done :: Bool - -- ^ A flag indicating whether the generation process is complete. - , totalDuration :: Maybe Int64 - -- ^ Optional total duration in milliseconds for the generation process. - , loadDuration :: Maybe Int64 - -- ^ Optional load duration in milliseconds for loading the model. - , promptEvalCount :: Maybe Int64 - -- ^ Optional count of prompt evaluations during the generation process. - , promptEvalDuration :: Maybe Int64 - -- ^ Optional duration in milliseconds for evaluating the prompt. - , evalCount :: Maybe Int64 - -- ^ Optional count of evaluations during the generation process. - , evalDuration :: Maybe Int64 - -- ^ Optional duration in milliseconds for evaluations during the generation process. - } - deriving (Show, Eq) - -instance ToJSON GenerateOps where - toJSON - ( GenerateOps - model - prompt - suffix - images - format - system - template - stream - raw - keepAlive - _ -- Host url - _ -- Response timeout - options - ) = - object - [ "model" .= model - , "prompt" .= prompt - , "suffix" .= suffix - , "images" .= images - , "format" .= format - , "system" .= system - , "template" .= template - , "stream" .= if isNothing stream then Just False else Just True - , "raw" .= raw - , "keep_alive" .= keepAlive - , "options" .= options - ] - -instance FromJSON GenerateResponse where - parseJSON = withObject "GenerateResponse" $ \v -> - GenerateResponse - <$> v .: "model" - <*> v .: "created_at" - <*> v .: "response" - <*> v .: "done" - <*> v .:? "total_duration" - <*> v .:? "load_duration" - <*> v .:? "prompt_eval_count" - <*> v .:? "prompt_eval_duration" - <*> v .:? "eval_count" - <*> v .:? "eval_duration" - -{- | -A function to create a default 'GenerateOps' type with preset values. - -Example: - -> let ops = defaultGenerateOps -> generate ops - -This will generate a response using the default configuration. --} -defaultGenerateOps :: GenerateOps -defaultGenerateOps = - GenerateOps - { modelName = "llama3.2" - , prompt = "what is 2+2" - , suffix = Nothing - , images = Nothing - , format = Nothing - , system = Nothing - , template = Nothing - , stream = Nothing - , raw = Nothing - , keepAlive = Nothing - , hostUrl = Nothing - , responseTimeOut = Nothing - , options = Nothing - } - -{- | -Generate function that returns either a 'GenerateResponse' type or an error message. -It takes a 'GenerateOps' configuration and performs a request to the Ollama generate API. - -Examples: - -Basic usage without streaming: - -> let ops = GenerateOps -> { modelName = "llama3.2" -> , prompt = "Tell me a joke." -> , suffix = Nothing -> , images = Nothing -> , format = Nothing -> , system = Nothing -> , template = Nothing -> , stream = Nothing -> , raw = Nothing -> , keepAlive = Nothing -> } -> result <- generate ops -> case result of -> Left errorMsg -> putStrLn ("Error: " ++ errorMsg) -> Right response -> print response - -Usage with streaming to print responses to the console: - -> void $ -> generate -> defaultGenerateOps -> { modelName = "llama3.2" -> , prompt = "what is functional programming?" -> , stream = Just (T.putStr . response_, pure ()) -> } - -In this example, the first function in the 'stream' tuple processes each chunk of response by printing it, -and the second function is a simple no-op flush.generate :: GenerateOps -> IO (Either String GenerateResponse) --} -generate :: GenerateOps -> IO (Either String GenerateResponse) -generate genOps = do - let url = fromMaybe defaultOllamaUrl (hostUrl genOps) - responseTimeout = fromMaybe 15 (responseTimeOut genOps) - manager <- - newManager -- Setting response timeout to 5 minutes, since llm takes time - defaultManagerSettings - { managerResponseTimeout = responseTimeoutMicro (responseTimeout * 60 * 1000000) - } - eInitialRequest <- - try $ parseRequest $ T.unpack (url <> "/api/generate") :: IO (Either HttpException Request) - case eInitialRequest of - Left e -> do - return $ Left $ show e - Right initialRequest -> do - let reqBody = genOps - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - eRes <- - try (withResponse request manager $ handleRequest genOps) :: - IO (Either HttpException (Either String GenerateResponse)) - case eRes of - Left e -> do - return $ Left $ "HTTP error occured: " <> show e - Right r -> return r - -handleRequest :: GenerateOps -> Response BodyReader -> IO (Either String GenerateResponse) -handleRequest genOps response = do - let streamResponse sendChunk flush = do - bs <- brRead $ responseBody response - if BS.null bs - then putStrLn "" >> pure (Left "") - else do - let eRes = eitherDecode (BSL.fromStrict bs) :: Either String GenerateResponse - case eRes of - Left e -> pure (Left e) - Right r -> do - _ <- sendChunk r - _ <- flush - if done r then pure (Right r) else streamResponse sendChunk flush - let genResponse op = do - bs <- brRead $ responseBody response - if bs == "" - then do - let eRes0 = eitherDecode (BSL.fromStrict op) :: Either String GenerateResponse - case eRes0 of - Left e -> pure (Left e) - Right r -> pure (Right r) - else genResponse (op <> bs) - case stream genOps of - Nothing -> genResponse "" - Just (sendChunk, flush) -> streamResponse sendChunk flush - -{- | - generateJson is a higher level function that takes generateOps (similar to generate) and also takes - a Haskell type (that has To and From JSON instance) and returns the response in provided type. - - This function simply calls generate with extra prompt appended to it, telling LLM to return the - response in certain JSON format and serializes the response. This function will be helpful when you - want to use the LLM to do something programmatic. - - For Example: - > let expectedJsonStrucutre = Example { - > sortedList = ["sorted List here"] - > , wasListAlreadSorted = False - > } - > eRes2 <- generateJson - > defaultGenerateOps - > { modelName = "llama3.2" - > , prompt = "Sort given list: [4, 2 , 3, 67]. Also tell whether list was already sorted or not." - > } - > expectedJsonStrucutre - > Nothing - > case eRes2 of - > Left e -> putStrLn e - > Right r -> print ("JSON response: " :: String, r) - -Output: - > ("JSON response: ",Example {sortedList = ["1","2","3","4"], wasListAlreadSorted = False}) - -Note: While Passing the type, construct the type that will help LLM understand the field better. - For example, in the above example, the sortedList's value is written as "Sorted List here". This - will help LLM understand context better. - - You can also provide number of retries in case the LLM field to return the response in correct JSON - in first attempt. --} -generateJson :: - (ToJSON jsonResult, FromJSON jsonResult) => - GenerateOps -> - -- | Haskell type that you want your result in - jsonResult -> - -- | Max retries - Maybe Int -> - IO (Either String jsonResult) -generateJson genOps@GenerateOps {..} jsonStructure mMaxRetries = do - let jsonHelperPrompt = - "You are an AI that returns only JSON object. \n" - <> "* Your output should be a JSON object that matches the following schema: \n" - <> T.decodeUtf8 (BSL.toStrict $ encode jsonStructure) - <> prompt - <> "\n" - <> "# How to treat the task:\n" - <> "* Stricly follow the schema for the output.\n" - <> "* Never return anything other than a JSON object.\n" - <> "* Do not talk to the user.\n" - generatedResponse <- generate genOps {prompt = jsonHelperPrompt} - case generatedResponse of - Left err -> return $ Left err - Right r -> do - case decode (BSL.fromStrict . T.encodeUtf8 $ response_ r) of - Nothing -> do - case mMaxRetries of - Nothing -> return $ Left "Decoding Failed :(" - Just n -> - if n < 1 - then return $ Left "Decoding failed :(" - else generateJson genOps jsonStructure (Just (n - 1)) - Just resultInType -> return $ Right resultInType - - -{- | - Example usage of 'Ollama.generate' with a JSON schema format and options field. - - In this example we pass a JSON schema that expects an object with an integer field @age@. - The options field is supplied as a JSON value. - - >>> import Data.Aeson (Value, object, (.=)) - >>> import Ollama (GenerateOps, defaultGenerateOps, SchemaFormat) - >>> let x :: Value - ... x = object [ "type" .= ("object" :: String) - ... , "properties" .= object [ "age" .= object ["type" .= ("integer" :: String)] ] - ... ] - >>> let opts :: Value - ... opts = object ["option" .= ("some value" :: String)] - >>> generate defaultGenerateOps - ... { modelName = "llama3.2" - ... , prompt = "Ollama is 22 years old and is busy saving the world. Respond using JSON" - ... , format = Just (SchemaFormat x) - ... , options = opts - ... } - Right (GenerateResponse {model = "llama3.2", createdAt = 2025-03-25 09:34:15.853417157 UTC, - response_ = "{\n \"age\": 22\n}", done = True, - totalDuration = Just 6625631744, loadDuration = Just 2578791966, - promptEvalCount = Just 43, promptEvalDuration = Just 2983000000, - evalCount = Just 10, evalDuration = Just 1061000000}) --} - diff --git a/src/Data/Ollama/List.hs b/src/Data/Ollama/List.hs deleted file mode 100644 --- a/src/Data/Ollama/List.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.List - ( -- * List Models API - list - , Models (..) - , ModelInfo (..) - ) -where - -import Data.Aeson -import Data.Ollama.Common.Types as CT -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time -import GHC.Int (Int64) -import Network.HTTP.Client -import Network.HTTP.Types.Status (statusCode) - -newtype Models = Models [ModelInfo] - deriving (Eq, Show) - -data ModelInfo = ModelInfo - { name :: Text - , modifiedAt :: UTCTime - , size :: Int64 - , digest :: Text - , details :: ModelDetails - } - deriving (Eq, Show) - --- Instances -instance FromJSON Models where - parseJSON = withObject "Models" $ \v -> Models <$> v .: "models" - -instance FromJSON ModelInfo where - parseJSON = withObject "ModelInfo" $ \v -> - ModelInfo - <$> v .: "name" - <*> v .: "modified_at" - <*> v .: "size" - <*> v .: "digest" - <*> v .: "details" - --- | List all models from local -list :: IO (Maybe Models) -list = do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - request <- parseRequest $ T.unpack (url <> "/api/tags") - response <- httpLbs request manager - if statusCode (responseStatus response) /= 200 - then pure Nothing - else do - let res = decode (responseBody response) :: Maybe Models - case res of - Nothing -> pure Nothing - Just l -> pure $ Just l diff --git a/src/Data/Ollama/Ps.hs b/src/Data/Ollama/Ps.hs deleted file mode 100644 --- a/src/Data/Ollama/Ps.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Ps - ( ps - , RunningModels (..) - , RunningModel (..) - ) where - -import Data.Aeson -import Data.Ollama.Common.Types as CT -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time -import GHC.Int (Int64) -import Network.HTTP.Client -import Network.HTTP.Types.Status (statusCode) - --- Types for Ps API -newtype RunningModels = RunningModels [RunningModel] - deriving (Eq, Show) - -data RunningModel = RunningModel - { name_ :: Text - , modelName :: Text - , size_ :: Int64 - , modelDigest :: Text - , modelDetails :: ModelDetails - , expiresAt :: UTCTime - , sizeVRam :: Int64 - } - deriving (Eq, Show) - -instance FromJSON RunningModels where - parseJSON = withObject "Models" $ \v -> RunningModels <$> v .: "models" - -instance FromJSON RunningModel where - parseJSON = withObject "RunningModel" $ \v -> - RunningModel - <$> v .: "name" - <*> v .: "model" - <*> v .: "size" - <*> v .: "digest" - <*> v .: "details" - <*> v .: "expires_at" - <*> v .: "size_vram" - --- | List running models -ps :: IO (Maybe RunningModels) -ps = do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - request <- parseRequest $ T.unpack (url <> "/api/ps") - response <- httpLbs request manager - if statusCode (responseStatus response) /= 200 - then pure Nothing - else do - let res = decode (responseBody response) :: Maybe RunningModels - case res of - Nothing -> pure Nothing - Just l -> pure $ Just l diff --git a/src/Data/Ollama/Pull.hs b/src/Data/Ollama/Pull.hs deleted file mode 100644 --- a/src/Data/Ollama/Pull.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Pull - ( -- * Downloaded Models - pull - , pullOps - ) where - -import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Maybe (fromMaybe) -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics -import GHC.Int (Int64) -import Network.HTTP.Client - --- TODO: Add Options parameter - --- | Configuration options for pulling a model. -data PullOps = PullOps - { name :: Text - -- ^ The name of the model to pull. - , insecure :: Maybe Bool - -- ^ Option to allow insecure connections. - -- If set to 'Just True', the pull operation will allow insecure connections. - , stream :: Maybe Bool - -- ^ Option to enable streaming of the download. - -- If set to 'Just True', the download will be streamed. - } - deriving (Show, Eq, Generic, ToJSON) - --- | Response data from a pull operation. -data PullResp = PullResp - { status :: Text - -- ^ The status of the pull operation, e.g., "success" or "failure". - , digest :: Maybe Text - -- ^ The digest of the model, if available. - , total :: Maybe Int64 - -- ^ The total size of the model in bytes, if available. - , completed :: Maybe Int64 - -- ^ The number of bytes completed, if available. - } - deriving (Show, Eq, Generic, FromJSON) - -{- | -Pull a model with additional options for insecure connections and streaming. -This function interacts directly with the Ollama API to download the specified model. - -Example: - -> pullOps "myModel" (Just True) (Just True) - -This will attempt to pull "myModel" with insecure connections allowed and enable streaming. --} -pullOps :: - -- | Model Name - Text -> - -- | Insecure - Maybe Bool -> - -- | Stream - Maybe Bool -> - IO () -pullOps modelName mInsecure mStream = do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/pull") - let reqBody = - PullOps - { name = modelName - , insecure = mInsecure - , stream = mStream - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - withResponse request manager $ \response -> do - let go = do - bs <- brRead $ responseBody response - let eRes = decode (BSL.fromStrict bs) :: Maybe PullResp - case eRes of - Nothing -> putStrLn "Something went wrong" - Just res -> do - if status res /= "success" - then do - let completed' = fromMaybe 0 (completed res) - let total' = fromMaybe 0 (total res) - putStrLn $ "Remaining bytes: " <> show (total' - completed') - go - else do - putStrLn "Completed" - go - -{- | -Pull a model using default options. This simplifies the pull operation by -not requiring additional options. - -Example: - -> pull "myModel" - -This will pull "myModel" using default settings (no insecure connections and no streaming). --} -pull :: - -- | Model Name - Text -> - IO () -pull modelName = pullOps modelName Nothing Nothing diff --git a/src/Data/Ollama/Push.hs b/src/Data/Ollama/Push.hs deleted file mode 100644 --- a/src/Data/Ollama/Push.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Push - ( -- * Push API - push - , pushOps - ) where - -import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Maybe (fromMaybe) -import Data.Ollama.Common.Utils as CU -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics -import GHC.Int (Int64) -import Network.HTTP.Client - --- TODO: Add Options parameter -data PushOps = PushOps - { name :: Text - , insecure :: Maybe Bool - , stream :: Maybe Bool - } - deriving (Show, Eq, Generic, ToJSON) - -data PushResp = PushResp - { status :: Text - , digest :: Maybe Text - , total :: Maybe Int64 - } - deriving (Show, Eq, Generic, FromJSON) - --- | Push a model with options -pushOps :: - -- | Model name - Text -> - -- | Insecure - Maybe Bool -> - -- | Stream - Maybe Bool -> - IO () -pushOps modelName mInsecure mStream = do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/push") - let reqBody = - PushOps - { name = modelName - , insecure = mInsecure - , stream = mStream - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - withResponse request manager $ \response -> do - let go = do - bs <- brRead $ responseBody response - let eRes = decode (BSL.fromStrict bs) :: Maybe PushResp - case eRes of - Nothing -> putStrLn "Something went wrong" - Just res -> do - if status res /= "success" - then do - let total' = fromMaybe 0 (total res) - putStrLn $ "Remaining bytes: " <> show total' - go - else do - putStrLn "Completed" - go - --- Higher level API for Pull --- This API is untested. Will test soon! - --- | Push a model -push :: - -- | Model name - Text -> - IO () -push modelName = pushOps modelName Nothing Nothing diff --git a/src/Data/Ollama/Show.hs b/src/Data/Ollama/Show.hs deleted file mode 100644 --- a/src/Data/Ollama/Show.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Ollama.Show - ( -- * Show Model Info API - showModel - , showModelOps - , ShowModelResponse (..) - ) where - -import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics -import GHC.Int (Int64) -import Network.HTTP.Client - --- TODO: Add Options parameter --- TODO: Add Context parameter - -{- | - #ShowModelOps# - Input parameters for show model information. --} -data ShowModelOps = ShowModelOps - { name :: Text - , verbose :: Maybe Bool - } - deriving (Show, Eq, Generic, ToJSON) - -{- | - #ShowModelResponse# - - Ouput structure for show model information. --} -data ShowModelResponse = ShowModelResponse - { modelFile :: Text - , parameters :: Text - , template :: Text - , details :: ModelDetails - , modelInfo :: ModelInfo - } - deriving (Show, Eq) - -data ModelDetails = ModelDetails - { parentModel :: Text - , format :: Text - , familiy :: Text - , families :: [Text] - , parameterSize :: Text - , quantizationLevel :: Text - } - deriving (Show, Eq) - -data ModelInfo = ModelInfo - { generalArchitecture :: Maybe Text - , generalFileType :: Maybe Int - , generalParameterCount :: Maybe Int64 - , generalQuantizationVersion :: Maybe Int - , llamaAttentionHeadCount :: Maybe Int - , llamaAttentionHeadCountKV :: Maybe Int - , llamaAttentionLayerNormRMSEpsilon :: Maybe Float - , llamaBlockCount :: Maybe Int - , llamaContextLength :: Maybe Int - , llamaEmbeddingLength :: Maybe Int - , llamaFeedForwardLength :: Maybe Int - , llamaRopeDimensionCount :: Maybe Int - , llamaRopeFreqBase :: Maybe Int64 - , llamaVocabSize :: Maybe Int64 - , tokenizerGgmlBosToken_id :: Maybe Int - , tokenizerGgmlEosToken_id :: Maybe Int - , tokenizerGgmlMerges :: Maybe [Text] - , tokenizerGgmlMode :: Maybe Text - , tokenizerGgmlPre :: Maybe Text - , tokenizerGgmlTokenType :: Maybe [Text] - , tokenizerGgmlTokens :: Maybe [Text] - } - deriving (Show, Eq) - --- FromJSON instances - --- | The instance for show model response -instance FromJSON ShowModelResponse where - parseJSON = withObject "ShowModelResponse" $ \v -> - ShowModelResponse - <$> v .: "modelfile" - <*> v .: "parameters" - <*> v .: "template" - <*> v .: "details" - <*> v .: "model_info" - -instance FromJSON ModelDetails where - parseJSON = withObject "ModelDetails" $ \v -> - ModelDetails - <$> v .: "parent_model" - <*> v .: "format" - <*> v .: "family" - <*> v .: "families" - <*> v .: "parameter_size" - <*> v .: "quantization_level" - -instance FromJSON ModelInfo where - parseJSON = withObject "ModelInfo" $ \v -> - ModelInfo - <$> v .:? "general.architecture" - <*> v .:? "general.file_type" - <*> v .:? "general.parameter_count" - <*> v .:? "general.quantization_version" - <*> v .:? "llama.attention.head_count" - <*> v .:? "llama.attention.head_count_kv" - <*> v .:? "llama.attention.layer_norm_rms_epsilon" - <*> v .:? "llama.block_count" - <*> v .:? "llama.context_length" - <*> v .:? "llama.embedding_length" - <*> v .:? "llama.feed_forward_length" - <*> v .:? "llama.rope.dimension_count" - <*> v .:? "llama.rope.freq_base" - <*> v .:? "llama.vocab_size" - <*> v .:? "tokenizer.ggml.bos_token_id" - <*> v .:? "tokenizer.ggml.eos_token_id" - <*> v .:? "tokenizer.ggml.merges" - <*> v .:? "tokenizer.ggml.model" - <*> v .:? "tokenizer.ggml.pre" - <*> v .:? "tokenizer.ggml.token_type" - <*> v .:? "tokenizer.ggml.tokens" - -{- | Show given model's information with options. - -@since 1.0.0.0 --} -showModelOps :: - -- | model name - Text -> - -- | verbose - Maybe Bool -> - IO (Maybe ShowModelResponse) -showModelOps - modelName - verbose_ = - do - let url = CU.defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/show") - let reqBody = - ShowModelOps - { name = modelName - , verbose = verbose_ - } - request = - initialRequest - { method = "POST" - , requestBody = RequestBodyLBS $ encode reqBody - } - response <- httpLbs request manager - let eRes = - eitherDecode (responseBody response) :: - Either String ShowModelResponse - case eRes of - Left _ -> pure Nothing - Right r -> pure $ Just r - -{- | Show given model's information. - -Higher level API for show. -@since 1.0.0.0 --} -showModel :: - -- | model name - Text -> - IO (Maybe ShowModelResponse) -showModel modelName = - showModelOps modelName Nothing diff --git a/src/Ollama.hs b/src/Ollama.hs --- a/src/Ollama.hs +++ b/src/Ollama.hs @@ -1,94 +1,197 @@ -{-# LANGUAGE DuplicateRecordFields #-} {- | - #Ollama-Haskell# - This library lets you run LlMs from within Haskell projects. Inspired by `ollama-python`. +Module : Ollama +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Top-level umbrella re-export module for the Ollama Haskell client library. + +== Quick Example + +@ +import Ollama + +main :: IO () +main = do + client <- defaultClient + let req = chatRequest "llama3.2" (userMessage "Why is the sky blue?" :| []) + result <- chat client req + case result of + Left err -> print err + Right resp -> case crMessage resp of + Just msg -> putStrLn (messageContent msg) + Nothing -> putStrLn "No message returned" +@ + +@since 1.0.0.0 -} -module Ollama - ( -- * Main APIs +module Ollama ( + -- * Client + OllamaClient, + newClient, + defaultClient, + clientFromEnv, + closeClient, + withClient, - -- ** Generate Texts - generate - , generateJson - , defaultGenerateOps - , GenerateOps (..) - , GenerateResponse (..) + -- * Config & Retry + OllamaClientConfig (..), + defaultConfig, + RetryPolicy (..), + LogLevel (..), - -- ** Chat with LLMs - , chat - , chatJson - , Role (..) - , defaultChatOps - , ChatResponse (..) - , ChatOps (..) + -- * API Endpoints - -- ** Embeddings - , embedding - , embeddingOps - , EmbeddingOps (..) - , EmbeddingResp (..) + -- ** Chat + chat, + chatStream, + ChatRequest (..), + ChatResponse (..), + chatRequest, + chatEvalTokensPerSecond, + chatPromptEvalTokensPerSecond, - -- * Ollama operations + -- ** Generate + generate, + generateStream, + GenerateRequest (..), + GenerateResponse (..), + generateRequest, + evalTokensPerSecond, + promptEvalTokensPerSecond, - -- ** Copy Models - , copyModel + -- ** Embeddings + embed, + EmbedRequest (..), + EmbedResponse (..), + embedRequest, + embeddings, + EmbeddingsRequest (..), + EmbeddingsResponse (..), - -- ** Create Models - , createModel - , createModelOps + -- ** Model Management + listModels, + showModel, + copyModel, + deleteModel, + ListResponse (..), + ModelInfo (..), + RunningModel (..), + ShowResponse (..), - -- ** Delete Models - , deleteModel + -- ** Create + createModel, + createModelStream, + defaultCreateRequest, + CreateRequest (..), + CreateResponse (..), + QuantizationType (..), - -- ** List Models - , list + -- ** Pull & Push + pull, + pullStream, + push, + pushStream, + PullResponse (..), + PushResponse (..), - -- ** List currently running models - , ps + -- ** Blobs + checkBlob, + pushBlob, - -- ** Push and Pull - , push - , pushOps - , pull - , pullOps + -- ** System + getVersion, + listRunning, + RunningModelsResponse (..), - -- ** Show Model Info - , showModel - , showModelOps + -- * Types & Primitives + ModelName (..), + mkModelName, + Digest (..), + Base64Image (..), + Duration (..), + durationToSeconds, + durationToMillis, + tokensPerSecond, + Version (..), + Think (..), + ThinkingLevel (..), - -- * Types - , ShowModelResponse (..) - , Models (..) - , ModelInfo (..) - , RunningModels (..) - , RunningModel (..) - , Message (..) - , Format(..) - ) -where + -- ** Messages + Role (..), + Message (..), + userMessage, + systemMessage, + assistantMessage, + toolMessage, + toolResultMessage, + imageMessage, -import Data.Ollama.Chat - ( ChatOps (..) - , ChatResponse (..) - , Message (..) - , Role (..) - , chat - , chatJson - , defaultChatOps - ) -import Data.Ollama.Copy (copyModel) -import Data.Ollama.Create (createModel, createModelOps) -import Data.Ollama.Delete (deleteModel) -import Data.Ollama.Embeddings (embedding, embeddingOps, EmbeddingOps (..), EmbeddingResp (..)) -import Data.Ollama.Generate - ( GenerateOps (..) - , GenerateResponse (..) - , defaultGenerateOps - , generate - , generateJson - ) -import Data.Ollama.List (ModelInfo (..), Models (..), list) -import Data.Ollama.Ps (RunningModel (..), RunningModels (..), ps) -import Data.Ollama.Pull (pull, pullOps) -import Data.Ollama.Push (push, pushOps) -import Data.Ollama.Show (ShowModelResponse (..), showModel, showModelOps) -import Data.Ollama.Common.Types (Format (..)) + -- ** Tools & Functions + Tool (..), + FunctionDef (..), + FunctionParameters (..), + ToolCall (..), + ToolCallFunction (..), + + -- ** Options & Format + ModelOptions (..), + defaultOptions, + Format (..), + ToSchema (..), + ToJsonType (..), + schemaFor, + formatFor, + + -- * Error Handling + OllamaError (..), + isRetryable, + throwOllama, + + -- * Streaming + HasDone (..), + collectStream, + foldStream, + + -- * Testing Infrastructure + newMockClient, + withMockClient, + mockGenerateResponse, + mockChatResponse, + mockEmbedResponse, + mockListModelsResponse, + + -- * Conversation Store + Conversation (..), + ConversationStore (..), + InMemoryStore (..), + initInMemoryStore, + saveConversationInMemory, + loadConversationInMemory, + listConversationsInMemory, + deleteConversationInMemory, + + -- * Model Context Protocol (MCP) Integration + module Ollama.MCP, +) where + +import Ollama.API.Blobs +import Ollama.API.Chat +import Ollama.API.Embed +import Ollama.API.Generate +import Ollama.API.Models +import Ollama.API.Models.Create +import Ollama.API.Models.Pull +import Ollama.API.Models.Push +import Ollama.API.Ps +import Ollama.API.Version +import Ollama.Client +import Ollama.Client.Config +import Ollama.Conversation +import Ollama.Error +import Ollama.MCP +import Ollama.Streaming +import Ollama.Testing +import Ollama.Types diff --git a/src/Ollama/API/Blobs.hs b/src/Ollama/API/Blobs.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Blobs.hs @@ -0,0 +1,45 @@ +{- | +Module : Ollama.API.Blobs +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Blob management endpoints (@/api/blobs/:digest@). + +@since 1.0.0.0 +-} +module Ollama.API.Blobs ( + checkBlob, + pushBlob, +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.ByteString (ByteString) +import Data.Functor (void) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (requestRaw) +import Ollama.Error (OllamaError (..)) +import Ollama.Types.Common (Digest (..)) + +{- | Check if a blob exists on the server (@HEAD /api/blobs/:digest@). + +@since 1.0.0.0 +-} +checkBlob :: (MonadIO m) => OllamaClient -> Digest -> m (Either OllamaError Bool) +checkBlob client (Digest d) = do + res <- requestRaw client "HEAD" ("/api/blobs/" <> d) Nothing + pure $ case res of + Right _ -> Right True + Left (ApiError 404 _) -> Right False + Left err -> Left err + +{- | Push / upload a file blob to the server (@POST /api/blobs/:digest@). + +@since 1.0.0.0 +-} +pushBlob :: (MonadIO m) => OllamaClient -> Digest -> ByteString -> m (Either OllamaError ()) +pushBlob client (Digest d) payload = do + res <- requestRaw client "POST" ("/api/blobs/" <> d) (Just payload) + pure $ void res diff --git a/src/Ollama/API/Chat.hs b/src/Ollama/API/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Chat.hs @@ -0,0 +1,170 @@ +{- | +Module : Ollama.API.Chat +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Chat completion API endpoint (@/api/chat@). + +@since 1.0.0.0 +-} +module Ollama.API.Chat ( + ChatRequest (..), + ChatResponse (..), + chatRequest, + chat, + chatStream, + chatEvalTokensPerSecond, + chatPromptEvalTokensPerSecond, +) where + +import Conduit (ConduitT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request, requestStreaming) +import Ollama.Error (OllamaError) +import Ollama.Streaming (HasDone (..)) +import Ollama.Types.Common (Duration, ModelName, Think, tokensPerSecond) +import Ollama.Types.Format (Format) +import Ollama.Types.Message (Message) +import Ollama.Types.Options (ModelOptions) +import Ollama.Types.Tool (Tool) + +{- | Chat completion request payload. + +@since 1.0.0.0 +-} +data ChatRequest = ChatRequest + { chatModel :: !ModelName + , chatMessages :: !(NonEmpty Message) + , chatTools :: !(Maybe [Tool]) + , chatFormat :: !(Maybe Format) + , chatOptions :: !(Maybe ModelOptions) + , chStream :: !(Maybe Bool) + , chatKeepAlive :: !(Maybe Text) + , chatThink :: !(Maybe Think) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ChatRequest where + toJSON ChatRequest {..} = + object $ + catMaybes + [ Just $ "model" .= chatModel + , Just $ "messages" .= chatMessages + , ("tools" .=) <$> chatTools + , ("format" .=) <$> chatFormat + , ("options" .=) <$> chatOptions + , ("stream" .=) <$> chStream + , ("keep_alive" .=) <$> chatKeepAlive + , ("think" .=) <$> chatThink + ] + +{- | Create a default 'ChatRequest' for a model and message history. + +@since 1.0.0.0 +-} +chatRequest :: ModelName -> NonEmpty Message -> ChatRequest +chatRequest model msgs = + ChatRequest + { chatModel = model + , chatMessages = msgs + , chatTools = Nothing + , chatFormat = Nothing + , chatOptions = Nothing + , chStream = Just False + , chatKeepAlive = Nothing + , chatThink = Nothing + } + +{- | Chat completion response payload. + +@since 1.0.0.0 +-} +data ChatResponse = ChatResponse + { crModel :: !ModelName + , crCreatedAt :: !UTCTime + , crMessage :: !(Maybe Message) + , crDone :: !Bool + , crDoneReason :: !(Maybe Text) + , crTotalDuration :: !(Maybe Duration) + , crLoadDuration :: !(Maybe Duration) + , crPromptEvalCount :: !(Maybe Int) + , crPromptEvalDuration :: !(Maybe Duration) + , crEvalCount :: !(Maybe Int) + , crEvalDuration :: !(Maybe Duration) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ChatResponse where + parseJSON = withObject "ChatResponse" $ \v -> + ChatResponse + <$> v .: "model" + <*> v .: "created_at" + <*> v .:? "message" + <*> v .: "done" + <*> v .:? "done_reason" + <*> v .:? "total_duration" + <*> v .:? "load_duration" + <*> v .:? "prompt_eval_count" + <*> v .:? "prompt_eval_duration" + <*> v .:? "eval_count" + <*> v .:? "eval_duration" + +instance ToJSON ChatResponse where + toJSON ChatResponse {..} = + object + [ "model" .= crModel + , "created_at" .= crCreatedAt + , "message" .= crMessage + , "done" .= crDone + , "done_reason" .= crDoneReason + , "total_duration" .= crTotalDuration + , "load_duration" .= crLoadDuration + , "prompt_eval_count" .= crPromptEvalCount + , "prompt_eval_duration" .= crPromptEvalDuration + , "eval_count" .= crEvalCount + , "eval_duration" .= crEvalDuration + ] + +instance HasDone ChatResponse where + isDone = crDone + +{- | Non-streaming chat completion API. + +@since 1.0.0.0 +-} +chat :: (MonadIO m) => OllamaClient -> ChatRequest -> m (Either OllamaError ChatResponse) +chat client req = request client "POST" "/api/chat" (Just req {chStream = Just False}) + +{- | Streaming chat completion API yielding 'ChatResponse' chunks. + +@since 1.0.0.0 +-} +chatStream :: (MonadUnliftIO m) => OllamaClient -> ChatRequest -> ConduitT () ChatResponse m () +chatStream client req = requestStreaming client "/api/chat" (req {chStream = Just True}) + +{- | Calculate generation throughput (eval tokens \/ second) from a 'ChatResponse'. + +@since 1.0.0.0 +-} +chatEvalTokensPerSecond :: ChatResponse -> Maybe Double +chatEvalTokensPerSecond ChatResponse {..} = + tokensPerSecond <$> crEvalCount <*> crEvalDuration + +{- | Calculate prompt evaluation throughput (prompt tokens \/ second) from a 'ChatResponse'. + +@since 1.0.0.0 +-} +chatPromptEvalTokensPerSecond :: ChatResponse -> Maybe Double +chatPromptEvalTokensPerSecond ChatResponse {..} = + tokensPerSecond <$> crPromptEvalCount <*> crPromptEvalDuration diff --git a/src/Ollama/API/Embed.hs b/src/Ollama/API/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Embed.hs @@ -0,0 +1,175 @@ +{- | +Module : Ollama.API.Embed +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Vector embeddings API endpoint (@/api/embed@). + +@since 1.0.0.0 +-} +module Ollama.API.Embed ( + EmbedRequest (..), + EmbedResponse (..), + embedRequest, + embed, + + -- * Deprecated Legacy API + EmbeddingsRequest (..), + EmbeddingsResponse (..), + embeddings, +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request) +import Ollama.Error (OllamaError) +import Ollama.Types.Common (Duration, ModelName) +import Ollama.Types.Options (ModelOptions) + +{- | Embedding request payload for single text or batch list of texts. + +@since 1.0.0.0 +-} +data EmbedRequest = EmbedRequest + { embModel :: !ModelName + , embInput :: !(Either Text [Text]) + , embTruncate :: !(Maybe Bool) + , embOptions :: !(Maybe ModelOptions) + , embKeepAlive :: !(Maybe Text) + , embDimensions :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON EmbedRequest where + toJSON EmbedRequest {..} = + object $ + catMaybes + [ Just $ "model" .= embModel + , Just $ case embInput of + Left single -> "input" .= single + Right multiple -> "input" .= multiple + , ("truncate" .=) <$> embTruncate + , ("options" .=) <$> embOptions + , ("keep_alive" .=) <$> embKeepAlive + , ("dimensions" .=) <$> embDimensions + ] + +{- | Create an 'EmbedRequest' for a list of input texts. + +@since 1.0.0.0 +-} +embedRequest :: ModelName -> [Text] -> EmbedRequest +embedRequest model inputs = + EmbedRequest + { embModel = model + , embInput = Right inputs + , embTruncate = Nothing + , embOptions = Nothing + , embKeepAlive = Nothing + , embDimensions = Nothing + } + +{- | Embedding response payload containing vector embeddings. + +@since 1.0.0.0 +-} +data EmbedResponse = EmbedResponse + { erModel :: !ModelName + , erEmbeddings :: ![[Double]] + , erTotalDuration :: !(Maybe Duration) + , erLoadDuration :: !(Maybe Duration) + , erPromptEvalCount :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON EmbedResponse where + parseJSON = withObject "EmbedResponse" $ \v -> + EmbedResponse + <$> v .: "model" + <*> v .: "embeddings" + <*> v .:? "total_duration" + <*> v .:? "load_duration" + <*> v .:? "prompt_eval_count" + +instance ToJSON EmbedResponse where + toJSON EmbedResponse {..} = + object + [ "model" .= erModel + , "embeddings" .= erEmbeddings + , "total_duration" .= erTotalDuration + , "load_duration" .= erLoadDuration + , "prompt_eval_count" .= erPromptEvalCount + ] + +{- | Generate vector embeddings. + +@since 1.0.0.0 +-} +embed :: (MonadIO m) => OllamaClient -> EmbedRequest -> m (Either OllamaError EmbedResponse) +embed client req = request client "POST" "/api/embed" (Just req) + +{- | Legacy request payload for deprecated @/api/embeddings@ endpoint. + +@since 1.0.0.0 +-} +data EmbeddingsRequest = EmbeddingsRequest + { ebrModel :: !ModelName + , ebrPrompt :: !Text + , ebrOptions :: !(Maybe ModelOptions) + , ebrKeepAlive :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON EmbeddingsRequest where + toJSON EmbeddingsRequest {..} = + object $ + catMaybes + [ Just $ "model" .= ebrModel + , Just $ "prompt" .= ebrPrompt + , ("options" .=) <$> ebrOptions + , ("keep_alive" .=) <$> ebrKeepAlive + ] + +instance FromJSON EmbeddingsRequest where + parseJSON = withObject "EmbeddingsRequest" $ \v -> + EmbeddingsRequest + <$> v .: "model" + <*> v .: "prompt" + <*> v .:? "options" + <*> v .:? "keep_alive" + +{- | Legacy response payload for deprecated @/api/embeddings@ endpoint. + +@since 1.0.0.0 +-} +newtype EmbeddingsResponse = EmbeddingsResponse + { ebrEmbedding :: [Double] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON EmbeddingsResponse where + parseJSON = withObject "EmbeddingsResponse" $ \v -> + EmbeddingsResponse <$> v .: "embedding" + +instance ToJSON EmbeddingsResponse where + toJSON EmbeddingsResponse {..} = + object ["embedding" .= ebrEmbedding] + +{- | Generate vector embeddings using the deprecated @/api/embeddings@ endpoint. + +@since 1.0.0.0 +-} +embeddings :: + (MonadIO m) => + OllamaClient -> + EmbeddingsRequest -> + m (Either OllamaError EmbeddingsResponse) +embeddings client req = request client "POST" "/api/embeddings" (Just req) +{-# DEPRECATED embeddings "Use embed instead" #-} diff --git a/src/Ollama/API/Generate.hs b/src/Ollama/API/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Generate.hs @@ -0,0 +1,199 @@ +{- | +Module : Ollama.API.Generate +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Text completion API endpoint (@/api/generate@). + +@since 1.0.0.0 +-} +module Ollama.API.Generate ( + GenerateRequest (..), + GenerateResponse (..), + generateRequest, + generate, + generateStream, + evalTokensPerSecond, + promptEvalTokensPerSecond, +) where + +import Conduit (ConduitT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request, requestStreaming) +import Ollama.Error (OllamaError) +import Ollama.Streaming (HasDone (..)) +import Ollama.Types.Common (Base64Image, Duration, ModelName, Think, tokensPerSecond) +import Ollama.Types.Format (Format) +import Ollama.Types.Options (ModelOptions) + +{- | Request payload for text generation completion. + +@since 1.0.0.0 +-} +data GenerateRequest = GenerateRequest + { genModel :: !ModelName + , genPrompt :: !Text + , genSuffix :: !(Maybe Text) + , genImages :: !(Maybe [Base64Image]) + , genFormat :: !(Maybe Format) + , genOptions :: !(Maybe ModelOptions) + , genSystem :: !(Maybe Text) + , genTemplate :: !(Maybe Text) + , genStream :: !(Maybe Bool) + , genRaw :: !(Maybe Bool) + , genKeepAlive :: !(Maybe Text) + , genThink :: !(Maybe Think) + , genWidth :: !(Maybe Int) + , genHeight :: !(Maybe Int) + , genSteps :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON GenerateRequest where + toJSON GenerateRequest {..} = + object $ + catMaybes + [ Just $ "model" .= genModel + , Just $ "prompt" .= genPrompt + , ("suffix" .=) <$> genSuffix + , ("images" .=) <$> genImages + , ("format" .=) <$> genFormat + , ("options" .=) <$> genOptions + , ("system" .=) <$> genSystem + , ("template" .=) <$> genTemplate + , ("stream" .=) <$> genStream + , ("raw" .=) <$> genRaw + , ("keep_alive" .=) <$> genKeepAlive + , ("think" .=) <$> genThink + , ("width" .=) <$> genWidth + , ("height" .=) <$> genHeight + , ("steps" .=) <$> genSteps + ] + +{- | Create a default 'GenerateRequest' for a model and prompt. + +@since 1.0.0.0 +-} +generateRequest :: ModelName -> Text -> GenerateRequest +generateRequest model prompt = + GenerateRequest + { genModel = model + , genPrompt = prompt + , genSuffix = Nothing + , genImages = Nothing + , genFormat = Nothing + , genOptions = Nothing + , genSystem = Nothing + , genTemplate = Nothing + , genStream = Just False + , genRaw = Nothing + , genKeepAlive = Nothing + , genThink = Nothing + , genWidth = Nothing + , genHeight = Nothing + , genSteps = Nothing + } + +{- | Response payload returned by text generation. + +@since 1.0.0.0 +-} +data GenerateResponse = GenerateResponse + { grModel :: !ModelName + , grCreatedAt :: !UTCTime + , grResponse :: !Text + , grDone :: !Bool + , grDoneReason :: !(Maybe Text) + , grContext :: !(Maybe [Int]) + , grTotalDuration :: !(Maybe Duration) + , grLoadDuration :: !(Maybe Duration) + , grPromptEvalCount :: !(Maybe Int) + , grPromptEvalDuration :: !(Maybe Duration) + , grEvalCount :: !(Maybe Int) + , grEvalDuration :: !(Maybe Duration) + , grThinking :: !(Maybe Text) + , grImage :: !(Maybe Base64Image) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GenerateResponse where + parseJSON = withObject "GenerateResponse" $ \v -> + GenerateResponse + <$> v .: "model" + <*> v .: "created_at" + <*> v .: "response" + <*> v .: "done" + <*> v .:? "done_reason" + <*> v .:? "context" + <*> v .:? "total_duration" + <*> v .:? "load_duration" + <*> v .:? "prompt_eval_count" + <*> v .:? "prompt_eval_duration" + <*> v .:? "eval_count" + <*> v .:? "eval_duration" + <*> v .:? "thinking" + <*> v .:? "image" + +instance ToJSON GenerateResponse where + toJSON GenerateResponse {..} = + object + [ "model" .= grModel + , "created_at" .= grCreatedAt + , "response" .= grResponse + , "done" .= grDone + , "done_reason" .= grDoneReason + , "context" .= grContext + , "total_duration" .= grTotalDuration + , "load_duration" .= grLoadDuration + , "prompt_eval_count" .= grPromptEvalCount + , "prompt_eval_duration" .= grPromptEvalDuration + , "eval_count" .= grEvalCount + , "eval_duration" .= grEvalDuration + , "thinking" .= grThinking + , "image" .= grImage + ] + +instance HasDone GenerateResponse where + isDone = grDone + +{- | Non-streaming text completion API. + +@since 1.0.0.0 +-} +generate :: + (MonadIO m) => OllamaClient -> GenerateRequest -> m (Either OllamaError GenerateResponse) +generate client req = request client "POST" "/api/generate" (Just req {genStream = Just False}) + +{- | Streaming text completion API yielding 'GenerateResponse' chunks. + +@since 1.0.0.0 +-} +generateStream :: + (MonadUnliftIO m) => OllamaClient -> GenerateRequest -> ConduitT () GenerateResponse m () +generateStream client req = requestStreaming client "/api/generate" (req {genStream = Just True}) + +{- | Calculate generation throughput (eval tokens \/ second) from a 'GenerateResponse'. + +@since 1.0.0.0 +-} +evalTokensPerSecond :: GenerateResponse -> Maybe Double +evalTokensPerSecond GenerateResponse {..} = + tokensPerSecond <$> grEvalCount <*> grEvalDuration + +{- | Calculate prompt evaluation throughput (prompt tokens \/ second) from a 'GenerateResponse'. + +@since 1.0.0.0 +-} +promptEvalTokensPerSecond :: GenerateResponse -> Maybe Double +promptEvalTokensPerSecond GenerateResponse {..} = + tokensPerSecond <$> grPromptEvalCount <*> grPromptEvalDuration diff --git a/src/Ollama/API/Models.hs b/src/Ollama/API/Models.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Models.hs @@ -0,0 +1,171 @@ +{- | +Module : Ollama.API.Models +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model management endpoints (list, show, copy, delete). + +@since 1.0.0.0 +-} +module Ollama.API.Models ( + -- * Listing + listModels, + ListResponse (..), + + -- * Show Info + showModel, + ShowRequest (..), + ShowResponse (..), + ShowModelInfo (..), + + -- * Copy + copyModel, + CopyRequest (..), + + -- * Delete + deleteModel, + DeleteRequest (..), +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request) +import Ollama.Error (OllamaError) +import Ollama.Types.Common (ModelName) +import Ollama.Types.Model (ListResponse (..), ModelDetails (..)) + +{- | Show model info request payload. + +@since 1.0.0.0 +-} +data ShowRequest = ShowRequest + { srqModel :: !ModelName + , srqVerbose :: !(Maybe Bool) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ShowRequest where + toJSON ShowRequest {..} = + object $ + catMaybes + [ Just $ "model" .= srqModel + , ("verbose" .=) <$> srqVerbose + ] + +{- | Detailed technical parameters from model metadata. + +@since 1.0.0.0 +-} +newtype ShowModelInfo = ShowModelInfo + { modelInfoMap :: Map Text Value + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ShowModelInfo where + parseJSON v = ShowModelInfo <$> parseJSON v + +instance ToJSON ShowModelInfo where + toJSON (ShowModelInfo m) = toJSON m + +{- | Model inspection response payload. + +@since 1.0.0.0 +-} +data ShowResponse = ShowResponse + { srsModelfile :: !Text + , srsParameters :: !(Maybe Text) + , srsTemplate :: !(Maybe Text) + , srsDetails :: !ModelDetails + , srsModelInfo :: !(Maybe ShowModelInfo) + , srsLicense :: !(Maybe Text) + , srsCapabilities :: !(Maybe [Text]) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ShowResponse where + parseJSON = withObject "ShowResponse" $ \v -> + ShowResponse + <$> v .:? "modelfile" .!= "" + <*> v .:? "parameters" + <*> v .:? "template" + <*> v .:? "details" .!= ModelDetails Nothing "" "" [] "" "" + <*> v .:? "model_info" + <*> v .:? "license" + <*> v .:? "capabilities" + +instance ToJSON ShowResponse where + toJSON ShowResponse {..} = + object + [ "modelfile" .= srsModelfile + , "parameters" .= srsParameters + , "template" .= srsTemplate + , "details" .= srsDetails + , "model_info" .= srsModelInfo + , "license" .= srsLicense + , "capabilities" .= srsCapabilities + ] + +{- | Copy model request payload. + +@since 1.0.0.0 +-} +data CopyRequest = CopyRequest + { cpSource :: !ModelName + , cpDestination :: !ModelName + } + deriving stock (Eq, Show, Generic) + +instance ToJSON CopyRequest where + toJSON CopyRequest {..} = + object + [ "source" .= cpSource + , "destination" .= cpDestination + ] + +{- | Delete model request payload. + +@since 1.0.0.0 +-} +newtype DeleteRequest = DeleteRequest + { delModel :: ModelName + } + deriving stock (Eq, Show, Generic) + +instance ToJSON DeleteRequest where + toJSON DeleteRequest {..} = object ["model" .= delModel] + +{- | List installed local models (@GET /api/tags@). + +@since 1.0.0.0 +-} +listModels :: (MonadIO m) => OllamaClient -> m (Either OllamaError ListResponse) +listModels client = request client "GET" "/api/tags" (Nothing :: Maybe Value) + +{- | Fetch information and Modelfile content for a model (@POST /api/show@). + +@since 1.0.0.0 +-} +showModel :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError ShowResponse) +showModel client model = request client "POST" "/api/show" (Just $ ShowRequest model Nothing) + +{- | Duplicate an existing model under a new tag (@POST /api/copy@). + +@since 1.0.0.0 +-} +copyModel :: (MonadIO m) => OllamaClient -> ModelName -> ModelName -> m (Either OllamaError ()) +copyModel client src dst = request client "POST" "/api/copy" (Just $ CopyRequest src dst) + +{- | Delete a local model (@DELETE /api/delete@). + +@since 1.0.0.0 +-} +deleteModel :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError ()) +deleteModel client model = request client "DELETE" "/api/delete" (Just $ DeleteRequest model) diff --git a/src/Ollama/API/Models/Create.hs b/src/Ollama/API/Models/Create.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Models/Create.hs @@ -0,0 +1,165 @@ +{- | +Module : Ollama.API.Models.Create +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model creation endpoint (@/api/create@). + +@since 1.0.0.0 +-} +module Ollama.API.Models.Create ( + CreateRequest (..), + CreateResponse (..), + QuantizationType (..), + createModel, + createModelStream, + defaultCreateRequest, +) where + +import Conduit (ConduitT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson +import Data.Int (Int64) +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request, requestStreaming) +import Ollama.Error (OllamaError) +import Ollama.Streaming (HasDone (..)) +import Ollama.Types.Common (Digest, ModelName) +import Ollama.Types.Message (Message) +import Ollama.Types.Options (ModelOptions) + +{- | Quantization precision options for model creation. + +@since 1.0.0.0 +-} +data QuantizationType = Q4_K_M | Q4_K_S | Q8_0 + deriving stock (Eq, Show, Bounded, Enum, Generic) + +instance ToJSON QuantizationType where + toJSON Q4_K_M = String "q4_K_M" + toJSON Q4_K_S = String "q4_K_S" + toJSON Q8_0 = String "q8_0" + +instance FromJSON QuantizationType where + parseJSON = withText "QuantizationType" $ \case + "q4_K_M" -> pure Q4_K_M + "q4_K_S" -> pure Q4_K_S + "q8_0" -> pure Q8_0 + other -> fail $ "Invalid QuantizationType: " <> show other + +{- | Model creation request configuration payload. + +@since 1.0.0.0 +-} +data CreateRequest = CreateRequest + { crqModel :: !ModelName + , crqFrom :: !(Maybe ModelName) + , crqFiles :: !(Maybe (Map Text Digest)) + , crqAdapters :: !(Maybe (Map Text Digest)) + , crqTemplate :: !(Maybe Text) + , crqRenderer :: !(Maybe Text) + , crqParser :: !(Maybe Text) + , crqLicense :: !(Maybe [Text]) + , crqSystem :: !(Maybe Text) + , crqParameters :: !(Maybe ModelOptions) + , crqMessages :: !(Maybe [Message]) + , crqStream :: !(Maybe Bool) + , crqQuantize :: !(Maybe QuantizationType) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON CreateRequest where + toJSON CreateRequest {..} = + object $ + catMaybes + [ Just $ "model" .= crqModel + , ("from" .=) <$> crqFrom + , ("files" .=) <$> crqFiles + , ("adapters" .=) <$> crqAdapters + , ("template" .=) <$> crqTemplate + , ("renderer" .=) <$> crqRenderer + , ("parser" .=) <$> crqParser + , ("license" .=) <$> crqLicense + , ("system" .=) <$> crqSystem + , ("parameters" .=) <$> crqParameters + , ("messages" .=) <$> crqMessages + , ("stream" .=) <$> crqStream + , ("quantize" .=) <$> crqQuantize + ] + +{- | Smart constructor for a basic 'CreateRequest'. + +@since 1.0.0.0 +-} +defaultCreateRequest :: ModelName -> CreateRequest +defaultCreateRequest name = + CreateRequest + { crqModel = name + , crqFrom = Nothing + , crqFiles = Nothing + , crqAdapters = Nothing + , crqTemplate = Nothing + , crqRenderer = Nothing + , crqParser = Nothing + , crqLicense = Nothing + , crqSystem = Nothing + , crqParameters = Nothing + , crqMessages = Nothing + , crqStream = Just False + , crqQuantize = Nothing + } + +{- | Progress / status response during model creation. + +@since 1.0.0.0 +-} +data CreateResponse = CreateResponse + { crsStatus :: !Text + , crsDigest :: !(Maybe Digest) + , crsTotal :: !(Maybe Int64) + , crsCompleted :: !(Maybe Int64) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON CreateResponse where + parseJSON = withObject "CreateResponse" $ \v -> + CreateResponse + <$> v .: "status" + <*> v .:? "digest" + <*> v .:? "total" + <*> v .:? "completed" + +instance ToJSON CreateResponse where + toJSON CreateResponse {..} = + object + [ "status" .= crsStatus + , "digest" .= crsDigest + , "total" .= crsTotal + , "completed" .= crsCompleted + ] + +instance HasDone CreateResponse where + isDone CreateResponse {..} = crsStatus == "success" + +{- | Create a model non-streaming. + +@since 1.0.0.0 +-} +createModel :: (MonadIO m) => OllamaClient -> CreateRequest -> m (Either OllamaError CreateResponse) +createModel client req = request client "POST" "/api/create" (Just req {crqStream = Just False}) + +{- | Create a model streaming progress updates. + +@since 1.0.0.0 +-} +createModelStream :: + (MonadUnliftIO m) => OllamaClient -> CreateRequest -> ConduitT () CreateResponse m () +createModelStream client req = requestStreaming client "/api/create" (req {crqStream = Just True}) diff --git a/src/Ollama/API/Models/Pull.hs b/src/Ollama/API/Models/Pull.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Models/Pull.hs @@ -0,0 +1,100 @@ +{- | +Module : Ollama.API.Models.Pull +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model pull endpoint (@/api/pull@). + +@since 1.0.0.0 +-} +module Ollama.API.Models.Pull ( + PullRequest (..), + PullResponse (..), + pull, + pullStream, +) where + +import Conduit (ConduitT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson +import Data.Int (Int64) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request, requestStreaming) +import Ollama.Error (OllamaError) +import Ollama.Streaming (HasDone (..)) +import Ollama.Types.Common (Digest, ModelName) + +{- | Pull model request configuration payload. + +@since 1.0.0.0 +-} +data PullRequest = PullRequest + { prqModel :: !ModelName + , prqInsecure :: !(Maybe Bool) + , prqStream :: !(Maybe Bool) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON PullRequest where + toJSON PullRequest {..} = + object $ + catMaybes + [ Just $ "model" .= prqModel + , ("insecure" .=) <$> prqInsecure + , ("stream" .=) <$> prqStream + ] + +{- | Pull progress/status response payload. + +@since 1.0.0.0 +-} +data PullResponse = PullResponse + { prStatus :: !Text + , prDigest :: !(Maybe Digest) + , prTotal :: !(Maybe Int64) + , prCompleted :: !(Maybe Int64) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON PullResponse where + parseJSON = withObject "PullResponse" $ \v -> + PullResponse + <$> v .: "status" + <*> v .:? "digest" + <*> v .:? "total" + <*> v .:? "completed" + +instance ToJSON PullResponse where + toJSON PullResponse {..} = + object + [ "status" .= prStatus + , "digest" .= prDigest + , "total" .= prTotal + , "completed" .= prCompleted + ] + +instance HasDone PullResponse where + isDone PullResponse {..} = prStatus == "success" + +{- | Download / pull a model (non-streaming, blocks until complete). + +@since 1.0.0.0 +-} +pull :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError PullResponse) +pull client model = + request client "POST" "/api/pull" (Just $ PullRequest model Nothing (Just False)) + +{- | Download / pull a model streaming progress updates. + +@since 1.0.0.0 +-} +pullStream :: (MonadUnliftIO m) => OllamaClient -> ModelName -> ConduitT () PullResponse m () +pullStream client model = + requestStreaming client "/api/pull" (PullRequest model Nothing (Just True)) diff --git a/src/Ollama/API/Models/Push.hs b/src/Ollama/API/Models/Push.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Models/Push.hs @@ -0,0 +1,100 @@ +{- | +Module : Ollama.API.Models.Push +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model push endpoint (@/api/push@). + +@since 1.0.0.0 +-} +module Ollama.API.Models.Push ( + PushRequest (..), + PushResponse (..), + push, + pushStream, +) where + +import Conduit (ConduitT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson +import Data.Int (Int64) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request, requestStreaming) +import Ollama.Error (OllamaError) +import Ollama.Streaming (HasDone (..)) +import Ollama.Types.Common (Digest, ModelName) + +{- | Push model request payload. + +@since 1.0.0.0 +-} +data PushRequest = PushRequest + { psqModel :: !ModelName + , psqInsecure :: !(Maybe Bool) + , psqStream :: !(Maybe Bool) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON PushRequest where + toJSON PushRequest {..} = + object $ + catMaybes + [ Just $ "model" .= psqModel + , ("insecure" .=) <$> psqInsecure + , ("stream" .=) <$> psqStream + ] + +{- | Push progress response payload. + +@since 1.0.0.0 +-} +data PushResponse = PushResponse + { psStatus :: !Text + , psDigest :: !(Maybe Digest) + , psTotal :: !(Maybe Int64) + , psCompleted :: !(Maybe Int64) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON PushResponse where + parseJSON = withObject "PushResponse" $ \v -> + PushResponse + <$> v .: "status" + <*> v .:? "digest" + <*> v .:? "total" + <*> v .:? "completed" + +instance ToJSON PushResponse where + toJSON PushResponse {..} = + object + [ "status" .= psStatus + , "digest" .= psDigest + , "total" .= psTotal + , "completed" .= psCompleted + ] + +instance HasDone PushResponse where + isDone PushResponse {..} = psStatus == "success" + +{- | Push a model to a remote library (non-streaming). + +@since 1.0.0.0 +-} +push :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError PushResponse) +push client model = + request client "POST" "/api/push" (Just $ PushRequest model Nothing (Just False)) + +{- | Push a model streaming upload progress updates. + +@since 1.0.0.0 +-} +pushStream :: (MonadUnliftIO m) => OllamaClient -> ModelName -> ConduitT () PushResponse m () +pushStream client model = + requestStreaming client "/api/push" (PushRequest model Nothing (Just True)) diff --git a/src/Ollama/API/Ps.hs b/src/Ollama/API/Ps.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Ps.hs @@ -0,0 +1,31 @@ +{- | +Module : Ollama.API.Ps +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Running models endpoint (@/api/ps@). + +@since 1.0.0.0 +-} +module Ollama.API.Ps ( + listRunning, + RunningModelsResponse (..), + RunningModel (..), +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (Value) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request) +import Ollama.Error (OllamaError) +import Ollama.Types.Model (RunningModel (..), RunningModelsResponse (..)) + +{- | List models currently loaded into memory (@GET /api/ps@). + +@since 1.0.0.0 +-} +listRunning :: (MonadIO m) => OllamaClient -> m (Either OllamaError RunningModelsResponse) +listRunning client = request client "GET" "/api/ps" (Nothing :: Maybe Value) diff --git a/src/Ollama/API/Version.hs b/src/Ollama/API/Version.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/Version.hs @@ -0,0 +1,30 @@ +{- | +Module : Ollama.API.Version +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Version endpoint (@/api/version@). + +@since 1.0.0.0 +-} +module Ollama.API.Version ( + getVersion, + Version (..), +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (Value) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request) +import Ollama.Error (OllamaError) +import Ollama.Types.Common (Version (..)) + +{- | Retrieve Ollama server engine version (@GET /api/version@). + +@since 1.0.0.0 +-} +getVersion :: (MonadIO m) => OllamaClient -> m (Either OllamaError Version) +getVersion client = request client "GET" "/api/version" (Nothing :: Maybe Value) diff --git a/src/Ollama/Client.hs b/src/Ollama/Client.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Client.hs @@ -0,0 +1,110 @@ +{- | +Module : Ollama.Client +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Opaque client management and construction functions. + +@since 1.0.0.0 +-} +module Ollama.Client ( + OllamaClient (..), + newClient, + defaultClient, + clientFromEnv, + closeClient, + withClient, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Data.Text (Text) +import Data.Text qualified as T +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Ollama.Client.Config (OllamaClientConfig (..), defaultConfig) +import System.Environment (lookupEnv) + +{- | Opaque client handle for dispatching API calls. + +@since 1.0.0.0 +-} +data OllamaClient = OllamaClient + { clientManager :: !Manager + , clientConfig :: !OllamaClientConfig + , clientOwned :: !Bool + } + +{- | Construct a client with custom configuration settings. + +@since 1.0.0.0 +-} +newClient :: (MonadIO m) => OllamaClientConfig -> m OllamaClient +newClient cfg = liftIO $ do + case configManager cfg of + Just mgr -> pure $ OllamaClient mgr cfg False + Nothing -> do + mgr <- newManager tlsManagerSettings + pure $ OllamaClient mgr cfg True + +{- | Construct a client with default settings (@http://127.0.0.1:11434@). + +@since 1.0.0.0 +-} +defaultClient :: (MonadIO m) => m OllamaClient +defaultClient = newClient defaultConfig + +{- | Construct a client resolving host and credentials from environment variables +(@OLLAMA_HOST@, @OLLAMA_API_KEY@). + +Parses @OLLAMA_HOST@ robustly, handling these formats: + + * @host:port@ → @http:\/\/host:port@ + * @http:\/\/host:port@ → used as-is + * @host@ → @http:\/\/host:11434@ + +@since 1.0.0.0 +-} +clientFromEnv :: (MonadIO m) => m OllamaClient +clientFromEnv = liftIO $ do + mbHost <- lookupEnv "OLLAMA_HOST" + mbKey <- lookupEnv "OLLAMA_API_KEY" + let hostText = maybe "http://127.0.0.1:11434" (normalizeHost . T.pack) mbHost + keyText = T.pack <$> mbKey + cfg = defaultConfig {configBaseUrl = hostText, configApiKey = keyText} + newClient cfg + +{- | Normalize an @OLLAMA_HOST@ value to a full URL with scheme. + +Handles: bare @host:port@, @http(s):\/\/host:port@, and bare @host@. + +@since 1.0.0.0 +-} +normalizeHost :: Text -> Text +normalizeHost raw + | "http://" `T.isPrefixOf` raw || "https://" `T.isPrefixOf` raw = T.dropWhileEnd (== '/') raw + | ":" `T.isInfixOf` raw = "http://" <> T.dropWhileEnd (== '/') raw + | otherwise = "http://" <> T.dropWhileEnd (== '/') raw <> ":11434" + +{- | Close the underlying HTTP connection manager if owned by this client. + +Note: Connection managers in @http-client@ are automatically reclaimed by garbage collection. + +@since 1.0.0.0 +-} +closeClient :: (MonadIO m) => OllamaClient -> m () +closeClient _ = pure () + +{- | Resource bracket helper to initialize, run a computation, and close client resources. + +@since 1.0.0.0 +-} +withClient :: (MonadUnliftIO m) => OllamaClientConfig -> (OllamaClient -> m a) -> m a +withClient cfg action = withRunInIO $ \run -> do + client <- newClient cfg + res <- run (action client) + closeClient client + pure res diff --git a/src/Ollama/Client/Config.hs b/src/Ollama/Client/Config.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Client/Config.hs @@ -0,0 +1,103 @@ +{- | +Module : Ollama.Client.Config +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Client configuration settings, retry policies, and logging thresholds. + +@since 0.3.0.0 +-} +module Ollama.Client.Config ( + OllamaClientConfig (..), + defaultConfig, + RetryPolicy (..), + noRetry, + constantRetry, + exponentialRetry, + LogLevel (..), +) where + +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.Text (Text) +import Network.HTTP.Client (Manager) + +{- | Logging levels for structured client events. + +@since 0.3.0.0 +-} +data LogLevel = Debug | Info | Warn | Error + deriving stock (Eq, Ord, Show, Bounded, Enum) + +{- | Configurable retry strategy for recoverable network errors. + +@since 0.3.0.0 +-} +data RetryPolicy + = -- | Disable all retries + NoRetry + | -- | Retry up to @count@ times with fixed @delayMicros@ interval + ConstantRetry !Int !Int + | -- | Retry up to @count@ times with exponential backoff starting at @baseDelayMicros@ + ExponentialRetry !Int !Int + deriving stock (Eq, Show) + +{- | Helper constructor for 'NoRetry'. + +@since 0.3.0.0 +-} +noRetry :: RetryPolicy +noRetry = NoRetry + +{- | Helper constructor for 'ConstantRetry'. + +@since 0.3.0.0 +-} +constantRetry :: Int -> Int -> RetryPolicy +constantRetry = ConstantRetry + +{- | Helper constructor for 'ExponentialRetry'. + +@since 0.3.0.0 +-} +exponentialRetry :: Int -> Int -> RetryPolicy +exponentialRetry = ExponentialRetry + +{- | Configuration settings for an 'Ollama.Client.OllamaClient'. + +@since 0.3.0.0 +-} +data OllamaClientConfig = OllamaClientConfig + { configBaseUrl :: !Text + , configTimeout :: !Int + , configRetry :: !RetryPolicy + , configManager :: !(Maybe Manager) + , configHeaders :: ![(CI ByteString, ByteString)] + , configApiKey :: !(Maybe Text) + , configLogger :: !(Maybe (LogLevel -> Text -> IO ())) + , configOnStart :: !(Maybe (IO ())) + , configOnSuccess :: !(Maybe (IO ())) + , configOnError :: !(Maybe (IO ())) + } + +{- | Default configuration connecting to @http://127.0.0.1:11434@ with 300s timeout and 'NoRetry'. + +@since 0.3.0.0 +-} +defaultConfig :: OllamaClientConfig +defaultConfig = + OllamaClientConfig + { configBaseUrl = "http://127.0.0.1:11434" + , configTimeout = 300 + , configRetry = NoRetry + , configManager = Nothing + , configHeaders = [] + , configApiKey = Nothing + , configLogger = Nothing + , configOnStart = Nothing + , configOnSuccess = Nothing + , configOnError = Nothing + } diff --git a/src/Ollama/Client/Internal.hs b/src/Ollama/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Client/Internal.hs @@ -0,0 +1,276 @@ +{- | +Module : Ollama.Client.Internal +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Low-level HTTP transport plumbing and request dispatchers. + +Implements retry logic, lifecycle callbacks, structured logging, +authentication header injection, and conduit-based response streaming. + +@since 1.0.0.0 +-} +module Ollama.Client.Internal ( + request, + requestRaw, + requestStreaming, +) where + +import Conduit ( + ConduitT, + awaitForever, + bracketP, + filterC, + takeWhileC, + transPipe, + yield, + (.|), + ) +import Control.Exception (SomeException, catch, try) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Retry qualified as Retry +import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.CaseInsensitive (CI) +import Data.Conduit.Binary qualified as CB +import Data.Conduit.Combinators (repeatM) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.HTTP.Client +import Network.HTTP.Types (statusCode) +import Ollama.Client (OllamaClient (..)) +import Ollama.Client.Config (LogLevel (..), OllamaClientConfig (..), RetryPolicy (..)) +import Ollama.Error (OllamaError (..), isRetryable) + +-- --------------------------------------------------------------------------- +-- Public API +-- --------------------------------------------------------------------------- + +{- | Dispatch a non-streaming JSON API request. + +Applies authentication headers, retry policy, lifecycle callbacks, +and structured logging as configured on the client. + +@since 1.0.0.0 +-} +request :: + (MonadIO m, ToJSON req, FromJSON resp) => + OllamaClient -> + ByteString -> + Text -> + Maybe req -> + m (Either OllamaError resp) +request client reqMethod endpoint mbPayload = + liftIO $ + withRetry client endpoint $ + executeJsonRequest client reqMethod endpoint mbPayload + +{- | Dispatch a raw (non-JSON) request returning raw bytes. + +Used for blob endpoints where the response body is not JSON. +Applies authentication headers, retry policy, lifecycle callbacks, +and structured logging. + +@since 1.0.0.0 +-} +requestRaw :: + (MonadIO m) => + OllamaClient -> + ByteString -> + Text -> + Maybe ByteString -> + m (Either OllamaError ByteString) +requestRaw client reqMethod endpoint mbPayload = + liftIO $ + withRetry client endpoint $ + executeRawRequest client reqMethod endpoint mbPayload + +{- | Dispatch a conduit-based streaming API request. + +Opens an HTTP response stream, reads line-delimited JSON chunks as they arrive, +decodes each chunk, and yields values into a 'ConduitT'. Stops when the server +closes the connection. + +@since 1.0.0.0 +-} +requestStreaming :: + (MonadUnliftIO m, ToJSON req, FromJSON resp) => + OllamaClient -> + Text -> + req -> + ConduitT () resp m () +requestStreaming OllamaClient {..} endpoint payload = do + let fullUrl = T.unpack $ configBaseUrl clientConfig <> endpoint + cfg = clientConfig + initReq <- liftIO $ parseRequest fullUrl + let req = + initReq + { method = "POST" + , responseTimeout = responseTimeoutNone + , requestHeaders = + [ ("Content-Type", "application/json") + , ("Accept", "application/x-ndjson, application/json") + , ("Connection", "keep-alive") + ] + ++ authHeader cfg + ++ configHeaders cfg + , requestBody = RequestBodyLBS (encode payload) + } + transPipe runResourceT $ + bracketP + (responseOpen req clientManager) + responseClose + ( \resp -> do + let bodyReader = responseBody resp + readChunk = liftIO $ brRead bodyReader `catch` \(_ :: HttpException) -> pure BS.empty + source = repeatM readChunk .| takeWhileC (not . BS.null) + source .| CB.lines .| filterC (not . BS.null) .| parseAndYield + ) + where + parseAndYield = awaitForever $ \line -> do + case eitherDecode (BSL.fromStrict line) of + Left _err -> pure () + Right val -> yield val + +-- --------------------------------------------------------------------------- +-- Core request execution +-- --------------------------------------------------------------------------- + +-- | Execute a JSON request without retry wrapping. +executeJsonRequest :: + (ToJSON req, FromJSON resp) => + OllamaClient -> + ByteString -> + Text -> + Maybe req -> + IO (Either OllamaError resp) +executeJsonRequest OllamaClient {..} reqMethod endpoint mbPayload = do + let fullUrl = T.unpack $ configBaseUrl clientConfig <> endpoint + cfg = clientConfig + initReq <- parseRequest fullUrl + let timeoutMicro = configTimeout cfg * 1000000 + req = + initReq + { method = reqMethod + , responseTimeout = responseTimeoutMicro timeoutMicro + , requestHeaders = + [("Content-Type", "application/json"), ("Accept", "application/json")] + ++ authHeader cfg + ++ configHeaders cfg + , requestBody = maybe mempty (RequestBodyLBS . encode) mbPayload + } + result <- try @HttpException $ httpLbs req clientManager + case result of + Left httpErr -> pure $ Left $ HttpError httpErr + Right resp -> do + let status = statusCode (responseStatus resp) + body = responseBody resp + if status >= 200 && status < 300 + then + if BSL.null body + then case eitherDecode "null" of + Left err -> pure $ Left $ DecodeError (T.pack err) (BSL.toStrict body) + Right val -> pure $ Right val + else case eitherDecode body of + Left err -> pure $ Left $ DecodeError (T.pack err) (BSL.toStrict body) + Right val -> pure $ Right val + else pure $ Left $ ApiError status (TE.decodeUtf8 . BSL.toStrict $ body) + +-- | Execute a raw byte request without retry wrapping. +executeRawRequest :: + OllamaClient -> + ByteString -> + Text -> + Maybe ByteString -> + IO (Either OllamaError ByteString) +executeRawRequest OllamaClient {..} reqMethod endpoint mbPayload = do + let fullUrl = T.unpack $ configBaseUrl clientConfig <> endpoint + cfg = clientConfig + initReq <- parseRequest fullUrl + let timeoutMicro = configTimeout cfg * 1000000 + req = + initReq + { method = reqMethod + , responseTimeout = responseTimeoutMicro timeoutMicro + , requestHeaders = authHeader cfg ++ configHeaders cfg + , requestBody = maybe mempty RequestBodyBS mbPayload + } + result <- try @HttpException $ httpLbs req clientManager + case result of + Left httpErr -> pure $ Left $ HttpError httpErr + Right resp -> do + let status = statusCode (responseStatus resp) + if status >= 200 && status < 300 + then pure $ Right (BSL.toStrict $ responseBody resp) + else pure $ Left $ ApiError status (TE.decodeUtf8 . BSL.toStrict $ body) + where + body = responseBody resp + +-- --------------------------------------------------------------------------- +-- Retry logic +-- --------------------------------------------------------------------------- + +{- | Wrap an IO action with the client's configured retry policy, lifecycle +callbacks, and structured logging. + +Only retries when 'isRetryable' returns 'True' for the error. +-} +withRetry :: + OllamaClient -> + Text -> + IO (Either OllamaError a) -> + IO (Either OllamaError a) +withRetry OllamaClient {clientConfig = cfg} endpoint action = do + let policy = toRetryPolicy (configRetry cfg) + shouldRetry _status (Left err) = do + logMsg cfg Warn $ "Retryable error on " <> endpoint <> ", will retry: " <> T.pack (show err) + pure $ isRetryable err + shouldRetry _status (Right _) = pure False + fireCallback (configOnStart cfg) + logMsg cfg Debug $ "Requesting " <> endpoint + result <- Retry.retrying policy shouldRetry (const action) + case result of + Left err -> do + fireCallback (configOnError cfg) + logMsg cfg Error $ "Request failed: " <> endpoint <> " — " <> T.pack (show err) + Right _ -> do + fireCallback (configOnSuccess cfg) + logMsg cfg Info $ "Request succeeded: " <> endpoint + pure result + +-- | Map our 'RetryPolicy' ADT to the @retry@ package's 'Retry.RetryPolicyM'. +toRetryPolicy :: RetryPolicy -> Retry.RetryPolicyM IO +toRetryPolicy NoRetry = Retry.limitRetries 0 +toRetryPolicy (ConstantRetry count delaySec) = + Retry.constantDelay (delaySec * 1000000) <> Retry.limitRetries count +toRetryPolicy (ExponentialRetry count initialDelayMs) = + Retry.exponentialBackoff (initialDelayMs * 1000) <> Retry.limitRetries count + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- | Build the Authorization header if an API key is configured. +authHeader :: OllamaClientConfig -> [(CI ByteString, ByteString)] +authHeader cfg = case configApiKey cfg of + Nothing -> [] + Just key -> [("Authorization", "Bearer " <> TE.encodeUtf8 key)] + +-- | Fire an optional callback, silently ignoring exceptions. +fireCallback :: Maybe (IO ()) -> IO () +fireCallback Nothing = pure () +fireCallback (Just cb) = cb `catch` \(_ :: SomeException) -> pure () + +-- | Log a message via the configured logger, if present. +logMsg :: OllamaClientConfig -> LogLevel -> Text -> IO () +logMsg cfg level msg = case configLogger cfg of + Nothing -> pure () + Just logger -> logger level msg `catch` \(_ :: SomeException) -> pure () diff --git a/src/Ollama/Conversation.hs b/src/Ollama/Conversation.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Conversation.hs @@ -0,0 +1,110 @@ +{- | +Module : Ollama.Conversation +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Conversation store typeclass and in-memory transactional implementation. + +@since 1.0.0.0 +-} +module Ollama.Conversation ( + Conversation (..), + ConversationStore (..), + InMemoryStore (..), + initInMemoryStore, + saveConversationInMemory, + loadConversationInMemory, + listConversationsInMemory, + deleteConversationInMemory, +) where + +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT, ask) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Ollama.Types.Common (ModelName) +import Ollama.Types.Message (Message) + +{- | Recorded chat conversation session. + +@since 1.0.0.0 +-} +data Conversation = Conversation + { conversationId :: !Text + , messages :: ![Message] + , model :: !ModelName + , createdAt :: !UTCTime + , lastUpdated :: !UTCTime + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +{- | Abstract interface for persisting and managing chat conversations. + +@since 1.0.0.0 +-} +class (Monad m) => ConversationStore m where + saveConversation :: Conversation -> m () + loadConversation :: Text -> m (Maybe Conversation) + listConversations :: m [Conversation] + deleteConversation :: Text -> m Bool + +{- | Thread-safe transactional in-memory conversation store. + +@since 1.0.0.0 +-} +newtype InMemoryStore = InMemoryStore (TVar (Map Text Conversation)) + +{- | Initialize a new empty 'InMemoryStore'. + +@since 1.0.0.0 +-} +initInMemoryStore :: IO InMemoryStore +initInMemoryStore = InMemoryStore <$> newTVarIO Map.empty + +{- | Save a conversation into an 'InMemoryStore'. + +@since 1.0.0.0 +-} +saveConversationInMemory :: (MonadIO m) => InMemoryStore -> Conversation -> m () +saveConversationInMemory (InMemoryStore ref) conv = liftIO $ atomically $ do + modifyTVar' ref (Map.insert (conversationId conv) conv) + +{- | Load a conversation by ID from an 'InMemoryStore'. + +@since 1.0.0.0 +-} +loadConversationInMemory :: (MonadIO m) => InMemoryStore -> Text -> m (Maybe Conversation) +loadConversationInMemory (InMemoryStore ref) cid = liftIO $ Map.lookup cid <$> readTVarIO ref + +{- | List all stored conversations from an 'InMemoryStore'. + +@since 1.0.0.0 +-} +listConversationsInMemory :: (MonadIO m) => InMemoryStore -> m [Conversation] +listConversationsInMemory (InMemoryStore ref) = liftIO $ Map.elems <$> readTVarIO ref + +{- | Delete a conversation by ID from an 'InMemoryStore'. + +@since 1.0.0.0 +-} +deleteConversationInMemory :: (MonadIO m) => InMemoryStore -> Text -> m Bool +deleteConversationInMemory (InMemoryStore ref) cid = liftIO $ atomically $ do + m <- readTVar ref + if Map.member cid m + then modifyTVar' ref (Map.delete cid) >> pure True + else pure False + +instance (MonadIO m) => ConversationStore (ReaderT InMemoryStore m) where + saveConversation conv = ask >>= \store -> saveConversationInMemory store conv + loadConversation cid = ask >>= \store -> loadConversationInMemory store cid + listConversations = ask >>= \store -> listConversationsInMemory store + deleteConversation cid = ask >>= \store -> deleteConversationInMemory store cid diff --git a/src/Ollama/Error.hs b/src/Ollama/Error.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Error.hs @@ -0,0 +1,66 @@ +{- | +Module : Ollama.Error +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Core error type definitions for the Ollama library. + +@since 3.0.0.0 +-} +module Ollama.Error ( + OllamaError (..), + isRetryable, + throwOllama, +) where + +import Control.Exception (Exception, throwIO) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network.HTTP.Client (HttpException) + +{- | Unified error type representing all failure modes in the Ollama client. + +@since 3.0.0.0 +-} +data OllamaError + = -- | HTTP transport failure (connection error, DNS failure, etc.) + HttpError !HttpException + | -- | Ollama API returned an error response (HTTP status code + message) + ApiError !Int !Text + | -- | Failed to decode JSON response body + DecodeError !Text !ByteString + | -- | Request timed out waiting for a response + TimeoutError + | -- | Client-side validation failure before sending the request + InvalidRequest !Text + deriving stock (Show) + +instance Exception OllamaError + +instance Eq OllamaError where + ApiError s1 t1 == ApiError s2 t2 = s1 == s2 && t1 == t2 + DecodeError t1 _ == DecodeError t2 _ = t1 == t2 + TimeoutError == TimeoutError = True + InvalidRequest t1 == InvalidRequest t2 = t1 == t2 + HttpError _ == HttpError _ = False + _ == _ = False + +{- | Determine whether an error is transient and safe to retry. + +@since 3.0.0.0 +-} +isRetryable :: OllamaError -> Bool +isRetryable (HttpError _) = True +isRetryable TimeoutError = True +isRetryable (ApiError status _) | status >= 500 = True +isRetryable _ = False + +{- | Helper to throw an 'OllamaError' as an exception. + +@since 3.0.0.0 +-} +throwOllama :: OllamaError -> IO a +throwOllama = throwIO diff --git a/src/Ollama/MCP.hs b/src/Ollama/MCP.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/MCP.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Ollama.MCP +Description : Model Context Protocol (MCP) tool conversion and server bridging for Ollama using mcp-server. +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Provides direct bidirectional conversion between Ollama function calling definitions ('Tool') +and Model Context Protocol ('ToolDefinition', 'Content', etc.) directly using the official +Hackage @mcp-server@ package. + +@since 0.4.0.0 +-} +module Ollama.MCP ( + -- * Re-exported MCP.Server Types & Functions + Content (..), + ContentImageData (..), + ContentAudioData (..), + ResourceContent (..), + PromptDefinition (..), + ResourceDefinition (..), + ToolDefinition (..), + ArgumentDefinition (..), + type McpSchema, + pattern McpSchema, + SchemaType (..), + schemaDescription, + schemaShape, + schema, + describedSchema, + mkToolDefinition, + mkPromptDefinition, + mkResourceDefinition, + McpServerInfo (..), + McpServerHandlers (..), + ServerCapabilities (..), + PromptCapabilities (..), + ResourceCapabilities (..), + ToolCapabilities (..), + LoggingCapabilities (..), + PromptListHandler, + PromptGetHandler, + ResourceListHandler, + ResourceReadHandler, + ToolListHandler, + ToolCallHandler, + PromptName, + ToolName, + ArgumentName, + ArgumentValue, + URI, + parseURI, + runMcpServerStdio, + runMcpServerHttp, + runMcpServerHttpWithConfig, + HttpConfig (..), + jsonValueToText, + McpProtocolError, + + -- * Conversion between Ollama and mcp-server Types + toolToMcpDefinition, + mcpDefinitionToTool, + toolCallToMcpArgs, + mcpContentToToolOutput, +) where + +import Data.Aeson (Value (..), encode) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TEncoding +import MCP.Server ( + HttpConfig (..), + runMcpServerHttp, + runMcpServerHttpWithConfig, + runMcpServerStdio, + ) +import MCP.Server.Types as ServerTypes ( + ArgumentDefinition (..), + ArgumentName, + ArgumentValue, + Content (..), + ContentAudioData (..), + ContentImageData (..), + Error (..), + LoggingCapabilities (..), + McpServerHandlers (..), + McpServerInfo (..), + PromptCapabilities (..), + PromptDefinition (..), + PromptGetHandler, + PromptListHandler, + PromptName, + ResourceCapabilities (..), + ResourceContent (..), + ResourceDefinition (..), + ResourceListHandler, + ResourceReadHandler, + Schema (..), + SchemaType (..), + ServerCapabilities (..), + ToolCallHandler, + ToolCapabilities (..), + ToolDefinition (..), + ToolListHandler, + ToolName, + URI, + describedSchema, + mkPromptDefinition, + mkResourceDefinition, + mkToolDefinition, + parseURI, + schema, + ) +import Ollama.Types.Tool ( + FunctionDef (..), + FunctionParameters (..), + Tool (..), + ToolCall (..), + ToolCallFunction (..), + ) + +-- | Alias for 'MCP.Server.Types.Error' to prevent collisions with 'Ollama.Error'. +type McpProtocolError = ServerTypes.Error + +-- | Alias for 'MCP.Server.Types.Schema' to avoid name collision with 'Ollama.Types.Format.SchemaBuilder.Schema'. +type McpSchema = ServerTypes.Schema + +-- | Pattern synonym for matching or constructing an 'McpSchema' ('ServerTypes.Schema'). +pattern McpSchema :: Maybe Text -> SchemaType -> McpSchema +pattern McpSchema desc shape = ServerTypes.Schema desc shape + +{-# COMPLETE McpSchema #-} + +-- | Convert an Aeson 'Value' to 'Text'. Strings are returned unquoted, while other JSON values are serialized. +jsonValueToText :: Value -> Text +jsonValueToText (String t) = t +jsonValueToText v = TL.toStrict (TEncoding.decodeUtf8 (encode v)) + +-- | Convert an Ollama 'Tool' into an MCP 'ToolDefinition' from @mcp-server@. +toolToMcpDefinition :: Tool -> ToolDefinition +toolToMcpDefinition Tool {toolFunction = FunctionDef {..}} = + let desc = fromMaybe "" fnDescription + convertParam :: FunctionParameters -> ServerTypes.Schema + convertParam p = + let pDesc = fpDescription p + shape = case fpType p of + "string" -> SchemaString (fpEnum p) + "integer" -> SchemaInteger + "number" -> SchemaNumber + "boolean" -> SchemaBoolean + "array" -> SchemaArray (ServerTypes.Schema Nothing (SchemaString Nothing)) + "object" -> + let props = maybe [] (\pm -> [(k, convertParam v) | (k, v) <- Map.toList pm]) (fpProperties p) + req = fromMaybe [] (fpRequired p) + in SchemaObject props req + _ -> SchemaString Nothing + in ServerTypes.Schema pDesc shape + inputSchema = case fnParameters of + Just p -> convertParam p + Nothing -> ServerTypes.Schema Nothing (SchemaObject [] []) + in mkToolDefinition fnName desc inputSchema + +-- | Convert an MCP 'ToolDefinition' from @mcp-server@ into an Ollama 'Tool'. +mcpDefinitionToTool :: ToolDefinition -> Tool +mcpDefinitionToTool ToolDefinition {..} = + let convertSchema :: ServerTypes.Schema -> FunctionParameters + convertSchema (ServerTypes.Schema mDesc shape) = + case shape of + SchemaString mEnum -> + FunctionParameters + { fpType = "string" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = mEnum + } + SchemaInteger -> + FunctionParameters + { fpType = "integer" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaNumber -> + FunctionParameters + { fpType = "number" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaBoolean -> + FunctionParameters + { fpType = "boolean" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaArray _itemSchema -> + FunctionParameters + { fpType = "array" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaObject props req -> + let propMap = Map.fromList [(k, convertSchema s) | (k, s) <- props] + in FunctionParameters + { fpType = "object" + , fpProperties = if Map.null propMap then Nothing else Just propMap + , fpRequired = if null req then Nothing else Just req + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + params = convertSchema toolDefinitionInputSchema + in Tool + { toolType = "function" + , toolFunction = + FunctionDef + { fnName = toolDefinitionName + , fnDescription = if T.null toolDefinitionDescription then Nothing else Just toolDefinitionDescription + , fnParameters = Just params + , fnStrict = Nothing + } + } + +-- | Convert an Ollama 'ToolCall' into an MCP tool name and arguments list for @mcp-server@. +toolCallToMcpArgs :: ToolCall -> (Text, [(Text, Text)]) +toolCallToMcpArgs (ToolCall (ToolCallFunction name args)) = + (name, [(k, jsonValueToText v) | (k, v) <- Map.toList args]) + +-- | Extract textual output from an MCP 'Content' (from @mcp-server@). +mcpContentToToolOutput :: Content -> Text +mcpContentToToolOutput (ContentText t) = t +mcpContentToToolOutput (ContentImage (ContentImageData _ mime)) = "[Image: " <> mime <> "]" +mcpContentToToolOutput (ContentAudio (ContentAudioData _ mime)) = "[Audio: " <> mime <> "]" +mcpContentToToolOutput (ContentEmbeddedResource res) = + "[Resource: " <> T.pack (show (resourceUri res)) <> "]" +mcpContentToToolOutput (ContentResourceLink resDef) = + "[Resource: " <> resourceDefinitionURI resDef <> "]" +mcpContentToToolOutput (ContentAnnotated _ inner) = mcpContentToToolOutput inner diff --git a/src/Ollama/Streaming.hs b/src/Ollama/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Streaming.hs @@ -0,0 +1,41 @@ +{- | +Module : Ollama.Streaming +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Streaming pipeline utilities, stream combinators, and 'HasDone' class for API responses. + +@since 1.0.0.0 +-} +module Ollama.Streaming ( + HasDone (..), + collectStream, + foldStream, +) where + +import Conduit (ConduitT, foldlC, runConduit, sinkList, (.|)) +import Control.Monad.IO.Unlift (MonadUnliftIO) + +{- | Typeclass for responses that indicate completion in a stream. + +@since 1.0.0.0 +-} +class HasDone a where + isDone :: a -> Bool + +{- | Collect all yielded items from a streaming conduit into a list. + +@since 1.0.0.0 +-} +collectStream :: (MonadUnliftIO m) => ConduitT () a m () -> m [a] +collectStream stream = runConduit $ stream .| sinkList + +{- | Fold over all yielded items from a streaming conduit. + +@since 1.0.0.0 +-} +foldStream :: (MonadUnliftIO m) => (b -> a -> b) -> b -> ConduitT () a m () -> m b +foldStream f acc stream = runConduit $ stream .| foldlC f acc diff --git a/src/Ollama/Testing.hs b/src/Ollama/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Testing.hs @@ -0,0 +1,162 @@ +{- | +Module : Ollama.Testing +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Mock client and test helpers for unit testing code without a live Ollama server. + +@since 1.0.0.0 +-} +module Ollama.Testing ( + newMockClient, + withMockClient, + mockGenerateResponse, + mockChatResponse, + mockEmbedResponse, + mockListModelsResponse, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.IORef (atomicModifyIORef, newIORef) +import Data.Text (Text) +import Data.Time (Day (..), UTCTime (..)) +import Network.HTTP.Client ( + defaultManagerSettings, + managerRawConnection, + newManager, + ) +import Network.HTTP.Client.Internal (makeConnection) +import Ollama.API.Chat (ChatResponse (..)) +import Ollama.API.Embed (EmbedResponse (..)) +import Ollama.API.Generate (GenerateResponse (..)) +import Ollama.Client (OllamaClient (..), closeClient) +import Ollama.Client.Config (defaultConfig) +import Ollama.Types.Common (Digest (..), Duration (..), ModelName (..)) +import Ollama.Types.Message (assistantMessage) +import Ollama.Types.Model (ListResponse (..), ModelDetails (..), ModelInfo (..)) + +{- | Construct an 'OllamaClient' that returns mock HTTP response bytes for any request. + +@since 1.0.0.0 +-} +newMockClient :: (MonadIO m) => ByteString -> m OllamaClient +newMockClient bodyBytes = liftIO $ do + let httpResponse = + "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: " + <> BS8.pack (show (BS8.length bodyBytes)) + <> "\r\n\r\n" + <> bodyBytes + ref <- newIORef [httpResponse] + let mockConn = + makeConnection + ( atomicModifyIORef ref $ \case + [] -> ([], "") + (x : xs) -> (xs, x) + ) + (\_ -> pure ()) + (pure ()) + settings = defaultManagerSettings {managerRawConnection = pure (\_ _ _ -> mockConn)} + mgr <- newManager settings + pure $ OllamaClient mgr defaultConfig True + +{- | Resource bracket helper to create a mock client, execute an action, and close resources. + +@since 1.0.0.0 +-} +withMockClient :: (MonadUnliftIO m) => ByteString -> (OllamaClient -> m a) -> m a +withMockClient body action = do + client <- newMockClient body + res <- action client + closeClient client + pure res + +{- | Construct a mock 'GenerateResponse'. + +@since 1.0.0.0 +-} +mockGenerateResponse :: ModelName -> Text -> GenerateResponse +mockGenerateResponse model text = + GenerateResponse + { grModel = model + , grCreatedAt = UTCTime (ModifiedJulianDay 60000) 0 + , grResponse = text + , grDone = True + , grDoneReason = Just "stop" + , grContext = Just [1, 2, 3] + , grTotalDuration = Just (Duration 1000000000) + , grLoadDuration = Just (Duration 100000000) + , grPromptEvalCount = Just 10 + , grPromptEvalDuration = Just (Duration 200000000) + , grEvalCount = Just 20 + , grEvalDuration = Just (Duration 700000000) + , grThinking = Nothing + , grImage = Nothing + } + +{- | Construct a mock 'ChatResponse'. + +@since 1.0.0.0 +-} +mockChatResponse :: ModelName -> Text -> ChatResponse +mockChatResponse model text = + ChatResponse + { crModel = model + , crCreatedAt = UTCTime (ModifiedJulianDay 60000) 0 + , crMessage = Just (assistantMessage text) + , crDone = True + , crDoneReason = Just "stop" + , crTotalDuration = Just (Duration 1000000000) + , crLoadDuration = Just (Duration 100000000) + , crPromptEvalCount = Just 10 + , crPromptEvalDuration = Just (Duration 200000000) + , crEvalCount = Just 20 + , crEvalDuration = Just (Duration 700000000) + } + +{- | Construct a mock 'EmbedResponse'. + +@since 1.0.0.0 +-} +mockEmbedResponse :: ModelName -> [[Double]] -> EmbedResponse +mockEmbedResponse model vectors = + EmbedResponse + { erModel = model + , erEmbeddings = vectors + , erTotalDuration = Just (Duration 500000000) + , erLoadDuration = Just (Duration 50000000) + , erPromptEvalCount = Just 8 + } + +{- | Construct a mock 'ListResponse'. + +@since 1.0.0.0 +-} +mockListModelsResponse :: [ModelName] -> ListResponse +mockListModelsResponse names = + ListResponse + { models = map mkModel names + } + where + mkModel name = + ModelInfo + { miName = name + , miModel = name + , miModifiedAt = UTCTime (ModifiedJulianDay 60000) 0 + , miSize = 4000000000 + , miDigest = Digest "sha256:1234567890abcdef" + , miDetails = + ModelDetails + { parentModel = Nothing + , format = "gguf" + , family = "llama" + , families = ["llama"] + , parameterSize = "7B" + , quantizationLevel = "Q4_K_M" + } + } diff --git a/src/Ollama/Types.hs b/src/Ollama/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types.hs @@ -0,0 +1,38 @@ +{- | +Module : Ollama.Types +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Re-export all domain types for convenience. + +@since 3.0.0.0 +-} +module Ollama.Types ( + module Ollama.Types.Common, + Role (System, User, Assistant), + Message (..), + userMessage, + systemMessage, + assistantMessage, + toolMessage, + toolResultMessage, + imageMessage, + Tool (..), + FunctionDef (..), + FunctionParameters (..), + ToolCall (..), + ToolCallFunction (..), + module Ollama.Types.Options, + module Ollama.Types.Format, + module Ollama.Types.Model, +) where + +import Ollama.Types.Common +import Ollama.Types.Format +import Ollama.Types.Message +import Ollama.Types.Model +import Ollama.Types.Options +import Ollama.Types.Tool diff --git a/src/Ollama/Types/Common.hs b/src/Ollama/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Common.hs @@ -0,0 +1,152 @@ +{- | +Module : Ollama.Types.Common +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Common newtypes and domain primitives for the Ollama API. + +@since 3.0.0.0 +-} +module Ollama.Types.Common ( + ModelName (..), + mkModelName, + Digest (..), + Base64Image (..), + Duration (..), + durationToSeconds, + durationToMillis, + tokensPerSecond, + Version (..), + Think (..), + ThinkingLevel (..), +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withText, (.:), (.=)) +import Data.Aeson.Types (typeMismatch) +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.String (IsString) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) + +{- | Model name following the @model:tag@ format. + +@since 3.0.0.0 +-} +newtype ModelName = ModelName {unModelName :: Text} + deriving newtype (Eq, Ord, Show, IsString, ToJSON, FromJSON, Hashable) + +{- | Smart constructor that validates that a model name is non-empty. + +@since 3.0.0.0 +-} +mkModelName :: Text -> Either Text ModelName +mkModelName t + | T.null t = Left "Model name cannot be empty" + | otherwise = Right (ModelName t) + +{- | SHA256 digest of a layer blob. + +@since 3.0.0.0 +-} +newtype Digest = Digest {unDigest :: Text} + deriving newtype (Eq, Ord, Show, ToJSON, FromJSON, Hashable) + +{- | Base64-encoded image data for multimodal inputs. + +@since 3.0.0.0 +-} +newtype Base64Image = Base64Image {unBase64Image :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +{- | Duration in nanoseconds as returned by the Ollama API. + +@since 3.0.0.0 +-} +newtype Duration = Duration {durationNanos :: Int64} + deriving newtype (Eq, Ord, Show, ToJSON, FromJSON, Num) + +{- | Convert duration nanoseconds to seconds. + +@since 3.0.0.0 +-} +durationToSeconds :: Duration -> Double +durationToSeconds (Duration ns) = fromIntegral ns / 1e9 + +{- | Convert duration nanoseconds to milliseconds. + +@since 1.0.0.0 +-} +durationToMillis :: Duration -> Double +durationToMillis (Duration ns) = fromIntegral ns / 1e6 + +{- | Calculate tokens per second (tokens\/s) given a token count and a 'Duration'. + +@since 1.0.0.0 +-} +tokensPerSecond :: Int -> Duration -> Double +tokensPerSecond count dur = + let secs = durationToSeconds dur + in if secs <= 0 then 0.0 else fromIntegral count / secs + +{- | Ollama server engine version string. + +@since 3.0.0.0 +-} +newtype Version = Version {unVersion :: Text} + deriving stock (Eq, Show, Generic) + +instance FromJSON Version where + parseJSON = \case + String s -> pure $ Version s + Object v -> Version <$> v .: "version" + v -> typeMismatch "Version" v + +instance ToJSON Version where + toJSON (Version s) = object ["version" .= s] + +{- | Thinking level settings for reasoning models. + +@since 3.0.0.0 +-} +data ThinkingLevel = ThinkLow | ThinkMedium | ThinkHigh | ThinkMax + deriving stock (Eq, Show, Bounded, Enum, Generic) + +instance ToJSON ThinkingLevel where + toJSON ThinkLow = String "low" + toJSON ThinkMedium = String "medium" + toJSON ThinkHigh = String "high" + toJSON ThinkMax = String "max" + +instance FromJSON ThinkingLevel where + parseJSON = withText "ThinkingLevel" $ \case + "low" -> pure ThinkLow + "medium" -> pure ThinkMedium + "high" -> pure ThinkHigh + "max" -> pure ThinkMax + other -> fail $ "Unknown thinking level: " <> T.unpack other + +{- | Controls whether a thinking/reasoning model outputs its thoughts. + +@since 3.0.0.0 +-} +data Think + = ThinkEnabled + | ThinkDisabled + | ThinkLevel !ThinkingLevel + deriving stock (Eq, Show, Generic) + +instance ToJSON Think where + toJSON ThinkEnabled = Bool True + toJSON ThinkDisabled = Bool False + toJSON (ThinkLevel lvl) = toJSON lvl + +instance FromJSON Think where + parseJSON (Bool True) = pure ThinkEnabled + parseJSON (Bool False) = pure ThinkDisabled + parseJSON (String s) = ThinkLevel <$> parseJSON (String s) + parseJSON v = typeMismatch "Think" v diff --git a/src/Ollama/Types/Format.hs b/src/Ollama/Types/Format.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Format.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +{- | +Module : Ollama.Types.Format +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Response formatting specifications for structured model output. + +@since 1.0.0.0 +-} +module Ollama.Types.Format ( + Format (..), + formatFor, + module Ollama.Types.Format.SchemaBuilder, + module Ollama.Types.Format.SchemaDerive, +) where + +import Data.Aeson +import Ollama.Types.Format.SchemaBuilder +import Ollama.Types.Format.SchemaDerive + +{- | Response output format hint. + +@since 1.0.0.0 +-} +data Format + = -- | Constrain response output to generic valid JSON + JsonFormat + | -- | Constrain response output to a specific JSON Schema + SchemaFormat !Schema + deriving stock (Eq, Show) + +instance ToJSON Format where + toJSON JsonFormat = String "json" + toJSON (SchemaFormat sch) = toJSON sch + +instance FromJSON Format where + parseJSON (String "json") = pure JsonFormat + parseJSON v = SchemaFormat <$> parseJSON v + +{- | Produce a 'Format' value suitable for the @genFormat@ \/ @chatFormat@ +request fields. + +@ +req = (generateRequest model prompt) + { genFormat = Just ('formatFor' \@Person) } +@ + +@since 0.4.0.0 +-} +formatFor :: forall a. (ToSchema a) => Format +formatFor = SchemaFormat (schemaFor @a) diff --git a/src/Ollama/Types/Format/SchemaBuilder.hs b/src/Ollama/Types/Format/SchemaBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Format/SchemaBuilder.hs @@ -0,0 +1,223 @@ +{- | +Module : Ollama.Types.Format.SchemaBuilder +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +DSL for constructing structured JSON Schemas for Ollama's structured output API. + +@since 1.0.0.0 +-} +module Ollama.Types.Format.SchemaBuilder ( + JsonType (..), + Property (..), + Schema (..), + SchemaBuilder, + emptyObject, + addProperty, + addObjectProperty, + requireField, + requireFields, + buildSchema, + objectOf, + arrayOf, + printSchema, + (|+), + (|++), + (|!), + (|!!), +) where + +import Data.Aeson +import Data.Map.Strict qualified as HM +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TEncoding +import GHC.Generics (Generic) + +{- | Supported JSON primitive and compound types. + +@since 1.0.0.0 +-} +data JsonType + = JString + | JNumber + | JInteger + | JBoolean + | JNull + | JArray !JsonType + | JObject !Schema + deriving stock (Show, Eq, Generic) + +instance ToJSON JsonType where + toJSON JString = "string" + toJSON JNumber = "number" + toJSON JInteger = "integer" + toJSON JBoolean = "boolean" + toJSON JNull = "null" + toJSON (JArray _) = "array" + toJSON (JObject _) = "object" + +{- | Property metadata for schema properties. + +@since 1.0.0.0 +-} +newtype Property = Property JsonType + deriving stock (Show, Eq, Generic) + +instance ToJSON Property where + toJSON (Property (JArray itemType)) = + object ["type" .= ("array" :: Text), "items" .= Property itemType] + toJSON (Property (JObject schema)) = toJSON schema + toJSON (Property typ) = object ["type" .= typ] + +{- | JSON schema specification. + +@since 1.0.0.0 +-} +data Schema = Schema + { schemaProperties :: !(HM.Map Text Property) + , schemaRequired :: ![Text] + } + deriving stock (Show, Eq, Generic) + +instance ToJSON Schema where + toJSON (Schema props req) = + object + [ "type" .= ("object" :: Text) + , "properties" .= props + , "required" .= req + ] + +instance FromJSON JsonType where + parseJSON = withText "JsonType" $ \case + "string" -> pure JString + "number" -> pure JNumber + "integer" -> pure JInteger + "boolean" -> pure JBoolean + "null" -> pure JNull + "array" -> pure (JArray JString) + "object" -> pure (JObject (Schema HM.empty [])) + other -> fail $ "Unknown JsonType: " <> T.unpack other + +instance FromJSON Property where + parseJSON = withObject "Property" $ \v -> do + t <- v .: "type" + case (t :: Text) of + "array" -> Property . JArray <$> (v .: "items" >>= parseJSON) + "object" -> Property . JObject <$> parseJSON (Object v) + _ -> Property <$> parseJSON (String t) + +instance FromJSON Schema where + parseJSON = withObject "Schema" $ \v -> + Schema + <$> v .:? "properties" .!= HM.empty + <*> v .:? "required" .!= [] + +{- | Opaque builder for fluid schema construction. + +@since 1.0.0.0 +-} +newtype SchemaBuilder = SchemaBuilder Schema + deriving stock (Show, Eq) + +{- | Create an empty schema builder object. + +@since 1.0.0.0 +-} +emptyObject :: SchemaBuilder +emptyObject = SchemaBuilder $ Schema HM.empty [] + +{- | Add a primitive property to the schema builder. + +@since 1.0.0.0 +-} +addProperty :: Text -> JsonType -> SchemaBuilder -> SchemaBuilder +addProperty name typ (SchemaBuilder s) = + SchemaBuilder $ s {schemaProperties = HM.insert name (Property typ) (schemaProperties s)} + +{- | Add a nested object property to the schema builder. + +@since 1.0.0.0 +-} +addObjectProperty :: Text -> Schema -> SchemaBuilder -> SchemaBuilder +addObjectProperty name nestedSchema (SchemaBuilder s) = + SchemaBuilder $ + s {schemaProperties = HM.insert name (Property (JObject nestedSchema)) (schemaProperties s)} + +{- | Mark a field as required. + +@since 1.0.0.0 +-} +requireField :: Text -> SchemaBuilder -> SchemaBuilder +requireField name (SchemaBuilder s) = + SchemaBuilder $ s {schemaRequired = name : schemaRequired s} + +{- | Mark multiple fields as required. + +@since 1.0.0.0 +-} +requireFields :: [Text] -> SchemaBuilder -> SchemaBuilder +requireFields names builder = foldr requireField builder names + +{- | Finalize a 'Schema' from a 'SchemaBuilder'. + +@since 1.0.0.0 +-} +buildSchema :: SchemaBuilder -> Schema +buildSchema (SchemaBuilder s) = s + +{- | Treat a 'SchemaBuilder' as a nested object type. + +@since 1.0.0.0 +-} +objectOf :: SchemaBuilder -> JsonType +objectOf builder = JObject (buildSchema builder) + +{- | Create an array schema type of an element type. + +@since 1.0.0.0 +-} +arrayOf :: JsonType -> JsonType +arrayOf = JArray + +{- | Pretty-print a schema as formatted JSON. + +@since 1.0.0.0 +-} +printSchema :: Schema -> IO () +printSchema = putStrLn . T.unpack . TL.toStrict . TEncoding.decodeUtf8 . encode + +{- | Infix alias for 'addProperty'. + +@since 1.0.0.0 +-} +(|+) :: SchemaBuilder -> (Text, JsonType) -> SchemaBuilder +builder |+ (name, typ) = addProperty name typ builder + +{- | Infix alias for 'addObjectProperty'. + +@since 1.0.0.0 +-} +(|++) :: SchemaBuilder -> (Text, Schema) -> SchemaBuilder +builder |++ (name, schema) = addObjectProperty name schema builder + +{- | Infix alias for 'requireField'. + +@since 1.0.0.0 +-} +(|!) :: SchemaBuilder -> Text -> SchemaBuilder +builder |! name = requireField name builder + +{- | Infix alias for 'requireFields'. + +@since 1.0.0.0 +-} +(|!!) :: SchemaBuilder -> [Text] -> SchemaBuilder +builder |!! names = requireFields names builder + +infixl 7 |+, |++ +infixl 6 |!, |!! diff --git a/src/Ollama/Types/Format/SchemaDerive.hs b/src/Ollama/Types/Format/SchemaDerive.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Format/SchemaDerive.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Ollama.Types.Format.SchemaDerive +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : experimental +Portability : portable + +Generic derivation of JSON 'Schema' from Haskell record types. + +This module provides the 'ToSchema' typeclass, which can automatically +derive a JSON Schema ('Schema') from any Haskell data type that has a +'GHC.Generics.Generic' instance. This eliminates the need to manually +construct schemas using the 'Ollama.Types.Format.SchemaBuilder.SchemaBuilder' DSL when working with +Ollama's structured output API. + +== Usage + +Simply derive 'Generic' and declare a 'ToSchema' instance: + +@ +data Person = Person + { name :: Text + , age :: Int + } deriving stock ('GHC.Generics.Generic', Show) + deriving anyclass ('ToSchema') + +\-\- Use it: +\-\- >>> 'schemaFor' \@Person +\-\- >>> 'Ollama.Types.Format.formatFor' \@Person +@ + +== Supported types + +* __Record types__: All fields become properties; non‑'Maybe' fields + are marked as required. +* __'Maybe' fields__: Present in the schema properties but excluded + from the @required@ array. +* __Nested records__: Recursively derived as nested @object@ schemas. +* __Lists__: Mapped to @array@ schemas. +* __Simple enums__: Sum types with all nullary constructors are + represented as @{\"type\": \"string\", \"enum\": [...]}@. + +@since 0.4.0.0 +-} +module Ollama.Types.Format.SchemaDerive ( + -- * Typeclass + ToSchema (..), + ToJsonType (..), + + -- * Convenience functions + schemaFor, + + -- * Generic Machinery (internal) + GToSchema (..), + GCollectFields (..), + GEnumConstructors (..), + GToSchemaDispatch (..), +) where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Map.Strict qualified as Map +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics +import GHC.TypeLits (KnownSymbol, symbolVal) +import Ollama.Types.Format.SchemaBuilder (JsonType (..), Property (..), Schema (..)) + +-- --------------------------------------------------------------------------- +-- Public API +-- --------------------------------------------------------------------------- + +{- | Typeclass for types whose structure can be represented as a JSON 'Schema'. + +A default implementation is provided via @GHC.Generics@, so you can derive +it for any record type that has a 'Generic' instance: + +@ +data MyType = MyType { field1 :: Text, field2 :: Int } + deriving stock ('Generic') + deriving anyclass ('ToSchema') +@ + +@since 0.4.0.0 +-} +class ToSchema a where + {- | Produce the JSON 'Schema' for type @a@. + + @since 0.4.0.0 + -} + toSchema :: Schema + default toSchema :: (GToSchema (Rep a)) => Schema + toSchema = gToSchema @(Rep a) + +{- | Convenience alias for @'toSchema' \@a@. + +@since 0.4.0.0 +-} +schemaFor :: forall a. (ToSchema a) => Schema +schemaFor = toSchema @a + +{- | Map a Haskell type to its JSON Schema 'JsonType'. + +Instances are provided for common primitive types ('Text', 'Int', 'Bool', +'Double', etc.), 'Maybe', lists, and any type with a 'ToSchema' instance +(which maps to a nested @object@ schema). + +For nested record types, you don't need to write an instance manually — +simply ensure the nested type has a 'ToSchema' instance and the default +method will handle it: + +@ +data Address = Address { city :: Text, zip :: Text } + deriving stock ('Generic') + deriving anyclass ('ToSchema', 'ToJsonType') +@ + +@since 0.4.0.0 +-} +class ToJsonType a where + toJsonType :: JsonType + default toJsonType :: (ToSchema a) => JsonType + toJsonType = JObject (toSchema @a) + +-- --------------------------------------------------------------------------- +-- GHC.Generics machinery (internal) +-- --------------------------------------------------------------------------- + +-- | Walk a generic representation to produce a 'Schema'. +class GToSchema (f :: Type -> Type) where + gToSchema :: Schema + +-- | Collect fields (properties + required list) from a generic representation. +class GCollectFields (f :: Type -> Type) where + gCollectFields :: ([(Text, Property)], [Text]) + +-- | Collect constructor names from a sum type for enum schemas. +class GEnumConstructors (f :: Type -> Type) where + gEnumConstructors :: [Text] + +-- --------------------------------------------------------------------------- +-- Datatype / Constructor / Sum dispatch +-- --------------------------------------------------------------------------- + +-- | Strip datatype metadata wrapper. +instance (GToSchemaDispatch f) => GToSchema (M1 D meta f) where + gToSchema = gToSchemaDispatch @f + +-- | Dispatch: determine if this is a single-constructor record or a sum type. +class GToSchemaDispatch (f :: Type -> Type) where + gToSchemaDispatch :: Schema + +-- | Single constructor → collect fields into an object schema. +instance (GCollectFields f) => GToSchemaDispatch (M1 C meta f) where + gToSchemaDispatch = + let (props, req) = gCollectFields @f + in Schema (Map.fromList props) req + +{- | Sum type → try to build an enum schema. +We treat all-nullary sum types as string enums. +-} +instance (GEnumConstructors f, GEnumConstructors g) => GToSchemaDispatch (f :+: g) where + gToSchemaDispatch = + let constructors = gEnumConstructors @f <> gEnumConstructors @g + in Schema Map.empty constructors + +-- --------------------------------------------------------------------------- +-- Constructor / field collection +-- --------------------------------------------------------------------------- + +-- | Strip constructor metadata wrapper. +instance (GCollectFields f) => GCollectFields (M1 C meta f) where + gCollectFields = gCollectFields @f + +-- | Product of fields: combine both sides. +instance (GCollectFields f, GCollectFields g) => GCollectFields (f :*: g) where + gCollectFields = + let (ps1, rs1) = gCollectFields @f + (ps2, rs2) = gCollectFields @g + in (ps1 <> ps2, rs1 <> rs2) + +-- | Unit constructor (no fields). +instance GCollectFields U1 where + gCollectFields = ([], []) + +-- | Record field with a 'Maybe' type (optional — not required). +instance + {-# OVERLAPPING #-} + (KnownSymbol name, ToJsonType a) => + GCollectFields (M1 S ('MetaSel ('Just name) su ss ds) (K1 R (Maybe a))) + where + gCollectFields = + let fieldName = T.pack $ symbolVal (Proxy @name) + prop = Property (toJsonType @a) + in ([(fieldName, prop)], []) + +-- | Record field with a non-'Maybe' type (required). +instance + {-# OVERLAPPABLE #-} + (KnownSymbol name, ToJsonType a) => + GCollectFields (M1 S ('MetaSel ('Just name) su ss ds) (K1 R a)) + where + gCollectFields = + let fieldName = T.pack $ symbolVal (Proxy @name) + prop = Property (toJsonType @a) + in ([(fieldName, prop)], [fieldName]) + +-- --------------------------------------------------------------------------- +-- ToJsonType instances +-- --------------------------------------------------------------------------- + +-- Strings +instance ToJsonType Text where toJsonType = JString +instance ToJsonType String where toJsonType = JString + +-- Integers +instance ToJsonType Int where toJsonType = JInteger +instance ToJsonType Int8 where toJsonType = JInteger +instance ToJsonType Int16 where toJsonType = JInteger +instance ToJsonType Int32 where toJsonType = JInteger +instance ToJsonType Int64 where toJsonType = JInteger +instance ToJsonType Integer where toJsonType = JInteger +instance ToJsonType Word where toJsonType = JInteger +instance ToJsonType Word8 where toJsonType = JInteger +instance ToJsonType Word16 where toJsonType = JInteger +instance ToJsonType Word32 where toJsonType = JInteger +instance ToJsonType Word64 where toJsonType = JInteger + +-- Floating point +instance ToJsonType Double where toJsonType = JNumber +instance ToJsonType Float where toJsonType = JNumber + +-- Boolean +instance ToJsonType Bool where toJsonType = JBoolean + +-- Maybe: unwrap to the inner type +instance (ToJsonType a) => ToJsonType (Maybe a) where + toJsonType = toJsonType @a + +-- Lists / arrays +instance (ToJsonType a) => ToJsonType [a] where + toJsonType = JArray (toJsonType @a) + +-- --------------------------------------------------------------------------- +-- Enum constructors +-- --------------------------------------------------------------------------- + +-- | Sum of two branches. +instance (GEnumConstructors f, GEnumConstructors g) => GEnumConstructors (f :+: g) where + gEnumConstructors = gEnumConstructors @f <> gEnumConstructors @g + +-- | A nullary constructor (unit): extract constructor name. +instance (KnownSymbol name) => GEnumConstructors (M1 C ('MetaCons name fx 'False) U1) where + gEnumConstructors = [T.toLower . T.pack $ symbolVal (Proxy @name)] + +{- | A constructor with fields — not a simple enum. Produce a type error +at the instance level by not providing an instance (compile-time failure). +Users will get "No instance for GEnumConstructors ..." which is clear enough. +-} diff --git a/src/Ollama/Types/Message.hs b/src/Ollama/Types/Message.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Message.hs @@ -0,0 +1,129 @@ +{- | +Module : Ollama.Types.Message +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Chat message definitions and helper constructors. + +@since 3.0.0.0 +-} +module Ollama.Types.Message ( + Role (..), + Message (..), + userMessage, + systemMessage, + assistantMessage, + toolMessage, + toolResultMessage, + imageMessage, +) where + +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Types.Common (Base64Image) +import Ollama.Types.Tool (ToolCall) + +{- | Entity role in a conversation. + +@since 3.0.0.0 +-} +data Role = System | User | Assistant | Tool + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +instance ToJSON Role where + toJSON System = String "system" + toJSON User = String "user" + toJSON Assistant = String "assistant" + toJSON Tool = String "tool" + +instance FromJSON Role where + parseJSON = withText "Role" $ \case + "system" -> pure System + "user" -> pure User + "assistant" -> pure Assistant + "tool" -> pure Tool + other -> fail $ "Invalid Role: " <> show other + +{- | Chat message within a conversation payload. + +@since 3.0.0.0 +-} +data Message = Message + { messageRole :: !Role + , messageContent :: !Text + , messageImages :: !(Maybe [Base64Image]) + , messageToolCalls :: !(Maybe [ToolCall]) + , messageToolName :: !(Maybe Text) + , messageThinking :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON Message where + toJSON Message {..} = + object $ + catMaybes + [ Just $ "role" .= messageRole + , Just $ "content" .= messageContent + , ("images" .=) <$> messageImages + , ("tool_calls" .=) <$> messageToolCalls + , ("tool_name" .=) <$> messageToolName + , ("thinking" .=) <$> messageThinking + ] + +instance FromJSON Message where + parseJSON = withObject "Message" $ \v -> + Message + <$> v .: "role" + <*> v .: "content" + <*> v .:? "images" + <*> v .:? "tool_calls" + <*> v .:? "tool_name" + <*> v .:? "thinking" + +{- | Create a 'User' role message. + +@since 3.0.0.0 +-} +userMessage :: Text -> Message +userMessage t = Message User t Nothing Nothing Nothing Nothing + +{- | Create a 'System' role message. + +@since 3.0.0.0 +-} +systemMessage :: Text -> Message +systemMessage t = Message System t Nothing Nothing Nothing Nothing + +{- | Create an 'Assistant' role message. + +@since 3.0.0.0 +-} +assistantMessage :: Text -> Message +assistantMessage t = Message Assistant t Nothing Nothing Nothing Nothing + +{- | Create a 'Tool' role message. + +@since 3.0.0.0 +-} +toolMessage :: Text -> Message +toolMessage t = Message Tool t Nothing Nothing Nothing Nothing + +{- | Create a 'Tool' role message with specific @tool_name@ informing the model of tool execution. + +@since 3.0.0.0 +-} +toolResultMessage :: Text -> Text -> Message +toolResultMessage content toolName = + Message Tool content Nothing Nothing (Just toolName) Nothing + +{- | Create a 'User' message with attached Base64 image data. + +@since 3.0.0.0 +-} +imageMessage :: Text -> [Base64Image] -> Message +imageMessage t imgs = Message User t (Just imgs) Nothing Nothing Nothing diff --git a/src/Ollama/Types/Model.hs b/src/Ollama/Types/Model.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Model.hs @@ -0,0 +1,161 @@ +{- | +Module : Ollama.Types.Model +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model info, details, listing, and metadata types. + +@since 1.0.0.0 +-} +module Ollama.Types.Model ( + ModelDetails (..), + ModelInfo (..), + ListResponse (..), + RunningModel (..), + RunningModelsResponse (..), +) where + +import Data.Aeson +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Ollama.Types.Common (Digest, ModelName) + +{- | Detailed specifications of a model's architecture and family. + +@since 1.0.0.0 +-} +data ModelDetails = ModelDetails + { parentModel :: !(Maybe Text) + , format :: !Text + , family :: !Text + , families :: ![Text] + , parameterSize :: !Text + , quantizationLevel :: !Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ModelDetails where + parseJSON = withObject "ModelDetails" $ \v -> + ModelDetails + <$> v .:? "parent_model" + <*> v .:? "format" .!= "" + <*> v .:? "family" .!= "" + <*> v .:? "families" .!= [] + <*> v .:? "parameter_size" .!= "" + <*> v .:? "quantization_level" .!= "" + +instance ToJSON ModelDetails where + toJSON ModelDetails {..} = + object + [ "parent_model" .= parentModel + , "format" .= format + , "family" .= family + , "families" .= families + , "parameter_size" .= parameterSize + , "quantization_level" .= quantizationLevel + ] + +{- | Summary information for an installed local model. + +@since 1.0.0.0 +-} +data ModelInfo = ModelInfo + { miName :: !ModelName + , miModel :: !ModelName + , miModifiedAt :: !UTCTime + , miSize :: !Int64 + , miDigest :: !Digest + , miDetails :: !ModelDetails + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ModelInfo where + parseJSON = withObject "ModelInfo" $ \v -> + ModelInfo + <$> v .: "name" + <*> v .: "model" + <*> v .: "modified_at" + <*> v .: "size" + <*> v .: "digest" + <*> v .: "details" + +instance ToJSON ModelInfo where + toJSON ModelInfo {..} = + object + [ "name" .= miName + , "model" .= miModel + , "modified_at" .= miModifiedAt + , "size" .= miSize + , "digest" .= miDigest + , "details" .= miDetails + ] + +{- | Response listing available local models. + +@since 1.0.0.0 +-} +newtype ListResponse = ListResponse + { models :: [ModelInfo] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +{- | Summary information for a model currently loaded in memory. + +@since 1.0.0.0 +-} +data RunningModel = RunningModel + { rmName :: !ModelName + , rmModel :: !ModelName + , rmSize :: !Int64 + , rmDigest :: !Digest + , rmDetails :: !ModelDetails + , rmExpiresAt :: !UTCTime + , rmSizeVram :: !Int64 + } + deriving stock (Eq, Show, Generic) + +instance FromJSON RunningModel where + parseJSON = withObject "RunningModel" $ \v -> + RunningModel + <$> v .: "name" + <*> v .: "model" + <*> v .: "size" + <*> v .: "digest" + <*> v .: "details" + <*> v .: "expires_at" + <*> v .: "size_vram" + +instance ToJSON RunningModel where + toJSON RunningModel {..} = + object + [ "name" .= rmName + , "model" .= rmModel + , "size" .= rmSize + , "digest" .= rmDigest + , "details" .= rmDetails + , "expires_at" .= rmExpiresAt + , "size_vram" .= rmSizeVram + ] + +{- | Response listing loaded running models. + +@since 1.0.0.0 +-} +newtype RunningModelsResponse = RunningModelsResponse + { runningModels :: [RunningModel] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON RunningModelsResponse where + parseJSON = withObject "RunningModelsResponse" $ \v -> + RunningModelsResponse <$> v .: "models" + +instance ToJSON RunningModelsResponse where + toJSON RunningModelsResponse {..} = + object ["models" .= runningModels] diff --git a/src/Ollama/Types/Options.hs b/src/Ollama/Types/Options.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Options.hs @@ -0,0 +1,135 @@ +{- | +Module : Ollama.Types.Options +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Model parameters and runtime execution options. + +@since 3.0.0.0 +-} +module Ollama.Types.Options ( + ModelOptions (..), + defaultOptions, +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:?), (.=)) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) + +{- | Optional inference and hardware tuning parameters. + +@since 3.0.0.0 +-} +data ModelOptions = ModelOptions + { optNumKeep :: !(Maybe Int) + , optSeed :: !(Maybe Int) + , optNumPredict :: !(Maybe Int) + , optDraftNumPredict :: !(Maybe Int) + , optTopK :: !(Maybe Int) + , optTopP :: !(Maybe Double) + , optMinP :: !(Maybe Double) + , optTypicalP :: !(Maybe Double) + , optRepeatLastN :: !(Maybe Int) + , optTemperature :: !(Maybe Double) + , optRepeatPenalty :: !(Maybe Double) + , optPresencePenalty :: !(Maybe Double) + , optFrequencyPenalty :: !(Maybe Double) + , optPenalizeNewline :: !(Maybe Bool) + , optStop :: !(Maybe [Text]) + , optNuma :: !(Maybe Bool) + , optNumCtx :: !(Maybe Int) + , optNumBatch :: !(Maybe Int) + , optNumGpu :: !(Maybe Int) + , optMainGpu :: !(Maybe Int) + , optUseMmap :: !(Maybe Bool) + , optNumThread :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ModelOptions where + toJSON opts = + object $ + catMaybes + [ ("num_keep" .=) <$> optNumKeep opts + , ("seed" .=) <$> optSeed opts + , ("num_predict" .=) <$> optNumPredict opts + , ("draft_num_predict" .=) <$> optDraftNumPredict opts + , ("top_k" .=) <$> optTopK opts + , ("top_p" .=) <$> optTopP opts + , ("min_p" .=) <$> optMinP opts + , ("typical_p" .=) <$> optTypicalP opts + , ("repeat_last_n" .=) <$> optRepeatLastN opts + , ("temperature" .=) <$> optTemperature opts + , ("repeat_penalty" .=) <$> optRepeatPenalty opts + , ("presence_penalty" .=) <$> optPresencePenalty opts + , ("frequency_penalty" .=) <$> optFrequencyPenalty opts + , ("penalize_newline" .=) <$> optPenalizeNewline opts + , ("stop" .=) <$> optStop opts + , ("numa" .=) <$> optNuma opts + , ("num_ctx" .=) <$> optNumCtx opts + , ("num_batch" .=) <$> optNumBatch opts + , ("num_gpu" .=) <$> optNumGpu opts + , ("main_gpu" .=) <$> optMainGpu opts + , ("use_mmap" .=) <$> optUseMmap opts + , ("num_thread" .=) <$> optNumThread opts + ] + +instance FromJSON ModelOptions where + parseJSON = withObject "ModelOptions" $ \v -> + ModelOptions + <$> v .:? "num_keep" + <*> v .:? "seed" + <*> v .:? "num_predict" + <*> v .:? "draft_num_predict" + <*> v .:? "top_k" + <*> v .:? "top_p" + <*> v .:? "min_p" + <*> v .:? "typical_p" + <*> v .:? "repeat_last_n" + <*> v .:? "temperature" + <*> v .:? "repeat_penalty" + <*> v .:? "presence_penalty" + <*> v .:? "frequency_penalty" + <*> v .:? "penalize_newline" + <*> v .:? "stop" + <*> v .:? "numa" + <*> v .:? "num_ctx" + <*> v .:? "num_batch" + <*> v .:? "num_gpu" + <*> v .:? "main_gpu" + <*> v .:? "use_mmap" + <*> v .:? "num_thread" + +{- | Default empty options (all settings default to server Modelfile values). + +@since 3.0.0.0 +-} +defaultOptions :: ModelOptions +defaultOptions = + ModelOptions + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing diff --git a/src/Ollama/Types/Tool.hs b/src/Ollama/Types/Tool.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Tool.hs @@ -0,0 +1,148 @@ +{- | +Module : Ollama.Types.Tool +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Tool calling and structured function interfaces for the Ollama API. + +@since 3.0.0.0 +-} +module Ollama.Types.Tool ( + Tool (..), + FunctionDef (..), + FunctionParameters (..), + ToolCall (..), + ToolCallFunction (..), +) where + +import Data.Aeson +import Data.Map.Strict (Map) +import Data.Text (Text) +import GHC.Generics (Generic) + +{- | Tool definition provided to the model. + +@since 3.0.0.0 +-} +data Tool = Tool + { toolType :: !Text + , toolFunction :: !FunctionDef + } + deriving stock (Eq, Show, Generic) + +instance ToJSON Tool where + toJSON Tool {..} = + object + [ "type" .= toolType + , "function" .= toolFunction + ] + +instance FromJSON Tool where + parseJSON = withObject "Tool" $ \v -> + Tool + <$> v .: "type" + <*> v .: "function" + +{- | Definition of a function that can be called by the model. + +@since 3.0.0.0 +-} +data FunctionDef = FunctionDef + { fnName :: !Text + , fnDescription :: !(Maybe Text) + , fnParameters :: !(Maybe FunctionParameters) + , fnStrict :: !(Maybe Bool) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON FunctionDef where + toJSON FunctionDef {..} = + object $ + ["name" .= fnName] + ++ maybe [] (\d -> ["description" .= d]) fnDescription + ++ maybe [] (\p -> ["parameters" .= p]) fnParameters + ++ maybe [] (\s -> ["strict" .= s]) fnStrict + +instance FromJSON FunctionDef where + parseJSON = withObject "FunctionDef" $ \v -> + FunctionDef + <$> v .: "name" + <*> v .:? "description" + <*> v .:? "parameters" + <*> v .:? "strict" + +{- | Parameters schema for a function call. + +@since 3.0.0.0 +-} +data FunctionParameters = FunctionParameters + { fpType :: !Text + , fpProperties :: !(Maybe (Map Text FunctionParameters)) + , fpRequired :: !(Maybe [Text]) + , fpAdditionalProperties :: !(Maybe Bool) + , fpDescription :: !(Maybe Text) + , fpEnum :: !(Maybe [Text]) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON FunctionParameters where + toJSON FunctionParameters {..} = + object $ + ["type" .= fpType] + ++ maybe [] (\p -> ["properties" .= p]) fpProperties + ++ maybe [] (\r -> ["required" .= r]) fpRequired + ++ maybe [] (\a -> ["additionalProperties" .= a]) fpAdditionalProperties + ++ maybe [] (\d -> ["description" .= d]) fpDescription + ++ maybe [] (\e -> ["enum" .= e]) fpEnum + +instance FromJSON FunctionParameters where + parseJSON = withObject "FunctionParameters" $ \v -> + FunctionParameters + <$> v .: "type" + <*> v .:? "properties" + <*> v .:? "required" + <*> v .:? "additionalProperties" + <*> v .:? "description" + <*> v .:? "enum" + +{- | Tool call returned in model's assistant response. + +@since 3.0.0.0 +-} +newtype ToolCall = ToolCall + { tcFunction :: ToolCallFunction + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ToolCall where + toJSON ToolCall {..} = object ["function" .= tcFunction] + +instance FromJSON ToolCall where + parseJSON = withObject "ToolCall" $ \v -> + ToolCall <$> v .: "function" + +{- | Function invocation payload inside a tool call. + +@since 3.0.0.0 +-} +data ToolCallFunction = ToolCallFunction + { tcfName :: !Text + , tcfArguments :: !(Map Text Value) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ToolCallFunction where + toJSON ToolCallFunction {..} = + object + [ "name" .= tcfName + , "arguments" .= tcfArguments + ] + +instance FromJSON ToolCallFunction where + parseJSON = withObject "ToolCallFunction" $ \v -> + ToolCallFunction + <$> v .: "name" + <*> v .: "arguments" diff --git a/test-integration/Main.hs b/test-integration/Main.hs new file mode 100644 --- /dev/null +++ b/test-integration/Main.hs @@ -0,0 +1,176 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Ollama +import Test.Tasty +import Test.Tasty.HUnit + +testModel :: ModelName +testModel = "qwen3.5:2b" + +fastOptions :: Maybe ModelOptions +fastOptions = Just (defaultOptions {optNumPredict = Just 15}) + +tests :: TestTree +tests = + testGroup + "ollama-haskell Live Server End-to-End Test Suite" + [ testCase "GET /api/version — getVersion" $ do + client <- defaultClient + res <- getVersion client + case res of + Left err -> assertFailure $ "Version request failed: " <> show err + Right ver -> assertBool "Version non-empty" (not $ T.null $ unVersion ver) + , testCase "GET /api/tags — listModels" $ do + client <- defaultClient + res <- listModels client + case res of + Left err -> assertFailure $ "List models failed: " <> show err + Right (ListResponse ms) -> + assertBool "Has installed models" (not $ null ms) + , testCase "POST /api/show — showModel" $ do + client <- defaultClient + res <- showModel client testModel + case res of + Left err -> assertFailure $ "Show model failed: " <> show err + Right resp -> + assertBool "Modelfile or details present" (not $ T.null $ srsModelfile resp) + , testCase "GET /api/ps — listRunning" $ do + client <- defaultClient + res <- listRunning client + case res of + Left err -> assertFailure $ "List running failed: " <> show err + Right _ -> pure () + , testCase "POST /api/chat — non-streaming chat" $ do + client <- defaultClient + let msgs = systemMessage "You are a helpful assistant." :| [userMessage "Say hello in one word."] + req = (chatRequest testModel msgs) {chatOptions = fastOptions, chatThink = Just ThinkDisabled} + res <- chat client req + case res of + Left err -> assertFailure $ "Chat request failed: " <> show err + Right resp -> do + assertBool "Chat response done" (crDone resp) + case crMessage resp of + Nothing -> assertFailure "Expected message in response" + Just msg -> + assertBool + "Message content or thinking present" + (not (T.null (messageContent msg)) || maybe False (not . T.null) (messageThinking msg)) + , testCase "POST /api/chat — streaming chat with conduit" $ do + client <- defaultClient + let req = (chatRequest testModel (userMessage "Count from 1 to 5." :| [])) {chatThink = Just ThinkDisabled} + chunks <- collectStream (chatStream client req) + assertBool "Stream produced response chunks" (not $ null chunks) + , testCase "POST /api/generate — non-streaming generate" $ do + client <- defaultClient + let req = + (generateRequest testModel "Write 3 words.") + { genOptions = fastOptions + , genThink = Just ThinkDisabled + } + res <- generate client req + case res of + Left err -> assertFailure $ "Generate request failed: " <> show err + Right resp -> do + assertBool "Generate response done" (grDone resp) + assertBool "Generated response non-empty" (not $ T.null $ grResponse resp) + , testCase "POST /api/generate — streaming generate with conduit" $ do + client <- defaultClient + let req = (generateRequest testModel "Say hi.") {genThink = Just ThinkDisabled} + chunks <- collectStream (generateStream client req) + assertBool "Stream produced generate chunks" (not $ null chunks) + , testCase "POST /api/generate — thinking model support" $ do + client <- defaultClient + let req = + (generateRequest testModel "What is 2 + 2?") + { genThink = Just ThinkEnabled + , genOptions = fastOptions + } + res <- generate client req + case res of + Left err -> assertFailure $ "Thinking generate failed: " <> show err + Right resp -> assertBool "Response done" (grDone resp) + , testCase "POST /api/chat — tool calling definition and execution" $ do + client <- defaultClient + let weatherTool = + Tool + { toolType = "function" + , toolFunction = + FunctionDef + { fnName = "get_current_weather" + , fnDescription = Just "Get current weather for a city" + , fnParameters = + Just + FunctionParameters + { fpType = "object" + , fpProperties = Nothing + , fpRequired = Just ["location"] + , fpAdditionalProperties = Nothing + , fpDescription = Nothing + , fpEnum = Nothing + } + , fnStrict = Nothing + } + } + req = + (chatRequest testModel (userMessage "What is the weather in Tokyo?" :| [])) + { chatTools = Just [weatherTool] + , chatOptions = fastOptions + , chatThink = Just ThinkDisabled + } + res <- chat client req + case res of + Left err -> assertFailure $ "Tool chat request failed: " <> show err + Right resp -> assertBool "Chat response completed" (crDone resp) + , testCase "POST /api/chat — structured output format" $ do + client <- defaultClient + let req = + (chatRequest testModel (userMessage "Respond with JSON listing 2 colors" :| [])) + { chatFormat = Just JsonFormat + , chatOptions = fastOptions + , chatThink = Just ThinkDisabled + } + res <- chat client req + case res of + Left err -> assertFailure $ "Structured chat failed: " <> show err + Right resp -> assertBool "Response done" (crDone resp) + , testCase "POST /api/embed — vector embeddings" $ do + client <- defaultClient + let req = embedRequest testModel ["Hello world", "Haskell LLM client"] + res <- embed client req + case res of + Left (ApiError 501 _) -> pure () + Left err -> assertFailure $ "Embed request failed: " <> show err + Right resp -> + assertBool "Embeddings non-empty" (not $ null $ erEmbeddings resp) + , testCase "POST /api/copy & DELETE /api/delete — model lifecycle" $ do + client <- defaultClient + let copyTarget = "qwen3.5:2b-test-copy" + copyRes <- copyModel client testModel copyTarget + case copyRes of + Left err -> assertFailure $ "Copy model failed: " <> show err + Right () -> do + delRes <- deleteModel client copyTarget + case delRes of + Left err -> assertFailure $ "Delete model failed: " <> show err + Right () -> pure () + , testCase "ConversationStore — InMemoryStore with real conversation" $ do + store <- initInMemoryStore + now <- getCurrentTime + let cid = "test-conv-1" + conv = + Conversation + cid + [systemMessage "You are a concise assistant.", userMessage "My favorite color is green."] + testModel + now + now + saveConversationInMemory store conv + mConv <- loadConversationInMemory store cid + assertEqual "Loaded saved conversation" (Just conv) mConv + ] + +main :: IO () +main = defaultMain tests diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,212 +1,36 @@ -{-# LANGUAGE OverloadedStrings #-} - module Main (main) where -import Data.Either -import Data.List.NonEmpty hiding (length) -import Data.Maybe -import Data.Ollama.Chat qualified as Chat -import Data.Text.IO qualified as T -import Ollama (GenerateOps (..), Role (..), defaultChatOps, defaultGenerateOps) -import Ollama qualified -import System.IO.Silently (capture) +import Test.Ollama.Golden.Chat qualified as GoldenChat +import Test.Ollama.Golden.Embed qualified as GoldenEmbed +import Test.Ollama.Golden.Generate qualified as GoldenGenerate +import Test.Ollama.Golden.Models qualified as GoldenModels +import Test.Ollama.Property.Roundtrip qualified as PropertyRoundtrip +import Test.Ollama.Unit.Config qualified as UnitConfig +import Test.Ollama.Unit.Error qualified as UnitError +import Test.Ollama.Unit.MCP qualified as UnitMCP +import Test.Ollama.Unit.SchemaBuilder qualified as UnitSchemaBuilder +import Test.Ollama.Unit.SchemaDerive qualified as UnitSchemaDerive +import Test.Ollama.Unit.Testing qualified as UnitTesting +import Test.Ollama.Unit.Types qualified as UnitTypes import Test.Tasty -import Test.Tasty.HUnit -import qualified Data.Text as T -import Data.Aeson tests :: TestTree tests = testGroup - "Tests" - [ generateTest - , chatTest - , psTest - , showTest - , embeddingTest - , generateFormatTest - , chatFormatTest - ] - -generateTest :: TestTree -generateTest = - testGroup - "Generate tests" - [ testCase "generate stream" $ do - output <- - capture $ - Ollama.generate - defaultGenerateOps - { modelName = "llama3.2" - , prompt = "what is 4 + 2?" - , stream = Just (T.putStr . Ollama.response_, pure ()) - } - assertBool "Checking if generate function is printing anything" (length output > 0) - , testCase "Generate non-stream" $ do - eRes <- - Ollama.generate - defaultGenerateOps - { modelName = "llama3.2" - , prompt = "what is 4 + 2?" - } - assertBool "Checking if generate function returns a valid value" (isRight eRes) - , testCase "Generate with invalid host" $ do - eRes <- Ollama.generate defaultGenerateOps { - modelName = "llama3.2" - , prompt = "what is 23 + 9?" - , hostUrl = pure "http://some-site" - , responseTimeOut = pure 2 - } - print ("got response" :: String ,eRes) - assertBool "Expecting Left" (isLeft eRes) - , testCase "Generate with invalid model" $ do - eRes <- Ollama.generate defaultGenerateOps {modelName = "invalid-model"} - assertBool "Expecting generation to fail with invalid model" (isLeft eRes) - ] - -generateFormatTest :: TestTree -generateFormatTest = - testGroup "Generate tests with format and options" - [ testCase "Generate with SchemaFormat and options" $ do - let schema = object - [ "type" .= ("object" :: String) - , "properties" .= object [ "age" .= object ["type" .= ("integer" :: String)] ] - ] - eRes <- - Ollama.generate - defaultGenerateOps - { modelName = "llama3.2" - , prompt = "Ollama is 22 years old and is busy saving the world. Respond using JSON" - , format = Just (Ollama.SchemaFormat schema) - } - case eRes of - Right res -> - assertBool "Response should contain JSON with key \"age\"" ( "age" `T.isInfixOf` Ollama.response_ res ) - Left err -> - assertFailure $ "Generation failed with error: " ++ show err - , testCase "Generate with JsonFormat and options" $ do - eRes <- - Ollama.generate - defaultGenerateOps - { modelName = "llama3.2" - , prompt = "Provide a simple JSON response describing Ollama." - , format = Just Ollama.JsonFormat - } - case eRes of - Right res -> - assertBool "Response should start with '{'" ( "{" `T.isPrefixOf` Ollama.response_ res ) - Left err -> - assertFailure $ "Generation failed with error: " ++ show err - ] - -chatTest :: TestTree -chatTest = - testGroup - "Chat tests" - [ testCase "chat stream" $ do - let msg = Ollama.Message User "What is 29 + 3?" Nothing Nothing - defaultMsg = Ollama.Message User "" Nothing Nothing - output <- - capture $ - Ollama.chat - defaultChatOps - { Chat.chatModelName = "llama3.2" - , Chat.messages = msg :| [] - , Chat.stream = Just (T.putStr . Chat.content . fromMaybe defaultMsg . Chat.message, pure ()) - } - assertBool "Checking if chat function is printing anything" (length output > 0) - , testCase "Chat non-stream" $ do - let msg = Ollama.Message User "What is 29 + 3?" Nothing Nothing - eRes <- - Ollama.chat - defaultChatOps - { Chat.chatModelName = "llama3.2" - , Chat.messages = msg :| [] - } - assertBool "Checking if chat function returns a valid value" (isRight eRes) - , testCase "Chat invalid host url" $ do - let msg = Ollama.Message User "What is 29 + 3?" Nothing Nothing - eRes <- - Ollama.chat - defaultChatOps - { Chat.chatModelName = "llama3.2" - , Chat.messages = msg :| [] - , Chat.hostUrl = pure "some random value" - , Chat.responseTimeOut = pure 2 - } - assertBool "It should return Left" (isLeft eRes) - ] - -chatFormatTest :: TestTree -chatFormatTest = - testGroup "Chat tests with format and options" - [ testCase "Chat with SchemaFormat and options" $ do - let schema = object - [ "type" .= ("object" :: String) - , "properties" .= object [ "age" .= object ["type" .= ("integer" :: String)] ] - ] - msg = Ollama.Message User "Ollama is 22 years old and is busy saving the world. Respond using JSON" Nothing Nothing - eRes <- - Ollama.chat - defaultChatOps - { Chat.chatModelName = "llama3.2" - , Chat.messages = msg :| [] - , Chat.format = Just (Ollama.SchemaFormat schema) - , Chat.options = Just $ object ["penalize_newline" .= Bool True] - } - case eRes of - Right res -> - assertBool "Chat response should contain key \"age\"" $ - maybe False (\m -> "age" `T.isInfixOf` Chat.content m) (Chat.message res) - Left err -> - assertFailure $ "Chat failed with error: " ++ show err - , testCase "Chat with JsonFormat and options" $ do - let msg = Ollama.Message User "Tell me about Ollama in JSON format." Nothing Nothing - eRes <- - Ollama.chat - defaultChatOps - { Chat.chatModelName = "llama3.2" - , Chat.messages = msg :| [] - , Chat.format = Just Ollama.JsonFormat - } - case eRes of - Right res -> - assertBool "Chat response should start with '{'" $ - maybe False (\m -> "{" `T.isPrefixOf` Chat.content m) (Chat.message res) - Left err -> - assertFailure $ "Chat failed with error: " ++ show err - ] - -psTest :: TestTree -psTest = - testGroup - "PS test" - [ testCase "check ps" $ do - mRes <- Ollama.ps - assertBool "Check if ps returns anything" (isJust mRes) - ] - -showTest :: TestTree -showTest = - testGroup - "Show test" - [ testCase "check show" $ do - mRes <- Ollama.showModel "llama3.2" - assertBool "Check if model exists or not" (isJust mRes) - ] - -embeddingTest :: TestTree -embeddingTest = - testGroup - "Embedding test" - [ testCase "check embedding" $ do - eRes <- Ollama.embedding "llama3.2" "Why is sky blue?" - assertBool "Check if embedding returns anything" (isRight eRes) + "ollama-haskell Pure Test Suite" + [ UnitTypes.tests + , UnitError.tests + , UnitConfig.tests + , UnitSchemaBuilder.tests + , UnitSchemaDerive.tests + , UnitTesting.testingTests + , UnitMCP.tests + , PropertyRoundtrip.tests + , GoldenChat.tests + , GoldenGenerate.tests + , GoldenEmbed.tests + , GoldenModels.tests ] main :: IO () -main = do - mRes <- Ollama.list - case mRes of - Nothing -> pure () -- Ollama is likely not running. Not running tests. - Just _ -> defaultMain tests +main = defaultMain tests diff --git a/test/Test/Ollama/Golden/Chat.hs b/test/Test/Ollama/Golden/Chat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Golden/Chat.hs @@ -0,0 +1,25 @@ +module Test.Ollama.Golden.Chat (tests) where + +import Data.Aeson (encode) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Ollama +import Test.Tasty +import Test.Tasty.Golden + +tests :: TestTree +tests = + testGroup + "Golden JSON Serialization Tests" + [ goldenVsString + "ChatRequest JSON wire format matches golden fixture" + "test/golden/chat_request.golden" + (pure $ encode $ chatRequest "llama3.2" (userMessage "Why is the sky blue?" :| [])) + , goldenVsString + "GenerateRequest JSON wire format matches golden fixture" + "test/golden/generate_request.golden" + (pure $ encode $ generateRequest "llama3.2" "Why is the sky blue?") + , goldenVsString + "EmbedRequest JSON wire format matches golden fixture" + "test/golden/embed_request.golden" + (pure $ encode $ embedRequest "nomic-embed-text" ["hello", "world"]) + ] diff --git a/test/Test/Ollama/Golden/Embed.hs b/test/Test/Ollama/Golden/Embed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Golden/Embed.hs @@ -0,0 +1,16 @@ +module Test.Ollama.Golden.Embed (tests) where + +import Data.Aeson (encode) +import Ollama +import Test.Tasty +import Test.Tasty.Golden + +tests :: TestTree +tests = + testGroup + "Embed Golden JSON Serialization Tests" + [ goldenVsString + "EmbedRequest golden serialization" + "test/golden/embed_request.golden" + (pure $ encode $ embedRequest "nomic-embed-text" ["hello", "world"]) + ] diff --git a/test/Test/Ollama/Golden/Generate.hs b/test/Test/Ollama/Golden/Generate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Golden/Generate.hs @@ -0,0 +1,16 @@ +module Test.Ollama.Golden.Generate (tests) where + +import Data.Aeson (encode) +import Ollama +import Test.Tasty +import Test.Tasty.Golden + +tests :: TestTree +tests = + testGroup + "Generate Golden JSON Serialization Tests" + [ goldenVsString + "GenerateRequest golden serialization" + "test/golden/generate_request.golden" + (pure $ encode $ generateRequest "llama3.2" "Why is the sky blue?") + ] diff --git a/test/Test/Ollama/Golden/Models.hs b/test/Test/Ollama/Golden/Models.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Golden/Models.hs @@ -0,0 +1,16 @@ +module Test.Ollama.Golden.Models (tests) where + +import Data.Aeson (encode) +import Ollama +import Test.Tasty +import Test.Tasty.Golden + +tests :: TestTree +tests = + testGroup + "Model Management Golden JSON Serialization Tests" + [ goldenVsString + "CreateRequest golden serialization" + "test/golden/create_request.golden" + (pure $ encode $ defaultCreateRequest "custom-model") + ] diff --git a/test/Test/Ollama/Property/Arbitrary.hs b/test/Test/Ollama/Property/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Property/Arbitrary.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Ollama.Property.Arbitrary () where + +import Data.Text (Text) +import Data.Text qualified as T +import Ollama +import Ollama.Types.Message qualified as M +import Test.QuickCheck + +genNonEmptyText :: Gen Text +genNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z']) + +instance Arbitrary Role where + arbitrary = elements [System, User, Assistant, M.Tool] + +instance Arbitrary ModelName where + arbitrary = ModelName <$> genNonEmptyText + +instance Arbitrary Digest where + arbitrary = Digest . ("sha256:" <>) <$> genNonEmptyText + +instance Arbitrary Base64Image where + arbitrary = Base64Image <$> genNonEmptyText + +instance Arbitrary Duration where + arbitrary = Duration <$> choose (1, 1000000000) + +instance Arbitrary ThinkingLevel where + arbitrary = elements [ThinkLow, ThinkMedium, ThinkHigh, ThinkMax] + +instance Arbitrary Think where + arbitrary = + oneof + [ pure ThinkEnabled + , pure ThinkDisabled + , ThinkLevel <$> arbitrary + ] + +instance Arbitrary Message where + arbitrary = + Message + <$> arbitrary + <*> genNonEmptyText + <*> pure Nothing + <*> pure Nothing + <*> pure Nothing + <*> pure Nothing + +instance Arbitrary Format where + arbitrary = pure JsonFormat diff --git a/test/Test/Ollama/Property/Roundtrip.hs b/test/Test/Ollama/Property/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Property/Roundtrip.hs @@ -0,0 +1,34 @@ +module Test.Ollama.Property.Roundtrip (tests) where + +import Data.Aeson (decode, encode) +import Data.Text qualified as T +import Ollama +import Test.Ollama.Property.Arbitrary () +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "Property & Roundtrip QuickCheck Tests" + [ testProperty "Role JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(r :: Role) -> decode (encode r) === Just r + , testProperty "Message JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(msg :: Message) -> decode (encode msg) === Just msg + , testProperty "ModelName JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(m :: ModelName) -> decode (encode m) === Just m + , testProperty "Think JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(t :: Think) -> decode (encode t) === Just t + , testProperty "Digest JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(d :: Digest) -> decode (encode d) === Just d + , testProperty "Duration JSON roundtrip: ∀ x. decode (encode x) == Just x" $ + \(dur :: Duration) -> decode (encode dur) === Just dur + , testProperty "Idempotency property: ∀ x. encode (decoded x) == encode x" $ + \(msg :: Message) -> case decode (encode msg) :: Maybe Message of + Nothing -> property False + Just decoded -> encode decoded === encode msg + , testProperty "Smart constructor invariant: mkModelName never returns empty ModelName" $ + \txt -> case mkModelName (T.pack txt) of + Left err -> err === "Model name cannot be empty" + Right (ModelName name) -> not (T.null name) === True + ] diff --git a/test/Test/Ollama/Unit/Config.hs b/test/Test/Ollama/Unit/Config.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/Config.hs @@ -0,0 +1,19 @@ +module Test.Ollama.Unit.Config (tests) where + +import Ollama.Client.Config +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit Config Tests" + [ testCase "defaultConfig settings" $ do + assertEqual "Default base URL" "http://127.0.0.1:11434" (configBaseUrl defaultConfig) + assertEqual "Default timeout" 300 (configTimeout defaultConfig) + assertEqual "Default retry policy" NoRetry (configRetry defaultConfig) + , testCase "RetryPolicy smart constructors" $ do + assertEqual "noRetry" NoRetry noRetry + assertEqual "constantRetry" (ConstantRetry 3 1000000) (constantRetry 3 1000000) + assertEqual "exponentialRetry" (ExponentialRetry 5 500000) (exponentialRetry 5 500000) + ] diff --git a/test/Test/Ollama/Unit/Error.hs b/test/Test/Ollama/Unit/Error.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/Error.hs @@ -0,0 +1,22 @@ +module Test.Ollama.Unit.Error (tests) where + +import Control.Exception (try) +import Ollama.Error +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit Error Tests" + [ testCase "isRetryable correctly classifies transient vs non-transient errors" $ do + assertBool "TimeoutError is retryable" (isRetryable TimeoutError) + assertBool "ApiError is not retryable" (not $ isRetryable (ApiError 404 "Not Found")) + assertBool "InvalidRequest is not retryable" (not $ isRetryable (InvalidRequest "Bad model")) + , testCase "OllamaError Eq instance compares ApiError and TimeoutError" $ do + assertEqual "ApiError equal" (ApiError 500 "Server Error") (ApiError 500 "Server Error") + assertBool "ApiError not equal to TimeoutError" (ApiError 500 "Server Error" /= TimeoutError) + , testCase "throwOllama raises OllamaError as an Exception" $ do + res <- try (throwOllama TimeoutError) :: IO (Either OllamaError ()) + assertEqual "Caught thrown OllamaError" (Left TimeoutError) res + ] diff --git a/test/Test/Ollama/Unit/MCP.hs b/test/Test/Ollama/Unit/MCP.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/MCP.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Ollama.Unit.MCP (tests) where + +import Data.Map.Strict qualified as Map +import MCP.Server.Types ( + Content (..), + ContentImageData (..), + ResourceContent (..), + ToolDefinition (..), + describedSchema, + mkToolDefinition, + parseURI, + schema, + ) +import Ollama.MCP ( + SchemaType (..), + mcpContentToToolOutput, + mcpDefinitionToTool, + schemaDescription, + schemaShape, + toolCallToMcpArgs, + toolToMcpDefinition, + ) +import Ollama.Types.Tool ( + FunctionDef (..), + FunctionParameters (..), + Tool (..), + ToolCall (..), + ToolCallFunction (..), + ) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit MCP Integration Tests (mcp-server)" + [ testCase "toolToMcpDefinition converts Ollama Tool to mcp-server ToolDefinition" $ do + let propMap = + Map.fromList + [ ("query", FunctionParameters "string" Nothing Nothing Nothing (Just "Search query") Nothing) + , ("limit", FunctionParameters "integer" Nothing Nothing Nothing (Just "Max results") Nothing) + ] + params = FunctionParameters "object" (Just propMap) (Just ["query"]) Nothing Nothing Nothing + ollamaTool = Tool "function" $ FunctionDef "search" (Just "Search codebase") (Just params) Nothing + mcpDef = toolToMcpDefinition ollamaTool + + toolDefinitionName mcpDef @?= "search" + toolDefinitionDescription mcpDef @?= "Search codebase" + case schemaShape (toolDefinitionInputSchema mcpDef) of + SchemaObject props req -> do + req @?= ["query"] + length props @?= 2 + case lookup "query" props of + Just s -> do + schemaDescription s @?= Just "Search query" + schemaShape s @?= SchemaString Nothing + Nothing -> assertFailure "Expected query in props" + _ -> assertFailure "Expected SchemaObject" + , testCase "mcpDefinitionToTool converts mcp-server ToolDefinition to Ollama Tool" $ do + let props = + [ ("path", describedSchema "File path" (SchemaString Nothing)) + , ("content", describedSchema "File content" (SchemaString Nothing)) + ] + s = schema (SchemaObject props ["path", "content"]) + mcpDef = mkToolDefinition "write_file" "Write file to disk" s + ollamaTool = mcpDefinitionToTool mcpDef + + toolType ollamaTool @?= "function" + let fn = toolFunction ollamaTool + fnName fn @?= "write_file" + fnDescription fn @?= Just "Write file to disk" + case fnParameters fn of + Just FunctionParameters {..} -> do + fpType @?= "object" + fpRequired @?= Just ["path", "content"] + case fpProperties of + Just pm -> Map.member "path" pm @?= True + Nothing -> assertFailure "Expected properties" + Nothing -> assertFailure "Expected parameters" + , testCase "toolCallToMcpArgs converts Ollama ToolCall to mcp-server argument pairs" $ do + let call = ToolCall (ToolCallFunction "greet" (Map.fromList [("name", "Alice")])) + (fn, args) = toolCallToMcpArgs call + fn @?= "greet" + lookup "name" args @?= Just "Alice" + , testCase "mcpContentToToolOutput extracts text from mcp-server Content" $ do + let textContent = ContentText "Execution output" + mcpContentToToolOutput textContent @?= "Execution output" + + let imgContent = ContentImage (ContentImageData "base64..." "image/png") + mcpContentToToolOutput imgContent @?= "[Image: image/png]" + + case parseURI "file:///workspace/test.txt" of + Just uri -> do + let resContent = ContentEmbeddedResource (ResourceText uri "text/plain" "file contents") + mcpContentToToolOutput resContent @?= "[Resource: file:///workspace/test.txt]" + Nothing -> assertFailure "Failed to parse URI" + ] diff --git a/test/Test/Ollama/Unit/SchemaBuilder.hs b/test/Test/Ollama/Unit/SchemaBuilder.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/SchemaBuilder.hs @@ -0,0 +1,33 @@ +module Test.Ollama.Unit.SchemaBuilder (tests) where + +import Data.Aeson (decode, encode) +import Ollama.Types.Format +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit SchemaBuilder DSL Tests" + [ testCase "Build object schema with required and optional fields" $ do + let builder = + emptyObject + |+ ("name", JString) + |+ ("age", JInteger) + |+ ("is_student", JBoolean) + |! "name" + sch = buildSchema builder + encoded = encode sch + assertBool "Non-empty JSON schema" (not $ null $ show encoded) + , testCase "Build array schema" $ do + let itemType = arrayOf JString + builder = emptyObject |+ ("items", itemType) + sch = buildSchema builder + encoded = encode sch + assertBool "Non-empty array schema" (not $ null $ show encoded) + , testCase "SchemaFormat wrapping & JSON roundtrip" $ do + let builder = emptyObject |+ ("count", JInteger) |! "count" + sch = buildSchema builder + fmt = SchemaFormat sch + assertEqual "SchemaFormat JSON roundtrip check" (Just fmt) (decode $ encode fmt) + ] diff --git a/test/Test/Ollama/Unit/SchemaDerive.hs b/test/Test/Ollama/Unit/SchemaDerive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/SchemaDerive.hs @@ -0,0 +1,170 @@ +module Test.Ollama.Unit.SchemaDerive (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Types.Format +import Test.Tasty +import Test.Tasty.HUnit + +-- --------------------------------------------------------------------------- +-- Test types +-- --------------------------------------------------------------------------- + +data SimplePerson = SimplePerson + { name :: Text + , age :: Int + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithOptional = PersonWithOptional + { personName :: Text + , personAge :: Int + , personNickname :: Maybe Text + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data Address = Address + { city :: Text + , zipCode :: Text + } + deriving stock (Generic) + deriving anyclass (ToSchema, ToJsonType) + +data PersonWithAddress = PersonWithAddress + { fullName :: Text + , homeAddress :: Address + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithHobbies = PersonWithHobbies + { hobbyName :: Text + , hobbies :: [Text] + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data Color = Red | Green | Blue + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithMaybeInt = PersonWithMaybeInt + { pmName :: Text + , pmScore :: Maybe Int + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Unit SchemaDerive Tests" + [ testSimpleRecord + , testOptionalFields + , testNestedRecord + , testArrayFields + , testEnumType + , testMaybeUnwrapsType + , testSchemaForAlias + , testFormatFor + , testMatchesManualSchema + ] + +testSimpleRecord :: TestTree +testSimpleRecord = testCase "Simple record produces correct schema" $ do + let schema = schemaFor @SimplePerson + props = schemaProperties schema + req = schemaRequired schema + assertEqual "Has 'name' property" (Just (Property JString)) (Map.lookup "name" props) + assertEqual "Has 'age' property" (Just (Property JInteger)) (Map.lookup "age" props) + assertEqual "Has 2 properties" 2 (Map.size props) + assertBool "'name' is required" ("name" `elem` req) + assertBool "'age' is required" ("age" `elem` req) + assertEqual "2 required fields" 2 (length req) + +testOptionalFields :: TestTree +testOptionalFields = testCase "Maybe fields are not required" $ do + let schema = schemaFor @PersonWithOptional + props = schemaProperties schema + req = schemaRequired schema + assertEqual "Has 3 properties" 3 (Map.size props) + assertEqual + "'personNickname' maps to JString" + (Just (Property JString)) + (Map.lookup "personNickname" props) + assertBool "'personName' is required" ("personName" `elem` req) + assertBool "'personAge' is required" ("personAge" `elem` req) + assertBool "'personNickname' is NOT required" ("personNickname" `notElem` req) + assertEqual "2 required fields" 2 (length req) + +testNestedRecord :: TestTree +testNestedRecord = testCase "Nested record becomes JObject" $ do + let schema = schemaFor @PersonWithAddress + props = schemaProperties schema + case Map.lookup "homeAddress" props of + Just (Property (JObject innerSchema)) -> do + let innerProps = schemaProperties innerSchema + assertEqual "Inner has 'city'" (Just (Property JString)) (Map.lookup "city" innerProps) + assertEqual "Inner has 'zipCode'" (Just (Property JString)) (Map.lookup "zipCode" innerProps) + other -> assertFailure $ "Expected JObject for homeAddress, got: " <> show other + +testArrayFields :: TestTree +testArrayFields = testCase "List fields become JArray" $ do + let schema = schemaFor @PersonWithHobbies + props = schemaProperties schema + assertEqual + "'hobbies' maps to JArray JString" + (Just (Property (JArray JString))) + (Map.lookup "hobbies" props) + +testEnumType :: TestTree +testEnumType = testCase "Simple enum produces schema with constructor names" $ do + let schema = schemaFor @Color + req = schemaRequired schema + -- Enum constructors are stored in required list (as enum values) + assertBool "Contains 'red'" ("red" `elem` req) + assertBool "Contains 'green'" ("green" `elem` req) + assertBool "Contains 'blue'" ("blue" `elem` req) + assertEqual "3 enum values" 3 (length req) + assertEqual "No properties" 0 (Map.size $ schemaProperties schema) + +testMaybeUnwrapsType :: TestTree +testMaybeUnwrapsType = testCase "Maybe Int field maps to JInteger" $ do + let schema = schemaFor @PersonWithMaybeInt + props = schemaProperties schema + assertEqual "'pmScore' maps to JInteger" (Just (Property JInteger)) (Map.lookup "pmScore" props) + +testSchemaForAlias :: TestTree +testSchemaForAlias = testCase "schemaFor is equivalent to toSchema" $ do + let s1 = schemaFor @SimplePerson + s2 = toSchema @SimplePerson + assertEqual "schemaFor == toSchema" s1 s2 + +testFormatFor :: TestTree +testFormatFor = testCase "formatFor wraps in SchemaFormat" $ do + let fmt = formatFor @SimplePerson + expected = SchemaFormat (schemaFor @SimplePerson) + assertEqual "formatFor wraps schema" expected fmt + +testMatchesManualSchema :: TestTree +testMatchesManualSchema = testCase "Derived schema matches manual DSL schema" $ do + let derived = schemaFor @SimplePerson + manual = + buildSchema $ + emptyObject + |+ ("name", JString) + |+ ("age", JInteger) + |!! ["name", "age"] + assertEqual "Properties match" (schemaProperties manual) (schemaProperties derived) + -- Required fields should contain the same elements (order may differ) + let derivedReq = schemaRequired derived + manualReq = schemaRequired manual + assertBool "All derived required fields in manual" (all (`elem` manualReq) derivedReq) + assertBool "All manual required fields in derived" (all (`elem` derivedReq) manualReq) diff --git a/test/Test/Ollama/Unit/Testing.hs b/test/Test/Ollama/Unit/Testing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/Testing.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + +{- | +Module : Test.Ollama.Unit.Testing +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Unit tests for Ollama.Testing mock client and helper functions. + +@since 1.0.0.0 +-} +module Test.Ollama.Unit.Testing (testingTests) where + +import Data.Aeson (encode) +import Data.ByteString.Lazy qualified as LBS +import Data.List.NonEmpty (NonEmpty ((:|))) +import Ollama.API.Chat (ChatResponse (..), chat, chatRequest) +import Ollama.API.Embed ( + EmbedResponse (..), + EmbeddingsRequest (..), + EmbeddingsResponse (..), + embed, + embedRequest, + embeddings, + ) +import Ollama.API.Generate (GenerateResponse (..), generate, generateRequest) +import Ollama.API.Models (ListResponse (..), listModels) +import Ollama.Testing ( + mockChatResponse, + mockEmbedResponse, + mockGenerateResponse, + mockListModelsResponse, + withMockClient, + ) +import Ollama.Types.Common (ModelName (..)) +import Ollama.Types.Message (userMessage) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +testingTests :: TestTree +testingTests = + testGroup + "Unit Testing Infrastructure Tests" + [ testCase "Mock generate response" $ do + let respPayload = mockGenerateResponse (ModelName "llama3.2") "Sky is blue" + encoded = encode respPayload + withMockClient (LBS.toStrict encoded) $ \client -> do + res <- generate client (generateRequest (ModelName "llama3.2") "Why?") + case res of + Left err -> fail $ "Expected success, got: " <> show err + Right resp -> assertEqual "Matching text" "Sky is blue" (grResponse resp) + , testCase "Mock chat response" $ do + let respPayload = mockChatResponse (ModelName "llama3.2") "Hello there" + encoded = encode respPayload + withMockClient (LBS.toStrict encoded) $ \client -> do + res <- chat client (chatRequest (ModelName "llama3.2") (userMessage "Hi" :| [])) + case res of + Left err -> fail $ "Expected success, got: " <> show err + Right resp -> assertEqual "Matching model" (ModelName "llama3.2") (crModel resp) + , testCase "Mock embed response" $ do + let respPayload = mockEmbedResponse (ModelName "nomic") [[0.1, 0.2]] + encoded = encode respPayload + withMockClient (LBS.toStrict encoded) $ \client -> do + res <- embed client (embedRequest (ModelName "nomic") ["test"]) + case res of + Left err -> fail $ "Expected success, got: " <> show err + Right resp -> assertEqual "Matching embeddings" [[0.1, 0.2]] (erEmbeddings resp) + , testCase "Mock deprecated embeddings endpoint" $ do + let respPayload = EmbeddingsResponse [0.5, 0.6] + encoded = encode respPayload + withMockClient (LBS.toStrict encoded) $ \client -> do + res <- embeddings client (EmbeddingsRequest (ModelName "nomic") "test" Nothing Nothing) + case res of + Left err -> fail $ "Expected success, got: " <> show err + Right resp -> assertEqual "Matching embedding" [0.5, 0.6] (ebrEmbedding resp) + , testCase "Mock list models response" $ do + let respPayload = mockListModelsResponse [ModelName "llama3.2", ModelName "nomic"] + encoded = encode respPayload + withMockClient (LBS.toStrict encoded) $ \client -> do + res <- listModels client + case res of + Left err -> fail $ "Expected success, got: " <> show err + Right resp -> assertEqual "Matching count" 2 (length (models resp)) + ] diff --git a/test/Test/Ollama/Unit/Types.hs b/test/Test/Ollama/Unit/Types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/Types.hs @@ -0,0 +1,72 @@ +module Test.Ollama.Unit.Types (tests) where + +import Conduit (yield) +import Data.Aeson (decode, encode) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Time (getCurrentTime) +import Ollama +import Ollama.Types.Message qualified as M +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit Types & API Tests" + [ testCase "ModelName smart constructor validation" $ do + assertEqual "Empty name invalid" (Left "Model name cannot be empty") (mkModelName "") + assertEqual "Valid name" (Right "llama3.2") (mkModelName "llama3.2") + , testCase "GenerateRequest smart constructor" $ do + let req = generateRequest "llama3.2" "Hello world" + assertEqual "Model match" (ModelName "llama3.2") (genModel req) + assertEqual "Prompt match" "Hello world" (genPrompt req) + assertEqual "Stream default" (Just False) (genStream req) + , testCase "ChatRequest smart constructor" $ do + let msg = userMessage "Hi" + req = chatRequest "llama3.2" (msg :| []) + assertEqual "Model match" (ModelName "llama3.2") (chatModel req) + assertEqual "Messages length" 1 (length (chatMessages req)) + , testCase "EmbedRequest smart constructor" $ do + let req = embedRequest "nomic-embed-text" ["hello", "world"] + assertEqual "Model match" (ModelName "nomic-embed-text") (embModel req) + assertEqual "Input match" (Right ["hello", "world"]) (embInput req) + , testCase "CreateRequest smart constructor" $ do + let req = defaultCreateRequest "custom-model" + assertEqual "Model match" (ModelName "custom-model") (crqModel req) + , testCase "Role JSON roundtrip" $ do + assertEqual "User role" (Just User) (decode (encode User)) + assertEqual "Assistant role" (Just Assistant) (decode (encode Assistant)) + assertEqual "System role" (Just System) (decode (encode System)) + assertEqual "Tool role" (Just M.Tool) (decode (encode M.Tool)) + , testCase "InMemoryStore operations" $ do + store <- initInMemoryStore + now <- getCurrentTime + let conv = + Conversation + { conversationId = "c1" + , messages = [userMessage "hi"] + , model = "llama3.2" + , createdAt = now + , lastUpdated = now + } + saveConversationInMemory store conv + mLoaded <- loadConversationInMemory store "c1" + assertEqual "Load conversation" (Just conv) mLoaded + + allConvs <- listConversationsInMemory store + assertEqual "List conversations" [conv] allConvs + + deleted <- deleteConversationInMemory store "c1" + assertBool "Delete succeeded" deleted + + mLoadedAfter <- loadConversationInMemory store "c1" + assertEqual "Load after delete" Nothing mLoadedAfter + , testCase "Streaming collectStream helper" $ do + let mockStream = mapM_ yield [1 .. 5 :: Int] + items <- collectStream mockStream + assertEqual "Collected list" [1, 2, 3, 4, 5] items + , testCase "Streaming foldStream helper" $ do + let mockStream = mapM_ yield [1 .. 5 :: Int] + sumVal <- foldStream (+) 0 mockStream + assertEqual "Folded sum" 15 sumVal + ]