diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Revision history for ollama-haskell +## Unreleased + +## 0.2.0.0 -- 2025-06-05 + +* Added stack matrix to ensure lib is buildable from lts-19.33 +* Made parameters & template fields optional in `ShowModelResponse`. +* Added extra parameters fields in `ModelInfo`. +* Added strict annotations for all fields. +* Fixed ToJSON instance for delete model request body. +* Removed duplicate code by using unified `withOllamaRequest` function for all API calls. +* Added unified config type `OllamaConfig` to hold common configuration options. +* Added validation for generate and chat functions to ensure required fields are present. +* Added convience functions for generating Message and ToolCall types. +* Added thinking field for chat and generate function. +* Added ModelOptions type to encapsulate model options. +* Added get ollama version function. +* Added Common Manager, Callback functions and retry option in OllamaConfig. +* Fixed tool_calls. +* Added MonadIO versions of api functions. +* Added more comprehensive error handling for API calls. +* Added more comprehensive test cases for all functions. +* Added schema builder for passing json format for structured output. + ## 0.1.3.0 -- 2025-03-25 * Added options, tools and tool_calls fields in chat and generate. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,74 +1,98 @@ -# 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). +**`ollama-haskell`** is an unofficial Haskell client for [Ollama](https://ollama.com), inspired by [`ollama-python`](https://github.com/ollama/ollama-python). It enables interaction with locally running LLMs through the Ollama HTTP API β€” directly from Haskell. -This library allows you to interact with Ollama, a tool that lets you run large language models (LLMs) locally, from within your Haskell projects. +--- -## Examples +## ✨ Features +* πŸ’¬ Chat with models +* ✍️ Text generation (with streaming) +* βœ… Chat with structured messages and tools +* 🧠 Embeddings +* 🧰 Model management (list, pull, push, show, delete) +* πŸ—ƒοΈ In-memory conversation history +* βš™οΈ Configurable timeouts, retries, streaming handlers + +--- + +## ⚑ Quick Example + ```haskell {-# LANGUAGE OverloadedStrings #-} -module Lib where +module Main where -import Ollama (GenerateOps(..), defaultGenerateOps, generate) +import Data.Ollama.Generate +import qualified Data.Text.IO as T main :: IO () main = do - void $ - generate + let ops = defaultGenerateOps - { modelName = "llama3.2" - , prompt = "what is functional programming?" - , stream = Just (T.putStr . Ollama.response_, pure ()) + { modelName = "gemma3" + , prompt = "What is the meaning of life?" } + eRes <- generate ops Nothing + case eRes of + Left err -> putStrLn $ "Something went wrong: " ++ show err + Right r -> do + putStr "LLM response: " + T.putStrLn (genResponse r) ``` -### Output - -```bash -ghci> import Lib -ghci> main +--- -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: +## πŸ“¦ Installation -**Pros:** +Add to your `.cabal` file: -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. +```cabal +build-depends: + base >=4.7 && <5, + ollama-haskell ``` -You can find practical examples demonstrating how to use the library in the `examples/OllamaExamples.hs` file. +Or use with `stack`/`nix-shell`. -## Prerequisite +--- -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). +## πŸ“š More Examples -## How to Use It +See [`examples/OllamaExamples.hs`](examples/OllamaExamples.hs) for: -1. Include the `ollama-haskell` package in your `.cabal` file: - ```cabal - build-depends: - base >= 4.7 && < 5, - ollama-haskell - ``` +* Chat with conversation memory +* Structured JSON output +* Embeddings +* Tool/function calling +* Multimodal input +* Streaming and non-streaming variants -3. Import the `Ollama` module and start integrating with your local LLM. +--- -## Future Updates +## πŸ›  Prerequisite -- [x] Improve documentation -- [x] Add tests. -- [x] Add examples. -- [x] Add CI/CD pipeline. -- [ ] `options` parameter in `generate`. +Make sure you have [Ollama installed and running locally](https://ollama.com/download). Run `ollama pull llama3` to download a model. -Stay tuned for future updates and improvements! +--- -## Author +## πŸ§ͺ Dev & Nix Support -This library is developed and maintained by [Tushar](https://github.com/tusharad). Feel free to reach out for any questions or suggestions! +Use Nix: -## Contributions +```bash +nix-shell +``` -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. +This will install `stack` and Ollama. + +--- + +## πŸ‘¨β€πŸ’» Author + +Created and maintained by [@tusharad](https://github.com/tusharad). PRs and feedback are welcome! + +--- + +## 🀝 Contributing + +Have ideas or improvements? Feel free to [open an issue](https://github.com/tusharad/ollama-haskell/issues) or submit a PR! diff --git a/ollama-haskell.cabal b/ollama-haskell.cabal --- a/ollama-haskell.cabal +++ b/ollama-haskell.cabal @@ -1,12 +1,12 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: ollama-haskell -version: 0.1.3.0 -synopsis: Haskell bindings for ollama. +version: 0.2.0.0 +synopsis: Haskell client for ollama. description: Ollama client for Haskell category: Web homepage: https://github.com/tusharad/ollama-haskell#readme @@ -28,14 +28,19 @@ library exposed-modules: Data.Ollama.Chat + Data.Ollama.Common.Config + Data.Ollama.Common.Error + Data.Ollama.Common.SchemaBuilder Data.Ollama.Common.Types Data.Ollama.Common.Utils + Data.Ollama.Conversation Data.Ollama.Copy Data.Ollama.Create Data.Ollama.Delete Data.Ollama.Embeddings Data.Ollama.Generate Data.Ollama.List + Data.Ollama.Load Data.Ollama.Ps Data.Ollama.Pull Data.Ollama.Push @@ -49,23 +54,30 @@ ImportQualifiedPost ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - aeson + aeson ==2.* , base >=4.7 && <5 - , base64-bytestring - , bytestring - , containers - , directory - , filepath - , http-client - , http-types - , text - , time + , base64-bytestring ==1.* + , bytestring >=0.10 && <0.13 + , containers >=0.6 && <0.9 + , directory >=1 && <1.4 + , filepath >=1 && <1.6 + , http-client >=0.6 && <0.8 + , http-client-tls >=0.2 && <0.4 + , http-types >=0.7 && <0.13 + , mtl ==2.* + , stm ==2.* + , text >=1 && <3 + , time ==1.* default-language: Haskell2010 test-suite ollama-haskell-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Test.Ollama.Chat + Test.Ollama.Embedding + Test.Ollama.Generate + Test.Ollama.Show Paths_ollama_haskell hs-source-dirs: test @@ -75,17 +87,21 @@ build-depends: aeson , base >=4.7 && <5 - , base64-bytestring - , bytestring - , containers - , directory - , filepath - , http-client - , http-types + , base64-bytestring ==1.* + , bytestring >=0.10 && <0.13 + , containers >=0.6 && <0.9 + , directory >=1 && <1.4 + , filepath >=1 && <1.6 + , http-client >=0.6 && <0.8 + , http-client-tls >=0.2 && <0.4 + , http-types >=0.7 && <0.13 + , mtl ==2.* , ollama-haskell + , scientific , silently - , tasty + , stm ==2.* + , tasty >=1.5 , tasty-hunit , text - , time + , time ==1.* default-language: Haskell2010 diff --git a/src/Data/Ollama/Chat.hs b/src/Data/Ollama/Chat.hs --- a/src/Data/Ollama/Chat.hs +++ b/src/Data/Ollama/Chat.hs @@ -1,110 +1,220 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Chat +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Chat functionality for interacting with the Ollama API. + +This module provides functions and types for initiating and managing chat interactions with an Ollama model. +It includes APIs for sending chat requests, constructing messages with different roles, and configuring chat +operations. The module supports both streaming and non-streaming responses, as well as optional tools and +structured output formats. + +The primary functions are 'chat' and 'chatM' for sending chat requests, and helper functions like +'systemMessage', 'userMessage', 'assistantMessage', and 'toolMessage' for constructing messages. +The 'ChatOps' type allows customization of chat parameters, and 'defaultChatOps' provides a convenient +starting point for configuration. + +Example: + +>>> let ops = defaultChatOps { chatModelName = "customModel", messages = userMessage "Hello!" :| [] } +>>> chat ops Nothing +Either OllamaError ChatResponse +-} module Data.Ollama.Chat ( -- * Chat APIs chat - , chatJson + , chatM + + -- * Message Types , Message (..) , Role (..) + , systemMessage + , userMessage + , assistantMessage + , toolMessage + , genMessage + + -- * Chat Configuration , defaultChatOps , ChatOps (..) + + -- * Response Types , ChatResponse (..) , Format (..) - , schemaFromType + + -- * Configuration and Error Types + , OllamaConfig (..) + , defaultOllamaConfig + , OllamaError (..) + , ModelOptions (..) + , defaultModelOptions + + -- * Tool and Function Types + , InputTool (..) + , FunctionDef (..) + , FunctionParameters (..) + , OutputFunction (..) + , ToolCall (..) ) where -import Control.Exception (try) +import Control.Monad.IO.Class (MonadIO (liftIO)) 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.Maybe (isNothing) +import Data.Ollama.Common.Config +import Data.Ollama.Common.Error (OllamaError (..)) +import Data.Ollama.Common.Types + ( ChatResponse (..) + , Format (..) + , FunctionDef (..) + , FunctionParameters (..) + , InputTool (..) + , Message (..) + , ModelOptions (..) + , OutputFunction (..) + , Role (..) + , ToolCall (..) + ) 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 +import Data.Text qualified as T --- | Enumerated roles that can participate in a chat. -data Role = System | User | Assistant | Tool - deriving (Show, Eq) +{- | Constructs a 'Message' with the specified role and content. -instance ToJSON Role where - toJSON System = String "system" - toJSON User = String "user" - toJSON Assistant = String "assistant" - toJSON Tool = String "tool" +Creates a 'Message' with the given 'Role' and textual content, setting optional fields +('images', 'tool_calls', 'thinking') to 'Nothing'. -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" +Example: --- TODO : Add tool_calls parameter +>>> genMessage User "What's the weather like?" +Message {role = User, content = "What's the weather like?", images = Nothing, tool_calls = Nothing, thinking = Nothing} +-} +genMessage :: Role -> Text -> Message +genMessage r c = + Message + { role = r + , content = c + , images = Nothing + , tool_calls = Nothing + , thinking = Nothing + } --- | 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) +{- | Creates a 'Message' with the 'System' role. --- TODO: Add Options parameter +Example: + +>>> systemMessage "You are a helpful assistant." +Message {role = System, content = "You are a helpful assistant.", images = Nothing, tool_calls = Nothing, thinking = Nothing} +-} +systemMessage :: Text -> Message +systemMessage c = genMessage System c + +{- | Creates a 'Message' with the 'User' role. + +Example: + +>>> userMessage "What's 2+2?" +Message {role = User, content = "What's 2+2?", images = Nothing, tool_calls = Nothing, thinking = Nothing} +-} +userMessage :: Text -> Message +userMessage c = genMessage User c + +{- | Creates a 'Message' with the 'Assistant' role. + +Example: + +>>> assistantMessage "2+2 equals 4." +Message {role = Assistant, content = "2+2 equals 4.", images = Nothing, tool_calls = Nothing, thinking = Nothing} +-} +assistantMessage :: Text -> Message +assistantMessage c = genMessage Assistant c + +{- | Creates a 'Message' with the 'Tool' role. + +Example: + +>>> toolMessage "Tool output: success" +Message {role = Tool, content = "Tool output: success", images = Nothing, tool_calls = Nothing, thinking = Nothing} +-} +toolMessage :: Text -> Message +toolMessage c = genMessage Tool c + +{- | Validates 'ChatOps' to ensure required fields are non-empty. + +Checks that the 'chatModelName' is not empty and that no 'Message' in 'messages' has empty content. +Returns 'Right' with the validated 'ChatOps' or 'Left' with an 'OllamaError' if validation fails. +-- +-- @since 0.2.0.0 +-} +validateChatOps :: ChatOps -> Either OllamaError ChatOps +validateChatOps ops + | T.null (chatModelName ops) = Left $ InvalidRequest "Chat model name cannot be empty" + | any (T.null . content) (messages ops) = + Left $ InvalidRequest "Messages cannot have empty content" + | otherwise = Right ops + +{- | Configuration for initiating a chat with an Ollama model. + +Defines the parameters for a chat request, including the model name, messages, and optional settings +for tools, response format, streaming, timeout, and model options. +-} data ChatOps = ChatOps - { chatModelName :: Text - -- ^ The name of the chat model to be used. - , messages :: NonEmpty Message + { chatModelName :: !Text + -- ^ The name of the chat model to be used (e.g., "gemma3"). + , messages :: !(NonEmpty Message) -- ^ A non-empty list of messages forming the conversation context. - , tools :: Maybe [Value] + , tools :: !(Maybe [InputTool]) -- ^ 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 + , format :: !(Maybe Format) + -- ^ Optional format for the chat response (e.g., JSON or JSON schema). + -- + -- @since 0.1.3.0 + , stream :: !(Maybe (ChatResponse -> IO (), IO ())) + -- ^ Optional streaming functions: the first handles each response chunk, the second flushes the stream. + , keepAlive :: !(Maybe Int) + -- ^ Optional override for the response timeout in minutes (default: 15 minutes). + , options :: !(Maybe ModelOptions) + -- ^ Optional model parameters (e.g., temperature) as specified in the Modelfile. + -- + -- @since 0.1.3.0 + , think :: !(Maybe Bool) + -- ^ Optional flag to enable thinking mode. + -- + -- @since 0.2.0.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 + show + ( ChatOps + { chatModelName = m + , messages = ms + , tools = t + , format = f + , keepAlive = ka + , think = th + } + ) = + let messagesStr = show (toList ms) + toolsStr = show t + formatStr = show f + keepAliveStr = show ka + thinkStr = show th + in T.unpack m + ++ "\nMessages:\n" + ++ messagesStr + ++ "\n" + ++ toolsStr + ++ "\n" + ++ formatStr + ++ "\n" + ++ keepAliveStr + ++ "\n" + ++ thinkStr instance Eq ChatOps where (==) a b = @@ -114,32 +224,8 @@ && 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) = + toJSON (ChatOps model_ messages_ tools_ format_ stream_ keepAlive_ options think_) = object [ "model" .= model_ , "messages" .= messages_ @@ -148,254 +234,65 @@ , "stream" .= if isNothing stream_ then Just False else Just True , "keep_alive" .= keepAlive_ , "options" .= options + , "think" .= think_ ] -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" +{- | Default configuration for initiating a chat. -{- | -A default configuration for initiating a chat with a model. -This can be used as a starting point and modified as needed. +Provides a default 'ChatOps' with the "gemma3" model and a sample user message ("What is 2+2?"). +Can be customized by modifying fields as needed. Example: -> let ops = defaultChatOps { chatModelName = "customModel" } -> chat ops +>>> let ops = defaultChatOps { chatModelName = "customModel", messages = userMessage "Hello!" :| [] } +>>> chat ops Nothing +Either OllamaError ChatResponse -} defaultChatOps :: ChatOps defaultChatOps = ChatOps - { chatModelName = "llama3.2" - , messages = Message User "What is 2+2?" Nothing Nothing :| [] + { chatModelName = "gemma3" + , messages = userMessage "What is 2+2?" :| [] , tools = Nothing , format = Nothing , stream = Nothing , keepAlive = Nothing - , hostUrl = Nothing - , responseTimeOut = Nothing , options = Nothing + , think = Nothing } -{- | -Initiates a chat session with the specified 'ChatOps' configuration and returns either -a 'ChatResponse' or an error message. +{- | Sends a chat request to the Ollama API. -This function sends a request to the Ollama chat API with the given options. +Validates the 'ChatOps' configuration and sends a POST request to the "/api//chat" endpoint. +Supports both streaming and non-streaming responses based on the 'stream' field in 'ChatOps'. +Returns an 'Either' containing an 'OllamaError' on failure or a 'ChatResponse' on success. 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. +>>> let ops = defaultChatOps { chatModelName = "gemma3", messages = userMessage "What's the capital of France?" :| [] } +>>> chat ops Nothing +Either OllamaError ChatResponse -} -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 +chat :: ChatOps -> Maybe OllamaConfig -> IO (Either OllamaError ChatResponse) +chat ops mbConfig = + case validateChatOps ops of + Left err -> return $ Left err + Right _ -> withOllamaRequest "/api//chat" "POST" (Just ops) mbConfig handler + where + handler = case stream ops of + Nothing -> commonNonStreamingHandler + Just (sc, fl) -> commonStreamHandler sc fl --- | 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 +{- | MonadIO version of 'chat' for use in monadic contexts. -{- | - Example usage of 'Ollama.chat' with a JSON schema format and options field. +Lifts the 'chat' function into a 'MonadIO' context, allowing it to be used in monadic computations. - 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@). +Example: - >>> 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}) +>>> import Control.Monad.IO.Class +>>> let ops = defaultChatOps { chatModelName = "gemma3", messages = userMessage "Hello!" :| [] } +>>> runReaderT (chatM ops Nothing) someContext +Either OllamaError ChatResponse -} +chatM :: MonadIO m => ChatOps -> Maybe OllamaConfig -> m (Either OllamaError ChatResponse) +chatM ops mbCfg = liftIO $ chat ops mbCfg diff --git a/src/Data/Ollama/Common/Config.hs b/src/Data/Ollama/Common/Config.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ollama/Common/Config.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Ollama.Common.Config +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : A unified configuration type for controlling Ollama client behavior. + +== Overview + +This module defines the core configuration record used throughout the Ollama Haskell client. + +Use 'defaultOllamaConfig' as a starting point and customize it with helper functions +like 'withOnModelStart', 'withOnModelFinish', or 'withOnModelError'. + +Includes settings for base URL, timeout, retry logic, and custom HTTP managers. +-} +module Data.Ollama.Common.Config + ( -- * Configuration Type + OllamaConfig (..) + + -- * Default Config + , defaultOllamaConfig + + -- * Hook Helpers + , withOnModelStart + , withOnModelFinish + , withOnModelError + ) where + +import Data.Text (Text) +import GHC.Generics +import Network.HTTP.Client + +{- | Configuration for the Ollama client. +Used across all requests to customize behavior such as timeouts, retries, +custom HTTP manager, and lifecycle hooks. +-- +-- @since 0.2.0.0 +-} +data OllamaConfig = OllamaConfig + { hostUrl :: Text + -- ^ Base URL for the Ollama server (default: @http://127.0.0.1:11434@) + , timeout :: Int + -- ^ Timeout in seconds for API requests (ignored if 'commonManager' is set) + , onModelStart :: Maybe (IO ()) + -- ^ Callback executed when a model starts + , onModelError :: Maybe (IO ()) + -- ^ Callback executed if a model encounters an error + , onModelFinish :: Maybe (IO ()) + -- ^ Callback executed when a model finishes (not called on error) + , retryCount :: Maybe Int + -- ^ Number of retries on failure (default: @0@ if 'Nothing') + , retryDelay :: Maybe Int + -- ^ Delay between retries in seconds (if applicable) + , commonManager :: Maybe Manager + -- ^ Shared HTTP manager; disables timeout and retry settings + } + deriving (Generic) + +{- | A default configuration pointing to @localhost:11434@ with 90s timeout +and no hooks or retry logic. +-} +defaultOllamaConfig :: OllamaConfig +defaultOllamaConfig = + OllamaConfig + { hostUrl = "http://127.0.0.1:11434" + , timeout = 90 + , onModelStart = Nothing + , onModelError = Nothing + , onModelFinish = Nothing + , retryCount = Nothing + , retryDelay = Nothing + , commonManager = Nothing + } + +-- | Add a callback to be executed when a model starts. +withOnModelStart :: IO () -> OllamaConfig -> OllamaConfig +withOnModelStart f cfg = cfg {onModelStart = Just f} + +-- | Add a callback to be executed when a model errors. +withOnModelError :: IO () -> OllamaConfig -> OllamaConfig +withOnModelError f cfg = cfg {onModelError = Just f} + +-- | Add a callback to be executed when a model finishes successfully. +withOnModelFinish :: IO () -> OllamaConfig -> OllamaConfig +withOnModelFinish f cfg = cfg {onModelFinish = Just f} diff --git a/src/Data/Ollama/Common/Error.hs b/src/Data/Ollama/Common/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ollama/Common/Error.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | +Module : Data.Ollama.Common.Error +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Unified error type for handling failures across the Ollama client. + +== Overview + +Defines the core 'OllamaError' type that wraps all potential errors +encountered while interacting with the Ollama API, including HTTP errors, +JSON decoding failures, API-specific errors, file I/O errors, and timeouts. +-} +module Data.Ollama.Common.Error + ( -- * Error Types + OllamaError (..) + + -- * Decoding Utilities + , DecodingErrorMessage + , DecodingFailedValue + ) where + +import Control.Exception (Exception, IOException) +import Data.Text (Text) +import GHC.Generics +import Network.HTTP.Client (HttpException) + +-- | Type alias for a decoding error message string. +type DecodingErrorMessage = String + +-- | Type alias for the value that failed to decode. +type DecodingFailedValue = String + +-- | Represents all possible errors that may occur when using the Ollama client. +-- +-- @since 0.2.0.0 +data OllamaError + = -- | Low-level HTTP exception (connection failure, etc.) + HttpError HttpException + | -- | Failure to decode a JSON response, includes message and raw value + DecodeError DecodingErrorMessage DecodingFailedValue + | -- | Error returned from Ollama's HTTP API + ApiError Text + | -- | Error during file operations (e.g., loading an image) + FileError IOException + | -- | Mismatch in expected JSON schema or structure + JsonSchemaError String + | -- | Request timed out + TimeoutError String + | -- | Request is malformed or violates input constraints + InvalidRequest String + deriving (Show, Generic) + +instance Eq OllamaError where + (HttpError _) == (HttpError _) = True + x == y = eqOllamaError x y + where + eqOllamaError :: OllamaError -> OllamaError -> Bool + eqOllamaError = (==) + +instance Exception OllamaError diff --git a/src/Data/Ollama/Common/SchemaBuilder.hs b/src/Data/Ollama/Common/SchemaBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ollama/Common/SchemaBuilder.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Ollama.Common.SchemaBuilder +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : DSL for constructing structured JSON Schemas for Ollama's structured output API. + +== Overview + +This module defines a simple schema builder DSL for programmatically constructing +JSON Schemas compatible with the structured output features in the Ollama API. + +It supports nested objects, arrays, required fields, and custom types, and +provides infix operators for a fluent and expressive syntax. + +== Example + +@ +import Data.Ollama.Common.SchemaBuilder + +let schema = + emptyObject + |+ ("name", JString) + |+ ("age", JInteger) + |++ ("address", buildSchema $ + emptyObject + |+ ("city", JString) + |+ ("zip", JInteger) + |! "city" + ) + |!! ["name", "age"] + & buildSchema + +printSchema schema +@ +-} +module Data.Ollama.Common.SchemaBuilder + ( -- * Core Types + JsonType (..) + , Property (..) + , Schema (..) + + -- * Schema Construction + , emptyObject + , addProperty + , addObjectProperty + , requireField + , requireFields + , buildSchema + + -- * Schema Utilities + , objectOf + , arrayOf + , toOllamaFormat + , printSchema + + -- * Infix Schema DSL + , (|+) + , (|++) + , (|!) + , (|!!) + ) 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 T +import GHC.Generics + +-- | Supported JSON types for schema generation. +data JsonType + = JString + | JNumber + | JInteger + | JBoolean + | JNull + | -- | Array of a specific type + JArray JsonType + | -- | Nested object schema + JObject Schema + deriving (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" + +-- | A named property with a given type (supports nested values). +newtype Property = Property JsonType + deriving (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] + +-- | Complete schema representation. +-- +-- @since 0.2.0.0 +data Schema = Schema + { schemaProperties :: HM.Map Text Property + , schemaRequired :: [Text] + } + deriving (Show, Eq, Generic) + +instance ToJSON Schema where + toJSON (Schema props req) = + object + [ "type" .= ("object" :: Text) + , "properties" .= props + , "required" .= req + ] + +-- | Internal builder for schema DSL. +newtype SchemaBuilder = SchemaBuilder Schema + deriving (Show, Eq) + +-- | Create an empty schema object. +emptyObject :: SchemaBuilder +emptyObject = SchemaBuilder $ Schema HM.empty [] + +-- | Add a simple field with a given name and type. +addProperty :: Text -> JsonType -> SchemaBuilder -> SchemaBuilder +addProperty name typ (SchemaBuilder s) = + SchemaBuilder $ s {schemaProperties = HM.insert name (Property typ) (schemaProperties s)} + +-- | Add a nested object field with its own schema. +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. +requireField :: Text -> SchemaBuilder -> SchemaBuilder +requireField name (SchemaBuilder s) = + SchemaBuilder $ s {schemaRequired = name : schemaRequired s} + +-- | Mark multiple fields as required. +requireFields :: [Text] -> SchemaBuilder -> SchemaBuilder +requireFields names builder = foldr requireField builder names + +-- | Finalize the schema from a builder. +buildSchema :: SchemaBuilder -> Schema +buildSchema (SchemaBuilder s) = s + +-- | Wrap a 'SchemaBuilder' as a nested object type. +objectOf :: SchemaBuilder -> JsonType +objectOf builder = JObject (buildSchema builder) + +-- | Create an array of a given JSON type. +arrayOf :: JsonType -> JsonType +arrayOf = JArray + +-- | Convert schema into a JSON 'Value' suitable for API submission. +toOllamaFormat :: Schema -> Value +toOllamaFormat = toJSON + +-- | Pretty print a schema as formatted JSON. +printSchema :: Schema -> IO () +printSchema = putStrLn . T.unpack . TL.toStrict . T.decodeUtf8 . encode + +-- | Infix alias for 'addProperty'. +(|+) :: SchemaBuilder -> (Text, JsonType) -> SchemaBuilder +builder |+ (name, typ) = addProperty name typ builder + +-- | Infix alias for 'addObjectProperty'. +(|++) :: SchemaBuilder -> (Text, Schema) -> SchemaBuilder +builder |++ (name, schema) = addObjectProperty name schema builder + +-- | Infix alias for 'requireField'. +(|!) :: SchemaBuilder -> Text -> SchemaBuilder +builder |! name = requireField name builder + +-- | Infix alias for 'requireFields'. +(|!!) :: SchemaBuilder -> [Text] -> SchemaBuilder +builder |!! names = requireFields names builder + +infixl 7 |+, |++ +infixl 6 |!, |!! diff --git a/src/Data/Ollama/Common/Types.hs b/src/Data/Ollama/Common/Types.hs --- a/src/Data/Ollama/Common/Types.hs +++ b/src/Data/Ollama/Common/Types.hs @@ -1,22 +1,82 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Common.Types +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Shared data types for request and response structures used throughout the Ollama client. + +== πŸ“‹ Overview + +This module defines common types for working with Ollama's API, including: + +- Chat messages and roles +- Text generation responses +- Structured function/tool calling +- Model metadata +- Streaming handling +- Custom model parameters + +These types are consumed and returned by higher-level modules +like `Data.Ollama.Chat`, `Data.Ollama.Generate`, and others. + +== Includes + +- Chat message structure and roles +- Generate and chat response records +- ModelOptions and advanced config +- Structured function/tool call interfaces +- JSON format hints and schema wrapping +- Helper class 'HasDone' for streaming termination + +Most types implement `ToJSON`/`FromJSON` for direct API interaction. +-} module Data.Ollama.Common.Types ( ModelDetails (..) - , OllamaClient (..) , Format (..) + , GenerateResponse (..) + , Message (..) + , Role (..) + , ChatResponse (..) + , HasDone (..) + , ModelOptions (..) + , InputTool (..) + , FunctionDef (..) + , FunctionParameters (..) + , ToolCall (..) + , OutputFunction (..) + , Version (..) ) where import Data.Aeson +import Data.Map qualified as HM +import Data.Maybe (catMaybes) +import Data.Ollama.Common.SchemaBuilder import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics +import GHC.Int (Int64) +-- | Metadata describing a specific model's identity and configuration. data ModelDetails = ModelDetails - { parentModel :: Maybe Text - , format :: Text - , familiy :: Text - , families :: [Text] - , parameterSize :: Text + { parentModel :: !(Maybe Text) + -- ^ The parent model from which this model was derived, if any. + , format :: !Text + -- ^ The format used for the model (e.g., "gguf"). + , family :: !Text + -- ^ The family name of the model (e.g., "llama", "mistral"). + , families :: ![Text] + -- ^ Alternative or related family identifiers. + , parameterSize :: !Text + -- ^ The size of the model's parameters, typically expressed as a string (e.g., "7B"). , quantizationLevel :: Text + -- ^ The quantization level used (e.g., "Q4", "Q8"). } deriving (Eq, Show) @@ -30,35 +90,358 @@ <*> v .: "parameter_size" <*> v .: "quantization_level" -newtype OllamaClient = OllamaClient - { host :: Text +{- | Format specification for the chat output. + +@since 0.1.3.0 +-} +data Format = JsonFormat | SchemaFormat Schema + deriving (Show, Eq) + +instance ToJSON Format where + toJSON JsonFormat = String "json" + toJSON (SchemaFormat schema) = toJSON schema + +{- | +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. + , genResponse :: !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. + , thinking :: !(Maybe Text) + -- ^ Thinking of reasoning models; if think is set to true + -- + -- @since 0.2.0.0 } + deriving (Show, Eq) + +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" + <*> v .:? "thinking" + +-- | 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 = withText "Role" $ \t -> + case t of + "system" -> pure System + "user" -> pure User + "assistant" -> pure Assistant + "tool" -> pure Tool + _ -> fail $ "Invalid Role value: " <> show t + +-- | 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 [ToolCall]) + -- ^ a list of tools in JSON that the model wants to use + -- + -- @since 0.1.3.0 + , thinking :: !(Maybe Text) + -- + -- @since 0.2.0.0 + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +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 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 workaround to use done field within commonStreamHandler +class HasDone a where + getDone :: a -> Bool + +instance HasDone GenerateResponse where + getDone GenerateResponse {..} = done + +instance HasDone ChatResponse where + getDone ChatResponse {..} = done + +-- | Optional model tuning parameters that influence generation behavior. +-- +-- @since 0.2.0.0 +data ModelOptions = ModelOptions + { numKeep :: Maybe Int + , -- \^ Number of tokens to keep from the previous context. + seed :: Maybe Int + , -- \^ Random seed for reproducibility. + numPredict :: Maybe Int + , -- \^ Maximum number of tokens to predict. + topK :: Maybe Int + , -- \^ Top-K sampling parameter. + topP :: Maybe Double + , -- \^ Top-P (nucleus) sampling parameter. + minP :: Maybe Double + , -- \^ Minimum probability for nucleus sampling. + typicalP :: Maybe Double + , -- \^ Typical sampling probability. + repeatLastN :: Maybe Int + , -- \^ Number of tokens to consider for repetition penalty. + temperature :: Maybe Double + , -- \^ Sampling temperature. Higher = more randomness. + repeatPenalty :: Maybe Double + , -- \^ Penalty for repeating the same tokens. + presencePenalty :: Maybe Double + , -- \^ Penalty for introducing new tokens. + frequencyPenalty :: Maybe Double + , -- \^ Penalty for frequent tokens. + penalizeNewline :: Maybe Bool + , -- \^ Whether to penalize newline tokens. + stop :: Maybe [Text] + , -- \^ List of stop sequences to end generation. + numa :: Maybe Bool + , -- \^ Whether to enable NUMA-aware optimizations. + numCtx :: Maybe Int + , -- \^ Number of context tokens. + numBatch :: Maybe Int + , -- \^ Batch size used during generation. + numGpu :: Maybe Int + , -- \^ Number of GPUs to use. + mainGpu :: Maybe Int + , -- \^ Index of the primary GPU to use. + useMmap :: Maybe Bool + , -- \^ Whether to memory-map the model. + numThread :: Maybe Int + } + -- \^ Number of threads to use for inference. + + deriving (Show, Eq) + +-- | Custom ToJSON instance for Options +instance ToJSON ModelOptions where + toJSON opts = + object $ + catMaybes + [ ("num_keep" .=) <$> numKeep opts + , ("seed" .=) <$> seed opts + , ("num_predict" .=) <$> numPredict opts + , ("top_k" .=) <$> topK opts + , ("top_p" .=) <$> topP opts + , ("min_p" .=) <$> minP opts + , ("typical_p" .=) <$> typicalP opts + , ("repeat_last_n" .=) <$> repeatLastN opts + , ("temperature" .=) <$> temperature opts + , ("repeat_penalty" .=) <$> repeatPenalty opts + , ("presence_penalty" .=) <$> presencePenalty opts + , ("frequency_penalty" .=) <$> frequencyPenalty opts + , ("penalize_newline" .=) <$> penalizeNewline opts + , ("stop" .=) <$> stop opts + , ("numa" .=) <$> numa opts + , ("num_ctx" .=) <$> numCtx opts + , ("num_batch" .=) <$> numBatch opts + , ("num_gpu" .=) <$> numGpu opts + , ("main_gpu" .=) <$> mainGpu opts + , ("use_mmap" .=) <$> useMmap opts + , ("num_thread" .=) <$> numThread opts + ] + +-- | A wrapper for the Ollama engine version string. +newtype Version = Version Text deriving (Eq, Show) +instance FromJSON Version where + parseJSON = withObject "version" $ \v -> do + Version <$> v .: "version" -{-| -E.g SchemaFormat -{ - "type": "object", - "properties": { - "age": { - "type": "integer" - }, - "available": { - "type": "boolean" - } - }, - "required": [ - "age", - "available" - ] +-- | Represents a tool that can be used in the conversation. +-- +-- @since 0.2.0.0 +data InputTool = InputTool + { toolType :: Text + -- ^ The type of the tool + , function :: FunctionDef + -- ^ The function associated with the tool } -|-} --- | Format specification for the chat output --- | Since 0.1.3.0 -data Format = JsonFormat | SchemaFormat Value + deriving (Show, Eq, Generic) + +instance ToJSON InputTool where + toJSON InputTool {..} = + object + [ "type" .= toolType + , "function" .= function + ] + +instance FromJSON InputTool where + parseJSON = withObject "Tool" $ \v -> + InputTool + <$> v .: "type" + <*> v .: "function" + +-- | Represents a function that can be called by the model. +-- +-- @since 0.2.0.0 +data FunctionDef = FunctionDef + { functionName :: Text + -- ^ The name of the function + , functionDescription :: Maybe Text + -- ^ Optional description of the function + , functionParameters :: Maybe FunctionParameters + -- ^ Optional parameters for the function + , functionStrict :: Maybe Bool + -- ^ Optional strictness flag + } + deriving (Show, Eq, Generic) + +instance ToJSON FunctionDef where + toJSON FunctionDef {..} = + object $ + [ "name" .= functionName + ] + ++ maybe [] (\d -> ["description" .= d]) functionDescription + ++ maybe [] (\p -> ["parameters" .= p]) functionParameters + ++ maybe [] (\s -> ["strict" .= s]) functionStrict + +instance FromJSON FunctionDef where + parseJSON = withObject "Function" $ \v -> + FunctionDef + <$> v .: "name" + <*> v .:? "description" + <*> v .:? "parameters" + <*> v .:? "strict" + +-- | Parameters definition for a function call used in structured output or tool calls. +-- +-- @since 0.2.0.0 +data FunctionParameters = FunctionParameters + { parameterType :: Text + -- ^ Type of the parameter (usually "object"). + , parameterProperties :: Maybe (HM.Map Text FunctionParameters) + -- ^ Optional nested parameters as a property map. + , requiredParams :: Maybe [Text] + -- ^ List of required parameter names. + , additionalProperties :: Maybe Bool + -- ^ Whether additional (unspecified) parameters are allowed. + } deriving (Show, Eq) -instance ToJSON Format where - toJSON JsonFormat = String "json" - toJSON (SchemaFormat schema) = schema +instance ToJSON FunctionParameters where + toJSON FunctionParameters {..} = + object + [ "type" .= parameterType + , "properties" .= parameterProperties + , "required" .= requiredParams + , "additionalProperties" .= additionalProperties + ] + +instance FromJSON FunctionParameters where + parseJSON = withObject "parameters" $ \v -> + FunctionParameters + <$> v .: "type" + <*> v .: "properties" + <*> v .: "required" + <*> v .: "additionalProperties" + +-- | A single tool call returned from the model, containing the function to be invoked. +-- +-- @since 0.2.0.0 +newtype ToolCall = ToolCall + { outputFunction :: OutputFunction + -- ^ The function the model intends to call, with arguments. + } + deriving (Show, Eq) + +-- | Output representation of a function to be called, including its name and arguments. +-- +-- @since 0.2.0.0 +data OutputFunction = OutputFunction + { outputFunctionName :: Text + -- ^ The name of the function to invoke. + , arguments :: HM.Map Text Value + -- ^ A key-value map of argument names to values (JSON values). + } + deriving (Eq, Show) + +instance ToJSON OutputFunction where + toJSON OutputFunction {..} = + object + [ "name" .= outputFunctionName + , "arguments" .= arguments + ] + +instance FromJSON OutputFunction where + parseJSON = withObject "function" $ \v -> + OutputFunction + <$> v .: "name" + <*> v .: "arguments" + +instance ToJSON ToolCall where + toJSON ToolCall {..} = object ["function" .= outputFunction] + +instance FromJSON ToolCall where + parseJSON = withObject "tool_calls" $ \v -> + ToolCall <$> v .: "function" diff --git a/src/Data/Ollama/Common/Utils.hs b/src/Data/Ollama/Common/Utils.hs --- a/src/Data/Ollama/Common/Utils.hs +++ b/src/Data/Ollama/Common/Utils.hs @@ -1,26 +1,71 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} -module Data.Ollama.Common.Utils (defaultOllamaUrl, OllamaClient (..), encodeImage) where +{- | +Module : Data.Ollama.Common.Utils +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Utility functions for interacting with the Ollama API, including image encoding, HTTP request handling, and retry logic. +This module provides helper functions for common tasks in the Ollama client, such as encoding images to Base64, +sending HTTP requests to the Ollama API, handling streaming and non-streaming responses, and managing retries for failed requests. +It also includes a default model options configuration and a function to retrieve the Ollama server version. + +The functions in this module are used internally by other modules like 'Data.Ollama.Chat' and 'Data.Ollama.Generate' but can also be used directly for custom API interactions. +-} +module Data.Ollama.Common.Utils + ( -- * Image Encoding + encodeImage + + -- * HTTP Request Handling + , withOllamaRequest + , commonNonStreamingHandler + , commonStreamHandler + , nonJsonHandler + + -- * Model Options + , defaultModelOptions + + -- * Retry Logic + , withRetry + + -- * Version Retrieval + , getVersion + ) where + +import Control.Concurrent (threadDelay) import Control.Exception (IOException, try) +import Data.Aeson import Data.ByteString qualified as BS import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Lazy qualified as BSL import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Data.Ollama.Common.Config +import Data.Ollama.Common.Error +import Data.Ollama.Common.Error qualified as Error import Data.Ollama.Common.Types import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Encoding qualified as TE +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types (Status (statusCode)) import System.Directory import System.FilePath -defaultOllamaUrl :: Text -defaultOllamaUrl = "http://127.0.0.1:11434" - +-- | List of supported image file extensions for 'encodeImage'. supportedExtensions :: [String] supportedExtensions = [".jpg", ".jpeg", ".png"] +-- | Safely read a file, returning an 'Either' with an 'IOException' on failure. safeReadFile :: FilePath -> IO (Either IOException BS.ByteString) safeReadFile = try . BS.readFile +-- | Read a file if it exists, returning 'Nothing' if it does not. asPath :: FilePath -> IO (Maybe BS.ByteString) asPath filePath = do exists <- doesFileExist filePath @@ -28,13 +73,15 @@ then either (const Nothing) Just <$> safeReadFile filePath else return Nothing +-- | Check if a file has a supported image extension. isSupportedExtension :: FilePath -> Bool -isSupportedExtension path = map toLower (takeExtension path) `elem` supportedExtensions +isSupportedExtension p = map toLower (takeExtension p) `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. +{- | Encodes an image file to Base64 format. + +Takes a file path to an image (jpg, jpeg, or png) and returns its data encoded as a Base64 'Text'. +Returns 'Nothing' if the file extension is unsupported or the file cannot be read. +This is useful for including images in API requests that expect Base64-encoded data, such as 'GenerateOps' images field. -} encodeImage :: FilePath -> IO (Maybe Text) encodeImage filePath = do @@ -43,3 +90,217 @@ else do maybeContent <- asPath filePath return $ fmap (TE.decodeUtf8 . Base64.encode) maybeContent + +{- | Executes an action with retry logic for recoverable errors. + +Retries the given action up to the specified number of times with a delay (in seconds) between attempts. +Only retries on recoverable errors such as HTTP errors, timeouts, JSON schema errors, or decoding errors. +-} +withRetry :: + -- | Number of retries + Int -> + -- | Delay between retries in seconds + Int -> + -- | Action to execute, returning 'Either' 'OllamaError' or a result + IO (Either OllamaError a) -> + IO (Either OllamaError a) +withRetry 0 _ action = action +withRetry retries delaySeconds action = do + result <- action + case result of + Left err | isRetryableError err -> do + threadDelay (delaySeconds * 1000000) -- Convert to microseconds + withRetry (retries - 1) delaySeconds action + _ -> return result + where + isRetryableError (HttpError _) = True + isRetryableError (TimeoutError _) = True + isRetryableError (JsonSchemaError _) = True + isRetryableError (DecodeError _ _) = True + isRetryableError _ = False + +{- | Sends an HTTP request to the Ollama API. + +A unified function for making API requests to the Ollama server. Supports both GET and POST methods, +customizable payloads, and optional configuration. The response is processed by the provided handler. +-} +withOllamaRequest :: + forall payload response. + (ToJSON payload) => + -- | API endpoint + Text -> + -- | HTTP method ("GET" or "POST") + BS.ByteString -> + -- | Optional request payload (must implement 'ToJSON') + Maybe payload -> + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig') + Maybe OllamaConfig -> + -- | Response handler to process the HTTP response + (Response BodyReader -> IO (Either OllamaError response)) -> + IO (Either OllamaError response) +withOllamaRequest endpoint reqMethod mbPayload mbOllamaConfig handler = do + let OllamaConfig {..} = fromMaybe defaultOllamaConfig mbOllamaConfig + fullUrl = T.unpack $ hostUrl <> endpoint + timeoutMicros = timeout * 1000000 + manager <- case commonManager of + Nothing -> + newTlsManagerWith + tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro timeoutMicros} + Just m -> pure m + eRequest <- try $ parseRequest fullUrl + case eRequest of + Left ex -> return $ Left $ Error.HttpError ex + Right req -> do + let request = + req + { method = reqMethod + , requestBody = + maybe mempty (\x -> RequestBodyLBS $ encode x) mbPayload + } + retryCnt = fromMaybe 0 retryCount + retryDelay_ = fromMaybe 1 retryDelay + withRetry retryCnt retryDelay_ $ do + fromMaybe (pure ()) onModelStart + eResponse <- try $ withResponse request manager handler + case eResponse of + Left ex -> do + fromMaybe (pure ()) onModelError + case ex of + (HttpExceptionRequest _ ResponseTimeout) -> + return $ Left $ Error.TimeoutError "No response from LLM yet" + _ -> return $ Left $ Error.HttpError ex + Right result -> do + fromMaybe (pure ()) onModelFinish + return result + +{- | Handles non-streaming API responses. + +Processes an HTTP response, accumulating all chunks until EOF and decoding the result as JSON. +Returns an 'Either' with an 'OllamaError' on failure or the decoded response on success. +Suitable for APIs that return a single JSON response. +-} +commonNonStreamingHandler :: + FromJSON a => + Response BodyReader -> + IO (Either OllamaError a) +commonNonStreamingHandler resp = do + let bodyReader = responseBody resp + respStatus = statusCode $ responseStatus resp + if respStatus >= 200 && respStatus < 300 + then do + finalBs <- readFullBuff BS.empty bodyReader + case eitherDecode (BSL.fromStrict finalBs) of + Left err -> pure . Left $ Error.DecodeError err (show finalBs) + Right decoded -> pure . Right $ decoded + else Left . ApiError . TE.decodeUtf8 <$> brRead bodyReader + +{- | Accumulates response chunks into a single ByteString. + +Internal helper function to read all chunks from a 'BodyReader' until EOF. +-} +readFullBuff :: BS.ByteString -> BodyReader -> IO BS.ByteString +readFullBuff acc reader = do + chunk <- brRead reader + if BS.null chunk + then pure acc + else readFullBuff (acc `BS.append` chunk) reader + +{- | Handles streaming API responses. + +Processes a streaming HTTP response, decoding each chunk as JSON and passing it to the provided +'sendChunk' function. The 'flush' function is called after each chunk. Stops when the response +indicates completion (via 'HasDone'). Returns the final decoded response or an error. +-} +commonStreamHandler :: + (HasDone a, FromJSON a) => + -- | Function to handle each decoded chunk + (a -> IO ()) -> + -- | Function to flush after each chunk + IO () -> + Response BodyReader -> + IO (Either OllamaError a) +commonStreamHandler sendChunk flush resp = go mempty + where + go acc = do + bs <- brRead $ responseBody resp + if BS.null bs + then do + case eitherDecode (BSL.fromStrict acc) of + Left err -> pure $ Left $ Error.DecodeError err (show acc) + Right decoded -> pure $ Right decoded + else do + let chunk = BSL.fromStrict bs + case eitherDecode chunk of + Left err -> return $ Left $ Error.DecodeError err (show acc) + Right res -> do + sendChunk res + flush + if getDone res then return (Right res) else go (acc <> bs) + +{- | Handles non-JSON API responses. + +Processes an HTTP response, accumulating all chunks into a 'ByteString'. Returns the accumulated +data on success (HTTP status 2xx) or an 'ApiError' on failure. +-} +nonJsonHandler :: Response BodyReader -> IO (Either OllamaError BS.ByteString) +nonJsonHandler resp = do + let bodyReader = responseBody resp + respStatus = statusCode $ responseStatus resp + if respStatus >= 200 && respStatus < 300 + then Right <$> readFullBuff BS.empty bodyReader + else Left . ApiError . TE.decodeUtf8 <$> brRead bodyReader + +{- | Default model options for API requests. + +Provides a default 'ModelOptions' configuration with all fields set to 'Nothing', +suitable as a starting point for customizing model parameters like temperature or token limits. + +Example: + +>>> let opts = defaultModelOptions { temperature = Just 0.7 } +-} +defaultModelOptions :: ModelOptions +defaultModelOptions = + ModelOptions + { numKeep = Nothing + , seed = Nothing + , numPredict = Nothing + , topK = Nothing + , topP = Nothing + , minP = Nothing + , typicalP = Nothing + , repeatLastN = Nothing + , temperature = Nothing + , repeatPenalty = Nothing + , presencePenalty = Nothing + , frequencyPenalty = Nothing + , penalizeNewline = Nothing + , stop = Nothing + , numa = Nothing + , numCtx = Nothing + , numBatch = Nothing + , numGpu = Nothing + , mainGpu = Nothing + , useMmap = Nothing + , numThread = Nothing + } + +{- | Retrieves the Ollama server version. + +Sends a GET request to the "/api//version" endpoint and returns the server version +as a 'Version' wrapped in an 'Either' 'OllamaError'. + +Example: + +>>> getVersion +-- +-- @since 0.2.0.0 +-} +getVersion :: IO (Either OllamaError Version) +getVersion = do + withOllamaRequest + "/api//version" + "GET" + (Nothing :: Maybe Value) + Nothing + commonNonStreamingHandler diff --git a/src/Data/Ollama/Conversation.hs b/src/Data/Ollama/Conversation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ollama/Conversation.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Ollama.Conversation +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Conversation management for the Ollama client, including storage and retrieval of chat sessions. + +This module provides types and functions for managing conversations in the Ollama client. It defines +a 'Conversation' type to represent a chat session, a 'ConversationStore' typeclass for storage operations, +and an in-memory implementation using 'InMemoryStore' and 'ConvoM'. The module supports saving, loading, +listing, and deleting conversations, with thread-safe operations using STM (Software Transactional Memory). + +The 'Conversation' type includes metadata such as a unique ID, messages, model name, and timestamps. +The 'ConversationStore' typeclass defines a generic interface for conversation storage, while 'InMemoryStore' +provides a concrete in-memory implementation. The 'ConvoM' monad integrates with 'InMemoryStore' for +monadic operations. + +Example: + +>>> store <- initInMemoryStore +>>> let conv = Conversation "conv1" [userMessage "Hello!"] "gemma3" <$> getCurrentTime <*> getCurrentTime +>>> runInMemoryConvo store $ saveConversation conv +>>> runInMemoryConvo store $ loadConversation "conv1" +Just (Conversation ...) +-} +module Data.Ollama.Conversation + ( -- * Conversation Types + Conversation (..) + , ConversationStore (..) + + -- * In-Memory Store + , InMemoryStore (..) + , ConvoM (..) + , initInMemoryStore + , runInMemoryConvo + + -- * Validation + , validateConversation + ) where + +import Control.Concurrent.STM +import Control.Monad.Reader +import Data.Aeson (FromJSON, ToJSON) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Ollama.Common.Types +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, getCurrentTime) +import GHC.Generics (Generic) + +{- | Represents a chat session with metadata and messages. + +Stores a conversation's unique identifier, list of messages, model name, creation time, and last updated time. +-} +data Conversation = Conversation + { conversationId :: !Text + -- ^ Unique identifier for the conversation. + , messages :: ![Message] + -- ^ List of messages in the conversation. + , model :: !Text + -- ^ Name of the model used in the conversation (e.g., "gemma3"). + , createdAt :: !UTCTime + -- ^ Timestamp when the conversation was created. + , lastUpdated :: !UTCTime + -- ^ Timestamp when the conversation was last updated. + } + deriving (Show, Eq, Generic) + +instance ToJSON Conversation +instance FromJSON Conversation + +{- | Typeclass defining operations for storing and managing conversations. + +Provides methods for saving, loading, listing, and deleting conversations in a monadic context. +-- +-- @since 0.2.0.0 +-} +class Monad m => ConversationStore m where + -- | Saves a conversation to the store. + -- + -- Validates the conversation and updates its 'lastUpdated' timestamp before saving. + saveConversation :: Conversation -> m () + + -- | Loads a conversation by its ID. + -- + -- Returns 'Just' the conversation if found, or 'Nothing' if not. + loadConversation :: Text -> m (Maybe Conversation) + + -- | Lists all conversations in the store. + listConversations :: m [Conversation] + + -- | Deletes a conversation by its ID. + -- + -- Returns 'True' if the conversation was found and deleted, 'False' otherwise. + deleteConversation :: Text -> m Bool + +{- | In-memory conversation store using a 'TVar' for thread-safe operations. + +Stores conversations in a 'Map' keyed by conversation IDs, wrapped in a 'TVar' for concurrent access. +-} +newtype InMemoryStore = InMemoryStore (TVar (Map Text Conversation)) + +{- | Monad for operations with 'InMemoryStore'. + +A wrapper around 'ReaderT' that provides access to an 'InMemoryStore' in a monadic context. +-} +newtype ConvoM a = ConvoM {runConvoM :: ReaderT InMemoryStore IO a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader InMemoryStore) + +{- | Runs a 'ConvoM' action with the given 'InMemoryStore'. + +Executes a monadic computation in the context of an in-memory store. + +Example: + +>>> store <- initInMemoryStore +>>> runInMemoryConvo store $ saveConversation conv +-} +runInMemoryConvo :: InMemoryStore -> ConvoM a -> IO a +runInMemoryConvo store = flip runReaderT store . runConvoM + +instance ConversationStore ConvoM where + saveConversation conv = do + case validateConversation conv of + Left err -> liftIO $ putStrLn ("Validation error: " <> T.unpack err) + Right validConv -> do + now <- liftIO getCurrentTime + let updatedConv = validConv {lastUpdated = now} + InMemoryStore ref <- ask + liftIO . atomically $ modifyTVar' ref (Map.insert (conversationId updatedConv) updatedConv) + + loadConversation cid = do + InMemoryStore ref <- ask + convs <- liftIO $ readTVarIO ref + return $ Map.lookup cid convs + + listConversations = do + InMemoryStore ref <- ask + convs <- liftIO $ readTVarIO ref + return $ Map.elems convs + + deleteConversation cid = do + InMemoryStore ref <- ask + liftIO . atomically $ do + convs <- readTVar ref + if Map.member cid convs + then do + writeTVar ref (Map.delete cid convs) + return True + else return False + +{- | Validates a 'Conversation' to ensure required fields are non-empty. + +Checks that the 'conversationId' is not empty and that the 'messages' list contains at least one message. +Returns 'Right' with the validated conversation or 'Left' with an error message. + +Example: + +>>> let conv = Conversation "" [] "gemma3" time time +>>> validateConversation conv +Left "Conversation ID cannot be empty" +-} +validateConversation :: Conversation -> Either Text Conversation +validateConversation conv + | T.null (conversationId conv) = Left "Conversation ID cannot be empty" + | null (messages conv) = Left "Conversation must have at least one message" + | otherwise = Right conv + +{- | Creates a new empty in-memory conversation store. + +Initializes an 'InMemoryStore' with an empty 'Map' wrapped in a 'TVar' for thread-safe operations. + +Example: + +>>> store <- initInMemoryStore +>>> runInMemoryConvo store $ listConversations +[] +-} +initInMemoryStore :: IO InMemoryStore +initInMemoryStore = InMemoryStore <$> newTVarIO Map.empty diff --git a/src/Data/Ollama/Copy.hs b/src/Data/Ollama/Copy.hs --- a/src/Data/Ollama/Copy.hs +++ b/src/Data/Ollama/Copy.hs @@ -3,53 +3,84 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{- | +Module : Data.Ollama.Copy +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for copying models in the Ollama client. + +This module provides functions to copy a model from a source name to a destination name using the Ollama API. +It includes both an IO-based function ('copyModel') and a monadic version ('copyModelM') for use in +'MonadIO' contexts. The copy operation is performed via a POST request to the "/api//copy" endpoint. + +Example: + +>>> copyModel "gemma3" "gemma3-copy" Nothing +Right () +-} module Data.Ollama.Copy ( -- * Copy Model API copyModel + , copyModelM ) where -import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU +import Data.Ollama.Common.Config (OllamaConfig (..)) +import Data.Ollama.Common.Error (OllamaError) +import Data.Ollama.Common.Utils (nonJsonHandler, withOllamaRequest) 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 +-- | Configuration for copying a model. data CopyModelOps = CopyModelOps - { source :: Text - , destination :: Text + { source :: !Text + -- ^ The name of the source model to copy. + , destination :: !Text + -- ^ The name of the destination model. } deriving (Show, Eq, Generic, ToJSON) --- | Copy model from source to destination +{- | Copies a model from a source name to a destination name. + +Sends a POST request to the "/api//copy" endpoint with the source and destination model names. +Returns 'Right ()' on success or 'Left' with an 'OllamaError' on failure. +Example: + +>>> copyModel "gemma3" "gemma3-copy" Nothing +Right () +-} copyModel :: - -- | Source model + -- | Source model name Text -> - -- | Destination model + -- | Destination model name Text -> - IO () + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError ()) 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") + destination_ + mbConfig = do + let reqBody = CopyModelOps {source = source_, destination = destination_} + withOllamaRequest + "/api//copy" + "POST" + (Just reqBody) + mbConfig + (fmap ((const ()) <$>) . nonJsonHandler) + +{- | MonadIO version of 'copyModel' for use in monadic contexts. + +Lifts the 'copyModel' function into a 'MonadIO' context, allowing it to be used in monadic computations. + +Example: + +>>> import Control.Monad.IO.Class +>>> runReaderT (copyModelM "gemma3" "gemma3-copy" Nothing) someContext +Right () +-} +copyModelM :: MonadIO m => Text -> Text -> Maybe OllamaConfig -> m (Either OllamaError ()) +copyModelM s d mbCfg = liftIO $ copyModel s d mbCfg diff --git a/src/Data/Ollama/Create.hs b/src/Data/Ollama/Create.hs --- a/src/Data/Ollama/Create.hs +++ b/src/Data/Ollama/Create.hs @@ -1,35 +1,64 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Create +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for creating new models in the Ollama client. + +This module provides functions to create a new model in the Ollama API using either a model file +content or a file path. It includes both an IO-based function ('createModel') and a monadic version +('createModelM') for use in 'MonadIO' contexts. The create operation is performed via a POST request +to the "/api//pull" endpoint, with streaming support for progress updates. + +Note: If both 'modelFile' and 'path' are provided, 'modelFile' takes precedence. + +Example: + +>>> createModel "myModel" (Just "FROM llama3\nPARAMETER temperature 0.8") (Just True) Nothing Nothing +Creating model... +Completed +-} module Data.Ollama.Create ( -- * Create Model API createModel - , createModelOps + , createModelM ) where -import Control.Monad (unless) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Types (HasDone (getDone)) 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 +-- | Configuration for creating a new model. data CreateModelOps = CreateModelOps - { name :: Text - , modelFile :: Maybe Text - , stream :: Maybe Bool - , path :: Maybe FilePath + { name :: !Text + -- ^ The name of the model to create. + , modelFile :: !(Maybe Text) + -- ^ Optional model file content (e.g., Modelfile text). Takes precedence over 'path'. + , stream :: !(Maybe Bool) + -- ^ Optional flag to enable streaming progress updates. + , path :: !(Maybe FilePath) + -- ^ Optional file path to a Modelfile. } deriving (Show, Eq) --- TODO: Add Context Param -newtype CreateModelResp = CreateModelResp {status :: Text} +-- | Response type for model creation. +newtype CreateModelResp + = -- | The status of the create operation (e.g., "success"). + CreateModelResp {status :: Text} deriving (Show, Eq) +instance HasDone CreateModelResp where + getDone CreateModelResp {..} = status /= "success" + instance ToJSON CreateModelOps where toJSON ( CreateModelOps @@ -50,71 +79,63 @@ 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. +{- | Creates a new model using either model file content or a file path. + +Sends a POST request to the "/api//pull" endpoint to create a model with the specified name. +The model can be defined either by 'modelFile' (Modelfile content as text) or 'path' (file path to a Modelfile). +If both are provided, 'modelFile' is used. Supports streaming progress updates if 'stream' is 'Just True'. +Prints progress messages to the console during creation. -} -createModelOps :: - -- | Model Name +createModel :: + -- | Model name Text -> - -- | Model File + -- | Optional model file content Maybe Text -> - -- | Stream + -- | Optional streaming flag Maybe Bool -> - -- | Path + -- | Optional file path to a Modelfile Maybe FilePath -> + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> IO () -createModelOps +createModel modelName modelFile_ stream_ - path_ = - do - let url = defaultOllamaUrl - manager <- newManager defaultManagerSettings - initialRequest <- parseRequest $ T.unpack (url <> "/api/create") - let reqBody = + path_ + mbConfig = + void $ + withOllamaRequest + "/api//pull" + "POST" + ( Just $ 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 + ) + mbConfig + (commonStreamHandler onToken onComplete) + where + onToken :: CreateModelResp -> IO () + onToken _ = do + putStrLn "Creating model..." -{- | Create a new model -| Please note, if you specify both ModelFile and Path, ModelFile will be used. + onComplete :: IO () + onComplete = putStrLn "Completed" + +{- | MonadIO version of 'createModel' for use in monadic contexts. + +Lifts the 'createModel' function into a 'MonadIO' context, allowing it to be used in monadic computations. -} -createModel :: - -- | Model Name +createModelM :: + MonadIO m => Text -> - -- | Model File Maybe Text -> - -- | Path + Maybe Bool -> Maybe FilePath -> - IO () -createModel modelName modelFile_ = - createModelOps - modelName - modelFile_ - Nothing + Maybe OllamaConfig -> + m () +createModelM m mf s p mbCfg = liftIO $ createModel m mf s p mbCfg diff --git a/src/Data/Ollama/Delete.hs b/src/Data/Ollama/Delete.hs --- a/src/Data/Ollama/Delete.hs +++ b/src/Data/Ollama/Delete.hs @@ -3,42 +3,69 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{- | +Module : Data.Ollama.Delete +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for deleting models in the Ollama client. + +This module provides functions to delete a model from the Ollama server using its name. It includes +both an IO-based function ('deleteModel') and a monadic version ('deleteModelM') for use in +'MonadIO' contexts. The delete operation is performed via a DELETE request to the "/api//delete" endpoint. + +Example: + +>>> deleteModel "gemma3" Nothing +Right () +-} module Data.Ollama.Delete - ( -- * Delete downloaded Models + ( -- * Delete Model API deleteModel + , deleteModelM ) where -import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU +import Data.Ollama.Common.Config (OllamaConfig (..)) +import Data.Ollama.Common.Error (OllamaError) +import Data.Ollama.Common.Utils (nonJsonHandler, withOllamaRequest) 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) +-- | Request payload for deleting a model. +newtype DeleteModelReq + = -- | The name of the model to delete. + DeleteModelReq {name :: Text} + deriving newtype (Show, Eq) --- | Delete a model +instance ToJSON DeleteModelReq where + toJSON (DeleteModelReq name_) = object ["name" .= name_] + +{- | Deletes a model from the Ollama server. + +Sends a DELETE request to the "/api//delete" endpoint with the specified model name. +Returns 'Right ()' on success or 'Left' with an 'OllamaError' on failure. +-} deleteModel :: - -- | Model name + -- | Model name to delete 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") + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError ()) +deleteModel modelName mbConfig = do + let reqBody = DeleteModelReq {name = modelName} + withOllamaRequest + "/api//delete" + "DELETE" + (Just reqBody) + mbConfig + (fmap ((const ()) <$>) . nonJsonHandler) + +{- | MonadIO version of 'deleteModel' for use in monadic contexts. + +Lifts the 'deleteModel' function into a context, +allowing it to be used in monadic computations. +-} +deleteModelM :: MonadIO m => Text -> Maybe OllamaConfig -> m (Either OllamaError ()) +deleteModelM t mbCfg = liftIO $ deleteModel t mbCfg diff --git a/src/Data/Ollama/Embeddings.hs b/src/Data/Ollama/Embeddings.hs --- a/src/Data/Ollama/Embeddings.hs +++ b/src/Data/Ollama/Embeddings.hs @@ -1,102 +1,180 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{- | +Module : Data.Ollama.Embeddings +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for generating text embeddings using the Ollama API. + +This module provides functions to generate text embeddings from an Ollama model. It includes both +high-level ('embedding', 'embeddingM') and low-level ('embeddingOps', 'embeddingOpsM') APIs for +generating embeddings, with support for customizing model options, truncation, and keep-alive settings. +The embeddings are returned as a list of float vectors, suitable for tasks like semantic search or +text similarity analysis. + +The 'EmbeddingOps' type configures the embedding request, and 'EmbeddingResp' represents the response +containing the model name and the generated embeddings. The 'defaultEmbeddingOps' provides a default +configuration for convenience. + +Example: + +>>> embedding "llama3.2" ["Hello, world!"] +Right (EmbeddingResp "llama3.2" [[0.1, 0.2, ...]]) +-} module Data.Ollama.Embeddings ( -- * Embedding API embedding , embeddingOps + , embeddingM + , embeddingOpsM + + -- * Configuration and Response Types + , defaultEmbeddingOps , EmbeddingOps (..) , EmbeddingResp (..) + + -- * Model Options + , ModelOptions (..) + , defaultModelOptions ) where +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Error (OllamaError) +import Data.Ollama.Common.Types (ModelOptions (..)) 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 +{- | Default configuration for embedding requests. + +Provides a default 'EmbeddingOps' with the "llama3.2" model, an empty input list, and no additional options. +Can be customized by modifying fields as needed. +-} +defaultEmbeddingOps :: EmbeddingOps +defaultEmbeddingOps = + EmbeddingOps + { model = "llama3.2" + , input = [] + , truncateInput = Nothing + , keepAliveEmbed = Nothing + , modelOptions = Nothing + } + +-- | Configuration for an embedding request. data EmbeddingOps = EmbeddingOps - { model :: Text - , input :: Text - , truncate :: Maybe Bool - , keepAlive :: Maybe Text + { model :: !Text + -- ^ The name of the model to use for generating embeddings (e.g., "llama3.2"). + , input :: ![Text] + -- ^ List of input texts to generate embeddings for. + , truncateInput :: !(Maybe Bool) + -- ^ Optional flag to truncate input if it exceeds model limits. + , keepAliveEmbed :: !(Maybe Int) + -- ^ Optional override for the keep-alive timeout in minutes. + , modelOptions :: !(Maybe ModelOptions) + -- ^ Optional model parameters (e.g., temperature) as specified in the Modelfile. + -- + -- @since 0.2.0.0 } deriving (Show, Eq) +-- | Response type for an embedding request. data EmbeddingResp = EmbeddingResp - { model :: Text - , embedding_ :: [[Float]] + { respondedModel :: !Text + -- ^ The name of the model that generated the embeddings. + , respondedEmbeddings :: ![[Float]] + -- ^ List of embedding vectors, one for each input text. } deriving (Show, Eq) instance FromJSON EmbeddingResp where - parseJSON = withObject "EmbeddingResp" $ \v -> EmbeddingResp - <$> v .: "model" - <*> v .: "embeddings" + parseJSON = withObject "EmbeddingResp" $ \v -> + EmbeddingResp + <$> v .: "model" + <*> v .: "embeddings" instance ToJSON EmbeddingOps where - toJSON (EmbeddingOps model_ input_ truncate' keepAlive_) = + toJSON (EmbeddingOps model_ input_ truncate' keepAlive_ ops) = object [ "model" .= model_ , "input" .= input_ , "truncate" .= truncate' , "keep_alive" .= keepAlive_ + , "options" .= ops ] --- TODO: Add Options parameter +{- | Generates embeddings for a list of input texts with full configuration. --- | Embedding API +Sends a POST request to the "/api//embed" endpoint to generate embeddings for the provided inputs. +Allows customization of truncation, keep-alive settings, model options, and Ollama configuration. +Returns 'Right' with an 'EmbeddingResp' on success or 'Left' with an 'OllamaError' on failure. +-} embeddingOps :: - -- | Model - Text -> - -- | Input + -- | Model name Text -> - -- | Truncate + -- | List of input texts + [Text] -> + -- | Optional truncation flag 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 + -- | Optional keep-alive timeout in minutes + Maybe Int -> + -- | Optional model options + Maybe ModelOptions -> + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError EmbeddingResp) +embeddingOps modelName input_ mTruncate mKeepAlive mbOptions mbConfig = do + withOllamaRequest + "/api//embed" + "POST" + ( Just $ + EmbeddingOps + { model = modelName + , input = input_ + , truncateInput = mTruncate + , keepAliveEmbed = mKeepAlive + , modelOptions = mbOptions + } + ) + mbConfig + commonNonStreamingHandler --- Higher level binding that only takes important params +{- | Simplified API for generating embeddings. --- | Embedding API +A higher-level function that generates embeddings using default settings for truncation, keep-alive, +model options, and Ollama configuration. Suitable for basic use cases. +-} embedding :: - -- | Model - Text -> - -- | Input + -- | Model name Text -> - IO (Either String EmbeddingResp) + -- | List of input texts + [Text] -> + IO (Either OllamaError EmbeddingResp) embedding modelName input_ = - embeddingOps modelName input_ Nothing Nothing + embeddingOps modelName input_ Nothing Nothing Nothing Nothing + +{- | MonadIO version of 'embedding' for use in monadic contexts. + +Lifts the 'embedding' function into a 'MonadIO' context, allowing it to be used in monadic computations. +-} +embeddingM :: MonadIO m => Text -> [Text] -> m (Either OllamaError EmbeddingResp) +embeddingM m ip = liftIO $ embedding m ip + +{- | MonadIO version of 'embeddingOps' for use in monadic contexts. + +Lifts the 'embeddingOps' function into a 'MonadIO' context, allowing it to be used in monadic computations +with full configuration options. +-} +embeddingOpsM :: + MonadIO m => + Text -> + [Text] -> + Maybe Bool -> + Maybe Int -> + Maybe ModelOptions -> + Maybe OllamaConfig -> + m (Either OllamaError EmbeddingResp) +embeddingOpsM m ip mbTruncate mbKeepAlive mbOptions mbCfg = + liftIO $ embeddingOps m ip mbTruncate mbKeepAlive mbOptions mbCfg diff --git a/src/Data/Ollama/Generate.hs b/src/Data/Ollama/Generate.hs --- a/src/Data/Ollama/Generate.hs +++ b/src/Data/Ollama/Generate.hs @@ -2,80 +2,111 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Generate +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Text generation functionality for the Ollama client. + +This module provides functions and types for generating text using an Ollama model. It includes APIs +for sending generation requests, both in IO ('generate') and monadic ('generateM') contexts, with +support for streaming and non-streaming responses. The 'GenerateOps' type configures the generation +request, allowing customization of the model, prompt, images, format, and other parameters. The +'defaultGenerateOps' provides a convenient starting point for configuration. + +The module supports advanced features like Base64-encoded images, custom templates, and model-specific +options (e.g., temperature). It also includes validation to ensure required fields are non-empty. + +Example: + +>>> let ops = defaultGenerateOps { modelName = "gemma3", prompt = "Write a poem." } +>>> generate ops Nothing +Right (GenerateResponse ...) +-} module Data.Ollama.Generate ( -- * Generate Texts generate + , generateM + + -- * Configuration , defaultGenerateOps - , generateJson , GenerateOps (..) + , validateGenerateOps + + -- * Response and Configuration Types , GenerateResponse (..) + , Format (..) + , OllamaConfig (..) + , defaultOllamaConfig + , ModelOptions (..) + , defaultModelOptions + + -- * Error Types + , OllamaError (..) ) where -import Control.Exception (try) +import Control.Monad.IO.Class (MonadIO (liftIO)) 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.Config (OllamaConfig (..), defaultOllamaConfig) +import Data.Ollama.Common.Error (OllamaError (..)) +import Data.Ollama.Common.Types (Format (..), GenerateResponse (..), ModelOptions (..)) 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 +{- | Validates 'GenerateOps' to ensure required fields are non-empty. -{- | - Input type for generate functions. This data type represents all possible configurations - that you can pass to the Ollama generate API. +Checks that the 'modelName' and 'prompt' fields are not empty. Returns 'Right' with the validated +'GenerateOps' or 'Left' with an 'OllamaError' if validation fails. - Example: +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" - > } +>>> validateGenerateOps defaultGenerateOps +Left (InvalidRequest "Prompt cannot be empty") +-- +-- @since 0.2.0.0 -} +validateGenerateOps :: GenerateOps -> Either OllamaError GenerateOps +validateGenerateOps ops + | T.null (modelName ops) = Left $ InvalidRequest "Model name cannot be empty" + | T.null (prompt ops) = Left $ InvalidRequest "Prompt cannot be empty" + | otherwise = Right ops + +-- | Configuration for a text generation request. 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. + { modelName :: !Text + -- ^ The name of the model to use for generation (e.g., "gemma3"). + , prompt :: !Text + -- ^ The prompt text to provide 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 + -- ^ Optional suffix to append to the generated text (not supported by all models). + , images :: !(Maybe [Text]) + -- ^ Optional list of Base64-encoded images to include with the request. + , format :: !(Maybe Format) + -- ^ Optional format specifier for the response (e.g., JSON). + -- + -- @since 0.1.3.0 + , system :: !(Maybe Text) + -- ^ Optional system text to include in the generation context. + , template :: !(Maybe Text) + -- ^ Optional template to format the response. + , stream :: !(Maybe (GenerateResponse -> IO (), IO ())) + -- ^ Optional streaming functions: the first handles each response chunk, the second flushes the stream. + , raw :: !(Maybe Bool) + -- ^ Optional flag to return the raw response. + , keepAlive :: !(Maybe Int) + -- ^ Optional override for how long (in minutes) the model stays loaded in memory (default: 5 minutes). + , options :: !(Maybe ModelOptions) + -- ^ Optional model parameters (e.g., temperature) as specified in the Modelfile. + -- + -- @since 0.1.3.0 + , think :: !(Maybe Bool) + -- ^ Optional flag to enable thinking mode. + -- + -- @since 0.2.0.0 } instance Show GenerateOps where @@ -103,6 +134,8 @@ <> show keepAlive <> ", options : " <> show options + <> ", think: " + <> show think instance Eq GenerateOps where (==) a b = @@ -116,35 +149,7 @@ && 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) + && think a == think b instance ToJSON GenerateOps where toJSON @@ -159,9 +164,8 @@ stream raw keepAlive - _ -- Host url - _ -- Response timeout - options + options + think ) = object [ "model" .= model @@ -175,37 +179,24 @@ , "raw" .= raw , "keep_alive" .= keepAlive , "options" .= options + , "think" .= think ] -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" +{- | Default configuration for text generation. -{- | -A function to create a default 'GenerateOps' type with preset values. +Provides a default 'GenerateOps' with the "gemma3" model and an empty prompt. Other fields are set +to 'Nothing' or default values. Can be customized by modifying fields as needed. Example: -> let ops = defaultGenerateOps -> generate ops - -This will generate a response using the default configuration. +>>> let ops = defaultGenerateOps { modelName = "customModel", prompt = "Hello!" } +>>> generate ops Nothing -} defaultGenerateOps :: GenerateOps defaultGenerateOps = GenerateOps - { modelName = "llama3.2" - , prompt = "what is 2+2" + { modelName = "gemma3" + , prompt = "" , suffix = Nothing , images = Nothing , format = Nothing @@ -214,197 +205,44 @@ , stream = Nothing , raw = Nothing , keepAlive = Nothing - , hostUrl = Nothing - , responseTimeOut = Nothing , options = Nothing + , think = 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) +{- | Generates text using the specified model and configuration. -Output: - > ("JSON response: ",Example {sortedList = ["1","2","3","4"], wasListAlreadSorted = False}) +Validates the 'GenerateOps' configuration and sends a POST request to the "/api//generate" endpoint. +Supports both streaming and non-streaming responses based on the 'stream' field in 'GenerateOps'. +Returns 'Right' with a 'GenerateResponse' on success or 'Left' with an 'OllamaError' on failure. -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. +Example: - You can also provide number of retries in case the LLM field to return the response in correct JSON - in first attempt. +>>> let ops = defaultGenerateOps { modelName = "gemma3", prompt = "Write a short poem." } +>>> generate ops Nothing +Right (GenerateResponse ...) -} -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 +generate :: GenerateOps -> Maybe OllamaConfig -> IO (Either OllamaError GenerateResponse) +generate ops mbConfig = + case validateGenerateOps ops of + Left err -> pure $ Left err + Right _ -> withOllamaRequest "/api//generate" "POST" (Just ops) mbConfig handler + where + handler = case stream ops of + Nothing -> commonNonStreamingHandler + Just (sc, fl) -> commonStreamHandler sc fl +{- | MonadIO version of 'generate' for use in monadic contexts. -{- | - Example usage of 'Ollama.generate' with a JSON schema format and options field. +Lifts the 'generate' function into a 'MonadIO' context, allowing it to be used in monadic computations. - 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. +Example: - >>> 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}) +>>> import Control.Monad.IO.Class +>>> let ops = defaultGenerateOps { modelName = "gemma3", prompt = "Hello!" } +>>> runReaderT (generateM ops Nothing) someContext +Right (GenerateResponse ...) -} - +generateM :: + MonadIO m => + GenerateOps -> Maybe OllamaConfig -> m (Either OllamaError GenerateResponse) +generateM ops mbCfg = liftIO $ generate ops mbCfg diff --git a/src/Data/Ollama/List.hs b/src/Data/Ollama/List.hs --- a/src/Data/Ollama/List.hs +++ b/src/Data/Ollama/List.hs @@ -1,39 +1,69 @@ +-- | +-- Module : Data.Ollama.List +-- Copyright : (c) 2025 Tushar Adhatrao +-- License : MIT +-- Maintainer : Tushar Adhatrao +-- Stability : experimental +-- Description : Functionality for listing available models in the Ollama client. +-- +-- This module provides functions to retrieve a list of models available on the Ollama server. +-- It includes both an IO-based function ('list') and a monadic version ('listM') for use in +-- 'MonadIO' contexts. The list operation is performed via a GET request to the "/api//tags" endpoint, +-- returning a 'Models' type containing a list of 'ModelInfo' records with details about each model. +-- +-- Example: +-- +-- >>> list Nothing +-- Right (Models [ModelInfo ...]) +-- {-# LANGUAGE OverloadedStrings #-} module Data.Ollama.List ( -- * List Models API - list - , Models (..) - , ModelInfo (..) - ) -where + list, + listM, + -- * Model Types + Models (..), + ModelInfo (..) + ) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Error (OllamaError) 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) +-- | A wrapper type containing a list of available models. +-- newtype Models = Models [ModelInfo] + -- ^ List of 'ModelInfo' records describing available models. deriving (Eq, Show) +-- | Details about a specific model. +-- data ModelInfo = ModelInfo - { name :: Text - , modifiedAt :: UTCTime - , size :: Int64 - , digest :: Text - , details :: ModelDetails - } - deriving (Eq, Show) + { name :: !Text + -- ^ The name of the model. + , modifiedAt :: !UTCTime + -- ^ The timestamp when the model was last modified. + , size :: !Int64 + -- ^ The size of the model in bytes. + , digest :: !Text + -- ^ The digest (hash) of the model. + , details :: !ModelDetails + -- ^ Additional details about the model (e.g., format, family, parameters). + } deriving (Eq, Show) --- Instances +-- | JSON parsing instance for 'Models'. instance FromJSON Models where parseJSON = withObject "Models" $ \v -> Models <$> v .: "models" +-- | JSON parsing instance for 'ModelInfo'. instance FromJSON ModelInfo where parseJSON = withObject "ModelInfo" $ \v -> ModelInfo @@ -43,17 +73,31 @@ <*> 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 +-- | Retrieves a list of available models from the Ollama server. +-- +-- Sends a GET request to the "/api//tags" endpoint to fetch the list of models. +-- Returns 'Right' with a 'Models' containing the list of 'ModelInfo' on success, +-- or 'Left' with an 'OllamaError' on failure. +list :: + Maybe OllamaConfig -> -- ^ Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + IO (Either OllamaError Models) +list mbConfig = do + withOllamaRequest + "/api//tags" + "GET" + (Nothing :: Maybe Value) + mbConfig + commonNonStreamingHandler + +-- | MonadIO version of 'list' for use in monadic contexts. +-- +-- Lifts the 'list' function into a 'MonadIO' context, allowing it to be used in monadic computations. +-- +-- Example: +-- +-- >>> import Control.Monad.IO.Class +-- >>> runReaderT (listM Nothing) someContext +-- Right (Models [ModelInfo ...]) +-- +listM :: MonadIO m => Maybe OllamaConfig -> m (Either OllamaError Models) +listM mbCfg = liftIO $ list mbCfg diff --git a/src/Data/Ollama/Load.hs b/src/Data/Ollama/Load.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ollama/Load.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Ollama.Load +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : High-level functions for loading and unloading models in the Ollama client. + +This module provides functions to load and unload generative models in the Ollama server. +It includes both IO-based functions ('loadGenModel', 'unloadGenModel') and monadic versions +('loadGenModelM', 'unloadGenModelM') for use in 'MonadIO' contexts. The operations are +performed via POST requests to the "/api//generate" endpoint, leveraging the 'GenerateOps' +configuration from the 'Data.Ollama.Generate' module. + +Loading a model keeps it in memory for faster subsequent requests, while unloading frees +up memory by setting the keep-alive duration to zero. + +Example: + +>>> loadGenModel "gemma3" +Right () +>>> unloadGenModel "gemma3" +Right () +-} +module Data.Ollama.Load + ( -- * Load and Unload Model APIs + loadGenModel + , unloadGenModel + , loadGenModelM + , unloadGenModelM + ) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Ollama.Common.Error +import Data.Ollama.Common.Utils (commonNonStreamingHandler, withOllamaRequest) +import Data.Ollama.Generate qualified as Gen +import Data.Text (Text) + +{- | Loads a generative model into memory. + +Sends a POST request to the "/api//generate" endpoint to load the specified model into +memory, ensuring faster response times for subsequent requests. Returns 'Right ()' on +success or 'Left' with an 'OllamaError' on failure. +-- +-- @since 0.2.0.0 +-} +loadGenModel :: + -- | Model name (e.g., "gemma3") + Text -> + IO (Either OllamaError ()) +loadGenModel m = do + let ops = Gen.defaultGenerateOps {Gen.modelName = m} + withOllamaRequest "/api//generate" "POST" (Just ops) Nothing commonNonStreamingHandler + +{- | Unloads a generative model from memory. + +Sends a POST request to the "/api//generate" endpoint with a keep-alive duration of zero +to unload the specified model from memory, freeing up resources. Returns 'Right ()' on +success or 'Left' with an 'OllamaError' on failure. +-- +-- @since 0.2.0.0 +-} +unloadGenModel :: + -- | Model name (e.g., "gemma3") + Text -> + IO (Either OllamaError ()) +unloadGenModel m = do + let ops = Gen.defaultGenerateOps {Gen.modelName = m, Gen.keepAlive = Just 0} + withOllamaRequest "/api//generate" "POST" (Just ops) Nothing commonNonStreamingHandler + +{- | MonadIO version of 'loadGenModel' for use in monadic contexts. + +Lifts the 'loadGenModel' function into a 'MonadIO' context, allowing it to be used in +monadic computations. + +Example: + +>>> import Control.Monad.IO.Class +>>> runReaderT (loadGenModelM "gemma3") someContext +Right () +-- +-- @since 0.2.0.0 +-} +loadGenModelM :: MonadIO m => Text -> m (Either OllamaError ()) +loadGenModelM t = liftIO $ loadGenModel t + +{- | MonadIO version of 'unloadGenModel' for use in monadic contexts. + +Lifts the 'unloadGenModel' function into a 'MonadIO' context, allowing it to be used in +monadic computations. + +Example: + +>>> import Control.Monad.IO.Class +>>> runReaderT (unloadGenModelM "gemma3") someContext +Right () +-- +-- @since 0.2.0.0 +-} +unloadGenModelM :: MonadIO m => Text -> m (Either OllamaError ()) +unloadGenModelM t = liftIO $ unloadGenModel t diff --git a/src/Data/Ollama/Ps.hs b/src/Data/Ollama/Ps.hs --- a/src/Data/Ollama/Ps.hs +++ b/src/Data/Ollama/Ps.hs @@ -1,39 +1,73 @@ {-# LANGUAGE OverloadedStrings #-} +{- | +Module : Data.Ollama.Ps +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for listing running models in the Ollama client. + +This module provides functions to retrieve a list of models currently running on the Ollama server. +It includes both an IO-based function ('ps') and a monadic version ('psM') for use in 'MonadIO' +contexts. The operation is performed via a GET request to the "/api//ps" endpoint, returning a +'RunningModels' type containing a list of 'RunningModel' records with details about each running model. + +Example: + +>>> ps Nothing +Right (RunningModels [RunningModel ...]) +-} module Data.Ollama.Ps - ( ps + ( -- * List Running Models API + ps + , psM + + -- * Model Types , RunningModels (..) , RunningModel (..) ) where +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Error (OllamaError) 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] +-- | A wrapper type containing a list of running models. +newtype RunningModels + = -- | List of 'RunningModel' records describing currently running models. + RunningModels [RunningModel] deriving (Eq, Show) +-- | Details about a specific running model. data RunningModel = RunningModel - { name_ :: Text - , modelName :: Text - , size_ :: Int64 - , modelDigest :: Text - , modelDetails :: ModelDetails - , expiresAt :: UTCTime - , sizeVRam :: Int64 + { name_ :: !Text + -- ^ The name of the running model instance. + , modelName :: !Text + -- ^ The base model name (e.g., "gemma3"). + , size_ :: !Int64 + -- ^ The size of the model in bytes. + , modelDigest :: !Text + -- ^ The digest (hash) of the model. + , modelDetails :: !ModelDetails + -- ^ Additional details about the model (e.g., format, family, parameters). + , expiresAt :: !UTCTime + -- ^ The timestamp when the model's memory allocation expires. + , sizeVRam :: !Int64 + -- ^ The size of the model's VRAM usage in bytes. } deriving (Eq, Show) +-- | JSON parsing instance for 'RunningModels'. instance FromJSON RunningModels where parseJSON = withObject "Models" $ \v -> RunningModels <$> v .: "models" +-- | JSON parsing instance for 'RunningModel'. instance FromJSON RunningModel where parseJSON = withObject "RunningModel" $ \v -> RunningModel @@ -45,17 +79,31 @@ <*> 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 +{- | Retrieves a list of currently running models from the Ollama server. + +Sends a GET request to the "/api//ps" endpoint to fetch the list of running models. +Returns 'Right' with a 'RunningModels' containing the list of 'RunningModel' on success, +or 'Left' with an 'OllamaError' on failure. +Example: + +>>> ps Nothing +Right (RunningModels [RunningModel {name_ = "gemma3:instance1", modelName = "gemma3", ...}]) +-} +ps :: + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError RunningModels) +ps mbConfig = do + withOllamaRequest + "/api//ps" + "GET" + (Nothing :: Maybe Value) + mbConfig + commonNonStreamingHandler + +{- | MonadIO version of 'ps' for use in monadic contexts. + +Lifts the 'ps' function into a 'MonadIO' context, allowing it to be used in monadic computations. +-} +psM :: MonadIO m => Maybe OllamaConfig -> m (Either OllamaError RunningModels) +psM mbCfg = liftIO $ ps mbCfg diff --git a/src/Data/Ollama/Pull.hs b/src/Data/Ollama/Pull.hs --- a/src/Data/Ollama/Pull.hs +++ b/src/Data/Ollama/Pull.hs @@ -2,113 +2,155 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Pull +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for pulling models in the Ollama client. + +This module provides functions to pull (download) models from the Ollama server. It includes both +high-level ('pull', 'pullM') and low-level ('pullOps', 'pullOpsM') APIs for pulling models, with +support for streaming progress updates and insecure connections. The 'PullOps' type configures the +pull request, and 'PullResp' represents the response containing the status and progress details. + +The pull operation is performed via a POST request to the "/api//pull" endpoint. Streaming mode, +when enabled, provides real-time progress updates by printing the remaining bytes to the console. + +Example: + +>>> pull "gemma3" +Remaining bytes: 123456789 +... +Completed +Right (PullResp {status = "success", ...}) +-} module Data.Ollama.Pull - ( -- * Downloaded Models + ( -- * Pull Model API pull , pullOps + , pullM + , pullOpsM ) where +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Maybe (fromMaybe) +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Error (OllamaError) +import Data.Ollama.Common.Types (HasDone (..)) 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. + { name :: !Text + -- ^ The name of the model to pull (e.g., "gemma3"). + , insecure :: !(Maybe Bool) + -- ^ Optional flag to allow insecure connections. If 'Just True', insecure connections are permitted. + , stream :: !(Maybe Bool) + -- ^ Optional flag to enable streaming of the download. If 'Just True', progress updates are 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 + { status :: !Text + -- ^ The status of the pull operation (e.g., "success" or "failure"). + , digest :: !(Maybe Text) + -- ^ The digest (hash) 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. + , completed :: !(Maybe Int64) + -- ^ The number of bytes downloaded, 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: +instance HasDone PullResp where + getDone PullResp {..} = status /= "success" -> pullOps "myModel" (Just True) (Just True) +{- | Pulls a model with full configuration. -This will attempt to pull "myModel" with insecure connections allowed and enable streaming. +Sends a POST request to the "/api//pull" endpoint to download the specified model. Supports +streaming progress updates (if 'stream' is 'Just True') and insecure connections (if 'insecure' +is 'Just True'). Prints remaining bytes during streaming and "Completed" when finished. +Returns 'Right' with a 'PullResp' on success or 'Left' with an 'OllamaError' on failure. -} pullOps :: - -- | Model Name + -- | Model name Text -> - -- | Insecure + -- | Optional insecure connection flag Maybe Bool -> - -- | Stream + -- | Optional streaming flag 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 + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError PullResp) +pullOps modelName mInsecure mStream mbConfig = do + withOllamaRequest + "/api//pull" + "POST" + (Just $ PullOps {name = modelName, insecure = mInsecure, stream = mStream}) + mbConfig + (commonStreamHandler onToken onComplete) + where + onToken :: PullResp -> IO () + onToken res = do + let completed' = fromMaybe 0 (completed res) + let total' = fromMaybe 0 (total res) + putStrLn $ "Remaining bytes: " <> show (total' - completed') -{- | -Pull a model using default options. This simplifies the pull operation by -not requiring additional options. + onComplete :: IO () + onComplete = putStrLn "Completed" +{- | Simplified API for pulling a model. + +A higher-level function that pulls a model using default settings for insecure connections, +streaming, and Ollama configuration. Suitable for basic use cases. +-} +pull :: + -- | Model name + Text -> + IO (Either OllamaError PullResp) +pull modelName = pullOps modelName Nothing Nothing Nothing + +{- | MonadIO version of 'pull' for use in monadic contexts. + +Lifts the 'pull' function into a 'MonadIO' context, allowing it to be used in monadic computations. + Example: -> pull "myModel" +>>> import Control.Monad.IO.Class +>>> runReaderT (pullM "gemma3") someContext +Right (PullResp {status = "success", ...}) +-} +pullM :: MonadIO m => Text -> m (Either OllamaError PullResp) +pullM t = liftIO $ pull t -This will pull "myModel" using default settings (no insecure connections and no streaming). +{- | MonadIO version of 'pullOps' for use in monadic contexts. + +Lifts the 'pullOps' function into a 'MonadIO' context, allowing it to be used in monadic computations +with full configuration options. + +Example: + +>>> import Control.Monad.IO.Class +>>> runReaderT (pullOpsM "gemma3" Nothing (Just True) Nothing) someContext +Remaining bytes: 123456789 +... +Completed +Right (PullResp {status = "success", ...}) -} -pull :: - -- | Model Name +pullOpsM :: + MonadIO m => Text -> - IO () -pull modelName = pullOps modelName Nothing Nothing + Maybe Bool -> + Maybe Bool -> + Maybe OllamaConfig -> + m (Either OllamaError PullResp) +pullOpsM t mbInsecure mbStream mbCfg = liftIO $ pullOps t mbInsecure mbStream mbCfg diff --git a/src/Data/Ollama/Push.hs b/src/Data/Ollama/Push.hs --- a/src/Data/Ollama/Push.hs +++ b/src/Data/Ollama/Push.hs @@ -2,84 +2,117 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Data.Ollama.Push +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for pushing models to the Ollama server. + +This module provides functions to push (upload) a model to the Ollama server. It includes +both an IO-based function ('push') and a monadic version ('pushM') for use in 'MonadIO' +contexts. The push operation is performed via a POST request to the "/api//pull" endpoint, +with support for streaming progress updates and insecure connections. + +The 'PushOps' type configures the push request, and 'PushResp' represents the response +containing the status and progress details. Streaming mode, when enabled, provides +real-time progress updates by printing to the console. + +Example: + +>>> push "gemma3" Nothing (Just True) Nothing +Pushing... +Completed +-} module Data.Ollama.Push - ( -- * Push API + ( -- * Push Model API push - , pushOps + , pushM ) where +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Maybe (fromMaybe) +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Types (HasDone (getDone)) 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 pushing a model. data PushOps = PushOps - { name :: Text - , insecure :: Maybe Bool - , stream :: Maybe Bool + { name :: !Text + -- ^ The name of the model to push (e.g., "gemma3"). + , insecure :: !(Maybe Bool) + -- ^ Optional flag to allow insecure connections. + -- If 'Just True', insecure connections are permitted. + , stream :: !(Maybe Bool) + -- ^ Optional flag to enable streaming of the upload. + -- If 'Just True', progress updates are streamed. } deriving (Show, Eq, Generic, ToJSON) +-- | Response data from a push operation. data PushResp = PushResp - { status :: Text - , digest :: Maybe Text - , total :: Maybe Int64 + { status :: !Text + -- ^ The status of the push operation (e.g., "success" or "failure"). + , digest :: !(Maybe Text) + -- ^ The digest (hash) of the model, if available. + , total :: !(Maybe Int64) + -- ^ The total size of the model in bytes, if available. } deriving (Show, Eq, Generic, FromJSON) --- | Push a model with options -pushOps :: +instance HasDone PushResp where + getDone PushResp {..} = status /= "success" + +{- | Pushes a model to the Ollama server with specified options. + +Sends a POST request to the "/api//pull" endpoint to upload the specified model. Supports +streaming progress updates (if 'stream' is 'Just True') and insecure connections (if +'insecure' is 'Just True'). Prints "Pushing..." during streaming and "Completed" when +finished. Returns '()' on completion. +-} +push :: -- | Model name Text -> - -- | Insecure + -- | Optional insecure connection flag Maybe Bool -> - -- | Stream + -- | Optional streaming flag Maybe Bool -> + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> 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 +push modelName mInsecure mStream mbConfig = do + void $ + withOllamaRequest + "/api//push" + "POST" + (Just $ PushOps {name = modelName, insecure = mInsecure, stream = mStream}) + mbConfig + (commonStreamHandler onToken onComplete) + where + onToken :: PushResp -> IO () + onToken _ = putStrLn "Pushing... " --- Higher level API for Pull --- This API is untested. Will test soon! + onComplete :: IO () + onComplete = putStrLn "Completed" --- | Push a model -push :: - -- | Model name - Text -> - IO () -push modelName = pushOps modelName Nothing Nothing +{- | MonadIO version of 'push' for use in monadic contexts. + +Lifts the 'push' function into a 'MonadIO' context, allowing it to be used in monadic +computations. + +Example: + +>>> import Control.Monad.IO.Class +>>> runReaderT (pushM "gemma3" Nothing (Just True) Nothing) someContext +Pushing... +Completed +-} +pushM :: MonadIO m => Text -> Maybe Bool -> Maybe Bool -> Maybe OllamaConfig -> m () +pushM t insec s mbCfg = liftIO $ push t insec s mbCfg diff --git a/src/Data/Ollama/Show.hs b/src/Data/Ollama/Show.hs --- a/src/Data/Ollama/Show.hs +++ b/src/Data/Ollama/Show.hs @@ -3,108 +3,149 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{- | +Module : Data.Ollama.Show +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Description : Functionality for retrieving detailed information about models in the Ollama client. + +This module provides functions to fetch detailed information about a specific model on the Ollama server. +It includes both high-level ('showModel', 'showModelM') and low-level ('showModelOps', 'showModelOpsM') APIs +for retrieving model details, with support for verbose output. The operation is performed via a POST request +to the "/api//show" endpoint, returning a 'ShowModelResponse' containing comprehensive model metadata. + +The 'ShowModelOps' type configures the request, and 'ShowModelResponse' and 'ShowModelInfo' represent the +response structure. The module also re-exports 'CT.ModelDetails' for completeness. + +Note: Verbose mode parsing is currently not fully supported. + +Example: + +>>> showModel "gemma3" +Right (ShowModelResponse {modelFile = "...", ...}) + +@since 1.0.0.0 +-} module Data.Ollama.Show ( -- * Show Model Info API showModel + , showModelM , showModelOps + , showModelOpsM + + -- * Response Types , ShowModelResponse (..) + , ShowModelInfo (..) + , CT.ModelDetails (..) ) where +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson -import Data.Ollama.Common.Utils qualified as CU +import Data.Ollama.Common.Config (OllamaConfig) +import Data.Ollama.Common.Error (OllamaError) +import Data.Ollama.Common.Types qualified as CT +import Data.Ollama.Common.Utils (commonNonStreamingHandler, withOllamaRequest) 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. --} +-- | Configuration options for requesting model information. data ShowModelOps = ShowModelOps - { name :: Text - , verbose :: Maybe Bool + { name :: !Text + -- ^ The name of the model to query (e.g., "gemma3"). + , verbose :: !(Maybe Bool) + -- ^ Optional flag to request verbose output. Note: Verbose mode parsing is currently incomplete. } deriving (Show, Eq, Generic, ToJSON) -{- | - #ShowModelResponse# - - Ouput structure for show model information. --} +-- | Response structure for 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 + { modelFile :: !Text + -- ^ The content of the model's Modelfile. + , parameters :: !(Maybe Text) + -- ^ Optional model parameters (e.g., temperature settings). + , template :: !(Maybe Text) + -- ^ Optional template used for the model. + , details :: !CT.ModelDetails + -- ^ General details about the model (e.g., format, family). + , modelInfo :: !ShowModelInfo + -- ^ Detailed technical information about the model. + , license :: !(Maybe Text) + -- ^ Optional license information for the model. + -- + -- @since 0.2.0.0 + , capabilities :: Maybe [Text] + -- ^ Optional list of model capabilities. + -- + -- @since 0.2.0.0 } 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] +-- | Detailed technical information about a model. +data ShowModelInfo = ShowModelInfo + { generalArchitecture :: !(Maybe Text) + -- ^ The architecture of the model (e.g., "llama"). + , generalFileType :: !(Maybe Int) + -- ^ The file type identifier for the model. + , generalParameterCount :: !(Maybe Int64) + -- ^ The number of parameters in the model. + , generalQuantizationVersion :: !(Maybe Int) + -- ^ The quantization version used by the model. + , llamaAttentionHeadCount :: !(Maybe Int) + -- ^ Number of attention heads in the LLaMA model. + , llamaAttentionHeadCountKV :: !(Maybe Int) + -- ^ Number of key-value attention heads in the LLaMA model. + , llamaAttentionLayerNormRMSEpsilon :: !(Maybe Float) + -- ^ RMS epsilon for layer normalization in the LLaMA model. + , llamaBlockCount :: !(Maybe Int) + -- ^ Number of blocks in the LLaMA model. + , llamaContextLength :: !(Maybe Int) + -- ^ Context length supported by the LLaMA model. + , llamaEmbeddingLength :: !(Maybe Int) + -- ^ Embedding length used by the LLaMA model. + , llamaFeedForwardLength :: !(Maybe Int) + -- ^ Feed-forward layer length in the LLaMA model. + , llamaRopeDimensionCount :: !(Maybe Int) + -- ^ RoPE dimension count in the LLaMA model. + , llamaRopeFreqBase :: !(Maybe Int64) + -- ^ Base frequency for RoPE in the LLaMA model. + , llamaVocabSize :: !(Maybe Int64) + -- ^ Vocabulary size of the LLaMA model. + , tokenizerGgmlBosToken_id :: !(Maybe Int) + -- ^ BOS (beginning of sequence) token ID for the GGML tokenizer. + , tokenizerGgmlEosToken_id :: !(Maybe Int) + -- ^ EOS (end of sequence) token ID for the GGML tokenizer. + , tokenizerGgmlMerges :: !(Maybe [Text]) + -- ^ List of merges for the GGML tokenizer. + , tokenizerGgmlMode :: !(Maybe Text) + -- ^ Mode of the GGML tokenizer. + , tokenizerGgmlPre :: !(Maybe Text) + -- ^ Pre-tokenization configuration for the GGML tokenizer. + , tokenizerGgmlTokenType :: !(Maybe [Text]) + -- ^ Token type information for the GGML tokenizer. + , tokenizerGgmlTokens :: !(Maybe [Text]) + -- ^ List of tokens for the GGML tokenizer. } deriving (Show, Eq) --- FromJSON instances - --- | The instance for show model response +-- | JSON parsing instance for 'ShowModelResponse'. instance FromJSON ShowModelResponse where parseJSON = withObject "ShowModelResponse" $ \v -> ShowModelResponse <$> v .: "modelfile" - <*> v .: "parameters" - <*> v .: "template" + <*> 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" + <*> v .:? "license" + <*> v .:? "capabilities" -instance FromJSON ModelInfo where +-- | JSON parsing instance for 'ShowModelInfo'. +instance FromJSON ShowModelInfo where parseJSON = withObject "ModelInfo" $ \v -> - ModelInfo + ShowModelInfo <$> v .:? "general.architecture" <*> v .:? "general.file_type" <*> v .:? "general.parameter_count" @@ -127,49 +168,63 @@ <*> v .:? "tokenizer.ggml.token_type" <*> v .:? "tokenizer.ggml.tokens" -{- | Show given model's information with options. +{- | Retrieves model information with configuration options. -@since 1.0.0.0 +Sends a POST request to the "/api//show" endpoint to fetch detailed information about +the specified model. Supports verbose output if 'verbose' is 'Just True' (though verbose +mode parsing is currently incomplete). Returns 'Right' with a 'ShowModelResponse' on +success or 'Left' with an 'OllamaError' on failure. -} showModelOps :: - -- | model name + -- | Model name Text -> - -- | verbose + -- | Optional verbose flag 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 + -- | Optional 'OllamaConfig' (defaults to 'defaultOllamaConfig' if 'Nothing') + Maybe OllamaConfig -> + IO (Either OllamaError ShowModelResponse) +showModelOps modelName verbose_ mbConfig = do + withOllamaRequest + "/api//show" + "POST" + ( Just $ + ShowModelOps + { name = modelName + , verbose = verbose_ + } + ) + mbConfig + commonNonStreamingHandler -{- | Show given model's information. +{- | Simplified API for retrieving model information. -Higher level API for show. -@since 1.0.0.0 +A higher-level function that fetches model information using default settings for +verbose output and Ollama configuration. Suitable for basic use cases. -} showModel :: - -- | model name + -- | Model name Text -> - IO (Maybe ShowModelResponse) + IO (Either OllamaError ShowModelResponse) showModel modelName = - showModelOps modelName Nothing + showModelOps modelName Nothing Nothing + +{- | MonadIO version of 'showModel' for use in monadic contexts. + +Lifts the 'showModel' function into a 'MonadIO' context, allowing it to be used in +monadic computations. +-} +showModelM :: MonadIO m => Text -> m (Either OllamaError ShowModelResponse) +showModelM t = liftIO $ showModel t + +{- | MonadIO version of 'showModelOps' for use in monadic contexts. + +Lifts the 'showModelOps' function into a 'MonadIO' context, allowing it to be used in +monadic computations with full configuration options. +-} +showModelOpsM :: + MonadIO m => + Text -> + Maybe Bool -> + Maybe OllamaConfig -> + m (Either OllamaError ShowModelResponse) +showModelOpsM t v mbCfg = liftIO $ showModelOps t v mbCfg diff --git a/src/Ollama.hs b/src/Ollama.hs --- a/src/Ollama.hs +++ b/src/Ollama.hs @@ -1,94 +1,194 @@ {-# LANGUAGE DuplicateRecordFields #-} + {- | - #Ollama-Haskell# - This library lets you run LlMs from within Haskell projects. Inspired by `ollama-python`. +Module : Data.Ollama +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +Portability : portable + +== Ollama Haskell + +This module provides a high-level Haskell interface to the [Ollama](https://ollama.com) API + for interacting with local LLMs. It includes support for: + +- Text generation (sync/streaming) +- Conversational chat (with tools and images) +- Embeddings +- Model management (pull, push, delete, list, show) +- Structured outputs +- Custom configuration and model options + +Inspired by @ollama-python@, this library is built to offer idiomatic Haskell bindings +over Ollama’s HTTP API. + +== πŸ”§ Usage + +Import this module as a top-level interface: + +@ +import Ollama +@ + +All functions return @Either OllamaError a@ or can be used in a Monad stack using +their @\*M@ variants. + +== πŸ”‘ Main APIs + +=== ✍️ Generate Text + +- 'generate', 'generateM' – Generate text from a model +- 'defaultGenerateOps' – Default generation parameters +- 'GenerateOps', 'GenerateResponse' – Request and response types + +=== πŸ’¬ Chat with LLMs + +- 'chat', 'chatM' – Send chat messages to a model +- 'ChatOps', 'ChatResponse', 'Role', 'Message' – Chat input/output types +- Supports tools via 'InputTool', 'FunctionDef', 'OutputFunction', etc. + +=== 🧠 Embeddings + +- 'embedding', 'embeddingM' – Generate vector embeddings +- 'EmbeddingOps', 'EmbeddingResp' – Request/response types + +=== πŸ“¦ Model Management + +- 'copyModel', 'createModel', 'deleteModel' +- 'list' – List all installed models +- 'ps', 'psM' – Show running models +- 'showModel', 'showModelM' – Show model info +- 'pull', 'push' – Pull/push models (with progress support) + +=== βš™οΈ Configuration + +- 'defaultOllamaConfig' – Modify host, retries, streaming, etc. +- 'withOnModelStart', 'withOnModelFinish', 'withOnModelError' – Hook support + +=== 🧰 Utilities + +- 'defaultModelOptions', 'encodeImage', 'withOllamaRequest' +- 'loadGenModel', 'unloadGenModel' – Load/unload generation models +- 'getVersion' – Ollama server version + +== 🧾 Types + +All request/response payloads and enums are exposed, including: + +- 'ModelOptions', 'OllamaConfig', 'OllamaError', 'Format' +- 'Models', 'ModelInfo', 'ModelDetails', 'ShowModelResponse' +- 'RunningModels', 'RunningModel', 'Version' -} module Ollama ( -- * Main APIs -- ** Generate Texts generate - , generateJson + , generateM , defaultGenerateOps , GenerateOps (..) , GenerateResponse (..) -- ** Chat with LLMs , chat - , chatJson + , chatM , Role (..) , defaultChatOps , ChatResponse (..) , ChatOps (..) + , InputTool (..) + , FunctionDef (..) + , FunctionParameters (..) + , ToolCall (..) + , OutputFunction (..) -- ** Embeddings , embedding , embeddingOps + , embeddingM + , embeddingOpsM , EmbeddingOps (..) , EmbeddingResp (..) - -- * Ollama operations - -- ** Copy Models , copyModel + , copyModelM -- ** Create Models , createModel - , createModelOps + , createModelM -- ** Delete Models , deleteModel + , deleteModelM -- ** List Models , list -- ** List currently running models , ps + , psM -- ** Push and Pull , push - , pushOps + , pushM , pull + , pullM , pullOps + , pullOpsM -- ** Show Model Info , showModel , showModelOps + , showModelM + , showModelOpsM + -- * Ollama config + , defaultOllamaConfig + , withOnModelStart + , withOnModelFinish + , withOnModelError + + -- * Utils + , defaultModelOptions + , ModelOptions (..) + , encodeImage + , withOllamaRequest + , getVersion + , loadGenModel + , unloadGenModel + , loadGenModelM + , unloadGenModelM + -- * Types , ShowModelResponse (..) , Models (..) , ModelInfo (..) + , ModelDetails (..) + , ShowModelInfo (..) , RunningModels (..) , RunningModel (..) , Message (..) - , Format(..) + , Format (..) + , OllamaError (..) + , OllamaConfig (..) + , Version (..) ) where 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.Common.Config +import Data.Ollama.Common.Types +import Data.Ollama.Common.Utils +import Data.Ollama.Copy +import Data.Ollama.Create +import Data.Ollama.Delete +import Data.Ollama.Embeddings 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 (..)) +import Data.Ollama.List +import Data.Ollama.Load +import Data.Ollama.Ps +import Data.Ollama.Pull +import Data.Ollama.Push +import Data.Ollama.Show diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,211 +2,29 @@ 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 Data.Text (unpack) +import Ollama (Version (..), getVersion) +import Test.Ollama.Chat qualified as Chat +import Test.Ollama.Embedding qualified as Embeddings +import Test.Ollama.Generate qualified as Generate +import Test.Ollama.Show qualified as Show 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) + [ Generate.tests + , Chat.tests + , Show.tests + , Embeddings.tests ] main :: IO () main = do - mRes <- Ollama.list - case mRes of - Nothing -> pure () -- Ollama is likely not running. Not running tests. - Just _ -> defaultMain tests + eRes <- getVersion + case eRes of + Left err -> putStrLn $ show err + Right (Version r) -> do + putStrLn $ "Ollama client version: " <> unpack r + defaultMain tests diff --git a/test/Test/Ollama/Chat.hs b/test/Test/Ollama/Chat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Chat.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Ollama.Chat (tests) where + +import Control.Monad (void) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Data.List.NonEmpty (fromList) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as HM +import Data.Maybe (isJust) +import Data.Ollama.Chat +import Data.Scientific +import Data.Text qualified as T +import Data.Time (diffUTCTime, getCurrentTime) +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Test.Tasty +import Test.Tasty.HUnit + +-- | Basic chat test with default options +basicChatTest :: TestTree +basicChatTest = testCase "Basic chat should contain 4 for 2+2" $ do + let ops = defaultChatOps + eRes <- chat ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> case message r of + Nothing -> assertFailure "Expected a message in response" + Just msg -> assertBool "Should contain '4'" (T.isInfixOf "4" (content msg)) + +-- | Test timeout configuration +timeoutTest :: TestTree +timeoutTest = testCase "Setting timeout" $ do + let config = Just $ defaultOllamaConfig {timeout = 1} + eRes <- chat defaultChatOps config + case eRes of + Left (TimeoutError _) -> pure () + _ -> assertFailure "Expected timeout error" + +-- | Test model lifecycle hooks on failure +hooksFailTest :: TestTree +hooksFailTest = testCase "Model lifecycle hooks should trigger on failure" $ do + refStart <- newIORef False + refError <- newIORef False + refFinish <- newIORef True + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- Guaranteed to fail + , onModelStart = Just $ writeIORef refStart True + , onModelError = Just $ writeIORef refError True + , onModelFinish = Just $ writeIORef refFinish False + } + void $ chat defaultChatOps (Just config) + wasStarted <- readIORef refStart + wasErrored <- readIORef refError + wasFinished <- readIORef refFinish + assertBool "onModelStart should be called" wasStarted + assertBool "onModelError should be called" wasErrored + assertBool "onModelFinish should be called" wasFinished + +-- | Test model lifecycle hooks on success +hooksSuccessTest :: TestTree +hooksSuccessTest = testCase "Model lifecycle hooks should trigger on success" $ do + refStart <- newIORef False + refError <- newIORef True + refFinish <- newIORef False + let config = + defaultOllamaConfig + { onModelStart = Just $ writeIORef refStart True + , onModelError = Just $ writeIORef refError False + , onModelFinish = Just $ writeIORef refFinish True + } + void $ chat defaultChatOps (Just config) + wasStarted <- readIORef refStart + wasErrored <- readIORef refError + wasFinished <- readIORef refFinish + assertBool "onModelStart should be called" wasStarted + assertBool "onModelError should not be called" wasErrored + assertBool "onModelFinish should be called" wasFinished + +-- | Test retry count +retryCountTest :: TestTree +retryCountTest = testCase "Should retry chat call retryCount times" $ do + counter <- newIORef (0 :: Int) + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- Fails + , retryCount = Just 2 + , retryDelay = Just 1 + , onModelStart = Just $ modifyIORef counter (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + _ <- chat defaultChatOps (Just config) + calls <- readIORef counter + assertEqual "Expected 3 attempts (1 initial + 2 retries)" 3 calls + +-- | Test retry delay +retryDelayTest :: TestTree +retryDelayTest = testCase "Should delay between retries" $ do + counter <- newIORef (0 :: Int) + let delaySecs = 2 + start <- getCurrentTime + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- Fails + , retryCount = Just 1 + , retryDelay = Just delaySecs + , onModelStart = Just $ modifyIORef counter (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + _ <- chat defaultChatOps (Just config) + end <- getCurrentTime + let elapsed = realToFrac (diffUTCTime end start) :: Double + expectedMin = fromIntegral delaySecs + assertBool + ("Elapsed time should be at least " ++ show expectedMin ++ "s, but was " ++ show elapsed) + (elapsed >= expectedMin) + +-- | Test common manager usage +commonManagerTest :: TestTree +commonManagerTest = testCase "Should reuse provided commonManager" $ do + refStart <- newIORef (0 :: Int) + mgr <- + newTlsManagerWith + tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 1000000} + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- Will fail fast + , commonManager = Just mgr + , timeout = 999 -- Shouldn’t matter, manager timeout takes precedence + , onModelStart = Just $ modifyIORef refStart (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + _ <- chat defaultChatOps (Just config) + _ <- chat defaultChatOps (Just config) + startCount <- readIORef refStart + assertEqual "Both requests should start (reuse manager)" 2 startCount + +-- | Test JSON format response +jsonFormatTest :: TestTree +jsonFormatTest = testCase "Should return response in JSON format" $ do + let ops = + defaultChatOps + { messages = + fromList + [userMessage "Return a JSON with keys 'name' and 'age' for John, 25 years old."] + , format = Just JsonFormat + } + eRes <- chat ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> case message r of + Nothing -> assertFailure "Expected a message in response" + Just msg -> do + let responseText = content msg + let decoded = Aeson.decode (BSL.pack $ T.unpack responseText) :: Maybe Aeson.Value + assertBool "Expected valid JSON object in response" (decoded /= Nothing) + +-- | Test streaming response +streamingTest :: TestTree +streamingTest = testCase "Should handle streaming response" $ do + chunksRef <- newIORef [] + let streamHandler chunk = modifyIORef chunksRef (++ [message chunk]) + flushHandler = pure () + ops = defaultChatOps {stream = Just (streamHandler, flushHandler)} + eRes <- chat ops Nothing + chunks <- readIORef chunksRef + let fullOutput = T.concat (map (maybe "" content) chunks) + case eRes of + Left err -> assertFailure $ "Expected streaming success, got error: " ++ show err + Right _ -> assertBool "Expected some streamed content" (not $ T.null fullOutput) + +-- | Test custom model options +modelOptionsTest :: TestTree +modelOptionsTest = testCase "Should use custom model options" $ do + let opts = + Just $ + defaultModelOptions + { temperature = Just 0.9 + , topP = Just 0.8 + , topK = Nothing + , numPredict = Just 20 + } + ops = defaultChatOps {options = opts} + eRes <- chat ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> assertBool "Expected a response message" (isJust (message r)) + +testToolCall_addTwoNumbers :: TestTree +testToolCall_addTwoNumbers = testCase "Tool call: addTwoNumbers(23, 46)" $ do + let messageList = NE.singleton $ userMessage "What is 23 + 46? (Use tool)" + paramProps = + HM.fromList + [ ("a", FunctionParameters "number" Nothing Nothing Nothing) + , ("b", FunctionParameters "number" Nothing Nothing Nothing) + ] + functionParams = + FunctionParameters + { parameterType = "object" + , requiredParams = Just ["a", "b"] + , parameterProperties = Just paramProps + , additionalProperties = Just False + } + functionDef = + FunctionDef + { functionName = "addTwoNumbers" + , functionDescription = Just "Add two numbers" + , functionParameters = Just functionParams + , functionStrict = Nothing + } + tool = + InputTool + { toolType = "function" + , function = functionDef + } + ops = + defaultChatOps + { chatModelName = "qwen3:0.6b" + , messages = messageList + , tools = Just [tool] + } + + res <- chat ops Nothing + case res of + Left err -> assertFailure $ "Chat failed: " ++ show err + Right ChatResponse {message = Nothing} -> assertFailure "No message in response" + Right ChatResponse {message = Just msg} -> + case tool_calls msg of + Nothing -> assertFailure "No tool calls received" + Just [toolCall] -> do + result <- captureAddToolCall toolCall + assertEqual "Expected result of 23 + 46" 69 result + Just other -> assertFailure $ "Unexpected number of tool calls: " ++ show other + +-- Helper to evaluate the tool call +captureAddToolCall :: ToolCall -> IO Int +captureAddToolCall (ToolCall func) + | outputFunctionName func == "addTwoNumbers" = + case ( HM.lookup "a" (arguments func) >>= convertToNumber + , HM.lookup "b" (arguments func) >>= convertToNumber + ) of + (Just a, Just b) -> return $ addTwoNumbers a b + _ -> assertFailure "Missing parameters a or b" >> return 0 + | otherwise = assertFailure "Unexpected function name" >> return 0 + +addTwoNumbers :: Int -> Int -> Int +addTwoNumbers = (+) + +-- Convert Aeson value to Int +convertToNumber :: Aeson.Value -> Maybe Int +convertToNumber (Aeson.Number n) = toBoundedInteger n +convertToNumber _ = Nothing + +-- | Group all tests +tests :: TestTree +tests = + sequentialTestGroup + "Chat tests" + AllFinish + [ basicChatTest + , timeoutTest + , hooksFailTest + , hooksSuccessTest + , retryCountTest + , retryDelayTest + , commonManagerTest + , jsonFormatTest + , streamingTest + , modelOptionsTest + , testToolCall_addTwoNumbers + ] diff --git a/test/Test/Ollama/Embedding.hs b/test/Test/Ollama/Embedding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Embedding.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Ollama.Embedding (tests) where + +import Data.Maybe (listToMaybe) +import Data.Ollama.Embeddings +import Test.Tasty +import Test.Tasty.HUnit + +testEmbeddingBasic :: TestTree +testEmbeddingBasic = testCase "Basic embedding with qwen3" $ do + res <- embedding "qwen3:0.6b" ["The sky is blue.", "Cats are independent."] + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right EmbeddingResp {..} -> do + assertEqual "Should return two embeddings" 2 (length respondedEmbeddings) + assertBool "Embeddings should not be empty" (all (not . null) respondedEmbeddings) + +testEmbeddingWithOptions :: TestTree +testEmbeddingWithOptions = testCase "Embedding with truncate and keepAlive" $ do + let opts = defaultModelOptions {numKeep = Just 5, seed = Just 42} + res <- embeddingOps "qwen3:0.6b" ["Hello world"] (Just True) (Just 30) (Just opts) Nothing + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right EmbeddingResp {..} -> do + assertEqual "Should return one embedding" 1 (length respondedEmbeddings) + assertBool + "Embedding vector should not be empty" + (not . null $ listToMaybe respondedEmbeddings) + +testEmbeddingInvalidModel :: TestTree +testEmbeddingInvalidModel = testCase "Embedding with invalid model name" $ do + res <- embedding "nonexistent-model" ["This should fail."] + case res of + Left _ -> return () -- Expected failure + Right _ -> assertFailure "Expected failure with invalid model name" + +tests :: TestTree +tests = + testGroup + "Embeddings tests" + [ testEmbeddingBasic + , testEmbeddingWithOptions + , testEmbeddingInvalidModel + ] diff --git a/test/Test/Ollama/Generate.hs b/test/Test/Ollama/Generate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Generate.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- + Tests related to Generate module +-} +module Test.Ollama.Generate (tests) where + +import Control.Monad (void) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Data.Ollama.Common.SchemaBuilder +import Data.Ollama.Common.Utils (encodeImage) +import Data.Ollama.Generate +import Data.Text qualified as T +import Data.Time (diffUTCTime, getCurrentTime) +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Test.Tasty +import Test.Tasty.HUnit + +generateTests :: TestTree +generateTests = + testGroup + "Generation with various options" + [ testCase "Should contain 4 in 2+2" $ do + eRes <- + generate + defaultGenerateOps {modelName = "gemma3", prompt = "What is 2+2?"} + Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> assertBool "Should contain 4" (T.isInfixOf "4" (genResponse r)) + , testCase "Setting timeout" $ do + eRes <- + generate + defaultGenerateOps {modelName = "gemma3", prompt = "Write a poem about French revolution"} + (Just $ defaultOllamaConfig {timeout = 1}) + case eRes of + Left (TimeoutError _) -> pure () + _ -> assertFailure "Expected timeout error" + ] + +testOnModelHooksFail :: TestTree +testOnModelHooksFail = testCase "Model lifecycle hooks should be triggered" $ do + refStart <- newIORef False + refError <- newIORef False + refFinish <- newIORef True + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- guaranteed to fail + , onModelStart = Just $ writeIORef refStart True + , onModelError = Just $ writeIORef refError True + , onModelFinish = Just $ writeIORef refFinish True + } + + void $ + generate + defaultGenerateOps {modelName = "gemma3", prompt = "what is 23+41?"} + (Just config) + + wasStarted <- readIORef refStart + wasErrored <- readIORef refError + wasFinished <- readIORef refFinish + + assertBool "onModelStart should be called" wasStarted + assertBool "onModelError should be called" wasErrored + assertBool "onModelFinish should be called" wasFinished + +testOnModelHooksSucc :: TestTree +testOnModelHooksSucc = testCase "Model lifecycle hooks should be triggered 2" $ do + refStart <- newIORef False + refError <- newIORef True + refFinish <- newIORef False + let config = + defaultOllamaConfig + { onModelStart = Just $ writeIORef refStart True + , onModelError = Just $ writeIORef refError False + , onModelFinish = Just $ writeIORef refFinish True + } + + void $ + generate + defaultGenerateOps {modelName = "gemma3", prompt = "what is 23+41?"} + (Just config) + + wasStarted <- readIORef refStart + wasErrored <- readIORef refError + wasFinished <- readIORef refFinish + + assertBool "onModelStart should be called" wasStarted + assertBool "onModelError should be called" wasErrored + assertBool "onModelFinish should be called" wasFinished + +testRetryCount :: TestTree +testRetryCount = testCase "Should retry generate call retryCount times" $ do + counter <- newIORef (0 :: Int) + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- fails + , retryCount = Just 2 + , retryDelay = Just 1 + , onModelStart = Just $ modifyIORef counter (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + + _ <- generate defaultGenerateOps {prompt = "Retry test"} (Just config) + calls <- readIORef counter + -- Should be retryCount + 1 (initial + retries) + assertEqual "Expected 3 attempts (1 initial + 2 retries)" 3 calls + +testRetryDelay :: TestTree +testRetryDelay = testCase "Should delay between retries" $ do + counter <- newIORef (0 :: Int) + let delaySecs = 2 + start <- getCurrentTime + + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- fails + , retryCount = Just 1 + , retryDelay = Just delaySecs + , onModelStart = Just $ modifyIORef counter (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + + _ <- generate defaultGenerateOps {prompt = "Retry delay test"} (Just config) + end <- getCurrentTime + let elapsed = realToFrac (diffUTCTime end start) :: Double + let expectedMin = fromIntegral delaySecs + + assertBool + ("Elapsed time should be at least " ++ show expectedMin ++ "s, but was " ++ show elapsed) + (elapsed >= expectedMin) + +testCommonManagerUsage :: TestTree +testCommonManagerUsage = testCase "Should reuse provided commonManager" $ do + refStart <- newIORef (0 :: Int) + mgr <- + newTlsManagerWith tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 1000000} + let config = + defaultOllamaConfig + { hostUrl = "http://localhost:12345" -- will fail fast + , commonManager = Just mgr + , timeout = 999 -- shouldn't matter, manager timeout will be used + , onModelStart = Just $ modifyIORef refStart (+ 1) + , onModelError = Just $ pure () + , onModelFinish = Just $ pure () + } + + _ <- generate defaultGenerateOps {prompt = "1"} (Just config) + _ <- generate defaultGenerateOps {prompt = "2"} (Just config) + startCount <- readIORef refStart + assertEqual "Both requests should start (reuse manager)" 2 startCount + +{- + Suffix is not supported for few gemma3 and qwen3. + +testSuffixOption :: TestTree +testSuffixOption = testCase "Should respect suffix in generation" $ do + let ops = defaultGenerateOps + { modelName = "qwen3:0.6b" + , prompt = "Complete this sentence: The Eiffel Tower is in" + , suffix = Just " [End]" + } + eRes <- generate ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> assertBool "Expected suffix in response" $ + T.isSuffixOf "[End]" (genResponse r) + -} + +testThinkOption :: TestTree +testThinkOption = testCase "Should activate thinking mode when think=True" $ do + let ops = + defaultGenerateOps + { modelName = "qwen3:0.6b" + , prompt = "What is 2+2?" + , think = Just True + } + eRes <- generate ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right _ -> pure () -- TODO: Need to find a way to know if model is thinking + +testFormatJsonFormat :: TestTree +testFormatJsonFormat = testCase "Should return response in JsonFormat" $ do + let ops = + defaultGenerateOps + { modelName = "gemma3" + , prompt = + "John was 23 year old in 2023, this is year 2025." + <> "How old is John assuming he celebrated this year's birthday; " + <> "Return an object with keys 'name' and 'age'." + , format = Just JsonFormat + } + eRes <- generate ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> do + let responseText = genResponse r + let decoded = Aeson.decode (BSL.pack $ T.unpack responseText) :: Maybe Aeson.Value + assertBool "Expected valid JSON object in response" (decoded /= Nothing) + +testFormatSchemaFormat :: TestTree +testFormatSchemaFormat = testCase "Should include SchemaFormat in the request" $ do + let schema = + buildSchema $ + emptyObject + |+ ("fruit", JString) + |+ ("quantity", JNumber) + |! "fruit" + |! "quantity" + + ops = + defaultGenerateOps + { modelName = "gemma3" + , prompt = "I had 3 apples, 1 gave one away. How many left?" + , format = Just (SchemaFormat schema) + } + + eRes <- generate ops Nothing + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> do + let response = T.toLower (genResponse r) + assertBool "Expected fruit information in response" $ + "apple" `T.isInfixOf` response || "fruit" `T.isInfixOf` response + +testImageInput :: TestTree +testImageInput = testCase "Should accept and process base64 image input" $ do + maybeImg <- encodeImage "./examples/sample.png" + case maybeImg of + Nothing -> assertFailure "Image encoding failed (unsupported format or missing file)" + Just imgData -> do + let ops = + defaultGenerateOps + { modelName = "gemma3" + , prompt = "Describe this image." + , images = Just [imgData] + } + cfg = Just defaultOllamaConfig {timeout = 300} + + eRes <- generate ops cfg + case eRes of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right r -> do + let response = T.toLower (genResponse r) + assertBool "Expected image-related description in response" $ + T.isInfixOf "i love haskell" response + +testStreamingHandler :: TestTree +testStreamingHandler = testCase "Should handle streaming response" $ do + -- IORef to collect streamed chunks + chunksRef <- newIORef [] + -- Define the stream handler: accumulate responses + let streamHandler chunk = modifyIORef chunksRef (++ [genResponse chunk]) + flushHandler = pure () + ops = + defaultGenerateOps + { modelName = "gemma3" + , prompt = "Write few words about Haskell." + , stream = Just (streamHandler, flushHandler) + } + eRes <- generate ops Nothing + -- Collect streamed chunks from IORef + chunks <- readIORef chunksRef + let fullOutput = T.concat chunks + case eRes of + Left err -> assertFailure $ "Expected streaming success, got error: " ++ show err + Right _ -> do + assertBool "Expected streamed text to include 'haskell'" $ + "haskell" `T.isInfixOf` T.toLower fullOutput + assertBool "Expected some streamed content" $ not (T.null fullOutput) + +testModelOptionsBasic :: TestTree +testModelOptionsBasic = testCase "ModelOptions: temperature and topP" $ do + let opts = + Just $ + defaultModelOptions + { temperature = Just 0.9 + , topP = Just 0.8 + , topK = Nothing + , numPredict = Just 20 + } + + eRes <- + generate + defaultGenerateOps + { modelName = "gemma3" + , prompt = "Generate a random list of 3 animals" + , options = opts + } + Nothing + + case eRes of + Left err -> assertFailure $ "Expected success, got: " ++ show err + Right r -> assertBool "Response should not be empty" (not . T.null $ genResponse r) + +tests :: TestTree +tests = + sequentialTestGroup + "Generate tests" + AllFinish + [ generateTests + , testOnModelHooksFail + , testOnModelHooksSucc + , testRetryCount + , testRetryDelay + , testCommonManagerUsage + , testThinkOption + , testFormatJsonFormat + , testFormatSchemaFormat + , testImageInput + , testStreamingHandler + , testModelOptionsBasic + ] diff --git a/test/Test/Ollama/Show.hs b/test/Test/Ollama/Show.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Show.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Ollama.Show (tests) where + +import Test.Tasty +import Test.Tasty.HUnit +import Data.Ollama.Show +import Data.Ollama.Ps +import Data.Text qualified as T +import Data.Maybe (isJust) + +testShowModelBasic :: TestTree +testShowModelBasic = testCase "Show model info: basic call" $ do + res <- showModel "gemma3" + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right ShowModelResponse {modelFile, modelInfo = ShowModelInfo {generalArchitecture}} -> do + assertBool "modelFile should not be empty" (not $ T.null modelFile) + assertBool "Architecture should be present" (isJust generalArchitecture) + +testShowModelVerbose :: TestTree +testShowModelVerbose = testCase "Show model info: verbose enabled" $ do + res <- showModelOps "qwen3:0.6b" (Just True) Nothing + case res of + Left _ -> pure () --assertFailure $ "Expected success, got error: " ++ show err + Right ShowModelResponse {template, parameters} -> do + -- Verbose should yield more details like parameters/template + assertBool "Should have a template if verbose" (isJust template) + assertBool "Should have parameters if verbose" (isJust parameters) + +testPsBasic :: TestTree +testPsBasic = testCase "List running models: basic success" $ do + res <- ps Nothing + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right (RunningModels _) -> do + assertBool "Should return a list (possibly empty)" True + +testPsModelFields :: TestTree +testPsModelFields = testCase "Running model fields are populated" $ do + res <- ps Nothing + case res of + Left _ -> return () -- Allow failure if no models are running + Right (RunningModels (m:_)) -> do + assertBool "name_ should not be empty" (not $ T.null $ name_ m) + assertBool "modelName should not be empty" (not $ T.null $ modelName m) + assertBool "modelDigest should not be empty" (not $ T.null $ modelDigest m) + assertBool "size_ should be positive" (size_ m > 0) + assertBool "sizeVRam should be non-negative" (sizeVRam m >= 0) + Right _ -> return () -- If empty, that's acceptable + +tests :: TestTree +tests = testGroup "show model tests" [ + testShowModelBasic + , testShowModelVerbose + , testPsBasic + , testPsModelFields + ]