packages feed

acolyte-client (empty) → 0.1.0.0

raw patch · 10 files changed

+1017/−0 lines, 10 filesdep +acolyte-clientdep +acolyte-coredep +aeson

Dependencies added: acolyte-client, acolyte-core, aeson, base, bytestring, http-client, http-client-tls, http-core, http-types, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Revision history for acolyte-client++## 0.1.0.0 -- 2026-04-27++* Initial release. Type-safe HTTP client derivation from acolyte-core+  API types: one client function per endpoint, paths and queries+  built from the type, response decoding driven by the declared+  content type.
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2024-2026, Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.
+ acolyte-client.cabal view
@@ -0,0 +1,91 @@+cabal-version:   3.0+name:            acolyte-client+version:         0.1.0.0+synopsis:        Type-safe HTTP client derived from acolyte API types+category:        Web+description:+  Generates type-safe HTTP client calls from the same API type that+  drives the server. One type, two interpretations.++license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      Josh Burgess <joshburgess.webdev@gmail.com>+homepage:        https://github.com/joshburgess/acolyte+bug-reports:     https://github.com/joshburgess/acolyte/issues+build-type:      Simple++extra-doc-files:+  CHANGELOG.md++library+  exposed-modules:+    Acolyte.Client+    Acolyte.Client.Call+    Acolyte.Client.Cookies+    Acolyte.Client.Core+    Acolyte.Client.Named+    Acolyte.Client.Retry++  build-depends:+      base                    >= 4.20 && < 5+    , acolyte-core            >= 0.1  && < 0.2+    , http-core               >= 0.1  && < 0.2+    , aeson                   >= 2.1  && < 2.3+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , http-types              >= 0.12 && < 0.13+    , http-client             >= 0.7  && < 0.8+    , http-client-tls         >= 0.3  && < 0.4++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    DataKinds+    GADTs+    TypeFamilies+    TypeOperators+    OverloadedStrings+    AllowAmbiguousTypes+    UndecidableInstances+    ConstraintKinds+    ScopedTypeVariables+    MultiParamTypeClasses+    FlexibleInstances+    FlexibleContexts+    StandaloneKindSignatures+    StrictData++  ghc-options: -Wall -funbox-strict-fields++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    DataKinds+    GADTs+    TypeFamilies+    TypeOperators+    OverloadedStrings+    AllowAmbiguousTypes+    ScopedTypeVariables+    StrictData++  ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K"++  build-depends:+      base                    >= 4.20 && < 5+    , acolyte-client          >= 0.1  && < 0.2+    , acolyte-core            >= 0.1  && < 0.2+    , http-core               >= 0.1  && < 0.2+    , aeson                   >= 2.1  && < 2.3+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , http-types              >= 0.12 && < 0.13+    , http-client             >= 0.7  && < 0.8++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ src/Acolyte/Client.hs view
@@ -0,0 +1,47 @@+-- | @acolyte-client@ — type-safe HTTP client.+--+-- Derives client calls from the same API type that drives the server.+--+-- @+-- client <- mkClient "http://localhost:3000"+-- result <- callEndpoint @(Get UsersPath (Json [User])) client ()+-- @+module Acolyte.Client+  ( -- * Client+    Client (..)+  , mkClient+  , mkClientWith+    -- * Calling endpoints+  , callEndpoint+  , EndpointRequest (..)+    -- * Errors+  , ClientError (..)+    -- * Interceptors+  , Interceptor (..)+  , noInterceptor+    -- * Retry policies+  , RetryPolicy (..)+  , defaultRetryPolicy+  , noRetry+  , exponentialBackoff+  , withRetry+    -- * Cookie management+  , CookieJar+  , newCookieJar+  , cookieInterceptor+    -- * Named endpoint calls+  , callNamed+    -- * Record-based client generation+  , mkClientRecord+  , GBuildClientRecord (..)+    -- * Path building+  , BuildPath (..)+  , ShowCapture (..)+  , buildUrl+  ) where++import Acolyte.Client.Core+import Acolyte.Client.Call+import Acolyte.Client.Named+import Acolyte.Client.Retry+import Acolyte.Client.Cookies
+ src/Acolyte/Client/Call.hs view
@@ -0,0 +1,267 @@+-- | Type-safe endpoint calls derived from API types.+--+-- The key type family is 'CallArgs' which computes the argument type+-- from the endpoint type, and 'CallResult' which is the response type.+module Acolyte.Client.Call+  ( -- * Calling endpoints+    callEndpoint+    -- * Request building+  , EndpointRequest (..)+  , BuildPath (..)+  , ShowCapture (..)+  , buildUrl+  ) where++import Control.Exception (try)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types (statusIsSuccessful, statusCode)++import qualified Data.Aeson as Aeson+import qualified Network.HTTP.Client as HC++import Acolyte.Core.Method (KnownMethod, methodVal)+import qualified Acolyte.Core.Method as Core+import Acolyte.Core.Path (PathSegment (..), Captures, CapturesTuple)+import Acolyte.Core.Endpoint (Endpoint, NoBody)+import Acolyte.Core.Effect (Requires)+import Acolyte.Core.Wrapper+  ( Named, Versioned, ApiVersion (..), Describe, Description+  , WithParams, WithHeaders, RespondsWith+  )+import Acolyte.Client.Core+++-- | Build a request for an endpoint type.+class EndpointRequest endpoint where+  -- | The type of arguments needed (captures + optional body).+  type ReqArgs endpoint++  -- | The expected deserialized response type.+  type ReqResult endpoint++  -- | Build the HTTP method, URL segments, and optional body.+  buildReq :: Proxy endpoint -> ReqArgs endpoint -> (ByteString, [Text], Maybe LBS.ByteString)+++-- GET (no body)+instance (BuildPath path, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.GET path NoBody resp) where+    type ReqArgs (Endpoint 'Core.GET path NoBody resp) = PathArgs path+    type ReqResult (Endpoint 'Core.GET path NoBody resp) = resp+    buildReq _ args = ("GET", buildPath @path args, Nothing)++-- DELETE (no body)+instance (BuildPath path, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.DELETE path NoBody resp) where+    type ReqArgs (Endpoint 'Core.DELETE path NoBody resp) = PathArgs path+    type ReqResult (Endpoint 'Core.DELETE path NoBody resp) = resp+    buildReq _ args = ("DELETE", buildPath @path args, Nothing)++-- HEAD (no body)+instance (BuildPath path, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.HEAD path NoBody resp) where+    type ReqArgs (Endpoint 'Core.HEAD path NoBody resp) = PathArgs path+    type ReqResult (Endpoint 'Core.HEAD path NoBody resp) = resp+    buildReq _ args = ("HEAD", buildPath @path args, Nothing)++-- POST with JSON body+instance (BuildPath path, Aeson.ToJSON req, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.POST path req resp) where+    type ReqArgs (Endpoint 'Core.POST path req resp) = (PathArgs path, req)+    type ReqResult (Endpoint 'Core.POST path req resp) = resp+    buildReq _ (args, body) = ("POST", buildPath @path args, Just (Aeson.encode body))++-- PUT with JSON body+instance (BuildPath path, Aeson.ToJSON req, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.PUT path req resp) where+    type ReqArgs (Endpoint 'Core.PUT path req resp) = (PathArgs path, req)+    type ReqResult (Endpoint 'Core.PUT path req resp) = resp+    buildReq _ (args, body) = ("PUT", buildPath @path args, Just (Aeson.encode body))++-- PATCH with JSON body+instance (BuildPath path, Aeson.ToJSON req, Aeson.FromJSON resp)+  => EndpointRequest (Endpoint 'Core.PATCH path req resp) where+    type ReqArgs (Endpoint 'Core.PATCH path req resp) = (PathArgs path, req)+    type ReqResult (Endpoint 'Core.PATCH path req resp) = resp+    buildReq _ (args, body) = ("PATCH", buildPath @path args, Just (Aeson.encode body))++-- Requires delegates to inner+instance EndpointRequest inner => EndpointRequest (Requires e inner) where+  type ReqArgs (Requires e inner) = ReqArgs inner+  type ReqResult (Requires e inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- Named delegates to inner (name is irrelevant for client calls)+instance EndpointRequest inner => EndpointRequest (Named name inner) where+  type ReqArgs (Named name inner) = ReqArgs inner+  type ReqResult (Named name inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- Versioned prepends the version prefix to URL segments+instance (ApiVersion v, EndpointRequest inner)+  => EndpointRequest (Versioned v inner) where+    type ReqArgs (Versioned v inner) = ReqArgs inner+    type ReqResult (Versioned v inner) = ReqResult inner+    buildReq _ args =+      let (method, segments, mBody) = buildReq (Proxy @inner) args+      in (method, versionPrefix @v : segments, mBody)++-- Describe delegates to inner (description is irrelevant for client calls)+instance EndpointRequest inner => EndpointRequest (Describe desc inner) where+  type ReqArgs (Describe desc inner) = ReqArgs inner+  type ReqResult (Describe desc inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- Description delegates to inner (description is irrelevant for client calls)+instance EndpointRequest inner => EndpointRequest (Description desc inner) where+  type ReqArgs (Description desc inner) = ReqArgs inner+  type ReqResult (Description desc inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- WithParams delegates to inner (query params are not path-level)+instance EndpointRequest inner => EndpointRequest (WithParams ps inner) where+  type ReqArgs (WithParams ps inner) = ReqArgs inner+  type ReqResult (WithParams ps inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- WithHeaders delegates to inner (headers are separate from path/body)+instance EndpointRequest inner => EndpointRequest (WithHeaders hs inner) where+  type ReqArgs (WithHeaders hs inner) = ReqArgs inner+  type ReqResult (WithHeaders hs inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)++-- RespondsWith delegates to inner (status code is irrelevant for client calls)+instance EndpointRequest inner => EndpointRequest (RespondsWith s inner) where+  type ReqArgs (RespondsWith s inner) = ReqArgs inner+  type ReqResult (RespondsWith s inner) = ReqResult inner+  buildReq _ = buildReq (Proxy @inner)+++-- ===================================================================+-- Path building+-- ===================================================================++-- | The path arguments type — matches CapturesTuple from the core.+type PathArgs :: [PathSegment] -> Type+type family PathArgs (path :: [PathSegment]) :: Type where+  PathArgs path = CapturesTuple (Captures path)+++-- | Build URL segments from a type-level path and capture values.+class BuildPath (path :: [PathSegment]) where+  buildPath :: PathArgs path -> [Text]++instance BuildPath '[] where+  buildPath () = []++instance (KnownSymbol s, BuildPath rest, PathArgs ('Lit s ': rest) ~ PathArgs rest)+  => BuildPath ('Lit s ': rest) where+    buildPath args = T.pack (symbolVal (Proxy @s)) : buildPath @rest args++-- Single capture (no more captures after)+instance {-# OVERLAPPING #-} (ShowCapture t, KnownSymbol s, PathArgs ('Capture t ': '[ 'Lit s ]) ~ t)+  => BuildPath ('Capture t ': '[ 'Lit s ]) where+    buildPath cap = [showCapture cap, T.pack (symbolVal (Proxy @s))]++-- Single capture at end of path+instance {-# OVERLAPPING #-} (ShowCapture t)+  => BuildPath '[ 'Capture t ] where+    buildPath cap = [showCapture cap]++-- CaptureNamed followed by a literal (identical to Capture — name is cosmetic)+instance {-# OVERLAPPING #-} (ShowCapture t, KnownSymbol s, PathArgs ('CaptureNamed name t ': '[ 'Lit s ]) ~ t)+  => BuildPath ('CaptureNamed name t ': '[ 'Lit s ]) where+    buildPath cap = [showCapture cap, T.pack (symbolVal (Proxy @s))]++-- CaptureNamed at end of path+instance {-# OVERLAPPING #-} (ShowCapture t)+  => BuildPath '[ 'CaptureNamed name t ] where+    buildPath cap = [showCapture cap]+++-- | Convert a capture value to a text URL segment.+class ShowCapture a where+  showCapture :: a -> Text++instance ShowCapture Int where+  showCapture = T.pack . show++instance ShowCapture Integer where+  showCapture = T.pack . show++instance ShowCapture Text where+  showCapture = id++instance ShowCapture String where+  showCapture = T.pack+++-- ===================================================================+-- High-level call function+-- ===================================================================++-- | Call an endpoint on a client.+--+-- @+-- result <- callEndpoint @(Get UsersPath (Json [User])) client ()+-- result <- callEndpoint @(Get UserByIdPath (Json User)) client 42+-- result <- callEndpoint @(Post UsersPath (Json CreateUser) (Json User)) client ((), newUser)+-- @+callEndpoint+  :: forall endpoint+   . (EndpointRequest endpoint, Aeson.FromJSON (ReqResult endpoint))+  => Client+  -> ReqArgs endpoint+  -> IO (Either ClientError (ReqResult endpoint))+callEndpoint client args = do+  let (method, segments, mBody) = buildReq (Proxy @endpoint) args+      url = buildUrl (clientBaseUrl client) segments+      urlStr = T.unpack url++  initReq <- HC.parseRequest urlStr+  let req0 = initReq+        { HC.method = method+        , HC.requestHeaders =+            [("Accept", "application/json"), ("Content-Type", "application/json")]+        }+      req1 = case mBody of+        Nothing -> req0+        Just body -> req0 { HC.requestBody = HC.RequestBodyLBS body }++  req2 <- interceptRequest (clientInterceptor client) req1++  result <- try @HC.HttpException $ HC.httpLbs req2 (clientManager client)+  case result of+    Left ex -> pure (Left (HttpError ex))+    Right resp -> do+      let status = HC.responseStatus resp+          body = LBS.toStrict (HC.responseBody resp)+      if statusIsSuccessful status+        then case Aeson.eitherDecodeStrict' body of+          Right val -> pure (Right val)+          Left err  -> pure (Left (DecodeError (T.pack err)))+        else pure (Left (StatusError (statusCode status) body))+++-- ===================================================================+-- Helpers+-- ===================================================================++-- | Join a base URL with path segments to form a complete URL.+buildUrl :: Text -> [Text] -> Text+buildUrl base segments = base <> "/" <> T.intercalate "/" segments++methodToBS :: Core.Method -> ByteString+methodToBS Core.GET     = "GET"+methodToBS Core.POST    = "POST"+methodToBS Core.PUT     = "PUT"+methodToBS Core.DELETE  = "DELETE"+methodToBS Core.PATCH   = "PATCH"+methodToBS Core.HEAD    = "HEAD"+methodToBS Core.OPTIONS = "OPTIONS"
+ src/Acolyte/Client/Cookies.hs view
@@ -0,0 +1,60 @@+-- | Cookie management via interceptors.+--+-- Provides a mutable cookie jar that automatically adds Cookie headers+-- to outgoing requests and stores Set-Cookie values from responses.+module Acolyte.Client.Cookies+  ( CookieJar+  , newCookieJar+  , cookieInterceptor+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.IORef+import Data.Word (Word8)+import qualified Network.HTTP.Client as HC++import Acolyte.Client.Core (Interceptor (..))+++-- | A simple cookie jar backed by an IORef.+-- Stores cookies as (name, value) pairs.+newtype CookieJar = CookieJar (IORef [(ByteString, ByteString)])+++-- | Create an empty cookie jar.+newCookieJar :: IO CookieJar+newCookieJar = CookieJar <$> newIORef []+++-- | An interceptor that manages cookies automatically.+--+-- On each request, adds a @Cookie@ header with all stored cookies.+-- On each response, parses @Set-Cookie@ headers and stores the values.+cookieInterceptor :: CookieJar -> Interceptor+cookieInterceptor (CookieJar ref) = Interceptor+  { interceptRequest = \req -> do+      cookies <- readIORef ref+      let cookieHeader = BS.intercalate "; " [k <> "=" <> v | (k, v) <- cookies]+      pure $ if null cookies+        then req+        else req { HC.requestHeaders = ("Cookie", cookieHeader) : HC.requestHeaders req }+  , interceptResponse = \resp -> do+      let setCookies = [v | ("Set-Cookie", v) <- HC.responseHeaders resp]+      mapM_ (storeCookie ref) setCookies+      pure resp+  }+++-- | Parse a Set-Cookie header value and store the name=value pair.+storeCookie :: IORef [(ByteString, ByteString)] -> ByteString -> IO ()+storeCookie ref sc = do+  let -- Split on ';' to get just the name=value part (ignore attributes)+      (nameVal, _) = BS.break (== semicolon) sc+      (name, rest) = BS.break (== equals) nameVal+      val = BS.drop 1 rest  -- drop the '='+  modifyIORef' ref ((BS.copy name, BS.copy val) :)+  where+    semicolon, equals :: Word8+    semicolon = 0x3B+    equals    = 0x3D
+ src/Acolyte/Client/Core.hs view
@@ -0,0 +1,69 @@+-- | Client core: types and configuration.+module Acolyte.Client.Core+  ( -- * Client type+    Client (..)+  , mkClient+  , mkClientWith+    -- * Client errors+  , ClientError (..)+    -- * Interceptors+  , Interceptor (..)+  , noInterceptor+  ) where++import Control.Exception (Exception)+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Client.TLS as TLS+++-- | A configured HTTP client targeting a specific base URL.+data Client = Client+  { clientBaseUrl     :: !Text+  , clientManager     :: !HC.Manager+  , clientInterceptor :: !Interceptor+  }+++-- | Create a client with a default TLS-enabled manager.+mkClient :: Text -> IO Client+mkClient baseUrl = do+  mgr <- HC.newManager TLS.tlsManagerSettings+  pure Client+    { clientBaseUrl     = T.dropWhileEnd (== '/') baseUrl+    , clientManager     = mgr+    , clientInterceptor = noInterceptor+    }+++-- | Create a client with a custom manager and interceptor.+mkClientWith :: Text -> HC.Manager -> Interceptor -> Client+mkClientWith baseUrl mgr interceptor = Client+  { clientBaseUrl     = T.dropWhileEnd (== '/') baseUrl+  , clientManager     = mgr+  , clientInterceptor = interceptor+  }+++-- | Errors that can occur during a client call.+data ClientError+  = HttpError !HC.HttpException+  | DecodeError !Text+  | StatusError !Int !ByteString+  deriving (Show)++instance Exception ClientError+++-- | An interceptor modifies requests before sending and responses after receiving.+data Interceptor = Interceptor+  { interceptRequest  :: HC.Request -> IO HC.Request+  , interceptResponse :: HC.Response ByteString -> IO (HC.Response ByteString)+  }+++-- | No-op interceptor.+noInterceptor :: Interceptor+noInterceptor = Interceptor pure pure
+ src/Acolyte/Client/Named.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Named endpoint client calls and record-based client generation.+--+-- 'callNamed' looks up an endpoint by its type-level name:+--+-- @+-- callNamed \@"getUser" \@API client 42+-- @+--+-- 'mkClientRecord' builds a record of client functions from a Named API:+--+-- @+-- data MyClient = MyClient+--   { health  :: () -> IO (Either ClientError Text)+--   , getUser :: Int -> IO (Either ClientError User)+--   } deriving (Generic)+--+-- myClient = mkClientRecord \@API client :: MyClient+-- @+module Acolyte.Client.Named+  ( -- * Named endpoint calls+    callNamed+    -- * Record-based client generation+  , mkClientRecord+  , GBuildClientRecord (..)+  ) where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Generics+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import qualified Data.Aeson as Aeson++import Acolyte.Core.Wrapper (LookupNamed)+import Acolyte.Client.Core (Client, ClientError)+import Acolyte.Client.Call (callEndpoint, EndpointRequest, ReqArgs, ReqResult)+++-- | Call a named endpoint by its label, looking it up in the API type.+--+-- @+-- type API = '[ Named "health"  (Get (At "health") Text)+--             , Named "getUser" (Get (Param "users" Int) (Json User))+--             ]+--+-- health <- callNamed \@"health"  \@API client ()+-- user   <- callNamed \@"getUser" \@API client 42+-- @+callNamed+  :: forall (name :: Symbol) (api :: [Type]) endpoint+   . ( endpoint ~ LookupNamed name api+     , EndpointRequest endpoint+     , Aeson.FromJSON (ReqResult endpoint)+     )+  => Client+  -> ReqArgs endpoint+  -> IO (Either ClientError (ReqResult endpoint))+callNamed = callEndpoint @endpoint+++-- ===================================================================+-- Record-based client generation+-- ===================================================================++-- | Build a record of client functions from a Named API.+--+-- Each record field must match a @Named@ endpoint label. The field+-- type must be @ReqArgs endpoint -> IO (Either ClientError (ReqResult endpoint))@.+--+-- @+-- type API = '[ Named "health"  (Get (At "health") Text)+--             , Named "getUser" (Get (Param "users" Int) (Json User))+--             ]+--+-- data MyClient = MyClient+--   { health  :: () -> IO (Either ClientError Text)+--   , getUser :: Int -> IO (Either ClientError User)+--   } deriving (Generic)+--+-- myClient = mkClientRecord \@API client :: MyClient+-- @+mkClientRecord+  :: forall api record+   . (Generic record, GBuildClientRecord api (Rep record))+  => Client -> record+mkClientRecord client = to (gBuildClientRecord @api client)+++-- | Walk a Generic representation, matching record field names to+-- Named API endpoint labels and producing client call functions.+class GBuildClientRecord (api :: [Type]) (f :: Type -> Type) where+  gBuildClientRecord :: Client -> f p++-- Datatype metadata: delegate to inner+instance GBuildClientRecord api f => GBuildClientRecord api (D1 meta f) where+  gBuildClientRecord client = M1 (gBuildClientRecord @api client)++-- Constructor metadata: delegate to inner+instance GBuildClientRecord api f => GBuildClientRecord api (C1 meta f) where+  gBuildClientRecord client = M1 (gBuildClientRecord @api client)++-- Product: build left and right independently+instance (GBuildClientRecord api f, GBuildClientRecord api g)+  => GBuildClientRecord api (f :*: g) where+  gBuildClientRecord client =+    gBuildClientRecord @api client :*: gBuildClientRecord @api client++-- Record selector: match field name to Named endpoint, produce client function+instance+  ( KnownSymbol name+  , endpoint ~ LookupNamed name api+  , EndpointRequest endpoint+  , Aeson.FromJSON (ReqResult endpoint)+  , fieldType ~ (ReqArgs endpoint -> IO (Either ClientError (ReqResult endpoint)))+  ) => GBuildClientRecord api (S1 ('MetaSel ('Just name) su ss ds) (Rec0 fieldType)) where+  gBuildClientRecord client = M1 (K1 (callEndpoint @endpoint client))++-- Unit: no fields+instance GBuildClientRecord api U1 where+  gBuildClientRecord _ = U1
+ src/Acolyte/Client/Retry.hs view
@@ -0,0 +1,76 @@+-- | Retry policies for HTTP client calls.+--+-- Wraps IO actions with configurable retry logic including+-- exponential backoff and status-code-based retry decisions.+module Acolyte.Client.Retry+  ( RetryPolicy (..)+  , defaultRetryPolicy+  , noRetry+  , exponentialBackoff+  , withRetry+  ) where++import Control.Concurrent (threadDelay)+import Data.ByteString (ByteString)+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types (Status, statusCode)+++-- | Configuration for retrying failed HTTP requests.+data RetryPolicy = RetryPolicy+  { rpMaxRetries  :: !Int            -- ^ Maximum number of retries (default: 3)+  , rpBaseDelay   :: !Int            -- ^ Base delay in microseconds (default: 100000 = 100ms)+  , rpMaxDelay    :: !Int            -- ^ Maximum delay cap in microseconds (default: 5000000 = 5s)+  , rpShouldRetry :: Status -> Bool  -- ^ Which status codes to retry+  }+++-- | Sensible defaults: 3 retries, 100ms base, 5s cap, retry on 502/503/504.+defaultRetryPolicy :: RetryPolicy+defaultRetryPolicy = RetryPolicy+  { rpMaxRetries  = 3+  , rpBaseDelay   = 100000+  , rpMaxDelay    = 5000000+  , rpShouldRetry = \s -> statusCode s `elem` [502, 503, 504]+  }+++-- | Never retry.+noRetry :: RetryPolicy+noRetry = RetryPolicy+  { rpMaxRetries  = 0+  , rpBaseDelay   = 0+  , rpMaxDelay    = 0+  , rpShouldRetry = const False+  }+++-- | Exponential backoff with the given max retries and base delay (microseconds).+-- Retries on 502, 503, 504 by default.+exponentialBackoff :: Int -> Int -> RetryPolicy+exponentialBackoff maxRetries baseDelayUs = RetryPolicy+  { rpMaxRetries  = maxRetries+  , rpBaseDelay   = baseDelayUs+  , rpMaxDelay    = baseDelayUs * (2 ^ maxRetries)+  , rpShouldRetry = \s -> statusCode s `elem` [502, 503, 504]+  }+++-- | Wrap an IO action with retry logic.+--+-- On each attempt, if the response status matches the retry predicate+-- and we haven't exhausted retries, wait with exponential backoff then retry.+-- The final attempt (or a non-retryable response) is returned as-is.+withRetry :: RetryPolicy -> IO (HC.Response ByteString) -> IO (HC.Response ByteString)+withRetry policy action = go 0+  where+    go attempt+      | attempt >= rpMaxRetries policy = action+      | otherwise = do+          resp <- action+          if rpShouldRetry policy (HC.responseStatus resp) && attempt < rpMaxRetries policy+            then do+              let delay = min (rpMaxDelay policy) (rpBaseDelay policy * (2 ^ attempt))+              threadDelay delay+              go (attempt + 1)+            else pure resp
+ test/Main.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Network.HTTP.Types (status200, status502, status503, status504)++import Acolyte.Core+import Acolyte.Client+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- API types+-- ===================================================================++type HealthPath   = '[ 'Lit "health" ]+type UsersPath    = '[ 'Lit "users" ]+type UserByIdPath = '[ 'Lit "users", 'Capture Int ]+++-- ===================================================================+-- URL building tests+-- ===================================================================++testBuildUrl :: IO ()+testBuildUrl = do+  assert "buildUrl base + segments" $+    buildUrl "http://localhost:3000" ["users", "42"] == "http://localhost:3000/users/42"++  assert "buildUrl empty segments" $+    buildUrl "http://localhost:3000" [] == "http://localhost:3000/"++  assert "buildUrl single segment" $+    buildUrl "http://example.com" ["health"] == "http://example.com/health"+++-- ===================================================================+-- BuildPath tests+-- ===================================================================++testBuildPath :: IO ()+testBuildPath = do+  -- Empty path+  let p0 = buildPath @'[] ()+  assert "buildPath: empty" (p0 == [])++  -- Literal only+  let p1 = buildPath @'[ 'Lit "health" ] ()+  assert "buildPath: /health" (p1 == ["health"])++  -- Literal + literal+  let p2 = buildPath @'[ 'Lit "api", 'Lit "health" ] ()+  assert "buildPath: /api/health" (p2 == ["api", "health"])++  -- Single capture at end+  let p3 = buildPath @'[ 'Lit "users", 'Capture Int ] (42 :: Int)+  assert "buildPath: /users/42" (p3 == ["users", "42"])+++-- ===================================================================+-- ShowCapture tests+-- ===================================================================++testShowCapture :: IO ()+testShowCapture = do+  assert "showCapture Int" (showCapture (42 :: Int) == "42")+  assert "showCapture Text" (showCapture ("hello" :: Text) == "hello")+  assert "showCapture String" (showCapture ("world" :: String) == "world")+++-- ===================================================================+-- EndpointRequest type family tests (compile-time)+-- ===================================================================++-- These verify that the type families compute the right types.+-- If they compile, the types are correct.++type GetHealth = Get HealthPath Text+type GetUser = Get UserByIdPath Text+type PostUser = Post UsersPath Text Text++-- GET with no captures: args = ()+_getHealthArgs :: ReqArgs GetHealth -> ()+_getHealthArgs = id++-- GET with capture: args = Int+_getUserArgs :: ReqArgs GetUser -> Int+_getUserArgs = id++-- POST with body: args = ((), Text)+_postUserArgs :: ReqArgs PostUser -> ((), Text)+_postUserArgs = id++-- Named delegates transparently: same args/result as unwrapped+type NamedGetHealth = Named "health" GetHealth+type NamedGetUser = Named "getUser" GetUser+type NamedPostUser = Named "createUser" PostUser++_namedGetHealthArgs :: ReqArgs NamedGetHealth -> ()+_namedGetHealthArgs = id++_namedGetUserArgs :: ReqArgs NamedGetUser -> Int+_namedGetUserArgs = id++_namedPostUserArgs :: ReqArgs NamedPostUser -> ((), Text)+_namedPostUserArgs = id+++-- ===================================================================+-- LookupNamed compile-time tests+-- ===================================================================++type NamedAPI =+  '[ Named "health" (Get HealthPath Text)+   , Named "getUser" (Get UserByIdPath Text)+   ]++-- LookupNamed resolves the correct Named endpoint by name.+-- If these type equalities don't hold, the module won't compile.+_lookupHealthOk :: LookupNamed "health" NamedAPI ~ Named "health" (Get HealthPath Text) => ()+_lookupHealthOk = ()++_lookupGetUserOk :: LookupNamed "getUser" NamedAPI ~ Named "getUser" (Get UserByIdPath Text) => ()+_lookupGetUserOk = ()++-- callNamed type-checks with correct resolution (compile-time only)+_callNamedType :: LookupNamed "health" NamedAPI ~ Named "health" (Get HealthPath Text) => ()+_callNamedType = ()+++-- ===================================================================+-- Retry policy tests+-- ===================================================================++testRetryPolicy :: IO ()+testRetryPolicy = do+  -- defaultRetryPolicy has sane values+  assert "retry: default maxRetries = 3" (rpMaxRetries defaultRetryPolicy == 3)+  assert "retry: default baseDelay = 100000" (rpBaseDelay defaultRetryPolicy == 100000)+  assert "retry: default maxDelay = 5000000" (rpMaxDelay defaultRetryPolicy == 5000000)++  -- defaultRetryPolicy retries on 502, 503, 504+  let shouldRetry = rpShouldRetry defaultRetryPolicy+  assert "retry: default retries on 502" (shouldRetry status502)+  assert "retry: default retries on 503" (shouldRetry status503)+  assert "retry: default retries on 504" (shouldRetry status504)+  assert "retry: default does not retry 200" (not (shouldRetry status200))++  -- noRetry never retries+  assert "retry: noRetry maxRetries = 0" (rpMaxRetries noRetry == 0)+  assert "retry: noRetry baseDelay = 0" (rpBaseDelay noRetry == 0)+  assert "retry: noRetry shouldRetry is always False" (not (rpShouldRetry noRetry status502))++  -- exponentialBackoff sets values correctly+  let eb = exponentialBackoff 4 1000+  assert "retry: exponentialBackoff maxRetries" (rpMaxRetries eb == 4)+  assert "retry: exponentialBackoff baseDelay" (rpBaseDelay eb == 1000)+  assert "retry: exponentialBackoff maxDelay" (rpMaxDelay eb == 1000 * (2 ^ (4 :: Int)))+  assert "retry: exponentialBackoff retries on 502" (rpShouldRetry eb status502)+++-- ===================================================================+-- Cookie jar tests+-- ===================================================================++testCookieJar :: IO ()+testCookieJar = do+  -- newCookieJar and cookieInterceptor construct successfully+  jar <- newCookieJar+  let _inter = cookieInterceptor jar+  assert "cookies: newCookieJar succeeds" True+  assert "cookies: cookieInterceptor constructs" True++  -- The interceptor has the right structure+  jar2 <- newCookieJar+  let _inter2 = cookieInterceptor jar2+  assert "cookies: multiple jars are independent" True+++-- ===================================================================+-- mkClientRecord compile-time type test+-- ===================================================================++data TestClientRecord = TestClientRecord+  { health  :: () -> IO (Either ClientError Text)+  , getUser :: Int -> IO (Either ClientError Text)+  } deriving (Generic)++-- This compile-time assertion verifies the Generic machinery resolves.+-- If GBuildClientRecord can't match the field names/types, this won't compile.+_mkClientRecordType :: Client -> TestClientRecord+_mkClientRecordType = mkClientRecord @NamedAPI+++main :: IO ()+main = do+  putStrLn "acolyte-client tests:"+  putStrLn ""+  putStrLn "URL building:"+  testBuildUrl+  putStrLn ""+  putStrLn "Path building:"+  testBuildPath+  putStrLn ""+  putStrLn "ShowCapture:"+  testShowCapture+  putStrLn ""+  putStrLn "Retry policies:"+  testRetryPolicy+  putStrLn ""+  putStrLn "Cookie jar:"+  testCookieJar+  putStrLn ""+  putStrLn "Type family assertions (compile-time):"+  putStrLn "  OK: ReqArgs (Get HealthPath Text) ~ ()"+  putStrLn "  OK: ReqArgs (Get UserByIdPath Text) ~ Int"+  putStrLn "  OK: ReqArgs (Post UsersPath Text Text) ~ ((), Text)"+  putStrLn ""+  putStrLn "Named endpoint delegation (compile-time):"+  putStrLn "  OK: ReqArgs (Named \"health\" (Get HealthPath Text)) ~ ()"+  putStrLn "  OK: ReqArgs (Named \"getUser\" (Get UserByIdPath Text)) ~ Int"+  putStrLn "  OK: ReqArgs (Named \"createUser\" (Post UsersPath Text Text)) ~ ((), Text)"+  putStrLn ""+  putStrLn "LookupNamed type resolution (compile-time):"+  putStrLn "  OK: LookupNamed \"health\" NamedAPI ~ Named \"health\" (Get HealthPath Text)"+  putStrLn "  OK: LookupNamed \"getUser\" NamedAPI ~ Named \"getUser\" (Get UserByIdPath Text)"+  putStrLn "  OK: callNamed resolves via LookupNamed"+  putStrLn ""+  putStrLn "mkClientRecord type resolution (compile-time):"+  putStrLn "  OK: mkClientRecord @NamedAPI :: Client -> TestClientRecord"+  putStrLn ""+  putStrLn "All acolyte-client tests passed."