roboservant 0.1.0.3 → 0.1.0.4

raw patch · 8 files changed

+239/−68 lines, 8 filesdep ~aesondep ~bytestringdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, bytestring, containers, dependent-map, dependent-sum, hashable, http-api-data, http-client, http-types, lifted-base, monad-control, mtl, random, servant, servant-client, servant-flatten, servant-server, string-conversions, text, time, unordered-containers, vinyl, wai, warp

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• Example.lhs +34/−0
• README.md +4/−0
• roboservant.cabal +69/−68
• src/Roboservant/Client.hs +25/−0
• src/Roboservant/Types/ReifiedApi/Server.hs +24/−0
• test/Records.hs +70/−0
• test/Spec.hs +10/−0

@@ -1,3 +1,6 @@ # Changelog for roboservant  ## Unreleased changes++## 0.1.0.4 - 2025-09-16+- document record-style servant API support and show it in the tutorial

@@ -23,6 +23,8 @@ import Roboservant.Types import Test.Hspec import Servant+import Servant.API.Generic +import Servant.Server.Generic (AsServer) import GHC.Generics import Data.Typeable import Data.Hashable@@ -128,6 +130,38 @@ ```haskell deriving via (Compound B) instance BuildFrom B deriving via (Atom B) instance Breakdown B+```+++## Record APIs++Roboservant can drive record-style servant APIs that use+`Servant.API.Generic` and `Servant.Server.Generic`. Define the+record-of-routes, provide a record server, and `fuzz` works as it does+for vanilla route trees.++```haskell+data RecordRoutes mode = RecordRoutes+  { recordGet :: mode :- Get '[JSON] Int+  , recordDelete :: mode :- Capture "unused" Int :> Delete '[JSON] ()+  }+  deriving stock (Generic)++type RecordApi = NamedRoutes RecordRoutes++recordServer :: RecordRoutes AsServer+recordServer =+  RecordRoutes+    { recordGet = pure 42+    , recordDelete = const (pure ())+    }++recordSpec :: Spec+recordSpec =+  describe "record apis" $+    it "fuzzes a NamedRoutes server" $+      RS.fuzz @RecordApi recordServer config+        >>= (`shouldSatisfy` isNothing) ```  

@@ -9,6 +9,10 @@  see full example [here](EXAMPLE.md) +Record-style servant APIs built with `Servant.API.Generic` and+`NamedRoutes` are supported as well; the example file now includes a+walkthrough of fuzzing a record server.+ ## why?  Servant gives us a lot of information about what a server can do. We

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack ----- hash: 9fb762faa0870b60a03c6e2ec00a2958457ab4a2951e16f4e589e183603afe47+-- hash: 13209f99d9f8ea91e1c5b19e7bc4e414b5870701bc606f7f662de3f1ac3072e0  name:           roboservant-version:        0.1.0.3+version:        0.1.0.4 synopsis:       Automatic session-aware servant testing description:    Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme> category:       Web@@ -47,25 +47,25 @@   ghc-options: -Wall -fwrite-ide-info -hiedir=.hie   build-depends:       base >=4.7 && <5-    , bytestring-    , containers-    , dependent-map-    , dependent-sum-    , hashable-    , http-types-    , lifted-base-    , monad-control-    , mtl-    , random-    , servant-    , servant-client-    , servant-flatten-    , servant-server-    , string-conversions-    , text-    , time-    , unordered-containers-    , vinyl+    , bytestring >=0.11 && <0.13+    , containers ==0.6.*+    , dependent-map ==0.4.*+    , dependent-sum ==0.7.*+    , hashable >=1.4 && <1.6+    , http-types ==0.12.*+    , lifted-base ==0.2.*+    , monad-control ==1.0.*+    , mtl >=2.2 && <2.4+    , random >=1.2 && <1.4+    , servant >=0.18 && <0.21+    , servant-client >=0.18 && <0.21+    , servant-flatten ==0.2.*+    , servant-server >=0.18 && <0.21+    , string-conversions ==0.4.*+    , text >=1.2 && <2.1+    , time >=1.9 && <1.13+    , unordered-containers >=0.2.10 && <0.3+    , vinyl >=0.13 && <0.15   default-language: Haskell2010  test-suite example@@ -79,32 +79,32 @@   build-tool-depends:       markdown-unlit:markdown-unlit   build-depends:-      aeson+      aeson >=1.5 && <2.3     , base >=4.7 && <5-    , bytestring-    , containers-    , dependent-map-    , dependent-sum-    , hashable+    , bytestring >=0.11 && <0.13+    , containers ==0.6.*+    , dependent-map ==0.4.*+    , dependent-sum ==0.7.*+    , hashable >=1.4 && <1.6     , hspec     , hspec-core-    , http-client-    , http-types-    , lifted-base-    , monad-control-    , mtl-    , random+    , http-client >=0.5 && <0.8+    , http-types ==0.12.*+    , lifted-base ==0.2.*+    , monad-control ==1.0.*+    , mtl >=2.2 && <2.4+    , random >=1.2 && <1.4     , roboservant-    , servant-    , servant-client-    , servant-flatten-    , servant-server-    , string-conversions-    , text-    , time-    , unordered-containers-    , vinyl-    , warp+    , servant >=0.18 && <0.21+    , servant-client >=0.18 && <0.21+    , servant-flatten ==0.2.*+    , servant-server >=0.18 && <0.21+    , string-conversions ==0.4.*+    , text >=1.2 && <2.1+    , time >=1.9 && <1.13+    , unordered-containers >=0.2.10 && <0.3+    , vinyl >=0.13 && <0.15+    , warp >=3.3 && <3.5   default-language: Haskell2010  test-suite roboservant-test@@ -119,6 +119,7 @@       Product       Put       QueryParams+      Records       Seeded       UnsafeIO       Valid@@ -127,33 +128,33 @@       test   ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N   build-depends:-      aeson+      aeson >=1.5 && <2.3     , base >=4.7 && <5-    , bytestring-    , containers-    , dependent-map-    , dependent-sum-    , hashable+    , bytestring >=0.11 && <0.13+    , containers ==0.6.*+    , dependent-map ==0.4.*+    , dependent-sum ==0.7.*+    , hashable >=1.4 && <1.6     , hspec     , hspec-core     , hspec-wai-    , http-api-data-    , http-client-    , http-types-    , lifted-base-    , monad-control-    , mtl-    , random+    , http-api-data >=0.4 && <0.7+    , http-client >=0.5 && <0.8+    , http-types ==0.12.*+    , lifted-base ==0.2.*+    , monad-control ==1.0.*+    , mtl >=2.2 && <2.4+    , random >=1.2 && <1.4     , roboservant-    , servant-    , servant-client-    , servant-flatten-    , servant-server-    , string-conversions-    , text-    , time-    , unordered-containers-    , vinyl-    , wai-    , warp+    , servant >=0.18 && <0.21+    , servant-client >=0.18 && <0.21+    , servant-flatten ==0.2.*+    , servant-server >=0.18 && <0.21+    , string-conversions ==0.4.*+    , text >=1.2 && <2.1+    , time >=1.9 && <1.13+    , unordered-containers >=0.2.10 && <0.3+    , vinyl >=0.13 && <0.15+    , wai ==3.2.*+    , warp >=3.3 && <3.5   default-language: Haskell2010

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}@@ -63,6 +64,24 @@   flattenClient :: Client ClientM api  -> ClientBundled (Endpoints api)  instance+  ( GenericServant routes (AsClientT ClientM)+  , FlattenClient (ToServantApi routes)+  , Client ClientM (ToServantApi routes) ~ ToServant routes (AsClientT ClientM)+  , ToReifiedClientApi (Endpoints (ToServantApi routes))+  , ToReifiedClientApi endpoints+  ) =>+  ToReifiedClientApi (NamedRoutes routes ': endpoints) where+  toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =+    let nested = toReifiedClientApi+                  (flattenClient @(ToServantApi routes) (toServant endpoint))+                  (Proxy @(Endpoints (ToServantApi routes)))+                  clientEnv+        offset = fromIntegral (length nested)+     in nested ++ shiftClient offset (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)+++instance+  {-# OVERLAPPABLE #-}   ( NormalizeFunction (Client ClientM endpoint)   , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))   , ToReifiedClientApi endpoints@@ -83,6 +102,9 @@           -> V.Curried (EndpointArgs endpoint) (IO ResultType)       foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv) +shiftClient :: ApiOffset -> ReifiedApi -> ReifiedApi+shiftClient offset = map (first (+ offset))+ mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g @@ -124,4 +146,7 @@  instance FlattenClient (Verb method statusCode contentTypes responseType)   where+  flattenClient c = c `AClientEndpoint` NoClientEndpoints++instance FlattenClient (NamedRoutes routes) where   flattenClient c = c `AClientEndpoint` NoClientEndpoints

@@ -19,6 +19,7 @@ module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where  import Servant+import Servant.Server.Generic (AsServer)  import Control.Monad.Except (runExceptT) import Data.Bifunctor@@ -42,6 +43,23 @@   toReifiedApi NoEndpoints _ = []  instance+  ( GenericServant routes AsServer+  , FlattenServer (ToServantApi routes)+  , Server (ToServantApi routes) ~ ToServant routes AsServer+  , ToReifiedApi (Endpoints (ToServantApi routes))+  , ToReifiedApi endpoints+  ) =>+  ToReifiedApi (NamedRoutes routes ': endpoints)+  where+  toReifiedApi (endpoint `AnEndpoint` endpoints) _ =+    let nested = toReifiedApi+                   (flattenServer @(ToServantApi routes) (toServant endpoint))+                   (Proxy @(Endpoints (ToServantApi routes)))+        offset = fromIntegral (length nested)+     in nested ++ shiftOffsets offset (toReifiedApi endpoints (Proxy @endpoints))++instance+  {-# OVERLAPPABLE #-}   ( NormalizeFunction (ServerT endpoint Handler)   , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))   , ToReifiedEndpoint endpoint@@ -58,7 +76,10 @@       : (map . first) (+1)         (toReifiedApi endpoints (Proxy @endpoints)) +shiftOffsets :: ApiOffset -> ReifiedApi -> ReifiedApi+shiftOffsets offset = map (first (+ offset)) + instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where   type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))   normalize handler = (runExceptT . runHandler') handler >>= \case@@ -103,6 +124,9 @@  instance FlattenServer (Verb method statusCode contentTypes responseType)   where+  flattenServer server = server `AnEndpoint` NoEndpoints++instance FlattenServer (NamedRoutes routes) where   flattenServer server = server `AnEndpoint` NoEndpoints  class NormalizeFunction m where

@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeOperators #-}++module Records where++import Data.Void (Void)+import Servant+import Servant.API.Generic+import Servant.Server.Generic++data Routes mode = Routes+  { getInt :: mode :- Get '[JSON] Int+  , captureVoid :: mode :- Capture "void" Void :> Get '[JSON] ()+  }+  deriving stock (Generic)++type Api = NamedRoutes Routes++server :: Server Api+server = recordServer++recordServer :: Routes AsServer+recordServer =+  Routes+    { getInt = pure 7+    , captureVoid = const (pure ())+    }++badServer :: Server Api+badServer = badRecordServer++badRecordServer :: Routes AsServer+badRecordServer =+  Routes+    { getInt = throwError err500+    , captureVoid = const (pure ())+    }++data ComplexRoutes mode = ComplexRoutes+  { nested :: mode :- "nested" :> Capture "level" Int :> QueryParam "extra" Int :> Get '[JSON] Int+  , optional :: mode :- QueryParam "bonus" Int :> Header' '[Required] "flag" Int :> Get '[JSON] Int+  , combined :: mode :- "combine" :> Capture "first" Int :> Capture "second" Int :> ReqBody '[JSON] Int :> Put '[JSON] Int+  }+  deriving stock (Generic)++type ComplexApi = NamedRoutes ComplexRoutes++complexServer :: Server ComplexApi+complexServer = complexRecordServer++complexRecordServer :: ComplexRoutes AsServer+complexRecordServer =+  ComplexRoutes+    { nested = \lvl mExtra -> pure $ lvl + maybe 0 (* 2) mExtra+    , optional = \mBonus hdr -> pure $ maybe 0 id mBonus + hdr+    , combined = \a b body -> pure (a + b + body)+    }++complexBadServer :: Server ComplexApi+complexBadServer = complexBadRecordServer++complexBadRecordServer :: ComplexRoutes AsServer+complexBadRecordServer =+  ComplexRoutes+    { nested = \_ _ -> throwError err500+    , optional = \_ _ -> throwError err500+    , combined = \_ _ _ -> throwError err500+    }

@@ -24,6 +24,7 @@ import qualified Put import qualified Product import qualified QueryParams+import qualified Records import qualified Roboservant as R import qualified Roboservant.Server as RS import qualified Roboservant.Client as RC@@ -68,6 +69,9 @@     describe "noError" $ do       fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)       fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app"   Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)+      fuzzBoth @Records.Api "finds no error in a record-based generic app" Records.server R.defaultConfig (`shouldSatisfy` isNothing)+      let complexSeeds = [R.hashedDyn (1 :: Int), R.hashedDyn (2 :: Int), R.hashedDyn (3 :: Int)]+      fuzzBoth @Records.ComplexApi "finds no error in a complex record-based generic app" Records.complexServer R.defaultConfig { R.seed = complexSeeds } (`shouldSatisfy` isNothing)       fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}         (\r ->            fmap (R.failureReason . R.rsException) r@@ -93,6 +97,12 @@      describe "Foo" $       fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)++    describe "Records" $+      do+        fuzzBoth @Records.Api "finds an error in a record-based generic app that throws" Records.badServer R.defaultConfig (`shouldSatisfy` serverFailure)+        let complexSeeds = [R.hashedDyn (10 :: Int), R.hashedDyn (20 :: Int), R.hashedDyn (30 :: Int)]+        fuzzBoth @Records.ComplexApi "finds an error in a complex record-based generic app that throws" Records.complexBadServer R.defaultConfig { R.seed = complexSeeds } (`shouldSatisfy` serverFailure)      describe "QueryParams" $       fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }