diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Example.lhs b/Example.lhs --- a/Example.lhs +++ b/Example.lhs @@ -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) ``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/roboservant.cabal b/roboservant.cabal --- a/roboservant.cabal +++ b/roboservant.cabal @@ -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 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 diff --git a/src/Roboservant/Client.hs b/src/Roboservant/Client.hs --- a/src/Roboservant/Client.hs +++ b/src/Roboservant/Client.hs @@ -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 diff --git a/src/Roboservant/Types/ReifiedApi/Server.hs b/src/Roboservant/Types/ReifiedApi/Server.hs --- a/src/Roboservant/Types/ReifiedApi/Server.hs +++ b/src/Roboservant/Types/ReifiedApi/Server.hs @@ -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 diff --git a/test/Records.hs b/test/Records.hs new file mode 100644 --- /dev/null +++ b/test/Records.hs @@ -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 + } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)] }