diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog for langchain-hs-gemini + +## 0.0.6.0 - 2026-10-02 + +- Initial release. Split from the monolithic `langchain-hs` package. +- Provides `Langchain.Provider.Gemini`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Tushar Adhatrao + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,102 @@ +# langchain-hs-gemini + +Google Gemini Interactions v1 API client and LangChain provider for [langchain-hs](https://hackage.haskell.org/package/langchain-hs). + +Built using type-safe **Servant bindings** over the official Google GenAI OpenAPI specification ([Interactions v1 API](https://ai.google.dev/api/interactions-api-v1)), following the design patterns of [`MercuryTechnologies/openai`](https://github.com/MercuryTechnologies/openai). + +## Features + +- **Type-Safe Servant Bindings (`Gemini.Client`)**: + - `createInteraction` (`POST /v1/interactions`) + - `getInteraction` (`GET /v1/interactions/{id}`) + - `cancelInteraction` (`POST /v1/interactions/{id}/cancel`) + - `deleteInteraction` (`DELETE /v1/interactions/{id}`) + - `embedContent` (`POST /v1/models/{model}:embedContent`) + - `batchEmbedContents` (`POST /v1/models/{model}:batchEmbedContents`) + - SSE Streaming (`streamGeminiInteraction`) +- **LangChain ChatModel Provider (`Langchain.Provider.Gemini`)**: + - Full `ChatModel` instance supporting synchronous `invoke` and streaming `stream`. + - Multi-turn conversation mapping and system instructions. + - Multi-modal content support (Base64 images, audio, documents). + - Function calling & tool binding via `ToolBinder`. + - Built-in tools: Code Execution, Google Search, Google Maps, File Search, URL Context. +- **LangChain Embeddings (`Langchain.Embeddings.Gemini`)**: + - Effect-polymorphic `Embeddings` instance (`embedQuery` and `embedDocuments`). + +## Installation + +```yaml +# package.yaml / .cabal +dependencies: + - langchain-hs-gemini + - langchain-hs-core +``` + +## Quick Start + +### 1. ChatModel Provider + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.Except (runExceptT) +import Langchain.Model +import Langchain.Provider.Gemini + +main :: IO () +main = do + let provider = newGemini "AIzaSy..." "gemini-3.6-flash" Nothing + res <- runExceptT $ invoke provider [userMessage "Why is the sky blue?"] Nothing + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right msg -> putStrLn $ extractMessageText msg +``` + +### 2. Streaming with Conduit + +```haskell +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Except (runExceptT) +import Langchain.Model +import Langchain.Provider.Gemini +import Langchain.Stream (collectEvents) + +main :: IO () +main = do + let provider = newGemini "AIzaSy..." "gemini-3.6-flash" Nothing + eEvents <- runResourceT $ runExceptT $ collectEvents $ stream provider [userMessage "Tell me a short story"] Nothing + case eEvents of + Left err -> print err + Right events -> mapM_ print events +``` + +### 3. Embeddings + +```haskell +import Control.Monad.Except (runExceptT) +import Langchain.Embeddings.Core (Embeddings (..)) +import Langchain.Embeddings.Gemini (defaultGeminiEmbeddings) + +main :: IO () +main = do + let embeddings = defaultGeminiEmbeddings "AIzaSy..." + res <- runExceptT $ embedQuery embeddings "Functional programming in Haskell" + case res of + Left err -> print err + Right vec -> putStrLn $ "Generated vector with dimension: " ++ show (length vec) +``` + +### 4. Direct Servant Client + +```haskell +import Gemini.Client + +main :: IO () +main = do + env <- newGeminiClientEnv "AIzaSy..." + let req = createModelInteraction "gemini-3.6-flash" (TextInput "Explain quantum computing in one sentence") + res <- runGeminiClient env (createInteraction "AIzaSy..." req) + case res of + Left clientErr -> print clientErr + Right interaction -> print (interactionSteps interaction) +``` diff --git a/langchain-hs-gemini.cabal b/langchain-hs-gemini.cabal new file mode 100644 --- /dev/null +++ b/langchain-hs-gemini.cabal @@ -0,0 +1,99 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.6. +-- +-- see: https://github.com/sol/hpack + +name: langchain-hs-gemini +version: 0.0.6.0 +synopsis: Google Gemini provider for langchain-hs +description: Google Gemini ChatModel provider for langchain-hs. Supports multi-modal content, streaming via Server-Sent Events, and function calling. Does not depend on OpenAI or Ollama packages. +category: AI +homepage: https://github.com/tusharad/langchain-hs#readme +bug-reports: https://github.com/tusharad/langchain-hs/issues +author: Tushar Adhatrao +maintainer: tusharadhatrao@gmail.com +copyright: 2025-2026 Tushar Adhatrao +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.12.4 + , GHC == 9.10.3 + , GHC == 9.8.4 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tusharad/langchain-hs + +library + exposed-modules: + Gemini.Client + Gemini.Client.API + Gemini.Client.Env + Gemini.Client.Types + Langchain.Provider.Gemini + Langchain.Embeddings.Gemini + other-modules: + Paths_langchain_hs_gemini + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson >=2.0 && <3 + , base >=4.17 && <5 + , bytestring >=0.10 && <0.13 + , conduit ==1.3.* + , containers >=0.6 && <0.9 + , http-client ==0.7.* + , http-client-tls >=0.3 && <0.5 + , http-conduit ==2.* + , langchain-hs-core ==0.0.6.* + , mtl >=2.2 && <2.4 + , resourcet >=1.2 && <1.4 + , servant >=0.19 && <0.21 + , servant-client >=0.19 && <0.21 + , servant-client-core >=0.19 && <0.21 + , text >=1.2 && <3 + default-language: Haskell2010 + +test-suite langchain-hs-gemini-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Gemini.Client.InteractionsSpec + Test.Gemini.Client.TypesSpec + Test.Langchain.Provider.GeminiSpec + Paths_langchain_hs_gemini + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-qq + , base >=4.17 && <5 + , bytestring + , conduit ==1.3.* + , containers + , directory + , filepath + , http-client ==0.7.* + , http-client-tls >=0.3 && <0.5 + , http-conduit ==2.* + , http-types + , langchain-hs-core + , langchain-hs-gemini + , mtl >=2.2 && <2.4 + , resourcet + , servant >=0.19 && <0.21 + , servant-client >=0.19 && <0.21 + , servant-client-core >=0.19 && <0.21 + , tasty + , tasty-hunit + , text + , wai + , warp + default-language: Haskell2010 diff --git a/src/Gemini/Client.hs b/src/Gemini/Client.hs new file mode 100644 --- /dev/null +++ b/src/Gemini/Client.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +{- | +Module : Gemini.Client +Description : Servant client bindings for Google Gemini Interactions v1 API & Embeddings +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Type-safe HTTP client functions generated directly from the Servant API specification +for the Google Gemini Interactions v1 API (). +-} +module Gemini.Client + ( -- * Client Operations + createInteraction + , getInteraction + , cancelInteraction + , deleteInteraction + , embedContent + , batchEmbedContents + + -- * Client Environment + , module Gemini.Client.Env + + -- * Data Models + , module Gemini.Client.Types + ) where + +import Data.Aeson (Value) +import Data.Text (Text) +import Servant.API ((:<|>) (..)) +import Servant.Client (ClientM, client) + +import Gemini.Client.API (geminiApi) +import Gemini.Client.Env +import Gemini.Client.Types + +-- Internal servant client functions derived from the API type +createInteractionInternal + :<|> getInteractionInternal + :<|> cancelInteractionInternal + :<|> deleteInteractionInternal + :<|> embedContentInternal + :<|> batchEmbedContentsInternal = + client geminiApi + +-- | Create a new interaction (model-based or agent-based). +createInteraction :: + -- | Google Gemini API key + Text -> + -- | Interaction request payload + CreateInteractionRequest -> + ClientM Interaction +createInteraction apiKey = createInteractionInternal (Just apiKey) + +-- | Retrieve full details of an interaction by ID. +getInteraction :: + -- | Google Gemini API key + Text -> + -- | Interaction ID + Text -> + -- | Optional stream parameter + Maybe Bool -> + -- | Optional last event ID + Maybe Text -> + ClientM Interaction +getInteraction apiKey interId = + getInteractionInternal interId (Just apiKey) + +-- | Cancel a background interaction by ID. +cancelInteraction :: + -- | Google Gemini API key + Text -> + -- | Interaction ID + Text -> + ClientM Interaction +cancelInteraction apiKey interId = + cancelInteractionInternal interId (Just apiKey) + +-- | Delete an interaction by ID. +deleteInteraction :: + -- | Google Gemini API key + Text -> + -- | Interaction ID + Text -> + ClientM Value +deleteInteraction apiKey interId = + deleteInteractionInternal interId (Just apiKey) + +-- | Generate embeddings for single content via @POST \/v1\/models\/{model}:embedContent@. +embedContent :: + -- | Google Gemini API key + Text -> + -- | Model name (e.g. @"gemini-embedding-001"@) + Text -> + -- | Content payload + EmbedContentRequest -> + ClientM EmbedContentResponse +embedContent apiKey modelName req = + let modelAction = modelName <> ":embedContent" + in embedContentInternal modelAction (Just apiKey) req + +-- | Generate batch embeddings via @POST \/v1\/models\/{model}:batchEmbedContents@. +batchEmbedContents :: + -- | Google Gemini API key + Text -> + -- | Model name (e.g. @"gemini-embedding-001"@) + Text -> + -- | Batch request payload + BatchEmbedContentsRequest -> + ClientM BatchEmbedContentsResponse +batchEmbedContents apiKey modelName req = + let modelAction = modelName <> ":batchEmbedContents" + in batchEmbedContentsInternal modelAction (Just apiKey) req diff --git a/src/Gemini/Client/API.hs b/src/Gemini/Client/API.hs new file mode 100644 --- /dev/null +++ b/src/Gemini/Client/API.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Gemini.Client.API +Description : Servant API definition for Google Gemini Interactions v1 & Embeddings +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Servant type definitions describing the Gemini Interactions v1 API endpoints +and embedding operations according to the Google GenAI OpenAPI specification. +-} +module Gemini.Client.API + ( GeminiAPI + , geminiApi + ) where + +import Data.Aeson (Value) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Servant.API + +import Gemini.Client.Types + +-- | Complete Servant API specification for Gemini Interactions v1 & Embeddings. +type GeminiAPI = + -- POST /v1/interactions + "v1" + :> "interactions" + :> Header "x-goog-api-key" Text + :> ReqBody '[JSON] CreateInteractionRequest + :> Post '[JSON] Interaction + :<|> + -- GET /v1/interactions/:id + "v1" + :> "interactions" + :> Capture "id" Text + :> Header "x-goog-api-key" Text + :> QueryParam "stream" Bool + :> QueryParam "last_event_id" Text + :> Get '[JSON] Interaction + :<|> + -- POST /v1/interactions/:id/cancel + "v1" + :> "interactions" + :> Capture "id" Text + :> "cancel" + :> Header "x-goog-api-key" Text + :> Post '[JSON] Interaction + :<|> + -- DELETE /v1/interactions/:id + "v1" + :> "interactions" + :> Capture "id" Text + :> Header "x-goog-api-key" Text + :> Delete '[JSON] Value + :<|> + -- POST /v1/models/:modelAction (e.g. "gemini-embedding-001:embedContent") + "v1" + :> "models" + :> Capture "modelAction" Text + :> Header "x-goog-api-key" Text + :> ReqBody '[JSON] EmbedContentRequest + :> Post '[JSON] EmbedContentResponse + :<|> + -- POST /v1/models/:modelAction (e.g. "gemini-embedding-001:batchEmbedContents") + "v1" + :> "models" + :> Capture "modelAction" Text + :> Header "x-goog-api-key" Text + :> ReqBody '[JSON] BatchEmbedContentsRequest + :> Post '[JSON] BatchEmbedContentsResponse + +-- | Proxy for 'GeminiAPI'. +geminiApi :: Proxy GeminiAPI +geminiApi = Proxy diff --git a/src/Gemini/Client/Env.hs b/src/Gemini/Client/Env.hs new file mode 100644 --- /dev/null +++ b/src/Gemini/Client/Env.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Gemini.Client.Env +Description : Client environment, execution runner, and SSE streaming conduit +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Environment configuration and request runners for the Google Gemini client, +including HTTP connection management, API key authentication, and SSE event streaming. +-} +module Gemini.Client.Env + ( GeminiClientEnv (..) + , newGeminiClientEnv + , newGeminiClientEnvWithBaseUrl + , runGeminiClient + , streamGeminiInteraction + ) where + +import Control.Monad (unless) +import Control.Monad.Trans.Resource (MonadResource) +import Data.Aeson (decodeStrict, encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Conduit (ConduitT, await, yield, (.|)) +import qualified Data.Conduit.Combinators as CC +import Data.Foldable (for_) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.HTTP.Client + ( Manager + , ManagerSettings + , managerResponseTimeout + , newManager + , responseTimeoutMicro + ) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Simple +import Servant.Client (ClientError, ClientM, mkClientEnv, runClientM) +import Servant.Client.Core.BaseUrl (BaseUrl (..), Scheme (..), parseBaseUrl) + +import Gemini.Client.Types + +-- | Environment holding HTTP connection manager, base URL, and API key. +data GeminiClientEnv = GeminiClientEnv + { clientManager :: !Manager + , clientBaseUrl :: !BaseUrl + , clientApiKey :: !Text + } + +-- | Default Gemini endpoint @https://generativelanguage.googleapis.com@. +defaultBaseUrl :: BaseUrl +defaultBaseUrl = BaseUrl Https "generativelanguage.googleapis.com" 443 "" + +geminiManagerSettings :: Network.HTTP.Client.ManagerSettings +geminiManagerSettings = + tlsManagerSettings + { managerResponseTimeout = responseTimeoutMicro (120 * 1000000) + } + +-- | Initialize a new t'GeminiClientEnv' targeting the default Gemini endpoint. +newGeminiClientEnv :: Text -> IO GeminiClientEnv +newGeminiClientEnv apiKey = do + mgr <- newManager geminiManagerSettings + pure $ GeminiClientEnv mgr defaultBaseUrl apiKey + +-- | Initialize a new t'GeminiClientEnv' targeting a custom base URL. +newGeminiClientEnvWithBaseUrl :: Text -> Text -> IO GeminiClientEnv +newGeminiClientEnvWithBaseUrl rawUrl apiKey = do + mgr <- newManager geminiManagerSettings + bUrl <- parseBaseUrl (T.unpack rawUrl) + pure $ GeminiClientEnv mgr bUrl apiKey + +-- | Execute a Servant 'ClientM' request in 'IO'. +runGeminiClient :: GeminiClientEnv -> ClientM a -> IO (Either ClientError a) +runGeminiClient GeminiClientEnv {..} action = do + let env = mkClientEnv clientManager clientBaseUrl + runClientM action env + +-- | Stream events from @POST /v1/interactions@ with SSE. +streamGeminiInteraction :: + (MonadResource m) => + GeminiClientEnv -> + CreateInteractionRequest -> + ConduitT () InteractionSseEvent m () +streamGeminiInteraction GeminiClientEnv {..} reqBody = do + let schemeStr = case baseUrlScheme clientBaseUrl of + Https -> "https" + Http -> "http" + portStr = case (baseUrlScheme clientBaseUrl, baseUrlPort clientBaseUrl) of + (Https, 443) -> "" + (Http, 80) -> "" + (_, p) -> ":" ++ show p + url = schemeStr ++ "://" ++ baseUrlHost clientBaseUrl ++ portStr ++ "/v1/interactions" + streamReq = reqBody {reqStream = Just True} + httpReq = + setRequestMethod "POST" $ + setRequestHeader "x-goog-api-key" [TE.encodeUtf8 clientApiKey] $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestHeader "Accept" ["text/event-stream"] $ + setRequestBodyLBS (encode streamReq) $ + parseRequest_ url + + httpSource httpReq $ \res -> + getResponseBody res .| CC.linesUnboundedAscii .| parseSseLines + where + parseSseLines = loop Nothing [] + where + loop mbEvent accData = + await >>= \case + Nothing -> pure () + Just rawLine -> do + let line = BSC.dropWhile (== ' ') rawLine + if BS.null line + then do + -- End of SSE block, dispatch + unless (null accData) $ do + let combined = BS.intercalate "\n" (reverse accData) + for_ (decodeStrict combined) yield + loop Nothing [] + else + if "event:" `BS.isPrefixOf` line + then do + let evName = TE.decodeUtf8 (BS.drop 6 line) + loop (Just (T.strip evName)) accData + else + if "data:" `BS.isPrefixOf` line + then do + let chunk = BS.drop 5 line + trimmed = BSC.dropWhile (== ' ') chunk + loop mbEvent (trimmed : accData) + else loop mbEvent accData diff --git a/src/Gemini/Client/Types.hs b/src/Gemini/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Gemini/Client/Types.hs @@ -0,0 +1,931 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +{- | +Module : Gemini.Client.Types +Description : Typed data models for Google Gemini Interactions v1 API and Embeddings +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Fully-typed OpenAPI data models corresponding to the Google Gemini Interactions v1 API +() and Embeddings endpoints. +-} +module Gemini.Client.Types + ( -- * Interactions + Interaction (..) + , InteractionStatus (..) + , CreateInteractionRequest (..) + , defaultCreateInteractionRequest + , createModelInteraction + , createAgentInteraction + + -- * Inputs and Contents + , InteractionsInput (..) + , Content (..) + + -- * Steps + , Step (..) + , GoogleSearchResultItem (..) + + -- * Tools + , Tool (..) + , functionTool + + -- * Generation and Output + , GenerationConfig (..) + , defaultGenerationConfig + , ResponseFormat (..) + , jsonResponseFormat + , Usage (..) + , ErrorDetail (..) + + -- * Streaming Events + , InteractionSseEvent (..) + , StepDeltaData (..) + + -- * Embeddings + , EmbedContentRequest (..) + , EmbedContentPayload (..) + , EmbedPart (..) + , EmbedContentResponse (..) + , EmbeddingValues (..) + , BatchEmbedContentsRequest (..) + , BatchEmbedRequestItem (..) + , BatchEmbedContentsResponse (..) + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +-- --------------------------------------------------------------------------- +-- Interaction & Status +-- --------------------------------------------------------------------------- + +-- | Lifecycle status of an Interaction. +data InteractionStatus + = StatusInProgress + | StatusRequiresAction + | StatusCompleted + | StatusFailed + | StatusCancelled + | StatusIncomplete + deriving (Eq, Show, Generic) + +instance ToJSON InteractionStatus where + toJSON = \case + StatusInProgress -> "in_progress" + StatusRequiresAction -> "requires_action" + StatusCompleted -> "completed" + StatusFailed -> "failed" + StatusCancelled -> "cancelled" + StatusIncomplete -> "incomplete" + +instance FromJSON InteractionStatus where + parseJSON = withText "InteractionStatus" $ \case + "in_progress" -> pure StatusInProgress + "requires_action" -> pure StatusRequiresAction + "completed" -> pure StatusCompleted + "failed" -> pure StatusFailed + "cancelled" -> pure StatusCancelled + "incomplete" -> pure StatusIncomplete + other -> fail $ "Unknown InteractionStatus: " ++ T.unpack other + +-- | An Interaction resource generated by Gemini. +data Interaction = Interaction + { interactionId :: !Text + , interactionObject :: !(Maybe Text) + , interactionModel :: !(Maybe Text) + , interactionAgent :: !(Maybe Text) + , interactionStatus :: !InteractionStatus + , interactionSteps :: ![Step] + , interactionUsage :: !(Maybe Usage) + , interactionCreated :: !(Maybe Text) + , interactionUpdated :: !(Maybe Text) + , interactionBackground :: !(Maybe Bool) + , interactionStore :: !(Maybe Bool) + , interactionStream :: !(Maybe Bool) + , interactionSystemInstruction :: !(Maybe Text) + , interactionTools :: !(Maybe [Tool]) + , interactionGenerationConfig :: !(Maybe GenerationConfig) + , interactionResponseFormat :: !(Maybe ResponseFormat) + , interactionPreviousInteractionId :: !(Maybe Text) + , interactionErrors :: !(Maybe [ErrorDetail]) + } + deriving (Eq, Show, Generic) + +instance FromJSON Interaction where + parseJSON = withObject "Interaction" $ \o -> do + interactionId <- o .:? "id" .!= "" + interactionObject <- o .:? "object" + interactionModel <- o .:? "model" + interactionAgent <- o .:? "agent" + interactionStatus <- o .:? "status" .!= StatusCompleted + interactionSteps <- o .:? "steps" .!= [] + interactionUsage <- o .:? "usage" + interactionCreated <- o .:? "created" + interactionUpdated <- o .:? "updated" + interactionBackground <- o .:? "background" + interactionStore <- o .:? "store" + interactionStream <- o .:? "stream" + interactionSystemInstruction <- o .:? "system_instruction" + interactionTools <- o .:? "tools" + interactionGenerationConfig <- o .:? "generation_config" + interactionResponseFormat <- o .:? "response_format" + interactionPreviousInteractionId <- o .:? "previous_interaction_id" + interactionErrors <- o .:? "errors" + pure Interaction {..} + +instance ToJSON Interaction where + toJSON Interaction {..} = + object $ + catMaybes + [ Just ("id" .= interactionId) + , ("object" .=) <$> interactionObject + , ("model" .=) <$> interactionModel + , ("agent" .=) <$> interactionAgent + , Just ("status" .= interactionStatus) + , Just ("steps" .= interactionSteps) + , ("usage" .=) <$> interactionUsage + , ("created" .=) <$> interactionCreated + , ("updated" .=) <$> interactionUpdated + , ("background" .=) <$> interactionBackground + , ("store" .=) <$> interactionStore + , ("stream" .=) <$> interactionStream + , ("system_instruction" .=) <$> interactionSystemInstruction + , ("tools" .=) <$> interactionTools + , ("generation_config" .=) <$> interactionGenerationConfig + , ("response_format" .=) <$> interactionResponseFormat + , ("previous_interaction_id" .=) <$> interactionPreviousInteractionId + , ("errors" .=) <$> interactionErrors + ] + +-- | Diagnostics and error records. +data ErrorDetail = ErrorDetail + { errorCode :: !(Maybe Text) + , errorMessage :: !Text + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- --------------------------------------------------------------------------- +-- Contents +-- --------------------------------------------------------------------------- + +-- | Multimodal content part. +data Content + = TextContent !Text + | -- | mime_type, base64 data + ImageContent !Text !Text + | -- | mime_type, base64 data + AudioContent !Text !Text + | -- | mime_type, base64 data + DocumentContent !Text !Text + deriving (Eq, Show, Generic) + +instance ToJSON Content where + toJSON = \case + TextContent txt -> + object ["type" .= ("text" :: Text), "text" .= txt] + ImageContent mime b64 -> + object ["type" .= ("image" :: Text), "mime_type" .= mime, "data" .= b64] + AudioContent mime b64 -> + object ["type" .= ("audio" :: Text), "mime_type" .= mime, "data" .= b64] + DocumentContent mime b64 -> + object ["type" .= ("document" :: Text), "mime_type" .= mime, "data" .= b64] + +instance FromJSON Content where + parseJSON = withObject "Content" $ \o -> do + t <- o .: "type" + case (t :: Text) of + "text" -> TextContent <$> o .: "text" + "image" -> ImageContent <$> o .: "mime_type" <*> o .: "data" + "audio" -> AudioContent <$> o .: "mime_type" <*> o .: "data" + "document" -> DocumentContent <$> o .: "mime_type" <*> o .: "data" + other -> fail $ "Unknown Content type: " ++ T.unpack other + +-- --------------------------------------------------------------------------- +-- Steps +-- --------------------------------------------------------------------------- + +-- | Single step within an interaction turn. +data Step + = UserInputStep ![Content] + | ModelOutputStep ![Content] + | FunctionCallStep + { callName :: !Text + , callArguments :: !Value + , callId :: !Text + } + | FunctionResultStep + { resultCallId :: !Text + , resultName :: !(Maybe Text) + , resultPayload :: !Value + , resultIsError :: !(Maybe Bool) + } + | ThoughtStep + { thoughtSignature :: !(Maybe Text) + , thoughtSummary :: !(Maybe [Content]) + } + | CodeExecutionCallStep + { codeCallId :: !Text + , codeCallCode :: !Text + , codeCallSignature :: !(Maybe Text) + } + | CodeExecutionResultStep + { codeResultCallId :: !Text + , codeResultOutput :: !Text + , codeResultIsError :: !(Maybe Bool) + } + | GoogleSearchCallStep + { searchCallId :: !Text + , searchQuery :: !Text + , searchType :: !(Maybe Text) + } + | GoogleSearchResultStep + { searchResultCallId :: !Text + , searchResultItems :: ![GoogleSearchResultItem] + } + | GoogleMapsCallStep + { mapsCallId :: !Text + , mapsQuery :: !(Maybe Text) + } + | GoogleMapsResultStep + { mapsResultCallId :: !Text + , mapsResultPayload :: !(Maybe Value) + } + | FileSearchCallStep + { fileSearchCallId :: !Text + , fileSearchQuery :: !(Maybe Text) + } + | FileSearchResultStep + { fileSearchResultCallId :: !Text + , fileSearchResultPayload :: !(Maybe Value) + } + | UrlContextCallStep + { urlCallId :: !Text + , urlQuery :: !(Maybe Text) + } + | UrlContextResultStep + { urlResultCallId :: !Text + , urlResultPayload :: !(Maybe Value) + } + deriving (Eq, Show, Generic) + +-- | Google Search result snippet. +data GoogleSearchResultItem = GoogleSearchResultItem + { searchTitle :: !(Maybe Text) + , searchUrl :: !(Maybe Text) + , searchSnippet :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +instance FromJSON GoogleSearchResultItem where + parseJSON = withObject "GoogleSearchResultItem" $ \o -> do + searchTitle <- o .:? "title" + searchUrl <- o .:? "url" + searchSnippet <- o .:? "snippet" + pure GoogleSearchResultItem {..} + +instance ToJSON GoogleSearchResultItem where + toJSON GoogleSearchResultItem {..} = + object $ + catMaybes + [ ("title" .=) <$> searchTitle + , ("url" .=) <$> searchUrl + , ("snippet" .=) <$> searchSnippet + ] + +instance ToJSON Step where + toJSON = \case + UserInputStep cs -> + object ["type" .= ("user_input" :: Text), "content" .= cs] + ModelOutputStep cs -> + object ["type" .= ("model_output" :: Text), "content" .= cs] + FunctionCallStep {..} -> + object + [ "type" .= ("function_call" :: Text) + , "name" .= callName + , "arguments" .= callArguments + , "id" .= callId + ] + FunctionResultStep {..} -> + object $ + [ "type" .= ("function_result" :: Text) + , "call_id" .= resultCallId + , "result" .= resultPayload + ] + ++ catMaybes + [ ("name" .=) <$> resultName + , ("is_error" .=) <$> resultIsError + ] + ThoughtStep {..} -> + object $ + ("type" .= ("thought" :: Text)) + : catMaybes + [ ("signature" .=) <$> thoughtSignature + , ("summary" .=) <$> thoughtSummary + ] + CodeExecutionCallStep {..} -> + object $ + [ "type" .= ("code_execution_call" :: Text) + , "id" .= codeCallId + , "arguments" .= object ["code" .= codeCallCode] + ] + ++ catMaybes [("signature" .=) <$> codeCallSignature] + CodeExecutionResultStep {..} -> + object $ + [ "type" .= ("code_execution_result" :: Text) + , "call_id" .= codeResultCallId + , "result" .= codeResultOutput + ] + ++ catMaybes [("is_error" .=) <$> codeResultIsError] + GoogleSearchCallStep {..} -> + object $ + [ "type" .= ("google_search_call" :: Text) + , "id" .= searchCallId + , "arguments" .= object ["query" .= searchQuery] + ] + ++ catMaybes [("search_type" .=) <$> searchType] + GoogleSearchResultStep {..} -> + object + [ "type" .= ("google_search_result" :: Text) + , "call_id" .= searchResultCallId + , "result" .= searchResultItems + ] + GoogleMapsCallStep {..} -> + object $ + ("type" .= ("google_maps_call" :: Text)) + : ("id" .= mapsCallId) + : catMaybes [("query" .=) <$> mapsQuery] + GoogleMapsResultStep {..} -> + object $ + ("type" .= ("google_maps_result" :: Text)) + : ("call_id" .= mapsResultCallId) + : catMaybes [("result" .=) <$> mapsResultPayload] + FileSearchCallStep {..} -> + object $ + ("type" .= ("file_search_call" :: Text)) + : ("id" .= fileSearchCallId) + : catMaybes [("query" .=) <$> fileSearchQuery] + FileSearchResultStep {..} -> + object $ + ("type" .= ("file_search_result" :: Text)) + : ("call_id" .= fileSearchResultCallId) + : catMaybes [("result" .=) <$> fileSearchResultPayload] + UrlContextCallStep {..} -> + object $ + ("type" .= ("url_context_call" :: Text)) + : ("id" .= urlCallId) + : catMaybes [("query" .=) <$> urlQuery] + UrlContextResultStep {..} -> + object $ + ("type" .= ("url_context_result" :: Text)) + : ("call_id" .= urlResultCallId) + : catMaybes [("result" .=) <$> urlResultPayload] + +instance FromJSON Step where + parseJSON = withObject "Step" $ \o -> do + t <- o .: "type" + case (t :: Text) of + "user_input" -> UserInputStep <$> (o .:? "content" .!= []) + "model_output" -> ModelOutputStep <$> (o .:? "content" .!= []) + "function_call" -> do + callName <- o .: "name" + callArguments <- o .:? "arguments" .!= object [] + callId <- o .:? "id" .!= "" + pure FunctionCallStep {..} + "function_result" -> do + resultCallId <- o .: "call_id" + resultName <- o .:? "name" + resultPayload <- o .: "result" + resultIsError <- o .:? "is_error" + pure FunctionResultStep {..} + "thought" -> do + thoughtSignature <- o .:? "signature" + thoughtSummary <- o .:? "summary" + pure ThoughtStep {..} + "code_execution_call" -> do + codeCallId <- o .:? "id" .!= "" + args <- o .:? "arguments" .!= object [] + codeCallCode <- case args of + Object ao -> ao .:? "code" .!= "" + _ -> pure "" + codeCallSignature <- o .:? "signature" + pure CodeExecutionCallStep {..} + "code_execution_result" -> do + codeResultCallId <- o .: "call_id" + codeResultOutput <- o .:? "result" .!= "" + codeResultIsError <- o .:? "is_error" + pure CodeExecutionResultStep {..} + "google_search_call" -> do + searchCallId <- o .:? "id" .!= "" + args <- o .:? "arguments" .!= object [] + searchQuery <- case args of + Object ao -> ao .:? "query" .!= "" + _ -> pure "" + searchType <- o .:? "search_type" + pure GoogleSearchCallStep {..} + "google_search_result" -> do + searchResultCallId <- o .: "call_id" + searchResultItems <- o .:? "result" .!= [] + pure GoogleSearchResultStep {..} + "google_maps_call" -> do + mapsCallId <- o .:? "id" .!= "" + mapsQuery <- o .:? "query" + pure GoogleMapsCallStep {..} + "google_maps_result" -> do + mapsResultCallId <- o .: "call_id" + mapsResultPayload <- o .:? "result" + pure GoogleMapsResultStep {..} + "file_search_call" -> do + fileSearchCallId <- o .:? "id" .!= "" + fileSearchQuery <- o .:? "query" + pure FileSearchCallStep {..} + "file_search_result" -> do + fileSearchResultCallId <- o .: "call_id" + fileSearchResultPayload <- o .:? "result" + pure FileSearchResultStep {..} + "url_context_call" -> do + urlCallId <- o .:? "id" .!= "" + urlQuery <- o .:? "query" + pure UrlContextCallStep {..} + "url_context_result" -> do + urlResultCallId <- o .: "call_id" + urlResultPayload <- o .:? "result" + pure UrlContextResultStep {..} + other -> fail $ "Unknown Step type: " ++ T.unpack other + +-- --------------------------------------------------------------------------- +-- InteractionsInput +-- --------------------------------------------------------------------------- + +-- | Flexible input format for Interaction creation. +data InteractionsInput + = TextInput !Text + | ContentInput !Content + | ContentListInput ![Content] + | StepListInput ![Step] + deriving (Eq, Show, Generic) + +instance ToJSON InteractionsInput where + toJSON = \case + TextInput t -> toJSON t + ContentInput c -> toJSON c + ContentListInput cs -> toJSON cs + StepListInput ss -> toJSON ss + +instance FromJSON InteractionsInput where + parseJSON v = case v of + String s -> pure $ TextInput s + Array arr -> + (StepListInput <$> parseJSON (Array arr)) + <|> (ContentListInput <$> parseJSON (Array arr)) + Object _ -> ContentInput <$> parseJSON v + _ -> fail "Invalid InteractionsInput format" + +-- --------------------------------------------------------------------------- +-- Tools +-- --------------------------------------------------------------------------- + +-- | Built-in or custom tool declared for the model. +data Tool + = FunctionTool + { functionName :: !Text + , functionDescription :: !(Maybe Text) + , functionParameters :: !(Maybe Value) + } + | GoogleSearchTool + | GoogleMapsTool + { mapsLatitude :: !(Maybe Double) + , mapsLongitude :: !(Maybe Double) + } + | CodeExecutionTool + | FileSearchTool + { fileSearchStoreNames :: !(Maybe [Text]) + } + | UrlContextTool + deriving (Eq, Show, Generic) + +-- | Construct a standard function tool. +functionTool :: Text -> Maybe Text -> Maybe Value -> Tool +functionTool = FunctionTool + +instance ToJSON Tool where + toJSON = \case + FunctionTool {..} -> + object $ + [ "type" .= ("function" :: Text) + , "name" .= functionName + ] + ++ catMaybes + [ ("description" .=) <$> functionDescription + , ("parameters" .=) <$> functionParameters + ] + GoogleSearchTool -> + object ["type" .= ("google_search" :: Text)] + GoogleMapsTool {..} -> + object $ + ("type" .= ("google_maps" :: Text)) + : catMaybes + [ ("latitude" .=) <$> mapsLatitude + , ("longitude" .=) <$> mapsLongitude + ] + CodeExecutionTool -> + object ["type" .= ("code_execution" :: Text)] + FileSearchTool {..} -> + object $ + ("type" .= ("file_search" :: Text)) + : catMaybes [("file_search_store_names" .=) <$> fileSearchStoreNames] + UrlContextTool -> + object ["type" .= ("url_context" :: Text)] + +instance FromJSON Tool where + parseJSON = withObject "Tool" $ \o -> do + t <- o .: "type" + case (t :: Text) of + "function" -> do + functionName <- o .: "name" + functionDescription <- o .:? "description" + functionParameters <- o .:? "parameters" + pure FunctionTool {..} + "google_search" -> pure GoogleSearchTool + "google_maps" -> do + mapsLatitude <- o .:? "latitude" + mapsLongitude <- o .:? "longitude" + pure GoogleMapsTool {..} + "code_execution" -> pure CodeExecutionTool + "file_search" -> do + fileSearchStoreNames <- o .:? "file_search_store_names" + pure FileSearchTool {..} + "url_context" -> pure UrlContextTool + other -> fail $ "Unknown Tool type: " ++ T.unpack other + +-- --------------------------------------------------------------------------- +-- GenerationConfig & ResponseFormat +-- --------------------------------------------------------------------------- + +-- | Model generation parameters. +data GenerationConfig = GenerationConfig + { maxOutputTokens :: !(Maybe Int) + , seed :: !(Maybe Int) + , stopSequences :: !(Maybe [Text]) + , thinkingLevel :: !(Maybe Text) + , thinkingSummaries :: !(Maybe Bool) + , toolChoice :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +-- | Default generation configuration with all options unset. +defaultGenerationConfig :: GenerationConfig +defaultGenerationConfig = GenerationConfig Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON GenerationConfig where + toJSON GenerationConfig {..} = + object $ + catMaybes + [ ("max_output_tokens" .=) <$> maxOutputTokens + , ("seed" .=) <$> seed + , ("stop_sequences" .=) <$> stopSequences + , ("thinking_level" .=) <$> thinkingLevel + , ("thinking_summaries" .=) <$> thinkingSummaries + , ("tool_choice" .=) <$> toolChoice + ] + +instance FromJSON GenerationConfig where + parseJSON = withObject "GenerationConfig" $ \o -> do + maxOutputTokens <- o .:? "max_output_tokens" + seed <- o .:? "seed" + stopSequences <- o .:? "stop_sequences" + thinkingLevel <- o .:? "thinking_level" + thinkingSummaries <- o .:? "thinking_summaries" + toolChoice <- o .:? "tool_choice" + pure GenerationConfig {..} + +-- | Structured output format specification. +data ResponseFormat + = TextResponseFormat + { responseMimeType :: !(Maybe Text) + , responseSchema :: !(Maybe Value) + } + deriving (Eq, Show, Generic) + +-- | Construct a JSON Schema response format constraint. +jsonResponseFormat :: Value -> ResponseFormat +jsonResponseFormat s = TextResponseFormat (Just "application/json") (Just s) + +instance ToJSON ResponseFormat where + toJSON (TextResponseFormat mime sch) = + object $ + ("type" .= ("text" :: Text)) + : catMaybes + [ ("mime_type" .=) <$> mime + , ("schema" .=) <$> sch + ] + +instance FromJSON ResponseFormat where + parseJSON = withObject "ResponseFormat" $ \o -> do + responseMimeType <- o .:? "mime_type" + responseSchema <- o .:? "schema" + pure TextResponseFormat {..} + +-- --------------------------------------------------------------------------- +-- Usage +-- --------------------------------------------------------------------------- + +-- | Token usage statistics. +data Usage = Usage + { totalInputTokens :: !(Maybe Int) + , totalOutputTokens :: !(Maybe Int) + , totalTokens :: !(Maybe Int) + , totalThoughtTokens :: !(Maybe Int) + , totalToolUseTokens :: !(Maybe Int) + , totalCachedTokens :: !(Maybe Int) + } + deriving (Eq, Show, Generic) + +instance FromJSON Usage where + parseJSON = withObject "Usage" $ \o -> do + totalInputTokens <- o .:? "total_input_tokens" + totalOutputTokens <- o .:? "total_output_tokens" + totalTokens <- o .:? "total_tokens" + totalThoughtTokens <- o .:? "total_thought_tokens" + totalToolUseTokens <- o .:? "total_tool_use_tokens" + totalCachedTokens <- o .:? "total_cached_tokens" + pure Usage {..} + +instance ToJSON Usage where + toJSON Usage {..} = + object $ + catMaybes + [ ("total_input_tokens" .=) <$> totalInputTokens + , ("total_output_tokens" .=) <$> totalOutputTokens + , ("total_tokens" .=) <$> totalTokens + , ("total_thought_tokens" .=) <$> totalThoughtTokens + , ("total_tool_use_tokens" .=) <$> totalToolUseTokens + , ("total_cached_tokens" .=) <$> totalCachedTokens + ] + +-- --------------------------------------------------------------------------- +-- CreateInteractionRequest +-- --------------------------------------------------------------------------- + +-- | Request envelope for POST \/v1\/interactions. +data CreateInteractionRequest = CreateInteractionRequest + { reqModel :: !(Maybe Text) + , reqAgent :: !(Maybe Text) + , reqInput :: !InteractionsInput + , reqSystemInstruction :: !(Maybe Text) + , reqTools :: !(Maybe [Tool]) + , reqGenerationConfig :: !(Maybe GenerationConfig) + , reqResponseFormat :: !(Maybe ResponseFormat) + , reqPreviousInteractionId :: !(Maybe Text) + , reqBackground :: !(Maybe Bool) + , reqStore :: !(Maybe Bool) + , reqStream :: !(Maybe Bool) + } + deriving (Eq, Show, Generic) + +-- | Construct a base request. +defaultCreateInteractionRequest :: InteractionsInput -> CreateInteractionRequest +defaultCreateInteractionRequest input = + CreateInteractionRequest + { reqModel = Nothing + , reqAgent = Nothing + , reqInput = input + , reqSystemInstruction = Nothing + , reqTools = Nothing + , reqGenerationConfig = Nothing + , reqResponseFormat = Nothing + , reqPreviousInteractionId = Nothing + , reqBackground = Nothing + , reqStore = Nothing + , reqStream = Nothing + } + +-- | Helper to create a model-based interaction. +createModelInteraction :: Text -> InteractionsInput -> CreateInteractionRequest +createModelInteraction modelName input = + (defaultCreateInteractionRequest input) {reqModel = Just modelName} + +-- | Helper to create an agent-based interaction. +createAgentInteraction :: Text -> InteractionsInput -> CreateInteractionRequest +createAgentInteraction agentName input = + (defaultCreateInteractionRequest input) {reqAgent = Just agentName} + +instance ToJSON CreateInteractionRequest where + toJSON CreateInteractionRequest {..} = + object $ + ("input" .= reqInput) + : catMaybes + [ ("model" .=) <$> reqModel + , ("agent" .=) <$> reqAgent + , ("system_instruction" .=) <$> reqSystemInstruction + , ("tools" .=) <$> reqTools + , ("generation_config" .=) <$> reqGenerationConfig + , ("response_format" .=) <$> reqResponseFormat + , ("previous_interaction_id" .=) <$> reqPreviousInteractionId + , ("background" .=) <$> reqBackground + , ("store" .=) <$> reqStore + , ("stream" .=) <$> reqStream + ] + +instance FromJSON CreateInteractionRequest where + parseJSON = withObject "CreateInteractionRequest" $ \o -> do + reqModel <- o .:? "model" + reqAgent <- o .:? "agent" + reqInput <- o .: "input" + reqSystemInstruction <- o .:? "system_instruction" + reqTools <- o .:? "tools" + reqGenerationConfig <- o .:? "generation_config" + reqResponseFormat <- o .:? "response_format" + reqPreviousInteractionId <- o .:? "previous_interaction_id" + reqBackground <- o .:? "background" + reqStore <- o .:? "store" + reqStream <- o .:? "stream" + pure CreateInteractionRequest {..} + +-- --------------------------------------------------------------------------- +-- Server-Sent Events (SSE) Streaming +-- --------------------------------------------------------------------------- + +-- | Incremental delta updates emitted during streaming. +data StepDeltaData + = TextDelta !Text + | ArgumentsDelta !Text + | ThoughtSignatureDelta !Text + | OtherDelta !Text !Value + deriving (Eq, Show, Generic) + +instance FromJSON StepDeltaData where + parseJSON = withObject "StepDeltaData" $ \o -> do + t <- o .: "type" + case (t :: Text) of + "text" -> TextDelta <$> o .: "text" + "arguments" -> ArgumentsDelta <$> o .: "arguments" + "thought_signature" -> ThoughtSignatureDelta <$> o .: "signature" + other -> pure $ OtherDelta other (Object o) + +instance ToJSON StepDeltaData where + toJSON = \case + TextDelta txt -> object ["type" .= ("text" :: Text), "text" .= txt] + ArgumentsDelta args -> object ["type" .= ("arguments" :: Text), "arguments" .= args] + ThoughtSignatureDelta sig -> object ["type" .= ("thought_signature" :: Text), "signature" .= sig] + OtherDelta _ val -> val + +-- | SSE event types dispatched on the interaction stream. +data InteractionSseEvent + = SseInteractionCreated !Interaction + | SseInteractionStatusUpdate !Text !InteractionStatus + | SseStepStart !Int !Step + | SseStepDelta !Int !StepDeltaData + | SseStepStop !Int + | SseInteractionCompleted !Interaction + | SseError !Text !Text + | SseOther !Text !Value + deriving (Eq, Show, Generic) + +instance FromJSON InteractionSseEvent where + parseJSON = withObject "InteractionSseEvent" $ \o -> do + evType <- o .: "event_type" + case (evType :: Text) of + "interaction.created" -> SseInteractionCreated <$> o .: "interaction" + "interaction.completed" -> SseInteractionCompleted <$> o .: "interaction" + "interaction.status_update" -> + SseInteractionStatusUpdate <$> o .: "interaction_id" <*> o .: "status" + "step.start" -> SseStepStart <$> o .: "index" <*> o .: "step" + "step.delta" -> SseStepDelta <$> o .: "index" <*> o .: "delta" + "step.stop" -> SseStepStop <$> o .: "index" + "error" -> do + errObj <- o .: "error" + c <- errObj .:? "code" .!= "" + m <- errObj .:? "message" .!= "" + pure $ SseError c m + other -> pure $ SseOther other (Object o) + +instance ToJSON InteractionSseEvent where + toJSON = \case + SseInteractionCreated inter -> + object ["event_type" .= ("interaction.created" :: Text), "interaction" .= inter] + SseInteractionCompleted inter -> + object ["event_type" .= ("interaction.completed" :: Text), "interaction" .= inter] + SseInteractionStatusUpdate iid st -> + object + ["event_type" .= ("interaction.status_update" :: Text), "interaction_id" .= iid, "status" .= st] + SseStepStart idx step -> + object ["event_type" .= ("step.start" :: Text), "index" .= idx, "step" .= step] + SseStepDelta idx d -> + object ["event_type" .= ("step.delta" :: Text), "index" .= idx, "delta" .= d] + SseStepStop idx -> + object ["event_type" .= ("step.stop" :: Text), "index" .= idx] + SseError code msg -> + object ["event_type" .= ("error" :: Text), "error" .= object ["code" .= code, "message" .= msg]] + SseOther ev val -> case val of + Object o -> Object (KM.insert "event_type" (String ev) o) + _ -> object ["event_type" .= ev, "data" .= val] + +-- --------------------------------------------------------------------------- +-- Embeddings +-- --------------------------------------------------------------------------- + +-- | Single text part within embedding payload. +newtype EmbedPart = EmbedPart {partText :: Text} + deriving (Eq, Show, Generic) + +instance ToJSON EmbedPart where + toJSON (EmbedPart t) = object ["text" .= t] + +instance FromJSON EmbedPart where + parseJSON = withObject "EmbedPart" $ \o -> EmbedPart <$> o .: "text" + +-- | Content payload container for embedding. +newtype EmbedContentPayload = EmbedContentPayload {payloadParts :: [EmbedPart]} + deriving (Eq, Show, Generic) + +instance ToJSON EmbedContentPayload where + toJSON (EmbedContentPayload ps) = object ["parts" .= ps] + +instance FromJSON EmbedContentPayload where + parseJSON = withObject "EmbedContentPayload" $ \o -> EmbedContentPayload <$> o .: "parts" + +-- | Single embedContent request body. +newtype EmbedContentRequest = EmbedContentRequest {requestContent :: EmbedContentPayload} + deriving (Eq, Show, Generic) + +instance ToJSON EmbedContentRequest where + toJSON (EmbedContentRequest p) = object ["content" .= p] + +instance FromJSON EmbedContentRequest where + parseJSON = withObject "EmbedContentRequest" $ \o -> EmbedContentRequest <$> o .: "content" + +-- | Embedding vector result. +newtype EmbeddingValues = EmbeddingValues {embeddingValues :: [Float]} + deriving (Eq, Show, Generic) + +instance FromJSON EmbeddingValues where + parseJSON = withObject "EmbeddingValues" $ \o -> EmbeddingValues <$> o .: "values" + +instance ToJSON EmbeddingValues where + toJSON (EmbeddingValues vs) = object ["values" .= vs] + +-- | Response from embedContent. +newtype EmbedContentResponse = EmbedContentResponse {responseEmbedding :: EmbeddingValues} + deriving (Eq, Show, Generic) + +instance FromJSON EmbedContentResponse where + parseJSON = withObject "EmbedContentResponse" $ \o -> EmbedContentResponse <$> o .: "embedding" + +instance ToJSON EmbedContentResponse where + toJSON (EmbedContentResponse ev) = object ["embedding" .= ev] + +-- | Single item in batchEmbedContents. +data BatchEmbedRequestItem = BatchEmbedRequestItem + { itemModel :: !Text + , itemContent :: !EmbedContentPayload + } + deriving (Eq, Show, Generic) + +instance ToJSON BatchEmbedRequestItem where + toJSON BatchEmbedRequestItem {..} = + object ["model" .= itemModel, "content" .= itemContent] + +instance FromJSON BatchEmbedRequestItem where + parseJSON = withObject "BatchEmbedRequestItem" $ \o -> do + itemModel <- o .: "model" + itemContent <- o .: "content" + pure BatchEmbedRequestItem {..} + +-- | Batch embed request body. +newtype BatchEmbedContentsRequest = BatchEmbedContentsRequest + { batchRequests :: [BatchEmbedRequestItem] + } + deriving (Eq, Show, Generic) + +instance ToJSON BatchEmbedContentsRequest where + toJSON (BatchEmbedContentsRequest reqs) = object ["requests" .= reqs] + +instance FromJSON BatchEmbedContentsRequest where + parseJSON = withObject "BatchEmbedContentsRequest" $ \o -> + BatchEmbedContentsRequest <$> o .: "requests" + +-- | Response from batchEmbedContents. +newtype BatchEmbedContentsResponse = BatchEmbedContentsResponse + { batchEmbeddings :: [EmbeddingValues] + } + deriving (Eq, Show, Generic) + +instance FromJSON BatchEmbedContentsResponse where + parseJSON = withObject "BatchEmbedContentsResponse" $ \o -> + BatchEmbedContentsResponse <$> o .: "embeddings" + +instance ToJSON BatchEmbedContentsResponse where + toJSON (BatchEmbedContentsResponse evs) = object ["embeddings" .= evs] diff --git a/src/Langchain/Embeddings/Gemini.hs b/src/Langchain/Embeddings/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Embeddings/Gemini.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Embeddings.Gemini +Description : Google Gemini integration for text embeddings +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Gemini implementation of LangChain's 'Embeddings' interface using Servant bindings. +-} +module Langchain.Embeddings.Gemini + ( GeminiEmbeddings (..) + , defaultGeminiEmbeddings + , newGeminiEmbeddings + ) where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +import Gemini.Client + ( BatchEmbedContentsRequest (..) + , BatchEmbedContentsResponse (..) + , BatchEmbedRequestItem (..) + , EmbedContentPayload (..) + , EmbedContentRequest (..) + , EmbedContentResponse (..) + , EmbedPart (..) + , EmbeddingValues (..) + , batchEmbedContents + , embedContent + , newGeminiClientEnv + , newGeminiClientEnvWithBaseUrl + , runGeminiClient + ) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Embeddings.Core (Embeddings (..)) +import Langchain.Error (llmError) + +-- | Configuration for Gemini embeddings. +data GeminiEmbeddings = GeminiEmbeddings + { embeddingApiKey :: !Text + -- ^ Gemini API key + , embeddingModel :: !Text + -- ^ Model name, e.g. @"gemini-embedding-001"@ + , embeddingBaseUrl :: !(Maybe Text) + -- ^ Optional custom base URL + } + deriving (Eq, Show, Generic) + +-- | Default embedding configuration using @gemini-embedding-001@. +defaultGeminiEmbeddings :: Text -> GeminiEmbeddings +defaultGeminiEmbeddings key = GeminiEmbeddings key "gemini-embedding-001" Nothing + +-- | Create a custom Gemini embedding configuration. +newGeminiEmbeddings :: Text -> Text -> Maybe Text -> GeminiEmbeddings +newGeminiEmbeddings = GeminiEmbeddings + +instance Embeddings GeminiEmbeddings where + embedDocuments _ [] = pure [] + embedDocuments GeminiEmbeddings {..} docs = do + env <- liftIO $ case embeddingBaseUrl of + Just u -> newGeminiClientEnvWithBaseUrl u embeddingApiKey + Nothing -> newGeminiClientEnv embeddingApiKey + let items = + [ BatchEmbedRequestItem + { itemModel = "models/" <> embeddingModel + , itemContent = EmbedContentPayload [EmbedPart (TL.toStrict (pageContent doc))] + } + | doc <- docs + ] + req = BatchEmbedContentsRequest items + eRes <- liftIO $ runGeminiClient env (batchEmbedContents embeddingApiKey embeddingModel req) + case eRes of + Left err -> + throwError $ + llmError (T.pack (show err)) (Just "GeminiEmbeddings") Nothing + Right resp -> + pure [embeddingValues ev | ev <- batchEmbeddings resp] + + embedQuery GeminiEmbeddings {..} query = do + env <- liftIO $ case embeddingBaseUrl of + Just u -> newGeminiClientEnvWithBaseUrl u embeddingApiKey + Nothing -> newGeminiClientEnv embeddingApiKey + let req = EmbedContentRequest (EmbedContentPayload [EmbedPart query]) + eRes <- liftIO $ runGeminiClient env (embedContent embeddingApiKey embeddingModel req) + case eRes of + Left err -> + throwError $ + llmError (T.pack (show err)) (Just "GeminiEmbeddings") Nothing + Right resp -> + pure $ embeddingValues (responseEmbedding resp) diff --git a/src/Langchain/Provider/Gemini.hs b/src/Langchain/Provider/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Provider/Gemini.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Provider.Gemini +Description : Google Gemini provider implementing ChatModel via Servant Interactions v1 API +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Gemini provider built on the Google Gemini Interactions v1 API using Servant client bindings. +Supports multi-modal content, multi-turn dialogues, tool calling, and SSE streaming. +-} +module Langchain.Provider.Gemini + ( Gemini (..) + , GeminiConfig (..) + , defaultGeminiConfig + , newGemini + , messagesToInteractionsInput + , interactionToMessage + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, ToJSON, decodeStrict, object, toJSON, (.=)) +import Data.Conduit (await, yield, (.|)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import GHC.Generics (Generic) + +import Gemini.Client + ( CreateInteractionRequest (..) + , GenerationConfig (..) + , Interaction (..) + , InteractionSseEvent (..) + , InteractionsInput (..) + , ResponseFormat (..) + , Step (..) + , StepDeltaData (..) + , Usage (..) + , createInteraction + , defaultCreateInteractionRequest + , newGeminiClientEnv + , newGeminiClientEnvWithBaseUrl + , runGeminiClient + , streamGeminiInteraction + ) +import qualified Gemini.Client.Types as GTypes +import Langchain.Cache.Core (CacheableChatModel (..)) +import Langchain.Error (llmError) +import Langchain.Model +import Langchain.Stream (StreamEvent (..), TokenUsage (..)) +import qualified Langchain.Tool as CoreTool +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Runtime configuration for Gemini interactions. +data GeminiConfig = GeminiConfig + { configTools :: !(Maybe [GTypes.Tool]) + -- ^ Tools (functions, Google Search, Code Execution, etc.) available to the model. + , configGenerationConfig :: !(Maybe GenerationConfig) + -- ^ Generation parameters such as token limits, stop sequences, and thinking level. + , configResponseFormat :: !(Maybe ResponseFormat) + -- ^ Output format constraints, e.g. JSON schema enforcement. + , configSystemInstruction :: !(Maybe Text) + -- ^ System instructions directing the model's persona or constraints. + , configPreviousInteractionId :: !(Maybe Text) + -- ^ Interaction ID to continue an ongoing session. + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Default empty Gemini configuration. +defaultGeminiConfig :: GeminiConfig +defaultGeminiConfig = + GeminiConfig + { configTools = Nothing + , configGenerationConfig = Nothing + , configResponseFormat = Nothing + , configSystemInstruction = Nothing + , configPreviousInteractionId = Nothing + } + +-- | Gemini ChatModel provider instance. +data Gemini = Gemini + { apiKey :: !Text + , model :: !Text + , baseUrl :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +-- | Create a new Gemini provider instance. +newGemini :: + -- | Google Gemini API key + Text -> + -- | Model name (e.g. @"gemini-3.6-flash"@) + Text -> + -- | Optional custom base URL + Maybe Text -> + Gemini +newGemini = Gemini + +-- | Convert Langchain ContentBlock to Gemini Content. +contentBlockToGemini :: ContentBlock -> GTypes.Content +contentBlockToGemini (TextBlock t) = GTypes.TextContent t +contentBlockToGemini (ImageBlock ImageContent {imageSource = ImageBase64 (Just mime) b64}) = + GTypes.ImageContent mime b64 +contentBlockToGemini (ImageBlock ImageContent {imageSource = ImageBase64 Nothing b64}) = + GTypes.ImageContent "image/jpeg" b64 +contentBlockToGemini (ImageBlock ImageContent {imageSource = ImageUrl url}) = + GTypes.TextContent ("[Image URL: " <> url <> "]") +contentBlockToGemini (AudioBlock mime b64) = GTypes.AudioContent mime b64 +contentBlockToGemini (DataBlock _) = GTypes.TextContent "[Data block]" + +-- | Convert a Langchain Message to Gemini Step(s). +messageToSteps :: [ToolCall] -> Message -> [Step] +messageToSteps priorToolCalls msg = case messageRole msg of + User -> + let contents = map contentBlockToGemini (NonEmpty.toList (messageContents msg)) + in [UserInputStep contents] + Assistant -> + let contents = map contentBlockToGemini (NonEmpty.toList (messageContents msg)) + textContent = [c | c@(GTypes.TextContent t) <- contents, not (T.null t)] + outputSteps = [ModelOutputStep textContent | not (null textContent)] + toolSteps = case messageToolCalls msg of + Nothing -> [] + Just tcs -> + [ FunctionCallStep + { callName = toolCallName tc + , callArguments = toolCallArguments tc + , callId = toolCallId tc + } + | tc <- tcs + ] + in outputSteps ++ toolSteps + Tool -> + let payload = parseOrWrap (extractMessageText msg) + tId = fromMaybe "" (messageToolId msg) + tName = messageName msg <|> lookupToolName tId priorToolCalls + in [FunctionResultStep tId tName payload Nothing] + Function -> + let payload = parseOrWrap (extractMessageText msg) + tId = fromMaybe "" (messageToolId msg) + tName = messageName msg <|> lookupToolName tId priorToolCalls + in [FunctionResultStep tId tName payload Nothing] + System -> + -- System instructions are extracted separately when possible + let contents = map contentBlockToGemini (NonEmpty.toList (messageContents msg)) + in [UserInputStep contents] + Developer -> + let contents = map contentBlockToGemini (NonEmpty.toList (messageContents msg)) + in [UserInputStep contents] + where + lookupToolName toolId calls = + toolCallName <$> List.find ((== toolId) . toolCallId) calls + + parseOrWrap rawTxt = + case decodeStrict (TE.encodeUtf8 rawTxt) of + Just val -> val + Nothing -> object ["result" .= rawTxt] + +-- | Convert a list of Langchain Messages to an 'InteractionsInput'. +messagesToInteractionsInput :: [Message] -> (Maybe Text, InteractionsInput) +messagesToInteractionsInput msgs = + case msgs of + [singleMsg] + | messageRole singleMsg == User + , [TextBlock t] <- NonEmpty.toList (messageContents singleMsg) -> + (Nothing, TextInput t) + _ -> + let (sysMsgs, nonSysMsgs) = List.partition isSystem msgs + extractedSys = case sysMsgs of + [] -> Nothing + _ -> Just $ T.intercalate "\n" (map extractMessageText sysMsgs) + priorToolCalls = concatMap (fromMaybe [] . messageToolCalls) msgs + allSteps = concatMap (messageToSteps priorToolCalls) nonSysMsgs + in (extractedSys, StepListInput allSteps) + where + isSystem m = messageRole m `elem` [System, Developer] + +-- | Convert an t'Interaction' result to a Langchain t'Message'. +interactionToMessage :: Interaction -> Message +interactionToMessage Interaction {..} = + let outputTexts = + [ t + | ModelOutputStep cs <- interactionSteps + , GTypes.TextContent t <- cs + ] + toolCalls = + [ ToolCall + { toolCallId = callId + , toolCallType = "function" + , toolCallName = callName + , toolCallArguments = callArguments + } + | FunctionCallStep {..} <- interactionSteps + ] + thoughtSigs = + [ sig + | ThoughtStep {thoughtSignature = Just sig} <- interactionSteps + ] + base = assistantMessage (T.intercalate "\n" outputTexts) + withCalls = + if null toolCalls + then base + else base {messageToolCalls = Just toolCalls} + withMeta = + if null thoughtSigs + then withCalls + else + withCalls + { messageMetadata = + Map.insert + "langchain.gemini.thoughtSignatures" + (toJSON thoughtSigs) + (messageMetadata withCalls) + } + in withMeta + +-- | Build a t'CreateInteractionRequest' from Gemini configuration and messages. +buildCreateRequest :: Gemini -> [Message] -> Maybe GeminiConfig -> CreateInteractionRequest +buildCreateRequest Gemini {..} msgs mbConfig = + let (mbExtractedSys, input) = messagesToInteractionsInput msgs + cfg = fromMaybe defaultGeminiConfig mbConfig + finalSys = configSystemInstruction cfg <|> mbExtractedSys + baseReq = defaultCreateInteractionRequest input + in baseReq + { reqModel = Just model + , reqSystemInstruction = finalSys + , reqTools = configTools cfg + , reqGenerationConfig = configGenerationConfig cfg + , reqResponseFormat = configResponseFormat cfg + , reqPreviousInteractionId = configPreviousInteractionId cfg + } + +instance ChatModel Gemini where + type ModelConfig Gemini = GeminiConfig + + invoke provider msgs mbConfig = do + let req = buildCreateRequest provider msgs mbConfig + env <- liftIO $ case baseUrl provider of + Just u -> newGeminiClientEnvWithBaseUrl u (apiKey provider) + Nothing -> newGeminiClientEnv (apiKey provider) + eRes <- liftIO $ runGeminiClient env (createInteraction (apiKey provider) req) + case eRes of + Left err -> + throwError $ + llmError (redactKey (apiKey provider) (T.pack (show err))) Nothing Nothing + Right interaction -> pure $ interactionToMessage interaction + + stream provider msgs mbConfig = do + let rId = "gemini-stream-run" + mName = model provider + yield $ LLMStart rId mName msgs + + env <- liftIO $ case baseUrl provider of + Just u -> newGeminiClientEnvWithBaseUrl u (apiKey provider) + Nothing -> newGeminiClientEnv (apiKey provider) + let req = buildCreateRequest provider msgs mbConfig + + (accumulated, mbCompletedInter) <- + streamGeminiInteraction env req .| consumeStream rId "" Nothing + + case mbCompletedInter of + Just completedInter -> do + let finalMsg = interactionToMessage completedInter + usage = toTokenUsage (interactionUsage completedInter) + yield $ LLMEnd rId finalMsg usage + Nothing -> do + let finalMsg = assistantMessage accumulated + yield $ LLMEnd rId finalMsg Nothing + where + consumeStream rId acc mbCompleted = + await >>= \case + Nothing -> pure (acc, mbCompleted) + Just (SseStepDelta _ (TextDelta txt)) -> do + yield $ LLMChunk rId txt Nothing + consumeStream rId (acc <> txt) mbCompleted + Just (SseInteractionCompleted inter) -> + consumeStream rId acc (Just inter) + Just (SseError code msg) -> + throwError $ + llmError (code <> ": " <> msg) Nothing Nothing + Just _ -> + consumeStream rId acc mbCompleted + + toTokenUsage Nothing = Nothing + toTokenUsage (Just Usage {..}) = + Just $ + TokenUsage + { promptTokens = fromMaybe 0 totalInputTokens + , completionTokens = fromMaybe 0 totalOutputTokens + , totalTokens = fromMaybe 0 totalTokens + } + +instance ToolBinder Gemini m where + bindToolsConfig tools mbConfig = + let cfg = fromMaybe defaultGeminiConfig mbConfig + geminiTools = map toGeminiTool tools + mergedTools = case configTools cfg of + Nothing -> Just geminiTools + Just existing -> Just (existing ++ geminiTools) + in Just cfg {configTools = mergedTools} + where + toGeminiTool t = + GTypes.FunctionTool + (CoreTool.toolName t) + (Just $ CoreTool.toolDescription t) + (Just $ CoreTool.toolSchema t) + +instance CacheableChatModel Gemini where + cacheModelIdentity Gemini {model = mName} _ = + object + [ "provider" .= ("gemini" :: Text) + , "model" .= mName + ] + +-- | Redact API key from strings to prevent accidental leakage in errors. +redactKey :: Text -> Text -> Text +redactKey key txt + | T.null key = txt + | otherwise = T.replace key "[REDACTED]" txt diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Test.Gemini.Client.InteractionsSpec as InteractionsSpec +import qualified Test.Gemini.Client.TypesSpec as TypesSpec +import qualified Test.Langchain.Provider.GeminiSpec as GeminiSpec +import Test.Tasty + +main :: IO () +main = + defaultMain $ + testGroup + "langchain-hs-gemini Test Suite" + [ TypesSpec.tests + , InteractionsSpec.tests + , GeminiSpec.tests + ] diff --git a/test/Test/Gemini/Client/InteractionsSpec.hs b/test/Test/Gemini/Client/InteractionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Gemini/Client/InteractionsSpec.hs @@ -0,0 +1,651 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-matches -Wno-incomplete-patterns #-} + +{- | +Module : Test.Gemini.Client.InteractionsSpec +Description : Test every single example from https://ai.google.dev/api/interactions-api-v1 +-} +module Test.Gemini.Client.InteractionsSpec (tests) where + +import Data.Aeson (encode) +import Data.Aeson.QQ (aesonQQ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Network.HTTP.Types (status200, status404) +import Network.Wai (Application, rawPathInfo, requestMethod, responseLBS, strictRequestBody) +import Network.Wai.Handler.Warp (testWithApplication) +import System.Directory (doesFileExist, getHomeDirectory) +import System.Environment (lookupEnv) +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +import Gemini.Client + +-- | Helper to start a local mock Warp server on a free port +withMockServer :: Application -> (Text -> IO a) -> IO a +withMockServer app action = + testWithApplication (pure app) $ \port -> + action ("http://127.0.0.1:" <> T.pack (show port)) + +-- | Read GEMINI API KEY from env or ~/.gemini_api_key +getLiveApiKey :: IO (Maybe Text) +getLiveApiKey = do + mbEnv <- lookupEnv "GEMINI_API_KEY" + case mbEnv of + Just k | not (null k) -> pure (Just (T.pack k)) + _ -> do + home <- getHomeDirectory + let p = home ".gemini_api_key" + exists <- doesFileExist p + if exists + then do + txt <- T.strip <$> TIO.readFile p + pure $ if T.null txt then Nothing else Just txt + else pure Nothing + +tests :: TestTree +tests = + testGroup + "Gemini.Client.InteractionsSpec (All Documentation Examples)" + [ mockExamplesTests + , liveExamplesTests + ] + +-- --------------------------------------------------------------------------- +-- 1. Mock Server Tests (Verifies all 14 examples against exact API contracts) +-- --------------------------------------------------------------------------- + +mockExamplesTests :: TestTree +mockExamplesTests = + testGroup + "Mock API Contract Tests" + [ testCase "Example 1: Simple Request" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_simple", + "object": "interaction", + "status": "completed", + "model": "gemini-3.6-flash", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Why did the chicken cross the road? To get to the other side!"}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = createModelInteraction "gemini-3.6-flash" (TextInput "Tell me a joke") + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> do + interactionId inter @?= "v1_mock_simple" + interactionStatus inter @?= StatusCompleted + case interactionSteps inter of + [ModelOutputStep [TextContent txt]] -> + assertBool "contains joke" ("chicken" `T.isInfixOf` txt) + other -> assertFailure ("Unexpected steps: " ++ show other) + , testCase "Example 2: Multi-turn Conversation" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_multiturn", + "object": "interaction", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Your name is Bob."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let steps = + [ UserInputStep [TextContent "Hi, I am Bob"] + , ModelOutputStep [TextContent "Hello Bob! Nice to meet you."] + , UserInputStep [TextContent "What is my name?"] + ] + req = createModelInteraction "gemini-3.6-flash" (StepListInput steps) + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> interactionStatus inter @?= StatusCompleted + , testCase "Example 3: Multimodal - Image Input" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_image", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "This is a red circle."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let contents = + [ TextContent "What is in this image?" + , ImageContent + "image/png" + "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAQAAAC1HAwCAAAAC0lEQVR42mNk+A8AAQUBAScY42YAAAAASUVORK5CYII=" + ] + req = createModelInteraction "gemini-3.6-flash" (ContentListInput contents) + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> interactionStatus inter @?= StatusCompleted + , testCase "Example 4: Function Calling (requires_action -> function_result)" $ do + let app req respond = do + body <- strictRequestBody req + let isFollowUp = "\"function_result\"" `BS.isInfixOf` LBS.toStrict body + resp = + if isFollowUp + then + [aesonQQ|{ + "id": "v1_mock_fc_step2", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "The weather in Tokyo is 20°C and sunny."}] + } + ] + }|] + else + [aesonQQ|{ + "id": "v1_mock_fc_step1", + "status": "requires_action", + "steps": [ + { + "type": "function_call", + "id": "call_tokyo", + "name": "get_weather", + "arguments": {"location": "Tokyo"} + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode resp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let tool = functionTool "get_weather" (Just "Get current weather") (Just [aesonQQ|{"type": "object"}|]) + req1 = + (createModelInteraction "gemini-3.6-flash" (TextInput "What is the weather in Tokyo?")) + { reqTools = Just [tool] + } + res1 <- runGeminiClient env (createInteraction "fake-key" req1) + case res1 of + Left err -> assertFailure (show err) + Right inter1 -> do + interactionStatus inter1 @?= StatusRequiresAction + case interactionSteps inter1 of + [FunctionCallStep {callId = cid, callName = cname}] -> do + cid @?= "call_tokyo" + cname @?= "get_weather" + -- Follow up with function_result + let resultStep = FunctionResultStep cid (Just cname) [aesonQQ|{"temperature": 20, "condition": "sunny"}|] Nothing + req2 = + (defaultCreateInteractionRequest (StepListInput [resultStep])) + { reqModel = Just "gemini-3.6-flash" + , reqPreviousInteractionId = Just (interactionId inter1) + } + res2 <- runGeminiClient env (createInteraction "fake-key" req2) + case res2 of + Left err2 -> assertFailure (show err2) + Right inter2 -> interactionStatus inter2 @?= StatusCompleted + other -> assertFailure ("Expected FunctionCallStep, got: " ++ show other) + , testCase "Example 5: Deep Research Agent" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_deep_research", + "agent": "deep-research", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Deep research findings on quantum computing."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = createAgentInteraction "deep-research" (TextInput "Research quantum computing breakthroughs") + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> do + interactionAgent inter @?= Just "deep-research" + interactionStatus inter @?= StatusCompleted + , testCase "Example 6: Antigravity Agent" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_antigravity", + "agent": "antigravity", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Antigravity task completed."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = createAgentInteraction "antigravity" (TextInput "Solve the algorithmic puzzle") + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> do + interactionAgent inter @?= Just "antigravity" + interactionStatus inter @?= StatusCompleted + , testCase "Example 7: Reuse Env (previous_interaction_id)" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_reuse", + "previous_interaction_id": "v1_mock_prev", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Continuing previous session."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Continue our conversation")) + { reqPreviousInteractionId = Just "v1_mock_prev" + } + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> interactionPreviousInteractionId inter @?= Just "v1_mock_prev" + , testCase "Example 8: With Sources / Grounding" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_sources", + "status": "completed", + "steps": [ + { + "type": "google_search_result", + "call_id": "call_search_1", + "result": [ + { + "title": "Example Source", + "url": "https://example.com/source", + "snippet": "Information from source" + } + ] + }, + { + "type": "model_output", + "content": [{"type": "text", "text": "According to Example Source, ..."}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Find recent news")) + { reqTools = Just [GoogleSearchTool] + } + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> do + let searchSteps = [s | s@(GoogleSearchResultStep {}) <- interactionSteps inter] + assertBool "Contains google_search_result step" (not (null searchSteps)) + , testCase "Example 9: Custom Agent / System Instruction" $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_pirate", + "status": "completed", + "system_instruction": "You are a pirate.", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Ahoy matey!"}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Hello")) + { reqSystemInstruction = Just "You are a pirate." + } + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> interactionSystemInstruction inter @?= Just "You are a pirate." + , testCase + "Example 10: Built-in Tools (CodeExecution, GoogleSearch, GoogleMaps, FileSearch, UrlContext)" + $ do + let app req respond = do + body <- strictRequestBody req + let expectedResp = + [aesonQQ|{ + "id": "v1_mock_tools", + "status": "completed", + "steps": [ + { + "type": "code_execution_call", + "id": "call_py", + "arguments": {"code": "print(2+2)"} + }, + { + "type": "code_execution_result", + "call_id": "call_py", + "result": "4\n" + }, + { + "type": "model_output", + "content": [{"type": "text", "text": "2 + 2 = 4"}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + let tools = + [ CodeExecutionTool + , GoogleSearchTool + , GoogleMapsTool (Just 37.77) (Just (-122.41)) + , FileSearchTool (Just ["my-store"]) + , UrlContextTool + ] + req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Run math code")) + { reqTools = Just tools + } + res <- runGeminiClient env (createInteraction "fake-key" req) + case res of + Left err -> assertFailure (show err) + Right inter -> do + let pyCalls = [s | s@(CodeExecutionCallStep {}) <- interactionSteps inter] + assertBool "Contains CodeExecutionCallStep" (not (null pyCalls)) + , testCase "Example 11: Cancel Interaction" $ do + let app req respond = do + let p = rawPathInfo req + m = requestMethod req + if m == "POST" && "/cancel" `BS.isSuffixOf` p + then do + let expectedResp = [aesonQQ|{"id": "v1_cancel_me", "status": "cancelled", "steps": []}|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + else respond $ responseLBS status404 [] "not found" + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + res <- runGeminiClient env (cancelInteraction "fake-key" "v1_cancel_me") + case res of + Left err -> assertFailure (show err) + Right inter -> interactionStatus inter @?= StatusCancelled + , testCase "Example 12: Get Interaction" $ do + let app req respond = do + let expectedResp = [aesonQQ|{"id": "v1_got_it", "status": "completed", "steps": []}|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode expectedResp) + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + res <- runGeminiClient env (getInteraction "fake-key" "v1_got_it" Nothing Nothing) + case res of + Left err -> assertFailure (show err) + Right inter -> interactionId inter @?= "v1_got_it" + , testCase "Example 13: Delete Interaction" $ do + let app req respond = do + respond $ responseLBS status200 [("Content-Type", "application/json")] "{}" + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + res <- runGeminiClient env (deleteInteraction "fake-key" "v1_del_me") + case res of + Left err -> assertFailure (show err) + Right val -> val @?= [aesonQQ|{}|] + , testCase "Example 14: Embeddings (embedContent and batchEmbedContents)" $ do + let app req respond = do + let p = rawPathInfo req + if ":embedContent" `BS.isSuffixOf` p + then do + let resp = [aesonQQ|{"embedding": {"values": [0.1, 0.2, 0.3]}}|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode resp) + else + if ":batchEmbedContents" `BS.isSuffixOf` p + then do + let resp = [aesonQQ|{"embeddings": [{"values": [0.1, 0.2]}, {"values": [0.3, 0.4]}]}|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode resp) + else respond $ responseLBS status404 [] "not found" + withMockServer app $ \base -> do + env <- newGeminiClientEnvWithBaseUrl base "fake-key" + -- Single + let singleReq = EmbedContentRequest (EmbedContentPayload [EmbedPart "Query text"]) + res1 <- runGeminiClient env (embedContent "fake-key" "gemini-embedding-001" singleReq) + case res1 of + Left err -> assertFailure (show err) + Right r -> embeddingValues (responseEmbedding r) @?= [0.1, 0.2, 0.3] + -- Batch + let batchReq = + BatchEmbedContentsRequest + [ BatchEmbedRequestItem "models/gemini-embedding-001" (EmbedContentPayload [EmbedPart "Doc 1"]) + , BatchEmbedRequestItem "models/gemini-embedding-001" (EmbedContentPayload [EmbedPart "Doc 2"]) + ] + res2 <- runGeminiClient env (batchEmbedContents "fake-key" "gemini-embedding-001" batchReq) + case res2 of + Left err -> assertFailure (show err) + Right r -> length (batchEmbeddings r) @?= 2 + ] + +-- --------------------------------------------------------------------------- +-- 2. Live API Tests (executed when ~/.gemini_api_key or GEMINI_API_KEY is present) +-- --------------------------------------------------------------------------- + +liveExamplesTests :: TestTree +liveExamplesTests = + testGroup + "Live Google Gemini API Tests (~/.gemini_api_key)" + [ testCase "Live: Simple Request, Get, and Delete Interaction lifecycle" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () -- Skip if no live key available + Just key -> do + env <- newGeminiClientEnv key + let req = createModelInteraction "gemini-3.6-flash" (TextInput "Reply with the exact word PONG") + resCreate <- runGeminiClient env (createInteraction key req) + case resCreate of + Left err -> assertFailure ("Live createInteraction failed: " ++ show err) + Right inter -> do + let interId = interactionId inter + assertBool "Interaction ID is non-empty" (not (T.null interId)) + -- Test GET interaction + resGet <- runGeminiClient env (getInteraction key interId Nothing Nothing) + case resGet of + Left err -> assertFailure ("Live getInteraction failed: " ++ show err) + Right gotInter -> interactionId gotInter @?= interId + -- Test DELETE interaction + resDel <- runGeminiClient env (deleteInteraction key interId) + case resDel of + Left err -> assertFailure ("Live deleteInteraction failed: " ++ show err) + Right _ -> pure () + , testCase "Live: Multi-turn Conversation" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + let steps = + [ UserInputStep [TextContent "My favorite fruit is Mango."] + , ModelOutputStep [TextContent "Got it! Your favorite fruit is Mango."] + , UserInputStep [TextContent "What is my favorite fruit? Reply in one word."] + ] + req = createModelInteraction "gemini-3.6-flash" (StepListInput steps) + res <- runGeminiClient env (createInteraction key req) + case res of + Left err -> assertFailure ("Live multi-turn failed: " ++ show err) + Right inter -> do + interactionStatus inter @?= StatusCompleted + -- Clean up + _ <- runGeminiClient env (deleteInteraction key (interactionId inter)) + pure () + , testCase "Live: Function Calling (Tool use)" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + let weatherTool = + functionTool + "get_weather" + (Just "Get the weather for a location") + ( Just + [aesonQQ|{ + "type": "object", + "properties": { + "location": {"type": "string"} + }, + "required": ["location"] + }|] + ) + req = + (createModelInteraction "gemini-3.6-flash" (TextInput "What is the weather in Tokyo?")) + { reqTools = Just [weatherTool] + } + res <- runGeminiClient env (createInteraction key req) + case res of + Left err -> assertFailure ("Live tool call failed: " ++ show err) + Right inter -> do + interactionStatus inter @?= StatusRequiresAction + case [s | s@(FunctionCallStep {}) <- interactionSteps inter] of + (FunctionCallStep {..} : _) -> do + callName @?= "get_weather" + -- Follow up with tool result + let resultStep = + FunctionResultStep + callId + (Just callName) + [aesonQQ|{"temperature": 22, "condition": "Sunny"}|] + Nothing + followUp = + (defaultCreateInteractionRequest (StepListInput [resultStep])) + { reqModel = Just "gemini-3.6-flash" + , reqPreviousInteractionId = Just (interactionId inter) + } + resFollowUp <- runGeminiClient env (createInteraction key followUp) + case resFollowUp of + Left fErr -> assertFailure ("Live follow-up failed: " ++ show fErr) + Right completedInter -> do + interactionStatus completedInter @?= StatusCompleted + -- Clean up + _ <- runGeminiClient env (deleteInteraction key (interactionId completedInter)) + pure () + [] -> assertFailure "Expected FunctionCallStep in interaction steps" + _ <- runGeminiClient env (deleteInteraction key (interactionId inter)) + pure () + , testCase "Live: Built-in Code Execution Tool" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Run python code to compute 999 * 333")) + { reqTools = Just [CodeExecutionTool] + } + res <- runGeminiClient env (createInteraction key req) + case res of + Left err -> assertFailure ("Live code execution failed: " ++ show err) + Right inter -> do + interactionStatus inter @?= StatusCompleted + _ <- runGeminiClient env (deleteInteraction key (interactionId inter)) + pure () + , testCase "Live: Built-in Google Search Tool" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Who won the cricket world cup in 2023?")) + { reqTools = Just [GoogleSearchTool] + } + res <- runGeminiClient env (createInteraction key req) + case res of + Left err -> assertFailure ("Live google search failed: " ++ show err) + Right inter -> do + interactionStatus inter @?= StatusCompleted + _ <- runGeminiClient env (deleteInteraction key (interactionId inter)) + pure () + , testCase "Live: Background Interaction and Cancel" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + let req = + (createModelInteraction "gemini-3.6-flash" (TextInput "Write a detailed history of the universe")) + { reqBackground = Just True + } + resCreate <- runGeminiClient env (createInteraction key req) + case resCreate of + Left err -> assertFailure ("Live background create failed: " ++ show err) + Right inter -> do + let interId = interactionId inter + resCancel <- runGeminiClient env (cancelInteraction key interId) + case resCancel of + Left err -> assertFailure ("Live cancel failed: " ++ show err) + Right cancelled -> do + interactionStatus cancelled @?= StatusCancelled + _ <- runGeminiClient env (deleteInteraction key interId) + pure () + , testCase "Live: Embeddings (gemini-embedding-001)" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + env <- newGeminiClientEnv key + -- Single embed + let singleReq = EmbedContentRequest (EmbedContentPayload [EmbedPart "Haskell LangChain"]) + resSingle <- runGeminiClient env (embedContent key "gemini-embedding-001" singleReq) + case resSingle of + Left err -> assertFailure ("Live embedContent failed: " ++ show err) + Right resp -> do + let vec = embeddingValues (responseEmbedding resp) + assertBool "Embedding dimension > 0" (not (null vec)) + -- Batch embed + let batchReq = + BatchEmbedContentsRequest + [ BatchEmbedRequestItem "models/gemini-embedding-001" (EmbedContentPayload [EmbedPart "Hello"]) + , BatchEmbedRequestItem "models/gemini-embedding-001" (EmbedContentPayload [EmbedPart "World"]) + ] + resBatch <- runGeminiClient env (batchEmbedContents key "gemini-embedding-001" batchReq) + case resBatch of + Left err -> assertFailure ("Live batchEmbedContents failed: " ++ show err) + Right resp -> length (batchEmbeddings resp) @?= 2 + ] diff --git a/test/Test/Gemini/Client/TypesSpec.hs b/test/Test/Gemini/Client/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Gemini/Client/TypesSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Gemini.Client.TypesSpec (tests) where + +import Data.Aeson (decode, encode) +import qualified Data.ByteString.Lazy as LBS +import Test.Tasty +import Test.Tasty.HUnit + +import Gemini.Client.Types + +tests :: TestTree +tests = + testGroup + "Gemini.Client.TypesSpec" + [ testGroup + "InteractionStatus JSON" + [ testCase "encodes and decodes all statuses" $ do + let statuses = + [ (StatusInProgress, "\"in_progress\"") + , (StatusRequiresAction, "\"requires_action\"") + , (StatusCompleted, "\"completed\"") + , (StatusFailed, "\"failed\"") + , (StatusCancelled, "\"cancelled\"") + , (StatusIncomplete, "\"incomplete\"") + ] + mapM_ (\(st, raw) -> encode st @?= raw) statuses + mapM_ (\(st, raw) -> decode raw @?= Just st) statuses + ] + , testGroup + "SSE Events JSON" + [ testCase "SseStepDelta TextDelta" $ do + let raw = + "{\"event_type\": \"step.delta\", \"index\": 0, \"delta\": {\"type\": \"text\", \"text\": \"chunk\"}}" :: + LBS.ByteString + case decode raw of + Just (SseStepDelta idx (TextDelta txt)) -> do + idx @?= 0 + txt @?= "chunk" + other -> assertFailure ("Unexpected decode result: " ++ show other) + , testCase "SseInteractionCompleted" $ do + let raw = + "{\"event_type\": \"interaction.completed\", \"interaction\": {\"id\": \"v1_abc\", \"status\": \"completed\", \"steps\": []}}" :: + LBS.ByteString + case decode raw of + Just (SseInteractionCompleted inter) -> do + interactionId inter @?= "v1_abc" + interactionStatus inter @?= StatusCompleted + other -> assertFailure ("Unexpected decode result: " ++ show other) + ] + ] diff --git a/test/Test/Langchain/Provider/GeminiSpec.hs b/test/Test/Langchain/Provider/GeminiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/GeminiSpec.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Test.Langchain.Provider.GeminiSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Aeson (encode) +import Data.Aeson.QQ (aesonQQ) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types (status200, status500) +import Network.Wai (Application, responseLBS, responseStream) +import Network.Wai.Handler.Warp (testWithApplication) +import System.Directory (doesFileExist, getHomeDirectory) +import System.Environment (lookupEnv) +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.ByteString.Builder as Builder +import Gemini.Client (InteractionsInput (..)) +import Langchain.Cache.Core (CacheableChatModel (..)) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Embeddings.Core (Embeddings (..)) +import Langchain.Embeddings.Gemini (GeminiEmbeddings (..), defaultGeminiEmbeddings) +import Langchain.Model +import Langchain.Provider.Gemini +import Langchain.Stream (StreamEvent (..), collectEvents) +import Langchain.Tool (Tool (..), createTool) +import Langchain.Tool.Binding (ToolBinder (..)) + +withMockServer :: Application -> (T.Text -> IO a) -> IO a +withMockServer app action = + testWithApplication (pure app) $ \port -> + action $ "http://127.0.0.1:" <> T.pack (show port) + +getLiveApiKey :: IO (Maybe T.Text) +getLiveApiKey = do + mbEnv <- lookupEnv "GEMINI_API_KEY" + case mbEnv of + Just k | not (null k) -> pure (Just (T.pack k)) + _ -> do + home <- getHomeDirectory + let p = home ".gemini_api_key" + exists <- doesFileExist p + if exists + then do + txt <- T.strip <$> TIO.readFile p + pure $ if T.null txt then Nothing else Just txt + else pure Nothing + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.GeminiSpec" + [ testGroup + "Provider Initialization and Config" + [ testCase "newGemini initializes correctly" $ do + let p = newGemini "my-api-key" "gemini-3.6-flash" (Just "http://custom") + apiKey p @?= "my-api-key" + model p @?= "gemini-3.6-flash" + baseUrl p @?= Just "http://custom" + , testCase "defaultGeminiConfig has empty fields" $ do + let cfg = defaultGeminiConfig + configTools cfg @?= Nothing + configSystemInstruction cfg @?= Nothing + , testCase "cacheModelIdentity returns correct identity" $ do + let p = newGemini "key" "gemini-3.6-flash" Nothing + identity = cacheModelIdentity p (Just defaultGeminiConfig) + identity @?= [aesonQQ|{"provider": "gemini", "model": "gemini-3.6-flash"}|] + ] + , testGroup + "Message to InteractionsInput mapping" + [ testCase "single user message maps to TextInput" $ do + let msgs = [userMessage "Hello world"] + (mbSys, input) = messagesToInteractionsInput msgs + mbSys @?= Nothing + case input of + TextInput t -> t @?= "Hello world" + other -> assertFailure ("Expected TextInput, got: " ++ show other) + , testCase "system and user messages extract system instruction" $ do + let msgs = [systemMessage "Be brief", userMessage "Hello"] + (mbSys, _input) = messagesToInteractionsInput msgs + mbSys @?= Just "Be brief" + ] + , testGroup + "ChatModel invoke (Mock)" + [ testCase "invoke returns assistant message" $ do + let app _req respond = do + let resp = + [aesonQQ|{ + "id": "v1_test_invoke", + "status": "completed", + "steps": [ + { + "type": "model_output", + "content": [{"type": "text", "text": "Hello from Gemini"}] + } + ] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode resp) + withMockServer app $ \url -> do + let provider = newGemini "fake-key" "gemini-3.6-flash" (Just url) + eRes <- runExceptT $ invoke provider [userMessage "Hi"] Nothing + case eRes of + Left err -> assertFailure (show err) + Right msg -> do + messageRole msg @?= Assistant + extractMessageText msg @?= "Hello from Gemini" + , testCase "invoke redacts API key on error" $ do + let app _req respond = respond $ responseLBS status500 [] "Internal Server Error" + withMockServer app $ \url -> do + let provider = newGemini "SECRET_KEY_12345" "gemini-3.6-flash" (Just url) + eRes <- runExceptT $ invoke provider [userMessage "Hi"] Nothing + case eRes of + Left err -> do + let errStr = T.pack (show err) + assertBool "Does not contain raw secret key" (not ("SECRET_KEY_12345" `T.isInfixOf` errStr)) + Right _ -> assertFailure "Expected failure on HTTP 500" + ] + , testGroup + "ToolBinder integration" + [ testCase "bindToolsConfig binds function tool to GeminiConfig" $ do + let dummyTool :: Tool IO + dummyTool = + createTool + "calculator" + "Do math" + [aesonQQ|{"type": "object"}|] + (\_ -> pure (Right "42")) + cfg :: Maybe GeminiConfig + cfg = bindToolsConfig @Gemini [dummyTool] Nothing + case cfg of + Nothing -> assertFailure "Expected Just GeminiConfig" + Just c -> case configTools c of + Just [_] -> pure () + other -> assertFailure ("Expected tool in configTools, got: " ++ show other) + ] + , testGroup + "ChatModel stream (Mock)" + [ testCase "stream yields LLMStart, LLMChunk, and LLMEnd" $ do + let sseBody = + "data: {\"event_type\": \"step.delta\", \"index\": 0, \"delta\": {\"type\": \"text\", \"text\": \"Hello \"}}\n\n" + <> "data: {\"event_type\": \"step.delta\", \"index\": 0, \"delta\": {\"type\": \"text\", \"text\": \"World!\"}}\n\n" + <> "data: {\"event_type\": \"interaction.completed\", \"interaction\": {\"id\": \"v1_st\", \"status\": \"completed\", \"steps\": [{\"type\": \"model_output\", \"content\": [{\"type\": \"text\", \"text\": \"Hello World!\"}]}]}}\n\n" + app _req respond = + respond $ + responseStream status200 [("Content-Type", "text/event-stream")] $ \write flush -> do + write (Builder.lazyByteString sseBody) + flush + withMockServer app $ \url -> do + let provider = newGemini "fake-key" "gemini-3.6-flash" (Just url) + eEvents <- runResourceT $ runExceptT $ collectEvents $ stream provider [userMessage "Hi"] Nothing + case eEvents of + Left err -> assertFailure (show err) + Right events -> do + assertBool "Has at least 3 events" (length events >= 3) + case (events, reverse events) of + (LLMStart {} : _, LLMEnd {} : _) -> pure () + other -> assertFailure ("Unexpected events: " ++ show other) + ] + , testGroup + "Embeddings GeminiEmbeddings (Mock)" + [ testCase "embedQuery and embedDocuments return vectors" $ do + let app req respond = do + let resp = + [aesonQQ|{ + "embedding": {"values": [0.1, 0.2, 0.3]}, + "embeddings": [{"values": [0.1, 0.2]}, {"values": [0.3, 0.4]}] + }|] + respond $ responseLBS status200 [("Content-Type", "application/json")] (encode resp) + withMockServer app $ \url -> do + let emb = GeminiEmbeddings "fake-key" "gemini-embedding-001" (Just url) + -- Query + eQ <- runExceptT $ embedQuery emb "query text" + case eQ of + Left err -> assertFailure (show err) + Right vec -> vec @?= [0.1, 0.2, 0.3] + -- Docs + let doc1 = Document (TL.pack "doc1") Map.empty + doc2 = Document (TL.pack "doc2") Map.empty + eD <- runExceptT $ embedDocuments emb [doc1, doc2] + case eD of + Left err -> assertFailure (show err) + Right vecs -> length vecs @?= 2 + ] + , testGroup + "Live Langchain Integration Tests (~/.gemini_api_key)" + [ testCase "Live invoke ChatModel" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + let provider = newGemini key "gemini-3.6-flash" Nothing + eRes <- runExceptT $ invoke provider [userMessage "Say 'LANGCHAIN_OK'"] Nothing + case eRes of + Left err -> assertFailure ("Live invoke failed: " ++ show err) + Right msg -> do + messageRole msg @?= Assistant + assertBool "Contains text" (not (T.null (extractMessageText msg))) + , testCase "Live stream ChatModel" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + let provider = newGemini key "gemini-3.6-flash" Nothing + eEvents <- + runResourceT $ runExceptT $ collectEvents $ stream provider [userMessage "Count 1, 2, 3"] Nothing + case eEvents of + Left err -> assertFailure ("Live stream failed: " ++ show err) + Right events -> do + assertBool "Received streaming events" (not (null events)) + , testCase "Live Embeddings (query & docs)" $ do + mbKey <- getLiveApiKey + case mbKey of + Nothing -> pure () + Just key -> do + let emb = defaultGeminiEmbeddings key + eQ <- runExceptT $ embedQuery emb "Haskell LangChain" + case eQ of + Left err -> assertFailure ("Live embedQuery failed: " ++ show err) + Right vec -> assertBool "Dimension > 0" (not (null vec)) + let docs = [Document "Document one" Map.empty, Document "Document two" Map.empty] + eD <- runExceptT $ embedDocuments emb docs + case eD of + Left err -> assertFailure ("Live embedDocuments failed: " ++ show err) + Right vecs -> length vecs @?= 2 + ] + ]