diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,21 @@ +# Changelog + +## 0.1.0.0 + +- Initial Hub client: paginated model, dataset, and Space discovery; + revision metadata, identity, buffered and streaming file downloads. +- Hosted chat completions, feature extraction, text classification, + text generation, and generic JSON inference requests. +- Parsed identifiers, opaque tokens, explicit errors, bounded redirects, + and origin-restricted pagination and authentication. +- Offline integration tests and source-distribution CI across GHC 9.6–9.14. +- Opaque domain types for repository metadata, endpoints, and chat identifiers; + parsers refine input once and JSON decoding preserves the same guarantees. +- Structural repository identities and routed models, with total constructors + for composing parsed components and reusing response identifiers in requests. +- Nonempty conversations and embedding batches, and smart constructors for + positive limits/timeouts and bounded sampling settings. Client construction + consumes parsed configuration and no longer returns an input-error branch. +- Parsec grammars over Text for domain values and endpoint origins, and over + ByteString for Link headers, with complete input consumption and redacted + errors. Quoted Link parameters preserve escaped delimiters. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,15 @@ +# Contributing + +Bug reports, documentation improvements, and pull requests are welcome. Include +a small reproducer and your GHC/Cabal versions in a report. Remove tokens, +private repository data, and sensitive error bodies before sharing logs. + +Run `scripts/validate.sh` before submitting a change. Tests use a local HTTP +server and must not require tokens, public network access, or paid inference. +Add focused regression tests for changed request shapes, error handling, and +credential boundaries. Match the explicit exports and Haddock module headers. + +Keep dependency bounds, the CI matrix, and `tested-with` aligned. Include new +fixture files in `extra-source-files`, update the changelog for public API +changes, and verify the unpacked source distribution. Do not claim a compiler +has been tested locally unless it has actually been run. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026, Emily Pillmore + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Emily Pillmore nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,327 @@ +# huggingface + +Haskell bindings to the [Hugging Face Hub](https://huggingface.co/docs/hub/api) +and [Inference Providers](https://huggingface.co/docs/inference-providers). + +`huggingface` provides a reusable HTTP client, typed request and response +records, explicit errors, pagination, and streaming downloads. It does not +require Python or execute downloaded model code. + +## Scope + +| Area | Operations | +| --- | --- | +| Hub discovery | Search and filter models, datasets, and Spaces, one page at a time | +| Hub metadata | Repository metadata and file listings at a branch, tag, or commit | +| Identity | Look up the configured token's owner | +| Files | Buffer small files or stream large files through a callback | +| Router inference | Non-streaming chat completions, multimodal message content, tool calls | +| HF Inference | Sentence embeddings, text classification, text generation, generic JSON tasks | + +This initial release covers the operations above. It does not implement Hub +uploads or commits, snapshot caching, local inference, binary inference tasks, +or SSE streaming. `infer` targets the `hf-inference` provider; chat completion +uses the router and supports provider suffixes. Each model must be served for +the requested task. The existence of a Hub repository alone does not imply +hosted inference availability. + +## Build + +```console +cabal build all +cabal test all --test-show-details=direct +cabal haddock all +cabal sdist +``` + +The package uses Haskell2010 and targets GHC 9.6–9.14. CI builds and tests the +unpacked source distribution on Linux across that range and on macOS with +GHC 9.14. The local initial implementation was validated with GHC 9.14.1; +the CI matrix is not a claim that every compiler was run locally. + +To use this checkout from another project, add `huggingface` to its +`build-depends` and include this directory in that project's `cabal.project`: + +```cabal +packages: . /path/to/huggingface +``` + +A `default.nix` expression is supplied for Nix users. Choose a nixpkgs set +whose Haskell packages satisfy the Cabal bounds; the expression is not pinned. + +## Modules + +Import `HuggingFace` for the domain API, or use focused imports: + +| Module | Responsibility | +| --- | --- | +| `HuggingFace.Client` | Client construction, parsed endpoints, and configuration | +| `HuggingFace.Error` | Error constructors and redacted diagnostics | +| `HuggingFace.Monad` | Opaque client computations, runner, and error/IO utilities | +| `HuggingFace.Hub` | Hub operations and downloads | +| `HuggingFace.Inference` | Hosted inference operations | +| `HuggingFace.Types.Auth` | Opaque tokens and their parser | +| `HuggingFace.Types.Repository` | Repository IDs, owners, names, paths, revisions, and commit SHAs | +| `HuggingFace.Types.Hub` | Listing options, metadata tags, and Hub response records | +| `HuggingFace.Types.Routing` | Model targets, provider selection, and resolved model names | +| `HuggingFace.Types.Chat` | Chat identifiers, messages, requests, responses, and defaults | +| `HuggingFace.Types.Tasks` | Text-generation parameters and task results | +| `HuggingFace.Types.Parameters` | Constrained numeric types and smart constructors | +| `HuggingFace.Types.Pagination` | Pages and opaque continuation handles | +| `HuggingFace.Utils` | Shared parsing, JSON, and HTTP utilities | +| `HuggingFace.Internal.HTTP` | Transport implementation for building additional operations | + +`HuggingFace.Types` re-exports the domain modules and errors for convenience. +Existing imports from `HuggingFace`, `HuggingFace.Types`, `HuggingFace.Hub`, +and `HuggingFace.Inference` remain supported. Domain implementations, parsers, +and JSON instances live together. Shared helpers live in `HuggingFace.Utils`. +Every library module is exposed by Cabal, including `HuggingFace.Internal.HTTP`. +`Internal` identifies transport implementation details, not package visibility; +import it and `Utils` explicitly when extending the client. + +Module visibility does not expose raw constructors. Direct newtype accessors +are declared as record fields. `RepoId`, `InferenceModel`, and `Client` use +records for their independently meaningful components. Exported selectors +support normal Haskell record updates. +`tokenBytes` explicitly reveals the credential for custom transports; +`nextPageURL` may contain private query parameters. `Token` and `NextPage` retain +redacted `Show` instances. `nextPageFromHeaders` parses a continuation, and the +transport checks its origin when it is consumed. `repoIdParser` supports composing larger Parsec +grammars; `parseRepoId` remains the entry point for a complete external value. + +For example, building a chat request needs no transport imports: + +```haskell +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Types.Chat (ChatRequest, defaultChatRequest, userMessage) +import HuggingFace.Types.Routing (parseInferenceModel) + +prepareChat :: Text -> Text -> Either HuggingFaceError ChatRequest +prepareChat target prompt = do + model <- parseInferenceModel target + pure (defaultChatRequest model (userMessage prompt :| [])) +``` + +## Public Hub reads + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import HuggingFace + +main :: IO () +main = do + result <- runHuggingFaceM $ do + limit <- liftEither (mkPositiveInt 10) + client <- liftIO (newClient defaultClientConfig) + page <- listModels client defaultListOptions + { listSearch = Just "bert", listLimit = Just limit } + liftIO $ mapM_ (print . repoIdText . repoId) (pageItems page) + either print pure result +``` + +`listModels`, `listDatasets`, and `listSpaces` return a single `Page RepoInfo`. +`pageNext` contains an opaque continuation when another page is available. +Call `nextPage client continuation` to fetch it; the result type can be fixed +with `HuggingFaceM (Page RepoInfo)`. Pagination remains +explicit so callers control how many requests they make. `listLimit` is the +requested page size, and the server may cap it. + +`parseRepoId`, `parseRevision`, and `parseRepoPath` turn external `Text` into +opaque domain values without throwing. +For example, `modelInfo client repository (Just revision)` retrieves a +specific revision, while `Nothing` uses the default branch. Revision slashes +are encoded as part of a single URL segment. `RepoInfo` retains unknown +metadata in `repoRaw`, and optional fields remain `Nothing` when omitted. + +## Authentication and chat + +The library never reads credentials implicitly. Pass a parsed token in +`accessToken`. The example executable reads `HF_TOKEN` when it is present. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Text as T +import HuggingFace +import System.Environment (getEnv) + +main :: IO () +main = do + result <- runHuggingFaceM $ do + rawToken <- liftIO (T.pack <$> getEnv "HF_TOKEN") + rawModel <- liftIO (T.pack <$> getEnv "HF_MODEL") + token <- liftEither (parseToken rawToken) + model <- liftEither (parseInferenceModel rawModel) + limit <- liftEither (mkPositiveInt 64) + client <- liftIO $ newClient defaultClientConfig { accessToken = Just token } + let request = (defaultChatRequest model (userMessage "Hello!" :| [])) + { chatMaxTokens = Just limit } + chatCompletion client request + either print print result +``` + +Set `HF_MODEL` to a currently served model, optionally with a provider suffix. +The token needs permission to call Inference Providers. Hosted calls can incur +charges. `chatExtra` accepts provider options such as `tools`, `seed`, and +`response_format`; it cannot override reserved typed fields or enable streaming. +`ChatMessage` also accepts JSON content arrays for multimodal requests and +preserves tool calls in responses. + +The compiled example uses `optparse-applicative` and offers these commands: + +```console +cabal run huggingface-example -- models bert +cabal run huggingface-example -- model google-bert/bert-base-uncased +cabal run huggingface-example -- chat "$HF_MODEL" "Explain a Haskell functor briefly." +``` + +Only the last command invokes hosted inference. + +Use `cabal run huggingface-example -- --help` for the command overview, or +`cabal run huggingface-example -- chat --help` for command-specific help. +Missing or invalid arguments produce usage errors before reading `HF_TOKEN` +or creating a client. Repository and routed model arguments use the library's +existing domain parsers. Use `--` before a positional argument beginning with +a dash, for example `chat "$HF_MODEL" -- "--explain this flag"`. + +## Parse once, use typed values + +Text received from configuration or JSON is parsed into domain types with +hidden constructors. Request functions consume those types without reparsing. +Direct accessors such as `accountNameText` are record selectors; computed +renderers such as `repoIdText` and `revisionText` remain ordinary functions. +Record updates can replace field values, so use the parsers and smart +constructors for external input. JSON decoding uses those same parsers. +There are no partial `IsString` or `Read` instances. + +Domain and endpoint grammars use Parsec directly over strict `Text`; pagination +headers use Parsec over `ByteString`. Parsers require complete input consumption +and construct the domain values as they parse. Parser diagnostics are replaced +with redacted errors, since raw unexpected tokens may contain credentials. +Numeric smart constructors still consume numbers, and Aeson handles JSON. + +| Domain | Types and entry points | +| --- | --- | +| Repository identity | `parseRepoId`, or `qualifiedRepo` with an `AccountName` and `RepoName` | +| Repository content | `parseRepoPath`, `parseRevision`, `mainRevision`, `commitRevision` | +| Commit identity | `parseCommitSha` parses forty hex digits and normalizes case | +| Chat target | `parseInferenceModel`, or `modelFromRepo` / `routeModel` with an existing `RepoId` | +| Routing | `Fastest`, `Cheapest`, `Preferred`, or `Via` a parsed `Provider` | +| Trusted origins | `parseEndpoint` retains a parsed request; default origins need no parsing | +| Metadata | Separate `HubTag`, `PipelineTag`, `LibraryName`, `SpaceSdk`, and `SortKey` types | +| Chat identity | Separate `ChatRole`, `ToolCallId`, `ParticipantName`, `CompletionId`, `ModelName`, and `FinishReason` types | +| Constrained numbers | `mkPositiveInt`, `mkChatTemperature`, `mkTopP`, `mkGenerationTemperature` | + +Returned `repoId`, `repoSha`, `fileName`, and `userName` fields are typed too. +For example, pass `repoId info` straight to `modelInfo`, `fileName file` to +`downloadFile`, or `commitRevision sha` as a revision. `routeModel (repoId info) +Fastest` selects a chat target without rendering and reparsing its ID. + +`ChatRequest` conversations and `featureExtraction` batches use `NonEmpty`: +construct one with `first :| rest`. For a dynamic list, use +`Data.List.NonEmpty.nonEmpty` at the input boundary and handle its `Nothing` +case there. Counts, page sizes, and response timeouts use `PositiveInt`; +sampling settings have their own bounds and reject NaN and infinity. + +Free-form prompts, generated text, display names, and classifier labels remain +`Text`. Extension payloads remain JSON. Open server-defined namespaces retain +future nonblank values rather than enumerating today's tags, roles, or stop +reasons. A provider's resolved `ModelName` is distinct from a router +`InferenceModel`, since provider aliases need not be Hub repository names. +`CompletionId` preserves empty IDs returned by Hugging Face / TGI. +`String` conversions are confined to dependencies that require them; HTTP +headers and file contents remain bytes. + +This is an API change from the initial unpublished scaffold: `mkToken`, +`mkRepoId`, `mkRevision`, and `mkRepoPath` are now `parseToken`, `parseRepoId`, +`parseRevision`, and `parseRepoPath`. `newClient` returns `IO Client`, and +`newClientWithManager` returns `Client`; configuration failures are handled +while constructing the typed configuration. + +## Downloads + +`downloadFile client kind repository revision path` buffers a file in memory. +Use `withDownload` for model weights. It supplies an `http-client` `BodyReader` +to a `HuggingFaceM` callback and releases the connection on success, typed error, +or IO exception: + +```haskell +import qualified Data.ByteString as BS +import HuggingFace.Monad (HuggingFaceM, liftIO) +import Network.HTTP.Client (BodyReader, brRead) +import System.IO (Handle) + +copyBody :: Handle -> BodyReader -> HuggingFaceM () +copyBody handle reader = do + chunk <- liftIO (brRead reader) + if BS.null chunk + then pure () + else liftIO (BS.hPut handle chunk) >> copyBody handle reader +``` + +Pass `copyBody handle` as the last argument to `withDownload`. The caller owns +the output handle, path selection, overwrite policy, and cleanup of partially +written files. Do not retain the reader after the callback returns. The +library follows at most five GET redirects and removes authentication when +crossing origins, including ports. HTTPS cannot redirect to HTTP. + +## Errors and configuration + +Client operations return `HuggingFaceM a`, an opaque newtype over +`ExceptT HuggingFaceError IO` with `Functor`, `Applicative`, `Monad`, `MonadIO`, +and `MonadError HuggingFaceError` instances. Compose operations in a `do` block; +an error stops subsequent actions. Run the whole computation once with +`runHuggingFaceM :: HuggingFaceM a -> IO (Either HuggingFaceError a)` at the +application boundary. The transformer constructor is not exposed. + +`HuggingFace.Monad` and the convenience import `HuggingFace` provide `liftEither` +for pure smart-constructor results, `liftIO` for ordinary IO, and `throwError` +and `catchError` for explicit error handling. These are the standard +[`mtl` operations](https://hackage.haskell.org/package/mtl-2.3.1/docs/Control-Monad-Except.html). +`liftHuggingFaceM` adapts existing `IO (Either HuggingFaceError a)` actions. +Pure parsers remain pure, and `newClient` still returns `IO Client`. + +For example, recover from a missing repository while preserving other errors: + +```haskell +import HuggingFace + +findModel :: Client -> RepoId -> HuggingFaceM (Maybe RepoInfo) +findModel client repository = + (Just <$> modelInfo client repository Nothing) `catchError` \err -> + case err of + HttpError {errorStatus = 404} -> pure Nothing + _ -> throwError err +``` + +HTTP errors retain status, +request ID, `Retry-After`, and at most 64 KiB of response content. `Show` +omits response bodies and headers; treat those fields as sensitive when +inspecting them yourself. Invalid JSON and schema mismatches return +`DecodeError`. Transport failures are classified without retaining or printing +the request. Asynchronous exceptions and non-HTTP callback exceptions propagate; +neither `catchError` nor `runHuggingFaceM` catches them. A typed error leaving a +download callback closes its response before an outer `catchError` handler runs. + +`newClient` creates a reusable TLS connection pool with transport retries +disabled. POSTs are never followed across redirects or automatically retried. +This avoids silently replaying a potentially billable request. Callers can +implement their own explicit retry policy using the returned status and headers. + +`newClientWithManager` accepts a caller-owned manager. When constructing that +manager, set `managerRetryableException = const False` to retain the no-replay +guarantee. The caller is also responsible for its TLS, proxy, and request hooks. +Only configure trusted Hub/inference origins, because the configured token +is sent to both. HTTPS is required except for loopback HTTP development servers. +Parse a custom origin with `parseEndpoint` before putting it in the configuration. +The default response timeout is 30 seconds; set `timeoutMicroseconds` to a +`PositiveInt` built with `mkPositiveInt` to change it. + +Successful JSON responses and `downloadFile` are buffered without a size cap. +Use bounded page sizes and `withDownload` for large content. Public requests +are subject to Hugging Face rate limits; no automatic background requests occur. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple (defaultMain) + +main :: IO () +main = defaultMain diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -0,0 +1,8 @@ +{ nixpkgs ? import {}, compiler ? "default" }: +let + haskellPackages = if compiler == "default" + then nixpkgs.haskellPackages + else nixpkgs.haskell.packages.${compiler}; + package = haskellPackages.callCabal2nix "huggingface" ./. {}; +in + if nixpkgs.lib.inNixShell then package.env else package diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Main +-- Description : Small command-line examples of the Hugging Face client +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module Main (main) where + +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import HuggingFace +import qualified Options.Applicative as Options +import System.Environment (lookupEnv) +import System.Exit (die) + +data Command + = SearchModels Text + | ShowModel RepoId + | RunChat InferenceModel Text + +commandInfo :: Options.ParserInfo Command +commandInfo = Options.info (Options.helper <*> commandParser) + ( Options.fullDesc + <> Options.progDesc "Query the Hugging Face Hub or run a hosted chat completion" + <> Options.footer "Authentication: set HF_TOKEN for authenticated requests. The chat command may incur provider charges." + ) + +commandParser :: Options.Parser Command +commandParser = Options.hsubparser + ( Options.command "models" (Options.info searchModels (Options.progDesc "Search models (up to ten results)")) + <> Options.command "model" (Options.info showModel (Options.progDesc "Show repository metadata")) + <> Options.command "chat" (Options.info runChat (Options.progDesc "Run a hosted chat completion")) + ) + where + searchModels = SearchModels <$> Options.strArgument + (Options.metavar "SEARCH" <> Options.help "Model search text") + showModel = ShowModel <$> Options.argument (domainReader parseRepoId) + (Options.metavar "OWNER/NAME" <> Options.help "Hub repository ID (a bare name is also accepted)") + runChat = RunChat + <$> Options.argument (domainReader parseInferenceModel) + (Options.metavar "MODEL" <> Options.help "Model repository with an optional provider or routing suffix") + <*> Options.strArgument (Options.metavar "PROMPT" <> Options.help "Prompt text; quote multiword prompts") + +domainReader :: (Text -> Either HuggingFaceError a) -> Options.ReadM a +domainReader parse = Options.eitherReader (first show . parse . T.pack) + +-- | Run a Hub query or an explicitly requested hosted chat completion. +main :: IO () +main = do + command <- Options.customExecParser (Options.prefs Options.showHelpOnEmpty) commandInfo + result <- runHuggingFaceM $ do + tokenText <- liftIO (lookupEnv "HF_TOKEN") + token <- liftEither (traverse (parseToken . T.pack) tokenText) + client <- liftIO $ newClient defaultClientConfig + { accessToken = token + } + case command of + SearchModels query -> do + limit <- liftEither (mkPositiveInt 10) + page <- listModels client defaultListOptions {listSearch = Just query, listLimit = Just limit} + liftIO $ mapM_ (T.putStrLn . repoIdText . repoId) (pageItems page) + ShowModel repository -> do + info <- modelInfo client repository Nothing + liftIO (print info) + RunChat target prompt -> do + completion <- chatCompletion client (defaultChatRequest target (userMessage prompt :| [])) + liftIO $ mapM_ (print . choiceMessage) (completionChoices completion) + either (die . show) pure result diff --git a/huggingface.cabal b/huggingface.cabal new file mode 100644 --- /dev/null +++ b/huggingface.cabal @@ -0,0 +1,96 @@ +cabal-version: 3.0 +name: huggingface +version: 0.1.0.0 +synopsis: Haskell bindings to the Hugging Face Hub and Inference APIs +description: + A typed HTTP client for discovering models, datasets, and Spaces on the + Hugging Face Hub, retrieving repository metadata and files, and running + hosted inference. Includes chat completions, feature extraction, text + generation, and classification, with explicit errors and pagination. +homepage: https://github.com/emilypi/huggingface +bug-reports: https://github.com/emilypi/huggingface/issues +license: BSD-3-Clause +license-file: LICENSE +author: Emily Pillmore +maintainer: Emily Pillmore +copyright: (c) 2026 Emily Pillmore +category: Network, Machine Learning +build-type: Simple +tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 +extra-doc-files: + README.md + CHANGELOG.md + CONTRIBUTING.md +extra-source-files: + scripts/validate.sh + default.nix + +source-repository head + type: git + location: https://github.com/emilypi/huggingface.git + +common settings + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates + build-depends: base >=4.18 && <4.23 + +library + import: settings + hs-source-dirs: src + exposed-modules: + HuggingFace + HuggingFace.Client + HuggingFace.Error + HuggingFace.Hub + HuggingFace.Inference + HuggingFace.Monad + HuggingFace.Types + HuggingFace.Types.Auth + HuggingFace.Types.Chat + HuggingFace.Types.Hub + HuggingFace.Types.Pagination + HuggingFace.Types.Parameters + HuggingFace.Types.Repository + HuggingFace.Types.Routing + HuggingFace.Types.Tasks + HuggingFace.Utils + HuggingFace.Internal.HTTP + build-depends: + aeson >=2.1 && <2.4 + , bytestring >=0.11 && <0.13 + , http-client >=0.7.13 && <0.8 + , http-client-tls >=0.3.6 && <0.5 + , http-types >=0.12 && <0.13 + , mtl >=2.3.1 && <2.4 + , network-uri >=2.6 && <2.7 + , parsec >=3.1.16 && <3.2 + , text >=2.0 && <2.3 + +test-suite huggingface-tests + import: settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts + build-depends: + huggingface + , aeson + , bytestring + , http-client + , http-types + , tasty >=1.4 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck >=0.10 && <0.12 + , text + , wai >=3.2 && <3.3 + , warp >=3.3 && <3.5 + +executable huggingface-example + import: settings + hs-source-dirs: examples + main-is: Main.hs + ghc-options: -threaded + build-depends: + huggingface + , optparse-applicative >=0.18 && <0.20 + , text diff --git a/scripts/validate.sh b/scripts/validate.sh new file mode 100644 --- /dev/null +++ b/scripts/validate.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash +set -euo pipefail +cd "$(dirname "$0")/.." +cabal check +cabal build all --enable-tests --ghc-options=-Werror +cabal test all --test-show-details=direct --ghc-options=-Werror +cabal haddock all +cabal sdist diff --git a/src/HuggingFace.hs b/src/HuggingFace.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace.hs @@ -0,0 +1,26 @@ +-- | +-- Module : HuggingFace +-- Description : Haskell client for the Hugging Face Hub and hosted inference +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +-- +-- Create a reusable 'Client' with 'newClient' and 'defaultClientConfig'. +-- Parse repository names with 'parseRepoId', then call 'modelInfo', +-- 'listModels', or 'chatCompletion'. See the README for complete examples. +-- Compose operations in 'HuggingFaceM' and run them with 'runHuggingFaceM'. +module HuggingFace + ( module HuggingFace.Client + , module HuggingFace.Hub + , module HuggingFace.Inference + , module HuggingFace.Monad + , module HuggingFace.Types + ) where + +import HuggingFace.Client +import HuggingFace.Hub +import HuggingFace.Inference +import HuggingFace.Monad +import HuggingFace.Types diff --git a/src/HuggingFace/Client.hs b/src/HuggingFace/Client.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Client.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Client +-- Description : Connection pooling, authentication, and endpoint configuration +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Client + ( Client, ClientConfig (..), defaultClientConfig, newClient, newClientWithManager + , clientManager, clientHub, clientInference, clientToken, clientTimeout + , Endpoint, parseEndpoint, endpointText, defaultHubEndpoint, defaultInferenceEndpoint + ) where + +import Control.Monad (when) +import Data.Char (isDigit, ord) +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP.Client + ( Manager, Request, defaultRequest, getUri, host, managerRetryableException + , newManager, parseRequest, port, secure ) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.URI (parseURI) +import qualified Text.Parsec as P +import HuggingFace.Error (HuggingFaceError (..)) +import HuggingFace.Utils (TextParser, parseText, matched) +import HuggingFace.Types.Auth (Token) +import HuggingFace.Types.Parameters (PositiveInt, positiveIntValue, defaultTimeout) + +-- | Reusable connection pool, parsed endpoints, and credentials. Construct a +-- client with 'newClient' or 'newClientWithManager'. +data Client = Client + { clientManager :: Manager -- ^ Connection manager used by this client. + , clientHub :: Request -- ^ Parsed Hub origin, without request credentials or endpoint-specific paths. + , clientInference :: Request -- ^ Parsed inference origin, without request credentials or task-specific paths. + , clientToken :: Maybe Token -- ^ Optional credential for this client's configured origins. + , clientTimeout :: Int -- ^ Response timeout in microseconds. + } + +-- | Parsed HTTP(S) origin. The request representation is retained so client +-- construction never reparses URLs. Plain HTTP is restricted to loopback. +newtype Endpoint = Endpoint Request + +instance Show Endpoint where + show = show . endpointText + +instance Eq Endpoint where + a == b = endpointText a == endpointText b + +-- | Parse an HTTPS origin (or loopback HTTP origin), with no credentials, +-- non-root path, query, or fragment. Parse errors never echo the input. +parseEndpoint :: Text -> Either HuggingFaceError Endpoint +parseEndpoint input = do + (tls, parsedPort) <- parseText malformed origin input + -- Delegate complete RFC URI / IPv6 syntax to network-uri (itself backed by + -- Parsec), then adapt to http-client's required String API. The origin + -- grammar has already consumed the entire input and bounded the port. + _ <- maybe (Left malformed) Right (parseURI (T.unpack input)) + request <- maybe (Left malformed) Right (parseRequest (T.unpack input) :: Maybe Request) + pure (Endpoint request {secure = tls, port = parsedPort}) + where + malformed = InvalidInput "Endpoint requires an HTTPS origin, or loopback HTTP origin, with a port in 1–65535 and no credentials, path, query, or fragment" + +origin :: TextParser (Bool, Int) +origin = do + _ <- P.string "http" + tls <- P.option False (True <$ P.char 's') + _ <- P.string "://" + hostname <- matched $ + P.between (P.char '[') (P.char ']') (P.skipMany1 (P.noneOf "]")) + P.<|> P.skipMany1 (P.satisfy (\c -> c /= ':' && c /= '/' && c /= '?' && c /= '#' && c /= '@' && c /= '[' && c /= ']')) + parsedPort <- P.option (if tls then 443 else 80) (P.char ':' *> portNumber) + P.optional (P.char '/') + if tls || hostname `elem` ["localhost", "127.0.0.1", "[::1]"] + then pure (tls, parsedPort) + else P.parserFail "Plain HTTP requires loopback" + +-- | Render the parsed origin. A missing root slash is normalized to @/@. +endpointText :: Endpoint -> Text +endpointText (Endpoint request) = T.pack (show (getUri request)) + +-- | Public Hub origin. +defaultHubEndpoint :: Endpoint +defaultHubEndpoint = Endpoint defaultRequest {secure = True, host = "huggingface.co", port = 443} + +-- | Public Inference Providers router origin. +defaultInferenceEndpoint :: Endpoint +defaultInferenceEndpoint = Endpoint defaultRequest {secure = True, host = "router.huggingface.co", port = 443} + +-- | Trusted client configuration built from parsed endpoints and a positive +-- timeout. The same token is sent to both origins: only configure endpoints +-- that you trust with it. +data ClientConfig = ClientConfig + { hubEndpoint :: Endpoint -- ^ Default: 'defaultHubEndpoint'. + , inferenceEndpoint :: Endpoint -- ^ Default: 'defaultInferenceEndpoint'. + , accessToken :: Maybe Token -- ^ Optional for public Hub reads. + , timeoutMicroseconds :: PositiveInt -- ^ Positive timeout, default thirty seconds. + } deriving (Show) + +-- | Public Hugging Face endpoints with no token and a thirty-second timeout. +defaultClientConfig :: ClientConfig +defaultClientConfig = ClientConfig defaultHubEndpoint defaultInferenceEndpoint Nothing defaultTimeout + +-- | Create a reusable TLS connection pool. Configuration is already parsed; +-- constructing the client does not perform any network requests. +newClient :: ClientConfig -> IO Client +newClient config = do + manager <- newManager tlsManagerSettings {managerRetryableException = const False} + pure (newClientWithManager manager config) + +-- | Use a caller-owned manager. The caller controls its TLS, proxy, and lifetime +-- settings; request-altering manager hooks must not reintroduce credentials. +-- Set @managerRetryableException = const False@ when creating it: http-client's +-- default retry policy can replay a POST if a reused connection loses a response. +-- The no-automatic-retry guarantee requires this setting for custom managers. +newClientWithManager :: Manager -> ClientConfig -> Client +newClientWithManager manager config = + let Endpoint hub = hubEndpoint config + Endpoint inference = inferenceEndpoint config + in Client manager hub inference (accessToken config) (positiveIntValue (timeoutMicroseconds config)) + +-- Accumulate with a bounded Int; fail before a later digit could overflow. +-- Leading zeroes are allowed, but a zero port is not a usable endpoint. +portNumber :: TextParser Int +portNumber = do + first <- digit + number <- rest first + when (number == 0) (P.parserFail "Zero port") + pure number + where + digit = (\c -> ord c - ord '0') <$> P.satisfy isDigit + rest n = P.option n $ do + d <- digit + let next = 10 * n + d + when (next > 65535) (P.parserFail "Port out of range") + rest next diff --git a/src/HuggingFace/Error.hs b/src/HuggingFace/Error.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Error.hs @@ -0,0 +1,43 @@ +-- | +-- Module : HuggingFace.Error +-- Description : Client errors and redacted diagnostics +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Error + ( HuggingFaceError (..) + ) where + +import Data.ByteString (ByteString) +import Data.Text (Text) + +-- | Client failures. HTTP response bodies and headers are retained for callers +-- but omitted from 'Show', since servers can echo credentials or private data. +-- Transport exceptions are classified without retaining their credential-bearing +-- request. Asynchronous and non-HTTP callback exceptions propagate; HTTP +-- exceptions raised while reading a download become 'TransportError'. +data HuggingFaceError + = InvalidInput Text + | TransportError Text + | HttpError + { errorStatus :: Int + , errorBody :: ByteString -- ^ At most 64 KiB of response content; treat as sensitive. + , errorRequestId :: Maybe ByteString + , errorRetryAfter :: Maybe ByteString + } + | DecodeError -- ^ A successful response did not match its expected JSON schema. + | UnsafeRedirect -- ^ Cross-origin API redirect, invalid location, or HTTPS downgrade. + | TooManyRedirects -- ^ More than five redirects. + | InvalidPagination -- ^ A continuation does not point at the configured Hub origin. + deriving (Eq) + +instance Show HuggingFaceError where + show (InvalidInput message) = "InvalidInput " ++ show message + show (TransportError message) = "TransportError " ++ show message + show HttpError {errorStatus = code} = "HttpError " ++ show code + show DecodeError = "DecodeError" + show UnsafeRedirect = "UnsafeRedirect" + show TooManyRedirects = "TooManyRedirects" + show InvalidPagination = "InvalidPagination" diff --git a/src/HuggingFace/Hub.hs b/src/HuggingFace/Hub.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Hub.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Hub +-- Description : Repository discovery, metadata, and streamed file downloads +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Hub + ( ListOptions (..), defaultListOptions + , listModels, listDatasets, listSpaces, nextPage + , repositoryInfo, modelInfo, datasetInfo, spaceInfo, whoAmI + , downloadFile, withDownload + ) where + +import Data.Aeson (FromJSON) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client (BodyReader, brConsume, requestHeaders, responseBody) +import Network.HTTP.Types (Query, hAccept) +import HuggingFace.Internal.HTTP +import HuggingFace.Client (Client, clientHub) +import HuggingFace.Monad (HuggingFaceM, liftIO) +import HuggingFace.Types.Hub +import HuggingFace.Types.Parameters (positiveIntValue) +import HuggingFace.Types.Pagination (Page, NextPage) +import HuggingFace.Types.Repository + +-- | Fetch one page of models. +listModels :: Client -> ListOptions -> HuggingFaceM (Page RepoInfo) +listModels = listRepositories Model + +-- | Fetch one page of datasets. +listDatasets :: Client -> ListOptions -> HuggingFaceM (Page RepoInfo) +listDatasets = listRepositories Dataset + +-- | Fetch one page of Spaces. +listSpaces :: Client -> ListOptions -> HuggingFaceM (Page RepoInfo) +listSpaces = listRepositories Space + +listRepositories :: RepoType -> Client -> ListOptions -> HuggingFaceM (Page RepoInfo) +listRepositories kind client options = getPage client (requestFor client (clientHub client) ["api", repoPlural kind] (listQuery options)) + +listQuery :: ListOptions -> Query +listQuery options = catMaybes + [ field "search" (listSearch options) + , field "author" (accountNameText <$> listAuthor options) + , field "sort" (sortKeyText <$> listSort options) + , (\n -> ("limit", Just (B8.pack (show (positiveIntValue n))))) <$> listLimit options + ] ++ [("filter", Just (encodeUtf8 (hubTagText f))) | f <- listFilter options] + ++ [("full", Just "true") | listFull options] + where + field key = fmap (\value -> (key, Just (encodeUtf8 value))) + +-- | Fetch a continuation obtained from a page. Only the configured Hub origin +-- is accepted, even when the continuation came from another client's page. +nextPage :: FromJSON a => Client -> NextPage -> HuggingFaceM (Page a) +nextPage = continuePage + +-- | Repository metadata at the default branch or an explicit revision. +-- Requests file sizes through @blobs=true@. +repositoryInfo :: Client -> RepoType -> RepoId -> Maybe Revision -> HuggingFaceM RepoInfo +repositoryInfo client kind repository revision = getJSON client $ + requestFor client (clientHub client) + (["api", repoPlural kind] ++ T.splitOn "/" (repoIdText repository) + ++ maybe [] (\r -> ["revision", revisionText r]) revision) + [("blobs", Just "true")] + +-- | Model metadata, optionally pinned to a revision. +modelInfo :: Client -> RepoId -> Maybe Revision -> HuggingFaceM RepoInfo +modelInfo client = repositoryInfo client Model + +-- | Dataset metadata, optionally pinned to a revision. +datasetInfo :: Client -> RepoId -> Maybe Revision -> HuggingFaceM RepoInfo +datasetInfo client = repositoryInfo client Dataset + +-- | Space metadata, optionally pinned to a revision. +spaceInfo :: Client -> RepoId -> Maybe Revision -> HuggingFaceM RepoInfo +spaceInfo client = repositoryInfo client Space + +-- | Identify the token's owner. Requires an access token. +whoAmI :: Client -> HuggingFaceM UserInfo +whoAmI client = getJSON client (requestFor client (clientHub client) ["api", "whoami-v2"] []) + +-- | Buffer a file in memory. Use 'withDownload' for large model weights. +downloadFile :: Client -> RepoType -> RepoId -> Revision -> RepoPath -> HuggingFaceM BL.ByteString +downloadFile client kind repository revision file = + withDownload client kind repository revision file (liftIO . fmap BL.fromChunks . brConsume) + +-- | Stream a repository file to a callback. The body reader is valid only while +-- the callback runs. Connections close on success, typed error, or exception. +-- HTTP failures use the monad's error channel; other IO exceptions propagate. +-- No filesystem paths are chosen or written by the library. Credentials are removed on CDN redirects; +-- an HTTPS request can never redirect to HTTP. At most five redirects are followed. +withDownload :: Client -> RepoType -> RepoId -> Revision -> RepoPath -> (BodyReader -> HuggingFaceM a) -> HuggingFaceM a +withDownload client kind repository revision file consume = + withBody True client request (consume . responseBody) + where + prefix = case kind of Model -> []; _ -> [repoPlural kind] + baseRequest = requestFor client (clientHub client) + (prefix ++ T.splitOn "/" (repoIdText repository) ++ ["resolve", revisionText revision] + ++ T.splitOn "/" (repoPathText file)) [] + request = baseRequest + { requestHeaders = (hAccept, "*/*") : filter ((/= hAccept) . fst) (requestHeaders baseRequest) + } diff --git a/src/HuggingFace/Inference.hs b/src/HuggingFace/Inference.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Inference.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Inference +-- Description : Hosted chat completions and HF Inference tasks +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Inference + ( ChatMessage (..), userMessage, systemMessage, assistantMessage + , ChatRequest (..), defaultChatRequest, ChatCompletion (..), ChatChoice (..), Usage (..) + , chatCompletion + , GenerationParameters (..), defaultGenerationParameters, GeneratedText (..), textGeneration + , Classification (..), classifyText, featureExtraction + , infer + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.Types (Parser, parseEither) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as T +import HuggingFace.Internal.HTTP +import HuggingFace.Client (Client, clientInference) +import HuggingFace.Error (HuggingFaceError (..)) +import HuggingFace.Monad (HuggingFaceM, throwError) +import HuggingFace.Types.Chat +import HuggingFace.Types.Repository (RepoId, repoIdText) +import HuggingFace.Types.Tasks + +-- | Submit a non-streaming chat completion. Calls may incur provider charges. +-- This operation is never automatically retried or replayed on a redirect. +chatCompletion + :: Client + -> ChatRequest + -> HuggingFaceM ChatCompletion +chatCompletion client = + postJSON client + (requestFor + client (clientInference client) + ["v1", "chat", "completions"] + [] + ) + +newtype Generations = Generations { _getGenerations :: [GeneratedText] } + +instance FromJSON Generations where + parseJSON value = Generations <$> (parseJSON value <|> ((: []) <$> parseJSON value)) + +-- | Generate text using a model served by @hf-inference@. Task availability +-- depends on the model/provider; use 'chatCompletion' for router-hosted LLMs. +textGeneration + :: Client + -> RepoId + -> Text + -> GenerationParameters + -> HuggingFaceM [GeneratedText] +textGeneration client model prompt parameters = + _getGenerations <$> + infer client model (object ["inputs" .= prompt, "parameters" .= parameters, "stream" .= False]) + +-- | Classify one input. Accepts the flat and single-batch response shapes used +-- by HF Inference. Multiple batches for a single input are rejected. +classifyText :: Client -> RepoId -> Text -> HuggingFaceM [Classification] +classifyText client model input = do + result <- infer client model (object ["inputs" .= input]) + either (const (throwError DecodeError)) pure (parseEither parseLabels result) + where + parseLabels value = parseJSON value <|> do + batches <- parseJSON value :: Parser [[Classification]] + case batches of + [labels] -> pure labels + _ -> fail "Expected one classification batch" + +-- | Compute sentence embeddings for a nonempty batch. Uses the explicit +-- @/pipeline/feature-extraction@ route. Models returning token-level tensors +-- instead of one vector per input are outside this convenience function's schema. +featureExtraction :: Client -> RepoId -> NonEmpty Text -> HuggingFaceM [[Double]] +featureExtraction client model inputs = + postJSON client + (requestFor client (clientInference client) + (["hf-inference", "models"] ++ T.splitOn "/" (repoIdText model) ++ ["pipeline", "feature-extraction"]) []) + (object ["inputs" .= inputs]) + +-- | Send a caller-defined JSON request to a model's default HF Inference task. +-- Use this for task-specific request/response schemas beyond the typed helpers. +-- This does not route to arbitrary providers. Binary and SSE responses are not +-- decoded here. No model code executes locally, and requests are not retried. +infer :: (ToJSON request, FromJSON response) => Client -> RepoId -> request -> HuggingFaceM response +infer client model = postJSON client + (requestFor client (clientInference client) (["hf-inference", "models"] ++ T.splitOn "/" (repoIdText model)) []) diff --git a/src/HuggingFace/Internal/HTTP.hs b/src/HuggingFace/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Internal/HTTP.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Internal.HTTP +-- Description : HTTP transport and credential-safe redirects +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +-- +-- Transport implementation shared by the Hub and inference APIs. This module +-- is exposed for callers building additional operations; 'requestFor' prepares +-- requests using the client's configuration. Import it explicitly rather than +-- through the "HuggingFace" convenience facade. +module HuggingFace.Internal.HTTP + ( requestFor, getJSON, postJSON, getPage, continuePage, withBody + ) where + +import Control.Exception (catch) +import Data.Aeson (FromJSON, ToJSON, encode) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import Network.HTTP.Client hiding (TooManyRedirects) +import Network.HTTP.Types +import Network.URI (URI (..), URIAuth (..), parseURIReference, relativeTo) +import HuggingFace.Error (HuggingFaceError (..)) +import HuggingFace.Monad +import HuggingFace.Types.Auth (tokenBytes) +import HuggingFace.Client (Client, clientManager, clientHub, clientToken, clientTimeout) +import HuggingFace.Utils (encodeSegments, readAtMost, sameOrigin, decodeJSON) +import HuggingFace.Types.Pagination (Page (..), NextPage, nextPageFromHeaders, nextPageURL) + +-- | Prepare a request for a trusted origin. Encodes path segments, sets the +-- timeout and bearer token, and disables automatic redirects and status throws. +-- The supplied origin must be trusted with the client's credential. +requestFor :: Client -> Request -> [Text] -> Query -> Request +requestFor client base segments query = base + { path = encodeSegments segments + , queryString = renderQuery True query + , redirectCount = 0 + , checkResponse = \_ _ -> pure () + , responseTimeout = responseTimeoutMicro (clientTimeout client) + , cookieJar = Nothing + , requestHeaders = [(hAccept, "application/json"), (hUserAgent, "huggingface-haskell/0.1.0.0")] + ++ case clientToken client of + Nothing -> [] + Just token -> [(hAuthorization, "Bearer " <> tokenBytes token)] + } + +-- | Execute a prepared request and decode JSON. GET redirects stay on-origin; +-- response and decoding failures use the library's redacted error types. +getJSON :: FromJSON a => Client -> Request -> HuggingFaceM a +getJSON client request = do + (_, _, body) <- getBytes client request + liftEither (decodeJSON body) + +-- | Submit JSON with a prepared request and decode its response. POST redirects +-- are not followed; use a manager with transport retries disabled. +postJSON :: (ToJSON a, FromJSON b) => Client -> Request -> a -> HuggingFaceM b +postJSON client request payload = getJSON client request + { method = methodPost + , requestBody = RequestBodyLBS (encode payload) + , requestHeaders = (hContentType, "application/json") : requestHeaders request + } + +getBytes :: Client -> Request -> HuggingFaceM (Request, ResponseHeaders, BL.ByteString) +getBytes client request = withBody False client request $ \response -> do + chunks <- liftIO (brConsume (responseBody response)) + pure (getOriginalRequest response, responseHeaders response, BL.fromChunks chunks) + +-- | Decode a JSON array and its Link continuation from a prepared request. +getPage :: FromJSON a => Client -> Request -> HuggingFaceM (Page a) +getPage client request = do + (finalRequest, headers, body) <- getBytes client request + items <- liftEither (decodeJSON body) + pure (Page items (nextPageFromHeaders finalRequest headers)) + +-- | Fetch a continuation only if it resolves to the configured Hub origin. +continuePage :: FromJSON a => Client -> NextPage -> HuggingFaceM (Page a) +continuePage client next = case redirectTarget False (clientHub client) (nextPageURL next) of + Right target | sameOrigin target (clientHub client) -> + let request = requestFor client target [] [] + in getPage client request {path = path target, queryString = queryString target} + _ -> throwError InvalidPagination + +-- | Consume a successful response while its body reader is in scope. Setting +-- the first argument to 'True' allows external GET redirects and strips +-- credentials when crossing origins. HTTPS downgrades are always rejected. +-- The response and its socket are closed before following another redirect. +-- Only GET redirects are followed; replaying a billable POST is never implicit. +-- Typed callback errors close the response before propagating to the caller. +withBody :: Bool -> Client -> Request -> (Response BodyReader -> HuggingFaceM a) -> HuggingFaceM a +withBody allowExternal client initial consume = go (5 :: Int) initial + where + go remaining request = do + outcome <- liftHuggingFaceM $ catchHTTP $ + withResponse request (clientManager client) $ \response -> runHuggingFaceM $ do + let code = statusCode (responseStatus response) + if code >= 200 && code < 300 + then Right <$> consume response + else if method request == methodGet && code `elem` [301, 302, 303, 307, 308] + then if remaining <= 0 then throwError TooManyRedirects else + case lookup hLocation (responseHeaders response) of + Nothing -> throwError UnsafeRedirect + Just location -> Left <$> liftEither (redirectTarget allowExternal request location) + else liftIO (responseError response) >>= throwError + case outcome of + Right value -> pure value + Left target -> go (remaining - 1) target + +catchHTTP :: IO (Either HuggingFaceError a) -> IO (Either HuggingFaceError a) +catchHTTP action = action `catch` handler + where + handler :: HttpException -> IO (Either HuggingFaceError a) + handler (HttpExceptionRequest _ ResponseTimeout) = pure (Left (TransportError "Response timeout")) + handler (HttpExceptionRequest _ ConnectionTimeout) = pure (Left (TransportError "Connection timeout")) + handler _ = pure (Left (TransportError "HTTP transport failure")) + +responseError :: Response BodyReader -> IO HuggingFaceError +responseError response = do + body <- readAtMost 65536 (responseBody response) + let headers = responseHeaders response + pure HttpError + { errorStatus = statusCode (responseStatus response) + , errorBody = body + , errorRequestId = lookup "x-request-id" headers + , errorRetryAfter = lookup "retry-after" headers + } + +redirectTarget :: Bool -> Request -> ByteString -> Either HuggingFaceError Request +redirectTarget allowExternal current location = do + reference <- maybe (Left UnsafeRedirect) Right (parseURIReference (B8.unpack location)) + let uri = reference `relativeTo` getUri current + case uriAuthority uri of + Just auth | null (uriUserInfo auth) && uriScheme uri `elem` ["http:", "https:"] -> pure () + _ -> Left UnsafeRedirect + target <- maybe (Left UnsafeRedirect) Right (parseRequest (show uri) :: Maybe Request) + if (secure current && not (secure target)) || (not allowExternal && not (sameOrigin current target)) + then Left UnsafeRedirect + else Right target + { method = methodGet + , redirectCount = 0 + , checkResponse = \_ _ -> pure () + , responseTimeout = responseTimeout current + , cookieJar = Nothing + , requestHeaders = if sameOrigin current target then requestHeaders current + else filter (\(key, _) -> key /= hAuthorization && key /= hCookie) (requestHeaders current) + } diff --git a/src/HuggingFace/Monad.hs b/src/HuggingFace/Monad.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Monad.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : HuggingFace.Monad +-- Description : Concrete client computations with typed errors +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +-- +-- Compose client operations in t'HuggingFaceM' and call 'runHuggingFaceM' at +-- the application's IO boundary. The constructor and transformer representation +-- are opaque; the standard 'MonadIO' and 'MonadError' operations are available. +module HuggingFace.Monad + ( HuggingFaceM, runHuggingFaceM, liftHuggingFaceM + , liftEither, liftIO, throwError, catchError + ) where + +import Control.Monad.Except + ( ExceptT (..), MonadError, catchError, liftEither, runExceptT, throwError ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import HuggingFace.Error (HuggingFaceError) + +-- | A concrete computation over @ExceptT HuggingFaceError IO@. +-- Typed errors stop subsequent actions unless handled with 'catchError'. +-- Ordinary IO exceptions and asynchronous cancellation remain IO exceptions; +-- 'catchError' does not intercept them. HTTP operations translate transport +-- exceptions into the library's redacted errors at the transport boundary. +newtype HuggingFaceM a = HuggingFaceM (ExceptT HuggingFaceError IO a) + deriving (Functor, Applicative, Monad, MonadIO, MonadError HuggingFaceError) + via (ExceptT HuggingFaceError IO) + +-- | Run a computation, returning its typed error or result. This does not +-- catch IO exceptions or asynchronous cancellation. +runHuggingFaceM :: HuggingFaceM a -> IO (Either HuggingFaceError a) +runHuggingFaceM (HuggingFaceM action) = runExceptT action + +-- | Embed an IO action that already returns a typed result. Useful when +-- adapting callback-based IO APIs or existing clients. Use 'liftEither' for +-- pure parser results and 'liftIO' for IO actions without typed errors. +-- The action runs once; its IO exceptions propagate unchanged. +liftHuggingFaceM :: IO (Either HuggingFaceError a) -> HuggingFaceM a +liftHuggingFaceM = HuggingFaceM . ExceptT diff --git a/src/HuggingFace/Types.hs b/src/HuggingFace/Types.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types.hs @@ -0,0 +1,34 @@ +-- | +-- Module : HuggingFace.Types +-- Description : Convenience re-exports of focused domain types +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +-- +-- Import the @HuggingFace.Types.*@ modules for individual domains. This module +-- re-exports their public types and "HuggingFace.Error" for convenience. +-- Constructors remain opaque; shared helpers are available separately from +-- "HuggingFace.Utils". +module HuggingFace.Types + ( module HuggingFace.Error + , module HuggingFace.Types.Auth + , module HuggingFace.Types.Repository + , module HuggingFace.Types.Hub + , module HuggingFace.Types.Routing + , module HuggingFace.Types.Chat + , module HuggingFace.Types.Tasks + , module HuggingFace.Types.Parameters + , module HuggingFace.Types.Pagination + ) where + +import HuggingFace.Error +import HuggingFace.Types.Auth +import HuggingFace.Types.Repository +import HuggingFace.Types.Hub +import HuggingFace.Types.Routing +import HuggingFace.Types.Chat +import HuggingFace.Types.Tasks +import HuggingFace.Types.Parameters +import HuggingFace.Types.Pagination diff --git a/src/HuggingFace/Types/Auth.hs b/src/HuggingFace/Types/Auth.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Auth.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Auth +-- Description : Opaque bearer tokens and explicit credential access +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Auth + ( Token, parseToken, tokenBytes + ) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Utils (parseValue, takeWhile1P, asciiAlphaNum) + +-- | Opaque bearer token with a redacted 'Show' instance. +newtype Token = Token + { tokenBytes :: ByteString + -- ^ Recover the bearer credential for a custom transport. This value is secret; + -- unlike the token's 'Show' instance, rendering these bytes exposes it. + } + +instance Show Token where + show _ = "" + +-- | Parse a bearer token without retaining malformed input in errors. +-- Its 'Show' instance never reveals the value. +parseToken :: Text -> Either HuggingFaceError Token +parseToken = parseValue "Token requires ASCII letters, digits, underscores, or hyphens" $ + Token . encodeUtf8 <$> takeWhile1P (\c -> asciiAlphaNum c || c == '_' || c == '-') diff --git a/src/HuggingFace/Types/Chat.hs b/src/HuggingFace/Types/Chat.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Chat.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Chat +-- Description : Chat identities, messages, requests, and completion responses +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Chat + ( ChatRole, parseChatRole, chatRoleText + , ToolCallId, parseToolCallId, toolCallIdText + , ParticipantName, parseParticipantName, participantNameText + , CompletionId, parseCompletionId, completionIdText + , FinishReason, parseFinishReason, finishReasonText + , systemRole, userRole, assistantRole, toolRole, developerRole + , ChatMessage (..), userMessage, systemMessage, assistantMessage + , ChatRequest (..), defaultChatRequest + , ChatCompletion (..), ChatChoice (..), Usage (..) + ) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Text.Parsec as P +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Utils (parseTextJSON, parseLabel, parseValue, label) +import HuggingFace.Types.Parameters (PositiveInt, ChatTemperature, TopP) +import HuggingFace.Types.Routing (InferenceModel, ModelName) + +-- | Open chat role; common roles have named constants. +newtype ChatRole = ChatRole + { chatRoleText :: Text + -- ^ Render a ChatRole. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a ChatRole from external text. +parseChatRole :: Text -> Either HuggingFaceError ChatRole +parseChatRole = fmap ChatRole . parseLabel "ChatRole" + +instance FromJSON ChatRole where parseJSON = parseTextJSON "ChatRole" parseChatRole + +-- | Opaque provider-assigned tool call identifier. +newtype ToolCallId = ToolCallId + { toolCallIdText :: Text + -- ^ Render a ToolCallId. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a ToolCallId from external text. +parseToolCallId :: Text -> Either HuggingFaceError ToolCallId +parseToolCallId = fmap ToolCallId . parseLabel "ToolCallId" + +instance FromJSON ToolCallId where parseJSON = parseTextJSON "ToolCallId" parseToolCallId + +-- | Open chat participant name; provider-specific naming rules remain server-side. +newtype ParticipantName = ParticipantName + { participantNameText :: Text + -- ^ Render a ParticipantName. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a ParticipantName from external text. +parseParticipantName :: Text -> Either HuggingFaceError ParticipantName +parseParticipantName = fmap ParticipantName . parseLabel "ParticipantName" + +instance FromJSON ParticipantName where parseJSON = parseTextJSON "ParticipantName" parseParticipantName + +-- | Opaque provider-assigned completion identifier. An empty identifier is +-- preserved because Hugging Face / TGI can return it on successful responses. +newtype CompletionId = CompletionId + { completionIdText :: Text + -- ^ Render a CompletionId. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a CompletionId from external text. +parseCompletionId :: Text -> Either HuggingFaceError CompletionId +parseCompletionId = parseValue "Expected a completion identifier without controls" $ + CompletionId <$> (label P.<|> ("" <$ P.eof)) + +instance FromJSON CompletionId where parseJSON = parseTextJSON "CompletionId" parseCompletionId + +-- | Open provider stop reason; unknown reasons are preserved. +newtype FinishReason = FinishReason + { finishReasonText :: Text + -- ^ Render a FinishReason. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a FinishReason from external text. +parseFinishReason :: Text -> Either HuggingFaceError FinishReason +parseFinishReason = fmap FinishReason . parseLabel "FinishReason" + +instance FromJSON FinishReason where parseJSON = parseTextJSON "FinishReason" parseFinishReason + +-- | System instruction role. +systemRole :: ChatRole +systemRole = ChatRole "system" + +-- | User message role. +userRole :: ChatRole +userRole = ChatRole "user" + +-- | Assistant response role. +assistantRole :: ChatRole +assistantRole = ChatRole "assistant" + +-- | Tool response role. +toolRole :: ChatRole +toolRole = ChatRole "tool" + +-- | Developer instruction role. +developerRole :: ChatRole +developerRole = ChatRole "developer" + +-- | A chat message. JSON content supports text, multimodal arrays, and null +-- content for tool calls. Provider-specific tool payloads are preserved as JSON. +data ChatMessage = ChatMessage + { messageRole :: ChatRole -- ^ For example @system@, @user@, @assistant@, or @tool@. + , messageContent :: Maybe Value -- ^ Text or multimodal content; absent for some tool calls. + , messageToolCalls :: Maybe Value -- ^ Tool call array, when present. + , messageToolCallId :: Maybe ToolCallId -- ^ Identifier for a tool response. + , messageName :: Maybe ParticipantName -- ^ Optional participant name. + } deriving stock (Eq, Show) + +instance ToJSON ChatMessage where + toJSON message = object $ ("role" .= messageRole message) + : catMaybes + [ ("content" .=) <$> messageContent message + , ("tool_calls" .=) <$> messageToolCalls message + , ("tool_call_id" .=) <$> messageToolCallId message + , ("name" .=) <$> messageName message + ] + +instance FromJSON ChatMessage where + parseJSON = withObject "ChatMessage" $ \o -> ChatMessage + <$> o .: "role" <*> o .:? "content" <*> o .:? "tool_calls" + <*> o .:? "tool_call_id" <*> o .:? "name" + +-- | Construct a plain-text user message. +userMessage :: Text -> ChatMessage +userMessage = textMessage userRole + +-- | Construct a plain-text system message. +systemMessage :: Text -> ChatMessage +systemMessage = textMessage systemRole + +-- | Construct a plain-text assistant message. +assistantMessage :: Text -> ChatMessage +assistantMessage = textMessage assistantRole + +textMessage :: ChatRole -> Text -> ChatMessage +textMessage role content = ChatMessage role (Just (String content)) Nothing Nothing Nothing + +-- | Non-streaming chat request for the router's OpenAI-compatible endpoint. +-- Model names can include a provider suffix such as @:fastest@ or @:together@. +data ChatRequest = ChatRequest + { chatModel :: InferenceModel -- ^ Hub model identifier and optional routing suffix. + , chatMessages :: NonEmpty ChatMessage -- ^ A nonempty conversation. + , chatMaxTokens :: Maybe PositiveInt -- ^ Positive output token limit. + , chatTemperature :: Maybe ChatTemperature -- ^ Finite sampling temperature in @[0,2]@. + , chatTopP :: Maybe TopP -- ^ Finite probability in @(0,1]@. + , chatExtra :: Object -- ^ Additional fields, e.g. @tools@ or @response_format@. + } deriving stock (Eq, Show) + +-- | Construct a request with server-default sampling settings. +defaultChatRequest :: InferenceModel -> NonEmpty ChatMessage -> ChatRequest +defaultChatRequest model messages = ChatRequest model messages Nothing Nothing Nothing KM.empty + +instance ToJSON ChatRequest where + toJSON request = Object $ KM.union fields extras + where + fields = KM.fromList $ ["model" .= chatModel request, "messages" .= chatMessages request, "stream" .= False] + ++ catMaybes + [ ("max_tokens" .=) <$> chatMaxTokens request + , ("temperature" .=) <$> chatTemperature request + , ("top_p" .=) <$> chatTopP request + ] + -- Reserved fields cannot replace parsed fields or enable streaming. + extras = foldr KM.delete (chatExtra request) ["model", "messages", "stream", "max_tokens", "temperature", "top_p"] + +-- | Token accounting when reported by the provider. +data Usage = Usage + { promptTokens :: Integer -- ^ Tokens in the prompt. + , completionTokens :: Integer -- ^ Tokens generated. + , totalTokens :: Integer -- ^ Total billed/reported tokens. + } deriving stock (Eq, Show) + +instance FromJSON Usage where + parseJSON = withObject "Usage" $ \o -> Usage + <$> o .: "prompt_tokens" <*> o .: "completion_tokens" <*> o .: "total_tokens" + +-- | One completion candidate. +data ChatChoice = ChatChoice + { choiceIndex :: Int -- ^ Candidate index. + , choiceMessage :: ChatMessage -- ^ Assistant message, including tool calls. + , choiceFinishReason :: Maybe FinishReason -- ^ Provider stop reason. + } deriving stock (Eq, Show) + +instance FromJSON ChatChoice where + parseJSON = withObject "ChatChoice" $ \o -> ChatChoice + <$> o .: "index" <*> o .: "message" <*> o .:? "finish_reason" + +-- | Completed non-streaming response. Additional fields remain in 'completionRaw'. +data ChatCompletion = ChatCompletion + { completionId :: CompletionId -- ^ Request identifier assigned by the provider. + , completionModel :: ModelName -- ^ Resolved model. + , completionChoices :: [ChatChoice] -- ^ Completion candidates. + , completionUsage :: Maybe Usage -- ^ Optional token accounting. + , completionRaw :: Object -- ^ Full response, including provider extensions. + } deriving stock (Eq, Show) + +instance FromJSON ChatCompletion where + parseJSON = withObject "ChatCompletion" $ \o -> ChatCompletion + <$> o .: "id" <*> o .: "model" <*> o .: "choices" <*> o .:? "usage" <*> pure o diff --git a/src/HuggingFace/Types/Hub.hs b/src/HuggingFace/Types/Hub.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Hub.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Hub +-- Description : Hub discovery options and repository metadata +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Hub + ( HubTag, parseHubTag, hubTagText + , PipelineTag, parsePipelineTag, pipelineTagText + , LibraryName, parseLibraryName, libraryNameText + , SpaceSdk, parseSpaceSdk, spaceSdkText + , SortKey, parseSortKey, sortKeyText + , RepoInfo (..), RepoFile (..), UserInfo (..) + , ListOptions (..), defaultListOptions + ) where + +import Data.Aeson +import Data.Text (Text) +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Utils (parseTextJSON, parseLabel) +import HuggingFace.Types.Parameters (PositiveInt) +import HuggingFace.Types.Repository (AccountName, RepoId, CommitSha, RepoPath) + +-- | Open Hub metadata tag, including namespaced tags. +newtype HubTag = HubTag + { hubTagText :: Text + -- ^ Render a HubTag. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a HubTag from external text. +parseHubTag :: Text -> Either HuggingFaceError HubTag +parseHubTag = fmap HubTag . parseLabel "HubTag" + +instance FromJSON HubTag where parseJSON = parseTextJSON "HubTag" parseHubTag + +-- | Open model task identifier. +newtype PipelineTag = PipelineTag + { pipelineTagText :: Text + -- ^ Render a PipelineTag. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a PipelineTag from external text. +parsePipelineTag :: Text -> Either HuggingFaceError PipelineTag +parsePipelineTag = fmap PipelineTag . parseLabel "PipelineTag" + +instance FromJSON PipelineTag where parseJSON = parseTextJSON "PipelineTag" parsePipelineTag + +-- | Open model library identifier. +newtype LibraryName = LibraryName + { libraryNameText :: Text + -- ^ Render a LibraryName. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a LibraryName from external text. +parseLibraryName :: Text -> Either HuggingFaceError LibraryName +parseLibraryName = fmap LibraryName . parseLabel "LibraryName" + +instance FromJSON LibraryName where parseJSON = parseTextJSON "LibraryName" parseLibraryName + +-- | Open Space SDK identifier. +newtype SpaceSdk = SpaceSdk + { spaceSdkText :: Text + -- ^ Render a SpaceSdk. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a SpaceSdk from external text. +parseSpaceSdk :: Text -> Either HuggingFaceError SpaceSdk +parseSpaceSdk = fmap SpaceSdk . parseLabel "SpaceSdk" + +instance FromJSON SpaceSdk where parseJSON = parseTextJSON "SpaceSdk" parseSpaceSdk + +-- | Open Hub sort field. +newtype SortKey = SortKey + { sortKeyText :: Text + -- ^ Render a SortKey. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a SortKey from external text. +parseSortKey :: Text -> Either HuggingFaceError SortKey +parseSortKey = fmap SortKey . parseLabel "SortKey" + +instance FromJSON SortKey where parseJSON = parseTextJSON "SortKey" parseSortKey + +-- | Shared Hub metadata. Optional fields may be absent from list responses. +-- Unknown fields remain available in 'repoRaw' for forward compatibility. +data RepoInfo = RepoInfo + { repoId :: RepoId -- ^ Fully qualified repository name. + , repoSha :: Maybe CommitSha -- ^ Revision commit SHA when supplied. + , repoPrivate :: Maybe Bool -- ^ Visibility, when included by the server. + , repoDownloads :: Maybe Integer -- ^ Download count, when available. + , repoLikes :: Maybe Integer -- ^ Like count, when available. + , repoTags :: [HubTag] -- ^ Hub metadata tags. + , repoPipelineTag :: Maybe PipelineTag -- ^ Model task, when available. + , repoLibraryName :: Maybe LibraryName -- ^ Associated model library. + , repoSdk :: Maybe SpaceSdk -- ^ Space SDK, when available. + , repoSiblings :: [RepoFile] -- ^ Files included in the metadata response. + , repoRaw :: Object -- ^ Complete JSON object, including provider extensions. + } deriving stock (Eq, Show) + +instance FromJSON RepoInfo where + parseJSON = withObject "RepoInfo" $ \o -> RepoInfo + <$> o .: "id" <*> o .:? "sha" <*> o .:? "private" + <*> o .:? "downloads" <*> o .:? "likes" <*> o .:? "tags" .!= [] + <*> o .:? "pipeline_tag" <*> o .:? "library_name" <*> o .:? "sdk" + <*> o .:? "siblings" .!= [] <*> pure o + +-- | A file returned in repository metadata. Size requires @blobs=true@. +data RepoFile = RepoFile + { fileName :: RepoPath -- ^ Relative path within the repository. + , fileSize :: Maybe Integer -- ^ Byte count, when supplied. + } deriving stock (Eq, Show) + +instance FromJSON RepoFile where + parseJSON = withObject "RepoFile" $ \o -> RepoFile <$> o .: "rfilename" <*> o .:? "size" + +-- | Identity returned by @/api/whoami-v2@. +data UserInfo = UserInfo + { userName :: AccountName -- ^ Account name. + , userFullName :: Maybe Text -- ^ Display name. + , userRaw :: Object -- ^ Full identity response; may contain private account data. + } deriving stock (Eq, Show) + +instance FromJSON UserInfo where + parseJSON = withObject "UserInfo" $ \o -> UserInfo <$> o .: "name" <*> o .:? "fullname" <*> pure o + +-- | Options common to the Hub's repository listing endpoints. 'listLimit' is +-- the requested page size, not a total across pages. The server may cap it. +data ListOptions = ListOptions + { listSearch :: Maybe Text -- ^ Search repository names. + , listAuthor :: Maybe AccountName -- ^ Restrict to an account or organization. + , listFilter :: [HubTag] -- ^ Repeated @filter@ query parameters. + , listSort :: Maybe SortKey -- ^ Server sort key, such as @downloads@ or @lastModified@. + , listLimit :: Maybe PositiveInt -- ^ Positive page size. + , listFull :: Bool -- ^ Ask for expanded metadata. + } deriving stock (Eq, Show) + +-- | Unfiltered first page, with the server's default size and ordering. +defaultListOptions :: ListOptions +defaultListOptions = ListOptions Nothing Nothing [] Nothing Nothing False diff --git a/src/HuggingFace/Types/Pagination.hs b/src/HuggingFace/Types/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Pagination.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Pagination +-- Description : Pages and parsed Link header continuations +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Pagination + ( Page (..), NextPage, nextPageFromHeaders, nextPageURL + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import Data.Char (isAscii, isAlphaNum, ord, toLower) +import Data.Either (fromRight) +import Data.Maybe (catMaybes, listToMaybe) +import Network.HTTP.Client (Request, getUri) +import Network.HTTP.Types (ResponseHeaders) +import Network.URI (parseURIReference, relativeTo) +import qualified Text.Parsec as P +import qualified Text.Parsec.ByteString as P +import HuggingFace.Utils (matchedBytes) + +-- | One server page. The caller explicitly decides whether to fetch another. +data Page a = Page + { pageItems :: [a] -- ^ Items in this response. + , pageNext :: Maybe NextPage -- ^ Opaque continuation supplied by the Hub. + } deriving stock (Eq, Show) + +-- | Opaque server-provided pagination continuation. +newtype NextPage = NextPage + { nextPageURL :: ByteString + -- ^ Recover the continuation URL as bytes. Query parameters may contain private + -- state; the 'Show' instance redacts them. Consuming a continuation still requires + -- checking its origin against the client's configured Hub endpoint. + } + deriving (Eq) via ByteString + +instance Show NextPage where + show _ = "" + +-- A Link header is a comma-separated list of targets and parameters. Parsing +-- quoted strings as a unit prevents embedded commas, semicolons, and escaped +-- quotes from being mistaken for delimiters or relation parameters. +links :: ByteString -> [ByteString] +links = fromRight [] . P.parse (linkHeader <* P.eof) "" + +linkHeader :: P.Parser [ByteString] +linkHeader = do + ows + -- HTTP list recipients ignore empty members (RFC 9110, section 5.6.1.2). + entries <- P.optionMaybe link `P.sepBy1` (P.char ',' *> ows) + pure [target | (target, parameters) <- catMaybes entries, maybe False (elem "next" . B8.words) (lookup "rel" parameters)] + where + link = do + target <- P.between (P.char '<') (P.char '>') $ + matchedBytes (P.skipMany (P.satisfy (\c -> c > ' ' && c < '\DEL' && c /= '<' && c /= '>'))) + ows + parameters <- P.many (P.char ';' *> ows *> parameter <* ows) + pure (target, parameters) + parameter = do + name <- token <* ows + value <- P.option "" (P.char '=' *> ows *> (quoted P.<|> token)) + pure (B8.map toLower name, value) + token = matchedBytes (P.skipMany1 (P.satisfy tokenChar)) + tokenChar c = (isAscii c && isAlphaNum c) || B8.elem c "!#$%&'*+-.^_`|~" + quoted = P.between (P.char '"') (P.char '"') (BS.concat <$> P.many chunk) + chunk = (P.char '\\' *> (B8.singleton <$> P.satisfy quotedPair)) + P.<|> matchedBytes (P.skipMany1 (P.satisfy quotedText)) + quotedPair c = c == '\t' || (ord c >= 32 && c /= '\DEL') + quotedText c = quotedPair c && c /= '"' && c /= '\\' + +ows :: P.Parser () +ows = P.skipMany (P.satisfy (\c -> c == ' ' || c == '\t')) + +-- | Parse the first @rel=next@ target from response Link headers and resolve it +-- against the final request URL. Malformed Link headers contribute no target. +-- The resulting handle is untrusted until the transport checks its origin. +nextPageFromHeaders :: Request -> ResponseHeaders -> Maybe NextPage +nextPageFromHeaders request headers = do + link <- listToMaybe (concatMap (links . snd) (filter ((== "link") . fst) headers)) + let resolved = case parseURIReference (B8.unpack link) of + Just uri -> B8.pack (show (uri `relativeTo` getUri request)) + Nothing -> link + pure (NextPage resolved) diff --git a/src/HuggingFace/Types/Parameters.hs b/src/HuggingFace/Types/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Parameters.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Parameters +-- Description : Constrained counts, timeouts, and sampling parameters +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Parameters + ( PositiveInt, mkPositiveInt, positiveIntValue, defaultTimeout + , ChatTemperature, mkChatTemperature, chatTemperatureValue + , TopP, mkTopP, topPValue + , GenerationTemperature, mkGenerationTemperature, generationTemperatureValue + ) where + +import Data.Aeson +import HuggingFace.Error (HuggingFaceError (..)) +import HuggingFace.Utils (fromEither, inRange) + +-- | Strictly positive machine integer for counts, limits, and microseconds. +-- No 'Num' instance is supplied, so arithmetic cannot bypass construction. +newtype PositiveInt = PositiveInt + { positiveIntValue :: Int + -- ^ Recover a positive integer. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Int + +-- | Refine an external integer into a positive count. +mkPositiveInt :: Int -> Either HuggingFaceError PositiveInt +mkPositiveInt n + | n > 0 = Right (PositiveInt n) + | otherwise = Left (InvalidInput "Expected a positive integer") + +-- | Thirty seconds in microseconds. +defaultTimeout :: PositiveInt +defaultTimeout = PositiveInt 30000000 + +instance FromJSON PositiveInt where parseJSON v = parseJSON v >>= fromEither . mkPositiveInt + +-- | A finite value in [0,2]. +newtype ChatTemperature = ChatTemperature + { chatTemperatureValue :: Double + -- ^ Recover the numeric value. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Double + +-- | Refine a number into a finite value in [0,2]. +mkChatTemperature :: Double -> Either HuggingFaceError ChatTemperature +mkChatTemperature t + | inRange 0 2 t = Right (ChatTemperature t) + | otherwise = Left (InvalidInput "ChatTemperature requires a finite value in [0,2]") + +instance FromJSON ChatTemperature where parseJSON v = parseJSON v >>= fromEither . mkChatTemperature + +-- | A finite value in (0,1]. +newtype TopP = TopP + { topPValue :: Double + -- ^ Recover the numeric value. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Double + +-- | Refine a number into a finite value in (0,1]. +mkTopP :: Double -> Either HuggingFaceError TopP +mkTopP t + | inRange 0 1 t && t > 0 = Right (TopP t) + | otherwise = Left (InvalidInput "TopP requires a finite value in (0,1]") + +instance FromJSON TopP where parseJSON v = parseJSON v >>= fromEither . mkTopP + +-- | A positive finite value. +newtype GenerationTemperature = GenerationTemperature + { generationTemperatureValue :: Double + -- ^ Recover the numeric value. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Double + +-- | Refine a number into a positive finite value. +mkGenerationTemperature :: Double -> Either HuggingFaceError GenerationTemperature +mkGenerationTemperature t + | not (isNaN t || isInfinite t) && t > 0 = Right (GenerationTemperature t) + | otherwise = Left (InvalidInput "GenerationTemperature requires a positive finite value") + +instance FromJSON GenerationTemperature where parseJSON v = parseJSON v >>= fromEither . mkGenerationTemperature diff --git a/src/HuggingFace/Types/Repository.hs b/src/HuggingFace/Types/Repository.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Repository.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Repository +-- Description : Repository names, revisions, paths, and commit identities +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Repository + ( RepoId, parseRepoId, repoIdText, repoOwner, repoName, qualifiedRepo + , RepoName, parseRepoName, repoNameText + , AccountName, parseAccountName, accountNameText + , Revision, parseRevision, revisionText, mainRevision, commitRevision + , RepoPath, parseRepoPath, repoPathText + , CommitSha, parseCommitSha, commitShaText + , RepoType (..) + , repoIdParser, repoPlural + ) where + +import Control.Monad (replicateM_, void) +import Data.Aeson +import Data.Char (isAscii, isHexDigit, isControl) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import qualified Data.Text as T +import qualified Text.Parsec as P +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Utils (TextParser, parseValue, parseTextJSON, matched, asciiAlphaNum, takeWhile1P) + +-- | Repository basename, distinct from its optional owner. +newtype RepoName = RepoName + { repoNameText :: Text + -- ^ Render a repository basename. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a Hub repository basename. +parseRepoName :: Text -> Either HuggingFaceError RepoName +parseRepoName = parseValue "Expected a Hub repository basename" (RepoName <$> nameParser) + +instance FromJSON RepoName where parseJSON = parseTextJSON "RepoName" parseRepoName + +-- | Repository identity with an optional owner and a basename. Parsers and +-- smart constructors assemble it from parsed names. +data RepoId = RepoId + { repoOwner :: Maybe AccountName -- ^ Optional owner of a repository. + , repoName :: RepoName -- ^ Repository basename. + } + deriving stock (Eq, Ord, Show) + +-- | Parse either a bare repository name or @owner/name@. +parseRepoId :: Text -> Either HuggingFaceError RepoId +parseRepoId = parseValue "Expected a repository name or owner/name" repoIdParser + +-- | Compose a repository parser with a larger grammar, such as a routing suffix. +-- Use 'parseRepoId' when parsing a complete external value. +repoIdParser :: TextParser RepoId +repoIdParser = do + first <- nameParser + P.option (RepoId Nothing (RepoName first)) $ + qualifiedRepo (AccountName first) . RepoName <$> (P.char '/' *> nameParser) + +-- | Assemble a qualified repository from parsed components without reparsing. +qualifiedRepo :: AccountName -> RepoName -> RepoId +qualifiedRepo owner = RepoId (Just owner) + +-- | Render a repository identity for display or persistence. +repoIdText :: RepoId -> Text +repoIdText (RepoId owner name) = maybe "" ((<> "/") . accountNameText) owner <> repoNameText name + +instance ToJSON RepoId where toJSON = toJSON . repoIdText +instance FromJSON RepoId where parseJSON = parseTextJSON "RepoId" parseRepoId + +-- | Branch, tag, or commit reference; slash-separated components are retained. +newtype Revision = Revision (NonEmpty Text) + deriving stock (Show) + deriving (Eq, Ord) via (NonEmpty Text) + +-- | Parse a revision. Slashes are encoded together as one URL segment. +parseRevision :: Text -> Either HuggingFaceError Revision +parseRevision = parseValue "Expected nonempty revision segments without traversal, controls, or backslashes" (Revision <$> components) + +-- | Render a revision. +revisionText :: Revision -> Text +revisionText (Revision parts) = T.intercalate "/" (NE.toList parts) + +-- | The default Hub branch. +mainRevision :: Revision +mainRevision = Revision ("main" :| []) + +-- | Pin a revision to an already parsed full commit SHA. +commitRevision :: CommitSha -> Revision +commitRevision sha = Revision (commitShaText sha :| []) + +instance ToJSON Revision where toJSON = toJSON . revisionText +instance FromJSON Revision where parseJSON = parseTextJSON "Revision" parseRevision + +-- | Nonempty relative file path with no empty, dot, or parent segments. +newtype RepoPath = RepoPath (NonEmpty Text) + deriving stock (Show) + deriving (Eq, Ord) via (NonEmpty Text) + +-- | Parse a repository-relative path, preserving Unicode and spaces. +parseRepoPath :: Text -> Either HuggingFaceError RepoPath +parseRepoPath = parseValue "Expected a relative repository file path without traversal, controls, or backslashes" (RepoPath <$> components) + +-- | Render a repository-relative path. +repoPathText :: RepoPath -> Text +repoPathText (RepoPath parts) = T.intercalate "/" (NE.toList parts) + +instance ToJSON RepoPath where toJSON = toJSON . repoPathText +instance FromJSON RepoPath where parseJSON = parseTextJSON "RepoPath" parseRepoPath + +-- | Full SHA-1 commit identifier, stored in canonical lowercase form. +newtype CommitSha = CommitSha + { commitShaText :: Text -- ^ Render a full commit identifier. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse exactly forty ASCII hexadecimal digits. Use 'parseRevision' for +-- abbreviated commit references, branches, or tags. +parseCommitSha :: Text -> Either HuggingFaceError CommitSha +parseCommitSha = parseValue "CommitSha requires forty hexadecimal digits" $ + CommitSha . T.toLower <$> matched (replicateM_ 40 (P.satisfy (\c -> isAscii c && isHexDigit c))) + +instance FromJSON CommitSha where parseJSON = parseTextJSON "CommitSha" parseCommitSha + +-- | Account or organization namespace. +newtype AccountName = AccountName + { accountNameText :: Text -- ^ Render an account or organization name. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a AccountName from external text. +parseAccountName :: Text -> Either HuggingFaceError AccountName +parseAccountName = parseValue "Expected a Hub account or organization name" (AccountName <$> nameParser) + +instance FromJSON AccountName where parseJSON = parseTextJSON "AccountName" parseAccountName + +-- | Hub repository kinds. +data RepoType = Model | Dataset | Space + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Hub collection path component for a repository kind. +repoPlural :: RepoType -> Text +repoPlural Model = "models" +repoPlural Dataset = "datasets" +repoPlural Space = "spaces" + +-- Hub name components start/end with a word character, cannot repeat '.' or +-- '-', and cannot end in '.git'. Length is bounded while consuming input. +nameParser :: TextParser Text +nameParser = matched $ word *> rest (95 :: Int) + where + word = P.satisfy (\c -> asciiAlphaNum c || c == '_') + nameChar = P.satisfy (\c -> asciiAlphaNum c || c == '_' || c == '-' || c == '.') + next = void word P.<|> do + P.notFollowedBy (P.try (P.string ".git" <* P.notFollowedBy nameChar)) + punctuation <- P.char '-' P.<|> P.char '.' + P.notFollowedBy (P.char punctuation) + void (P.lookAhead nameChar) + rest 0 = P.notFollowedBy nameChar + rest n = P.optional (next *> rest (n - 1)) + +components :: TextParser (NonEmpty Text) +components = (:|) <$> component <*> P.many (P.char '/' *> component) + where + component = do + part <- takeWhile1P (\c -> c /= '/' && c /= '\\' && not (isControl c)) + case part of + "." -> P.parserFail "Dot segment" + ".." -> P.parserFail "Parent segment" + _ -> pure part diff --git a/src/HuggingFace/Types/Routing.hs b/src/HuggingFace/Types/Routing.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Routing.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Routing +-- Description : Inference model identities and provider selection +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Routing + ( Provider, parseProvider, providerText + , Routing (..), InferenceModel, parseInferenceModel, inferenceModelText + , modelRepository, modelRouting, modelFromRepo, routeModel + , ModelName, parseModelName, modelNameText + ) where + +import Data.Aeson +import Data.Text (Text) +import qualified Text.Parsec as P +import HuggingFace.Error (HuggingFaceError) +import HuggingFace.Utils (TextParser, parseValue, parseTextJSON, parseLabel, takeWhile1P, asciiAlphaNum) +import HuggingFace.Types.Repository (RepoId, repoIdText, repoIdParser) + +-- | Provider-resolved model name; it need not be a Hub repository ID. +newtype ModelName = ModelName + { modelNameText :: Text + -- ^ Render a ModelName. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a ModelName from external text. +parseModelName :: Text -> Either HuggingFaceError ModelName +parseModelName = fmap ModelName . parseLabel "ModelName" + +instance FromJSON ModelName where parseJSON = parseTextJSON "ModelName" parseModelName + +-- | Provider routing slug; policy names are reserved for Routing constructors. +newtype Provider = Provider + { providerText :: Text + -- ^ Render a Provider. + } + deriving stock (Show) + deriving (Eq, Ord, ToJSON) via Text + +-- | Parse a Provider from external text. +parseProvider :: Text -> Either HuggingFaceError Provider +parseProvider = parseValue "Expected a provider slug, not a routing policy" providerParser + +instance FromJSON Provider where parseJSON = parseTextJSON "Provider" parseProvider + +-- | Router selection policy or a named provider. An absent routing choice uses +-- the server default; it is distinct from explicitly selecting 'Fastest'. +data Routing = Fastest | Cheapest | Preferred | Via Provider deriving stock (Eq, Ord, Show) + +-- | A Hub model repository paired with an optional parsed routing choice. +data InferenceModel = InferenceModel + { modelRepository :: RepoId -- ^ The repository referenced by a routed model. + , modelRouting :: Maybe Routing -- ^ Optional explicit routing choice. + } deriving stock (Eq, Ord, Show) + +-- | Parse @owner/model@ or @owner/model:provider-or-policy@. +parseInferenceModel :: Text -> Either HuggingFaceError InferenceModel +parseInferenceModel = parseValue "Expected a model repository with at most one routing suffix" $ + InferenceModel <$> repoIdParser <*> P.optionMaybe (P.char ':' *> routingParser) + +routingParser :: TextParser Routing +routingParser = do + slug <- takeWhile1P (\c -> asciiAlphaNum c || c == '-') + pure $ case slug of + "fastest" -> Fastest + "cheapest" -> Cheapest + "preferred" -> Preferred + _ -> Via (Provider slug) + +providerParser :: TextParser Provider +providerParser = do + routing <- routingParser + case routing of + Via provider -> pure provider + _ -> P.parserFail "Reserved routing policy" + +-- | Choose the router's default policy for an existing repository identifier. +modelFromRepo :: RepoId -> InferenceModel +modelFromRepo repository = InferenceModel repository Nothing + +-- | Select a routing policy without converting an identifier back to text. +routeModel :: RepoId -> Routing -> InferenceModel +routeModel repository routing = InferenceModel repository (Just routing) + +-- | Render a model together with its optional routing suffix. +inferenceModelText :: InferenceModel -> Text +inferenceModelText (InferenceModel repository routing) = repoIdText repository <> maybe "" ((":" <>) . render) routing + where + render Fastest = "fastest" + render Cheapest = "cheapest" + render Preferred = "preferred" + render (Via provider) = providerText provider + +instance ToJSON InferenceModel where toJSON = toJSON . inferenceModelText +instance FromJSON InferenceModel where parseJSON = parseTextJSON "InferenceModel" parseInferenceModel diff --git a/src/HuggingFace/Types/Tasks.hs b/src/HuggingFace/Types/Tasks.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Types/Tasks.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Types.Tasks +-- Description : HF Inference task parameters and results +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Types.Tasks + ( GenerationParameters (..), defaultGenerationParameters + , GeneratedText (..), Classification (..) + ) where + +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import HuggingFace.Types.Parameters (PositiveInt, GenerationTemperature) + +-- | Parameters for the HF Inference text-generation task. +data GenerationParameters = GenerationParameters + { generationMaxNewTokens :: Maybe PositiveInt -- ^ Positive output token limit. + , generationTemperature :: Maybe GenerationTemperature -- ^ Positive finite sampling temperature. + , generationDoSample :: Maybe Bool -- ^ Enable sampling. + , generationReturnFullText :: Maybe Bool -- ^ Include the prompt in output. + } deriving (Eq, Show) + +-- | Use the server's generation defaults. +defaultGenerationParameters :: GenerationParameters +defaultGenerationParameters = GenerationParameters Nothing Nothing Nothing Nothing + +instance ToJSON GenerationParameters where + toJSON parameters = object $ catMaybes + [ ("max_new_tokens" .=) <$> generationMaxNewTokens parameters + , ("temperature" .=) <$> generationTemperature parameters + , ("do_sample" .=) <$> generationDoSample parameters + , ("return_full_text" .=) <$> generationReturnFullText parameters + ] + +-- | Generated text and optional token-level details. +data GeneratedText = GeneratedText + { generatedText :: Text -- ^ Generated output. + , generationDetails :: Maybe Value -- ^ Provider-specific token and sampling details. + } deriving (Eq, Show) + +instance FromJSON GeneratedText where + parseJSON = withObject "GeneratedText" $ \o -> GeneratedText <$> o .: "generated_text" <*> o .:? "details" + +-- | A predicted label and score. +data Classification = Classification + { classificationLabel :: Text -- ^ Predicted label. + , classificationScore :: Double -- ^ Model confidence score. + } deriving (Eq, Show) + +instance FromJSON Classification where + parseJSON = withObject "Classification" $ \o -> Classification <$> o .: "label" <*> o .: "score" diff --git a/src/HuggingFace/Utils.hs b/src/HuggingFace/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HuggingFace/Utils.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : HuggingFace.Utils +-- Description : Shared parsing, JSON, and HTTP utilities +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-3-Clause +-- Maintainer : emilypi@cohomolo.gy +-- Stability : experimental +-- Portability : GHC +module HuggingFace.Utils + ( TextParser, parseText, parseValue, parseTextJSON, parseLabel, fromEither, decodeJSON + , matched, matchedBytes, takeWhile1P, label, asciiAlphaNum, inRange + , encodeSegments, readAtMost, sameOrigin + ) where + +import Data.Aeson (FromJSON, Value, eitherDecode, withText) +import qualified Data.Aeson.Types as JSON +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Char (isAlphaNum, isAscii, isControl, isSpace, toLower) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Foreign as TF +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client (BodyReader, Request, brRead, secure, port, host) +import Network.HTTP.Types (urlEncode) +import qualified Text.Parsec as P +import qualified Text.Parsec.ByteString as PB +import HuggingFace.Error (HuggingFaceError (..)) + +-- | Parsec parser over strict 'Text', without user state. +type TextParser = P.Parsec Text () + +-- | Require complete input consumption and replace parser errors with the +-- caller's diagnostic. Parsec errors may contain input +-- tokens, so they must never escape a parser that can receive credentials. +parseText :: e -> TextParser a -> Text -> Either e a +parseText err parser = either (const (Left err)) Right . P.parse (parser <* P.eof) "" + +-- | Capture consumed Text without an intermediate String or rescanning the +-- remaining input. Parsec consumes complete characters, so the byte-length +-- difference always falls on a UTF-8 boundary; takeWord8 is the safe slicer. +matched :: TextParser a -> TextParser Text +matched parser = do + before <- P.getInput + _ <- parser + after <- P.getInput + pure (TF.takeWord8 (fromIntegral (TF.lengthWord8 before - TF.lengthWord8 after)) before) + +-- | Consume one or more matching characters and return the consumed text. +takeWhile1P :: (Char -> Bool) -> TextParser Text +takeWhile1P predicate = matched (P.skipMany1 (P.satisfy predicate)) + +-- | Whether a character is an ASCII letter or decimal digit. +asciiAlphaNum :: Char -> Bool +asciiAlphaNum c = isAscii c && isAlphaNum c + +-- | Parse an open label, preserving spaces, Unicode, and punctuation, with +-- at least one non-space character and no control characters. +label :: TextParser Text +label = do + _ <- P.lookAhead (P.skipMany (P.satisfy isSpace) *> P.satisfy (not . isSpace)) + takeWhile1P (not . isControl) + +-- | Decode a JSON string using a domain parser. The first argument names the +-- expected type in Aeson diagnostics. +parseTextJSON :: Text -> (Text -> Either HuggingFaceError a) -> Value -> JSON.Parser a +parseTextJSON name parse = withText (T.unpack name) (fromEither . parse) + +-- | Lift a domain result into Aeson's parser. +fromEither :: Either HuggingFaceError a -> JSON.Parser a +fromEither = either (fail . show) pure + +-- | Parse a complete value, reporting 'InvalidInput' with the supplied message. +parseValue :: Text -> TextParser a -> Text -> Either HuggingFaceError a +parseValue message = parseText (InvalidInput message) + +-- | Parse a complete 'label'; the first argument identifies the domain type. +parseLabel :: Text -> Text -> Either HuggingFaceError Text +parseLabel name = parseValue (name <> " requires nonblank text without control characters") label + +-- | Test a finite number against inclusive lower and upper bounds. +inRange :: Double -> Double -> Double -> Bool +inRange low high t = not (isNaN t || isInfinite t) && t >= low && t <= high + +-- | Decode JSON without retaining potentially sensitive parser diagnostics. +decodeJSON :: FromJSON a => BL.ByteString -> Either HuggingFaceError a +decodeJSON = either (const (Left DecodeError)) Right . eitherDecode + +-- | Capture the bytes consumed by a ByteString parser. +matchedBytes :: PB.Parser a -> PB.Parser ByteString +matchedBytes parser = do + before <- P.getInput + _ <- parser + after <- P.getInput + pure (BS.take (BS.length before - BS.length after) before) + +-- | Encode each path segment as UTF-8 and percent-escape it, then join the +-- segments under a leading slash. Slashes inside a segment are escaped too. +encodeSegments :: [Text] -> ByteString +encodeSegments parts = "/" <> BS.intercalate "/" (map (urlEncode True . encodeUtf8) parts) + +-- | Read at most the requested number of bytes, or none for a nonpositive limit. +-- The last chunk may exceed the limit; its excess bytes are consumed and +-- discarded. Use this for a bounded preview before closing the response. +readAtMost :: Int -> BodyReader -> IO ByteString +readAtMost limit reader = BS.concat . reverse <$> go limit [] + where + go n chunks + | n <= 0 = pure chunks + | otherwise = do + chunk <- brRead reader + if BS.null chunk then pure chunks + else go (n - BS.length chunk) (BS.take n chunk : chunks) + +-- | Compare TLS, port, and case-insensitive hostname; paths are ignored. +sameOrigin :: Request -> Request -> Bool +sameOrigin a b = secure a == secure b && port a == port b + && B8.map toLower (host a) == B8.map toLower (host b) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Exception (AsyncException (UserInterrupt), IOException, throwIO, try) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Either (isLeft) +import Data.IORef +import Data.List (isInfixOf, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text.Encoding (encodeUtf8) +import Data.Text (Text) +import qualified Data.Text as T +import HuggingFace.Monad +import HuggingFace.Client +import HuggingFace.Error +import HuggingFace.Hub + ( listModels, listDatasets, listSpaces, nextPage + , modelInfo, datasetInfo, spaceInfo, whoAmI, downloadFile, withDownload + ) +import HuggingFace.Inference (chatCompletion, textGeneration, classifyText, featureExtraction, infer) +import qualified HuggingFace.Internal.HTTP as Transport +import HuggingFace.Types.Auth +import HuggingFace.Types.Chat +import HuggingFace.Types.Hub +import HuggingFace.Types.Pagination +import HuggingFace.Types.Parameters +import HuggingFace.Types.Repository +import HuggingFace.Types.Routing +import HuggingFace.Types.Tasks +import qualified HuggingFace.Utils as Utils +import Network.HTTP.Client (brRead, defaultManagerSettings, managerRetryableException, managerModifyResponse, newManager) +import qualified Network.HTTP.Client.Internal as HTTP +import Network.HTTP.Types +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp (testWithApplication) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +data Observed = Observed + { observedMethod :: Method + , observedPath :: ByteString + , observedQuery :: Query + , observedHeaders :: RequestHeaders + , observedBody :: BL.ByteString + } deriving (Show) + +type Reply = (Status, ResponseHeaders, BL.ByteString) + +withServer :: (Observed -> IO Reply) -> (Int -> IO [Observed] -> IO a) -> IO a +withServer handler action = do + seen <- newIORef [] + let app request respond = do + body <- Wai.strictRequestBody request + let observed = Observed (Wai.requestMethod request) (Wai.rawPathInfo request) + (Wai.queryString request) (Wai.requestHeaders request) body + atomicModifyIORef' seen (\values -> (observed : values, ())) + (status, headers, payload) <- handler observed + respond (Wai.responseLBS status headers payload) + testWithApplication (pure app) $ \port -> action port (reverse <$> readIORef seen) + +withFixture :: Reply -> (Client -> IO [Observed] -> IO a) -> IO a +withFixture reply action = withServer (const (pure reply)) $ \port seen -> do + client <- clientAt port (Just token) + action client seen + +clientAt :: Int -> Maybe Token -> IO Client +clientAt port tokenValue = do + manager <- newManager defaultManagerSettings {managerRetryableException = const False} + pure $ newClientWithManager manager defaultClientConfig + { hubEndpoint = endpointAt port, inferenceEndpoint = endpointAt port, accessToken = tokenValue } + +origin :: Int -> Text +origin port = "http://127.0.0.1:" <> T.pack (show port) + +endpointAt :: Int -> Endpoint +endpointAt = valid . parseEndpoint . origin + +expectRight :: Show e => Either e a -> IO a +expectRight = either (\err -> assertFailure (show err) >> fail "unreachable") pure + +valid :: Show e => Either e a -> a +valid = either (error . show) id + +token :: Token +token = valid (parseToken "hf_test_token") + +repository :: RepoId +repository = valid (parseRepoId "owner/model") + +repoJSON :: BL.ByteString +repoJSON = "{\"id\":\"owner/model\",\"sha\":\"0123456789abcdef0123456789abcdef01234567\",\"private\":false,\"downloads\":42,\"likes\":2,\"siblings\":[{\"rfilename\":\"config.json\",\"size\":17}],\"futureField\":true}" + +chatJSON :: BL.ByteString +chatJSON = "{\"id\":\"chat-1\",\"model\":\"owner/model\",\"choices\":[{\"index\":0,\"message\":{\"role\":\"assistant\",\"content\":\"Hello!\"},\"finish_reason\":\"stop\"}],\"usage\":{\"prompt_tokens\":2,\"completion_tokens\":3,\"total_tokens\":5}}" + +jsonReply :: BL.ByteString -> Reply +jsonReply = (,,) status200 [(hContentType, "application/json")] + +main :: IO () +main = defaultMain $ testGroup "huggingface" + [ identifierTests, domainTests, grammarTests, moduleTests, monadTests, hubTests, transportTests, inferenceTests ] + +monadTests :: TestTree +monadTests = testGroup "Concrete client computations" + [ testCase "parser errors prevent any request" $ withFixture (jsonReply repoJSON) $ \client seen -> do + result <- runHuggingFaceM $ do + parsed <- liftEither (parseRepoId "owner/../model") + modelInfo client parsed Nothing + case result of + Left InvalidInput{} -> pure () + _ -> assertFailure (show result) + length <$> seen >>= (@?= 0) + , testCase "metadata and downloads compose without intermediate Either handling" $ + withServer (\request -> pure $ if "/api/" `BS.isPrefixOf` observedPath request + then jsonReply repoJSON else (status200, [], "content")) $ \port seen -> do + client <- clientAt port Nothing + result <- runHuggingFaceM $ do + info <- modelInfo client repository Nothing + file <- liftEither (parseRepoPath "config.json") + downloadFile client Model (repoId info) mainRevision file + result @?= Right "content" + map observedPath <$> seen >>= (@?= + ["/api/models/owner/model", "/owner/model/resolve/main/config.json"]) + , testCase "catchError can recover from an HTTP error with another operation" $ + withServer (\request -> pure $ if observedPath request == "/api/models" + then jsonReply "[]" else (status404, [], "missing")) $ \port seen -> do + client <- clientAt port Nothing + result <- runHuggingFaceM $ + (modelInfo client repository Nothing >> pure [repository]) `catchError` \err -> + case err of + HttpError {errorStatus = 404} -> map repoId . pageItems <$> listModels client defaultListOptions + _ -> throwError err + result @?= Right [] + map observedPath <$> seen >>= (@?= ["/api/models/owner/model", "/api/models"]) + , testCase "decode errors stop a subsequent inference request" $ withFixture (jsonReply "invalid") $ \client seen -> do + result <- runHuggingFaceM $ do + info <- modelInfo client repository Nothing + infer client (repoId info) (object []) :: HuggingFaceM Value + result @?= Left DecodeError + map observedPath <$> seen >>= (@?= ["/api/models/owner/model"]) + , testCase "IO adapters run once and participate in typed recovery" $ do + calls <- newIORef (0 :: Int) + let action = liftHuggingFaceM $ do + modifyIORef' calls (+ 1) + pure (Left DecodeError :: Either HuggingFaceError ()) + readIORef calls >>= (@?= 0) + result <- runHuggingFaceM $ (action >> liftIO (modifyIORef' calls (+ 100))) + `catchError` \err -> liftIO (err @?= DecodeError) + result @?= Right () + readIORef calls >>= (@?= 1) + , testCase "typed callback errors release the response before outer recovery" $ + withServer (const (pure (jsonReply "payload"))) $ \port seen -> do + closed <- newIORef False + manager <- newManager defaultManagerSettings + { managerRetryableException = const False + , managerModifyResponse = \response -> do + let HTTP.ResponseClose close = HTTP.responseClose' response + pure response {HTTP.responseClose' = HTTP.ResponseClose (close >> writeIORef closed True)} + } + let client = newClientWithManager manager defaultClientConfig {hubEndpoint = endpointAt port} + aborted = InvalidInput "Stopped download" + result <- runHuggingFaceM $ + withDownload client Model repository mainRevision (valid (parseRepoPath "file")) + (\_ -> do + liftIO (readIORef closed >>= (@?= False)) + throwError aborted) + `catchError` \err -> do + liftIO (err @?= aborted) + liftIO (readIORef closed >>= (@?= True)) + pure ("recovered" :: Text) + result @?= Right "recovered" + length <$> seen >>= (@?= 1) + ] + +moduleTests :: TestTree +moduleTests = testGroup "Exposed extension modules" + [ testCase "transport supports custom operations with parsed client configuration" $ + withFixture (jsonReply repoJSON) $ \client seen -> do + let request = Transport.requestFor client (clientHub client) ["api", "models", "owner", "model"] [] + response <- runHuggingFaceM (Transport.getJSON client request) >>= expectRight + repoId response @?= repository + requests <- seen + map observedPath requests @?= ["/api/models/owner/model"] + map (lookup hAuthorization . observedHeaders) requests @?= [Just "Bearer hf_test_token"] + , testCase "header-created continuations still require the configured origin" $ + withFixture (jsonReply "[]") $ \client seen -> do + let request = Transport.requestFor client (clientHub client) ["api", "models"] [] + headers = [("link", "; rel=next")] + case nextPageFromHeaders request headers of + Nothing -> assertFailure "missing parsed continuation" + Just next -> do + nextPageURL next @?= "https://other.example/api/models?cursor=PRIVATE" + show next @?= "" + (runHuggingFaceM (Transport.continuePage client next) :: IO (Either HuggingFaceError (Page RepoInfo))) + >>= (@?= Left InvalidPagination) + requests <- seen + length requests @?= 0 + , testCase "shared parser runners consume complete values and redact failures" $ do + Utils.parseValue "Malformed repository" repoIdParser "owner/model" @?= Right repository + Utils.parseValue "Malformed repository" repoIdParser "owner/model?secret=PRIVATE" + @?= Left (InvalidInput "Malformed repository") + (Utils.decodeJSON "{\"id\":\"PRIVATE/invalid/id\"}" :: Either HuggingFaceError RepoInfo) + @?= Left DecodeError + ] + +identifierTests :: TestTree +identifierTests = testGroup "Parsed domain values" + [ testCase "token is redacted in configuration" $ do + show token @?= "" + assertBool "config leaked token" (not ("hf_test_token" `isInfixOf` show defaultClientConfig {accessToken = Just token})) + , testCase "invalid tokens never echo their input" $ mapM_ (\value -> do + let result = parseToken value + assertBool "accepted malformed token" (isLeft result) + assertBool "echoed secret" (not ("SECRET" `isInfixOf` show result))) + ["", "hf_SECRET\r\nInjected: true", "hf_SECRET token", "hf_SECRET\955"] + , testGroup "invalid repositories" + [ testCase (show bad) $ assertBool "accepted invalid repo" (isLeft (parseRepoId bad)) + | bad <- ["", "/name", "name/", "a/b/c", "a/../b", "a?x=1", "https://example.com", "-name", "a..b", "a--b", "name.git", T.replicate 97 "x"] ] + , testProperty "repository identity round-trips" $ forAll (listOf1 (elements ['a' .. 'z'])) $ \name -> + let input = "owner/" <> T.pack (take 40 name) + in fmap repoIdText (parseRepoId input) === Right input + , testCase "branches may include slashes" $ + fmap revisionText (parseRevision "refs/pr/42") @?= Right "refs/pr/42" + , testCase "revisions reject empty and dot-only segments" $ + mapM_ (\input -> assertBool "unsafe revision" (isLeft (parseRevision input))) ["../main", "refs/../main", "/main", "main/"] + , testGroup "unsafe file paths" + [ testCase (show bad) $ assertBool "accepted unsafe path" (isLeft (parseRepoPath bad)) + | bad <- ["", "/config.json", "../config.json", "a/../b", "a/./b", "a//b", "a/", "a\\b", "a\NULb"] ] + , testCase "Unicode file names remain intact" $ + fmap repoPathText (parseRepoPath "sub/λ weights.json") @?= Right "sub/λ weights.json" + , testCase "unsafe endpoints fail to parse" $ + mapM_ (\endpoint -> assertBool "accepted unsafe endpoint" (isLeft (parseEndpoint endpoint))) + ["http://example.com", "https://user:secret@example.com", "https://example.com/api", "https://example.com?token=x", "https://example.com#fragment", "file:///tmp/data"] + , testCase "endpoint ports cannot overflow or wrap to another destination" $ + mapM_ (\portText -> assertBool "invalid port parsed" (isLeft (parseEndpoint ("https://example.com:" <> portText)))) + ["", "0", "-1", "65536", "65979", "18446744073709552059", "not-a-port"] + + ] + +domainTests :: TestTree +domainTests = testGroup "Domain boundaries" + [ testCase "repository components compose without reparsing" $ do + owner <- expectRight (parseAccountName "owner") + name <- expectRight (parseRepoName "model") + qualifiedRepo owner name @?= repository + repoOwner repository @?= Just owner + repoName repository @?= name + repoOwner <$> parseRepoId "bert" @?= Right Nothing + , testProperty "parsed repositories survive JSON encoding" $ + forAll (listOf1 (elements ['a' .. 'z'])) $ \name -> + let value = valid (parseRepoId ("owner/" <> T.pack (take 40 name))) + in eitherDecode (encode value) === Right value + , testCase "qualified fields parse during JSON decoding" $ do + mapM_ (\value -> assertBool "invalid response identity accepted" $ + isLeft (eitherDecode (encode value) :: Either String RepoInfo)) + [ object ["id" .= ("a/b/c" :: Text)] + , object ["id" .= repository, "sha" .= ("abc" :: Text)] + , object ["id" .= repository, "siblings" .= [object ["rfilename" .= ("../weights" :: Text)]]] + , object ["id" .= repository, "pipeline_tag" .= ("" :: Text)] + ] + assertBool "invalid account accepted" $ + isLeft (eitherDecode "{\"name\":\"owner/name\"}" :: Either String UserInfo) + , testCase "commit SHAs normalize and become revisions without reparsing" $ do + sha <- expectRight (parseCommitSha "0123456789ABCDEF0123456789ABCDEF01234567") + commitShaText sha @?= "0123456789abcdef0123456789abcdef01234567" + revisionText (commitRevision sha) @?= commitShaText sha + eitherDecode (encode sha) @?= Right sha + mapM_ (\raw -> assertBool "malformed SHA parsed" (isLeft (parseCommitSha raw))) + ["", "abc", T.replicate 40 "g", T.replicate 39 "a", T.replicate 41 "a"] + , testCase "all router policies and named providers retain their structure" $ do + provider <- expectRight (parseProvider "together") + let targets = modelFromRepo repository : map (routeModel repository) [Fastest, Cheapest, Preferred, Via provider] + mapM_ (\target -> do + modelRepository target @?= repository + parseInferenceModel (inferenceModelText target) @?= Right target + eitherDecode (encode target) @?= Right target) targets + map modelRouting targets @?= [Nothing, Just Fastest, Just Cheapest, Just Preferred, Just (Via provider)] + assertBool "policy accepted as provider" (isLeft (parseProvider "fastest")) + mapM_ (\raw -> assertBool "malformed model parsed" (isLeft (parseInferenceModel raw))) + ["", " ", "owner/model:", ":fastest", "owner/model:fastest:cheapest", "owner/model:bad provider", "owner/model:provider/path"] + , testCase "parsed paths and revisions retain escaped and Unicode content" $ do + let path = valid (parseRepoPath "λ/a %20.json") + revision = valid (parseRevision "refs/pr/42") + eitherDecode (encode path) @?= Right path + eitherDecode (encode revision) @?= Right revision + , testCase "open namespaces retain future server values" $ do + info <- expectRight (eitherDecode "{\"id\":\"owner/model\",\"tags\":[\"license:future-1.0\"],\"pipeline_tag\":\"future-task\",\"library_name\":\"future-library\",\"sdk\":\"future-sdk\"}" :: Either String RepoInfo) + map hubTagText (repoTags info) @?= ["license:future-1.0"] + fmap pipelineTagText (repoPipelineTag info) @?= Just "future-task" + fmap libraryNameText (repoLibraryName info) @?= Just "future-library" + fmap spaceSdkText (repoSdk info) @?= Just "future-sdk" + response <- expectRight (eitherDecode "{\"id\":\"provider:completion:1\",\"model\":\"provider/deployment/model-v2\",\"choices\":[{\"index\":0,\"message\":{\"role\":\"future_role\"},\"finish_reason\":\"future_reason\"}]}" :: Either String ChatCompletion) + completionIdText (completionId response) @?= "provider:completion:1" + modelNameText (completionModel response) @?= "provider/deployment/model-v2" + map (chatRoleText . messageRole . choiceMessage) (completionChoices response) @?= ["future_role"] + map (fmap finishReasonText . choiceFinishReason) (completionChoices response) @?= [Just "future_reason"] + , testCase "message identifiers parse on input and retain their JSON shape" $ do + call <- expectRight (parseToolCallId "call-1") + name <- expectRight (parseParticipantName "search_tool") + let message = ChatMessage toolRole (Just (String "result")) Nothing (Just call) (Just name) + toJSON message @?= object ["role" .= ("tool" :: Text), "content" .= ("result" :: Text), "tool_call_id" .= ("call-1" :: Text), "name" .= ("search_tool" :: Text)] + eitherDecode (encode message) @?= Right message + mapM_ (\raw -> do + participant <- expectRight (parseParticipantName raw) + eitherDecode (encode participant) @?= Right participant) + ["Zoë Reviewer", T.replicate 128 "x"] + mapM_ (\payload -> assertBool "invalid message identifier accepted" $ + isLeft (eitherDecode payload :: Either String ChatMessage)) + ["{\"role\":\"\"}", "{\"role\":\"tool\",\"tool_call_id\":\"\"}", "{\"role\":\"user\",\"name\":\"\"}"] + , testCase "numeric constraints produce usable types at construction" $ do + positiveIntValue <$> mkPositiveInt 1 @?= Right 1 + mapM_ (\n -> assertBool "nonpositive count parsed" (isLeft (mkPositiveInt n))) [minBound, -1, 0] + mapM_ (\n -> assertBool "invalid temperature parsed" (isLeft (mkChatTemperature n))) [-0.1, 2.1, 0/0, 1/0, -1/0] + mapM_ (\n -> assertBool "invalid top_p parsed" (isLeft (mkTopP n))) [0, -1, 1.1, 0/0, 1/0] + mapM_ (\n -> assertBool "invalid generation temperature parsed" (isLeft (mkGenerationTemperature n))) [0, -1, 0/0, 1/0] + mapM_ (\n -> chatTemperatureValue <$> mkChatTemperature n @?= Right n) [0, 2] + topPValue <$> mkTopP 1 @?= Right 1 + generationTemperatureValue <$> mkGenerationTemperature 3 @?= Right 3 + assertBool "numeric JSON bypassed smart constructor" (isLeft (eitherDecode "0" :: Either String PositiveInt)) + eitherDecode (encode (valid (mkTopP 0.7))) @?= Right (valid (mkTopP 0.7)) + , testCase "endpoint parser retains a renderable origin and hides bad credentials" $ do + mapM_ (\raw -> do + endpoint <- expectRight (parseEndpoint raw) + parseEndpoint (endpointText endpoint) @?= Right endpoint) + ["https://huggingface.co", "https://router.huggingface.co/", "https://example.com:1", "https://example.com:65535", "http://localhost:8080", "http://127.0.0.1:8000", "http://[::1]:8000"] + parseEndpoint (endpointText defaultHubEndpoint) @?= Right defaultHubEndpoint + parseEndpoint (endpointText defaultInferenceEndpoint) @?= Right defaultInferenceEndpoint + assertBool "parser echoed credentials" (not ("SECRET" `isInfixOf` show (parseEndpoint "https://user:SECRET@example.com"))) + ] + +grammarTests :: TestTree +grammarTests = testGroup "Parsec grammars" + [ testCase "Hub names handle punctuation and the exact length boundary" $ do + mapM_ (\raw -> fmap repoNameText (parseRepoName raw) @?= Right raw) + ["a", "_", "a_b", "a-b.c", "a-.b", "model.gitx", "model.git-more", T.replicate 96 "x"] + mapM_ (\raw -> assertBool "malformed name parsed" (isLeft (parseRepoName raw))) + [".a", "a.", "a-", "a..b", "a--b", "model.git", T.replicate 97 "x", "owner/name", "model:fastest"] + assertBool "invalid owner suffix parsed" (isLeft (parseRepoId "owner.git/model")) + assertBool "oversized owner parsed" (isLeft (parseRepoId (T.replicate 97 "x" <> "/model"))) + , testCase "routing policy prefixes do not consume provider slugs" $ do + mapM_ (\raw -> do + target <- expectRight (parseInferenceModel ("owner/model:" <> raw)) + case modelRouting target of + Just (Via provider) -> providerText provider @?= raw + other -> assertFailure (show other)) + ["fastest-provider", "cheapest-provider", "preferred-provider"] + mapM_ (\raw -> assertBool "trailing input parsed" (isLeft (parseInferenceModel raw))) + ["owner/model:fastest/extra", "owner/model:fastest:extra", "owner/model.git:fastest", "owner/model/extra:fastest", "owner/model:fastest\n"] + , testCase "tokens and complete identifiers reject trailing input" $ do + assertBool "token prefix accepted" (isLeft (parseToken "hf_secret!")) + assertBool "SHA prefix accepted" (isLeft (parseCommitSha (T.replicate 40 "a" <> "extra"))) + mapM_ (\raw -> assertBool "repository prefix accepted" (isLeft (parseRepoId raw))) + ["owner/model?key=value", "owner/model\n", "owner/model trailing"] + , testCase "component parsing preserves non-BMP text and excludes traversal" $ do + let raw = "🦄/λ weights/文件.json" + fmap repoPathText (parseRepoPath raw) @?= Right raw + fmap revisionText (parseRevision raw) @?= Right raw + mapM_ (\bad -> assertBool "bad segment accepted" (isLeft (parseRepoPath bad))) + ["🦄/../file", "🦄/./file", "🦄//file", "🦄/file\r\n"] + , testCase "open label grammars preserve spaces without accepting blank input" $ do + fmap participantNameText (parseParticipantName " Zoë Reviewer 🦄 ") @?= Right " Zoë Reviewer 🦄 " + mapM_ (\raw -> assertBool "blank label parsed" (isLeft (parseHubTag raw))) ["", " ", "\x2003", "abc\NUL"] + fmap completionIdText (parseCompletionId "") @?= Right "" + assertBool "blank nonempty completion ID parsed" (isLeft (parseCompletionId " ")) + , testCase "origin grammar consumes only a complete origin" $ do + fmap endpointText (parseEndpoint "https://example.com:000443/") @?= Right "https://example.com/" + mapM_ (\raw -> assertBool "non-origin parsed" (isLeft (parseEndpoint raw))) + [ "https://example.com//", "https://example.com/?secret=1", "https://example.com/#fragment" + , "https://example.com:443garbage", "https://example.com:443:80" + , "https://[::1", "https://[not-an-ip]", "http://localhost.evil.example" + , "https://example.com\n", "https://example.com@other.example" + ] + , testProperty "routed repository components render and reparse" $ + forAll (listOf1 (elements ['a' .. 'z'])) $ \suffix -> + let raw = "owner/model-" <> T.pack (take 40 suffix) <> ":fastest-provider" + in fmap inferenceModelText (parseInferenceModel raw) === Right raw + ] + +hubTests :: TestTree +hubTests = testGroup "Hub API" + [ testCase "lists models with encoded query parameters and authentication" $ + withFixture (jsonReply ("[" <> repoJSON <> "]")) $ \client seen -> do + page <- runHuggingFaceM (listModels client defaultListOptions + { listSearch = Just "hello & λ", listAuthor = Just (valid (parseAccountName "owner")), listFilter = map (valid . parseHubTag) ["text-generation", "pytorch"], listLimit = Just (valid (mkPositiveInt 2)), listFull = True }) + >>= expectRight + map repoId (pageItems page) @?= [repository] + requests <- seen + case requests of + [request] -> do + observedPath request @?= "/api/models" + observedMethod request @?= methodGet + lookup hAuthorization (observedHeaders request) @?= Just "Bearer hf_test_token" + sort (observedQuery request) @?= sort + [("search", Just "hello & \206\187"), ("author", Just "owner"), ("filter", Just "text-generation"), ("filter", Just "pytorch"), ("limit", Just "2"), ("full", Just "true")] + _ -> assertFailure (show requests) + , testCase "lists datasets and Spaces" $ withFixture (jsonReply "[]") $ \client seen -> do + _ <- runHuggingFaceM (listDatasets client defaultListOptions) >>= expectRight + _ <- runHuggingFaceM (listSpaces client defaultListOptions) >>= expectRight + map observedPath <$> seen >>= (@?= ["/api/datasets", "/api/spaces"]) + , testCase "metadata routes preserve slash-containing revisions" $ withFixture (jsonReply repoJSON) $ \client seen -> do + let revision = Just (valid (parseRevision "refs/pr/42")) + model <- runHuggingFaceM (modelInfo client repository revision) >>= expectRight + repoSha model @?= Just (valid (parseCommitSha "0123456789abcdef0123456789abcdef01234567")) + repoDownloads model @?= Just 42 + repoSiblings model @?= [RepoFile (valid (parseRepoPath "config.json")) (Just 17)] + KM.lookup "futureField" (repoRaw model) @?= Just (Bool True) + _ <- runHuggingFaceM (datasetInfo client repository Nothing) >>= expectRight + _ <- runHuggingFaceM (spaceInfo client repository Nothing) >>= expectRight + map observedPath <$> seen >>= (@?= ["/api/models/owner/model/revision/refs%2Fpr%2F42", "/api/datasets/owner/model", "/api/spaces/owner/model"]) + , testCase "metadata tolerates absent and null optional fields" $ do + info <- expectRight (eitherDecode "{\"id\":\"owner/model\",\"tags\":null,\"siblings\":null}" :: Either String RepoInfo) + repoTags info @?= [] + repoSiblings info @?= [] + repoPrivate info @?= Nothing + , testCase "metadata identifiers feed subsequent requests without parsing" $ + withServer (\request -> pure $ if "/api/" `BS.isPrefixOf` observedPath request + then jsonReply repoJSON else (status200, [], "content")) $ \port seen -> do + client <- clientAt port Nothing + info <- runHuggingFaceM (modelInfo client repository Nothing) >>= expectRight + case (repoSha info, repoSiblings info) of + (Just sha, file : _) -> do + runHuggingFaceM (downloadFile client Model (repoId info) (commitRevision sha) (fileName file)) >>= (@?= Right "content") + let target = routeModel (repoId info) Fastest + modelRepository target @?= repoId info + _ -> assertFailure "fixture must include a commit and file" + map observedPath <$> seen >>= (@?= + ["/api/models/owner/model", "/owner/model/resolve/0123456789abcdef0123456789abcdef01234567/config.json"]) + , testCase "whoami uses authenticated identity endpoint" $ withFixture (jsonReply "{\"name\":\"emilypi\",\"fullname\":\"Emily\"}") $ \client seen -> do + user <- runHuggingFaceM (whoAmI client) >>= expectRight + userName user @?= valid (parseAccountName "emilypi") + map observedPath <$> seen >>= (@?= ["/api/whoami-v2"]) + , testCase "public requests omit Authorization" $ withServer (const (pure (jsonReply "[]"))) $ \port seen -> do + client <- clientAt port Nothing + _ <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + map (lookup hAuthorization . observedHeaders) <$> seen >>= (@?= [Nothing]) + , testCase "Link pagination handles commas, quoted parameters and relative URLs" $ + withServer (\request -> pure $ if null (observedQuery request) + then (status200, [("link", "; title=\"one,two\"; rel=\"next last\", ; rel=\"prev\"")], "[]") + else jsonReply ("[" <> repoJSON <> "]")) $ \port seen -> do + client <- clientAt port (Just token) + first <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext first of + Nothing -> assertFailure "missing continuation" + Just next -> do + second <- runHuggingFaceM (nextPage client next) >>= expectRight + map repoId (pageItems second) @?= [repository] + pageNext second @?= Nothing + map observedQuery <$> seen >>= (@?= [[], [("cursor", Just "a,b")]]) + , testCase "cross-origin continuations are rejected" $ + withFixture (status200, [("link", "; rel=next")], "[]") $ \client seen -> do + first <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext first of + Just next -> (runHuggingFaceM (nextPage client next) :: IO (Either HuggingFaceError (Page RepoInfo))) >>= (@?= Left InvalidPagination) + Nothing -> assertFailure "missing continuation" + length <$> seen >>= (@?= 1) + , testCase "Link parameters accept HTTP whitespace around names and values" $ + withFixture (status200, [("link", ";\trel\t=\t\"next\"\t")], "[]") $ \client seen -> do + first <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext first of + Nothing -> assertFailure "missing tab-separated continuation" + Just next -> do + second <- runHuggingFaceM (nextPage client next) :: IO (Either HuggingFaceError (Page RepoInfo)) + _ <- expectRight second + map observedQuery <$> seen >>= (@?= [[], [("cursor", Just "x")]]) + , testCase "quoted Link extensions keep escaped quotes and delimiters inside values" $ + withFixture (status200, [("link", "; title=\"one\\\",two;three\"; rel=\"next last\"")], "[]") $ \client seen -> do + first <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext first of + Nothing -> assertFailure "missing quoted continuation" + Just next -> do + second <- runHuggingFaceM (nextPage client next) :: IO (Either HuggingFaceError (Page RepoInfo)) + _ <- expectRight second + map observedQuery <$> seen >>= (@?= [[], [("cursor", Just "a,b")]]) + , testCase "HTTP list grammar ignores empty Link members" $ + withFixture (status200, [("link", " , , ; rel=next, , ")], "[]") $ \client seen -> do + first <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext first of + Nothing -> assertFailure "missing continuation between empty members" + Just next -> do + second <- runHuggingFaceM (nextPage client next) :: IO (Either HuggingFaceError (Page RepoInfo)) + _ <- expectRight second + map observedQuery <$> seen >>= (@?= [[], [("cursor", Just "x")]]) + , testGroup "Link grammar cannot mistake extensions or malformed input for next" + [ testCase (show header) $ withFixture (status200, [("link", header)], "[]") $ \client _ -> do + page <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + pageNext page @?= Nothing + | header <- [ "; title=\"ignore; rel=next\"; rel=prev" + , "; rel=prev; rel=next" + , "; rel=\"next\" garbage" + , "; rel=\"next" + , " pure $ case observedPath request of + "/api/models" -> (status302, [(hLocation, "/relocated/models")], "") + "/relocated/models" | null (observedQuery request) -> (status200, [("link", "; rel=next")], "[]") + "/relocated/models" -> jsonReply ("[" <> repoJSON <> "]") + _ -> (status404, [], "")) $ \port seen -> do + client <- clientAt port Nothing + page <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + case pageNext page of + Nothing -> assertFailure "missing continuation" + Just next -> do + result <- runHuggingFaceM (nextPage client next) >>= expectRight + map repoId (pageItems result) @?= [repository] + map observedPath <$> seen >>= (@?= ["/api/models", "/relocated/models", "/relocated/models"]) + , testCase "downloads encode file names and repository prefixes" $ withFixture (jsonReply "bytes") $ \client seen -> do + let revision = valid (parseRevision "branch/name") + file = valid (parseRepoPath "sub/λ weights?.json") + mapM_ (\kind -> runHuggingFaceM (downloadFile client kind repository revision file) >>= (@?= Right "bytes")) [Model, Dataset, Space] + map (lookup hAccept . observedHeaders) <$> seen >>= (@?= replicate 3 (Just "*/*")) + map observedPath <$> seen >>= (@?= + [ "/owner/model/resolve/branch%2Fname/sub/%CE%BB%20weights%3F.json" + , "/datasets/owner/model/resolve/branch%2Fname/sub/%CE%BB%20weights%3F.json" + , "/spaces/owner/model/resolve/branch%2Fname/sub/%CE%BB%20weights%3F.json" ]) + ] + +transportTests :: TestTree +transportTests = testGroup "Transport" + [ testGroup "HTTP errors" + [ testCase (show code) $ withFixture (mkStatus code "error", [("x-request-id", "request-42"), ("retry-after", "7")], "{\"error\":\"hf_test_token\"}") $ \client seen -> do + result <- runHuggingFaceM (modelInfo client repository Nothing) + case result of + Left err@HttpError{} -> do + errorStatus err @?= code + errorRequestId err @?= Just "request-42" + errorRetryAfter err @?= Just "7" + assertBool "error body lost" ("hf_test_token" `BS.isInfixOf` errorBody err) + assertBool "error display leaked token" (not ("hf_test_token" `isInfixOf` show err)) + _ -> assertFailure (show result) + length <$> seen >>= (@?= 1) + | code <- [401, 403, 404, 429, 500, 503] ] + , testCase "error bodies are bounded" $ withFixture (status500, [], BL.replicate 100000 120) $ \client _ -> do + result <- runHuggingFaceM (modelInfo client repository Nothing) + case result of + Left err@HttpError{} -> BS.length (errorBody err) @?= 65536 + _ -> assertFailure (show result) + , testGroup "JSON errors" + [ testCase (B8.unpack (BL.toStrict payload)) $ withFixture (jsonReply payload) $ \client _ -> + runHuggingFaceM (modelInfo client repository Nothing) >>= (@?= Left DecodeError) + | payload <- ["error", "{\"not_id\":true}", "{\"id\":3}"] ] + , testCase "same-origin GET redirects retain token" $ + withServer (\request -> pure $ if observedPath request == "/api/models/owner/model" + then (status302, [(hLocation, "/canonical")], "") else jsonReply repoJSON) $ \port seen -> do + client <- clientAt port (Just token) + _ <- runHuggingFaceM (modelInfo client repository Nothing) >>= expectRight + map (lookup hAuthorization . observedHeaders) <$> seen >>= (@?= replicate 2 (Just "Bearer hf_test_token")) + , testCase "API redirects cannot cross origins" $ withFixture (status302, [(hLocation, "https://example.invalid/data")], "") $ \client _ -> + runHuggingFaceM (modelInfo client repository Nothing) >>= (@?= Left UnsafeRedirect) + , testCase "redirect loops terminate" $ withFixture (status302, [(hLocation, "/loop")], "") $ \client seen -> do + runHuggingFaceM (modelInfo client repository Nothing) >>= (@?= Left TooManyRedirects) + length <$> seen >>= (@?= 6) + , testCase "download redirects remove credentials across ports" $ + withServer (const (pure (jsonReply "download"))) $ \cdnPort cdnSeen -> + withFixture (status302, [(hLocation, encodeUtf8 (origin cdnPort <> "/blob"))], "") $ \client _ -> do + runHuggingFaceM (downloadFile client Model repository mainRevision (valid (parseRepoPath "weights.bin"))) >>= (@?= Right "download") + map (lookup hAuthorization . observedHeaders) <$> cdnSeen >>= (@?= [Nothing]) + , testCase "download callbacks can stop early and subsequent requests work" $ withFixture (jsonReply "payload") $ \client _ -> do + result <- runHuggingFaceM (withDownload client Model repository mainRevision (valid (parseRepoPath "file")) (liftIO . brRead)) + result @?= Right "payload" + result2 <- runHuggingFaceM (withDownload client Model repository mainRevision (valid (parseRepoPath "file")) (const (pure ()))) + result2 @?= Right () + , testCase "callback exceptions and asynchronous cancellation propagate" $ withFixture (jsonReply "payload") $ \client _ -> do + ioResult <- try (runHuggingFaceM (withDownload client Model repository mainRevision (valid (parseRepoPath "file")) (const (liftIO (ioError (userError "callback")))))) :: IO (Either IOException (Either HuggingFaceError ())) + assertBool "swallowed callback exception" (isLeft ioResult) + asyncResult <- try (runHuggingFaceM (withDownload client Model repository mainRevision (valid (parseRepoPath "file")) (const (liftIO (throwIO UserInterrupt))))) :: IO (Either AsyncException (Either HuggingFaceError ())) + asyncResult @?= Left UserInterrupt + ] + +inferenceTests :: TestTree +inferenceTests = testGroup "Hosted inference" + [ testCase "chat request, extensions, and typed response" $ withFixture (jsonReply chatJSON) $ \client seen -> do + let request = (defaultChatRequest (routeModel repository Fastest) (systemMessage "Be concise" :| [userMessage "Hi"])) + { chatMaxTokens = Just (valid (mkPositiveInt 20)), chatTemperature = Just (valid (mkChatTemperature 0.2)) + , chatExtra = KM.fromList [("stream", Bool True), ("model", String "wrong"), ("seed", Number 42)] } + response <- runHuggingFaceM (chatCompletion client request) >>= expectRight + completionUsage response @?= Just (Usage 2 3 5) + map (messageContent . choiceMessage) (completionChoices response) @?= [Just (String "Hello!")] + requests <- seen + case requests of + [sent] -> do + observedPath sent @?= "/v1/chat/completions" + observedMethod sent @?= methodPost + lookup hContentType (observedHeaders sent) @?= Just "application/json" + payload <- expectRight (eitherDecode (observedBody sent) :: Either String Object) + KM.lookup "model" payload @?= Just (String "owner/model:fastest") + KM.lookup "stream" payload @?= Just (Bool False) + KM.lookup "seed" payload @?= Just (Number 42) + KM.lookup "max_tokens" payload @?= Just (Number 20) + KM.member "top_p" payload @?= False + _ -> assertFailure (show requests) + , testCase "tool-call messages allow absent content" $ do + let payload = "{\"role\":\"assistant\",\"content\":null,\"tool_calls\":[{\"id\":\"call-1\"}]}" + message <- expectRight (eitherDecode payload :: Either String ChatMessage) + messageContent message @?= Nothing + assertBool "lost tool calls" (messageToolCalls message /= Nothing) + eitherDecode (encode message) @?= Right message + , testCase "successful TGI chat responses can have an empty completion ID" $ + withFixture (jsonReply "{\"id\":\"\",\"model\":\"tgi\",\"choices\":[]}") $ \client _ -> do + response <- runHuggingFaceM (chatCompletion client (defaultChatRequest (modelFromRepo repository) (userMessage "Hi" :| []))) >>= expectRight + completionIdText (completionId response) @?= "" + , testCase "chat redirects are returned without replaying POST" $ withFixture (status307, [(hLocation, "/other")], "") $ \client seen -> do + response <- runHuggingFaceM (chatCompletion client (defaultChatRequest (modelFromRepo repository) (userMessage "Hi" :| []))) + case response of Left err@HttpError{} -> errorStatus err @?= 307; _ -> assertFailure (show response) + length <$> seen >>= (@?= 1) + , testCase "lost response on a reused connection does not replay a billed POST" $ do + calls <- newIORef (0 :: Int) + let app request respond + | Wai.requestMethod request == methodGet = respond (Wai.responseLBS status200 [] "[]") + | otherwise = do + _ <- Wai.strictRequestBody request + atomicModifyIORef' calls (\n -> (n + 1, ())) + -- Drop the connection after receiving the POST, before any + -- response headers. A default http-client manager retries it. + respond (Wai.responseRaw (\_ _ -> pure ()) (Wai.responseLBS status500 [] "")) + testWithApplication (pure app) $ \port -> do + client <- newClient defaultClientConfig {hubEndpoint = endpointAt port, inferenceEndpoint = endpointAt port} + _ <- runHuggingFaceM (listModels client defaultListOptions) >>= expectRight + result <- runHuggingFaceM (chatCompletion client (defaultChatRequest (modelFromRepo repository) (userMessage "Hi" :| []))) + case result of + Left (TransportError _) -> pure () + _ -> assertFailure (show result) + readIORef calls >>= (@?= 1) + , testCase "feature extraction uses explicit task route and batch" $ withFixture (jsonReply "[[0.1,0.2],[0.3,0.4]]") $ \client seen -> do + runHuggingFaceM (featureExtraction client repository ("one" :| ["two"])) >>= (@?= Right [[0.1,0.2],[0.3,0.4]]) + requests <- seen + case requests of + [request] -> do + observedPath request @?= "/hf-inference/models/owner/model/pipeline/feature-extraction" + eitherDecode (observedBody request) @?= Right (object ["inputs" .= (["one", "two"] :: [Text])]) + _ -> assertFailure (show requests) + , testGroup "generation response shapes" + [ testCase (show index) $ withFixture (jsonReply payload) $ \client seen -> do + runHuggingFaceM (textGeneration client repository "Hello" defaultGenerationParameters {generationMaxNewTokens = Just (valid (mkPositiveInt 4))}) >>= (@?= Right [GeneratedText "world" Nothing]) + requests <- seen + case requests of + [request] -> do + observedPath request @?= "/hf-inference/models/owner/model" + eitherDecode (observedBody request) @?= Right (object ["inputs" .= ("Hello" :: Text), "parameters" .= object ["max_new_tokens" .= (4 :: Int)], "stream" .= False]) + _ -> assertFailure (show requests) + | (index, payload) <- zip [1 :: Int ..] ["[{\"generated_text\":\"world\"}]", "{\"generated_text\":\"world\"}"] ] + , testGroup "classification response shapes" + [ testCase (show index) $ withFixture (jsonReply payload) $ \client _ -> + runHuggingFaceM (classifyText client repository "great") >>= (@?= Right [Classification "POSITIVE" 0.9]) + | (index, payload) <- zip [1 :: Int ..] ["[{\"label\":\"POSITIVE\",\"score\":0.9}]", "[[{\"label\":\"POSITIVE\",\"score\":0.9}]]"] ] + , testCase "generic inference preserves custom JSON" $ withFixture (jsonReply "{\"answer\":42}") $ \client _ -> do + result <- runHuggingFaceM (infer client repository (object ["inputs" .= ("custom task" :: Text)])) :: IO (Either HuggingFaceError Value) + result @?= Right (object ["answer" .= (42 :: Int)]) + ]