make servant-client work

This commit is contained in:
Mark Wotton 2021-03-16 15:20:09 -04:00
parent 53ab47e4c1
commit c41cee3296
14 changed files with 493 additions and 260 deletions

View File

@ -13,23 +13,37 @@ Our api under test:
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
import Roboservant
import qualified Roboservant.Server as RS
import qualified Roboservant.Client as RC
import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Roboservant.Types
import Test.Hspec
import Servant
import GHC.Generics
import Data.Typeable
import Data.Hashable
import Data.Maybe(isNothing, isJust)
import qualified Network.Wai.Handler.Warp as Warp
import Data.Aeson(FromJSON,ToJSON)
newtype A = A Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
instance FromJSON A
instance ToJSON A
newtype B = B Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
instance FromJSON B
instance ToJSON B
type Api =
"item" :> Get '[JSON] A
:<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B
@ -62,13 +76,24 @@ main = hspec spec
spec :: Spec
spec = describe "example" $ do
it "good server should not fail" $ do
fuzz @Api goodServer config
RS.fuzz @Api goodServer config
>>= (`shouldSatisfy` isNothing)
it "bad server should fail" $ do
fuzz @Api badServer config
RS.fuzz @Api badServer config
>>= (`shouldSatisfy` isJust)
```
The previous test just picked apart the server and ran functions manually: sometimes, we want to test via
an honest-to-goodness network port, like so:
```haskell
around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do
it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do
RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)
```
(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:
we want to check what a client does when presented with a faulty server.)
We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.
There are other tweakable things in the config, like maximum runtime, reps,
@ -104,3 +129,15 @@ build it up from components.
deriving via (Compound B) instance BuildFrom B
deriving via (Atom B) instance Breakdown B
```
test utilities:
``` haskell
withServer :: Application -> ActionWith ClientEnv -> IO ()
withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)
where genClientEnv port = do
baseUrl <- parseBaseUrl "http://localhost"
manager <- newManager defaultManagerSettings
pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
```

View File

@ -1,9 +1,11 @@
n=$1
k=$2
cat prelude
echo -n "type Api = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
echo -n "type SubApi = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
for i in $(seq 2 $n); do
echo " :<|> \"route${i}\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
echo -n " :<|> \"route${i}\" :> "
echo "ReqBody '[JSON] Input :> Post '[JSON] Output"
done
echo -n "server = handler "
@ -11,3 +13,14 @@ echo -n "server = handler "
for i in $(seq 2 $n); do
echo -n ":<|> handler "
done
echo
echo
echo -n "type Api = Flatten ("
for i in $(seq 1 $k); do
echo -n '"foo" :> '
done;
echo "SubApi )"

View File

@ -12,6 +12,7 @@ import Servant
import Data.Hashable
import GHC.Generics
import Data.Aeson
import Servant.API.Flatten
data Input = Input1 { foo :: String }
| Input2 { bar :: Int }
@ -52,19 +53,9 @@ handler = pure . \case
Input1 foo -> Output1 foo
Input2 bar -> Output2 bar
main = fuzz @Api server defaultConfig (pure ())
main =
-- fuzz @Api server defaultConfig
pure ()
f = flatten (Proxy @Api)
defaultConfig :: Config
defaultConfig = Config {
-- you can pass extra values in using the seed argument. This can be useful
-- for things that might not be produceable within the api, like auth tokens.
seed = [hashedDyn "blah"]
, maxRuntime = 0.5
-- if we get to 1000 interactions with the api, call it quits.
, maxReps = 1000
-- if you're using this inside quickcheck or hedgehog, you might want to set this
-- from their seed to make sure it stays deterministic
, rngSeed = 0
-- 0 to 100: fail tests if we hit less than this percentage of endpoints.
, coverageThreshold = 0
}

View File

@ -1,8 +1,8 @@
lo=$1
hi=$2
k=$3
for i in $(seq $lo 5 $hi); do
./genFile.sh $i > main.hs;
./genFile.sh $i $k > main.hs;
echo "sievedn: $i,";
/usr/bin/time -f "%e" stack ghc main.hs 2>&1;
# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;

View File

@ -55,7 +55,10 @@ tests:
- hspec
- hspec-core
- http-api-data
- http-client
- hspec-wai
- wai
- warp
example:
main: Example.lhs
source-dirs: .
@ -63,6 +66,10 @@ tests:
dependencies:
- roboservant
- hspec
- warp
- http-client
- aeson
- hspec-core
ghc-options: -pgmL markdown-unlit
build-tools: markdown-unlit

View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: fa8c07f0c2fc10f18d3e925b8f702612c0c9fd81faa7942f901af388d509c231
-- hash: 4c71b6b9460f4719791bb8e67f4a5398b807cd8d17c43dc69da806bb5ba9fb4b
name: roboservant
version: 0.1.0.2
@ -28,13 +28,13 @@ source-repository head
library
exposed-modules:
Roboservant
Roboservant.Client
Roboservant.Direct
Roboservant.Server
Roboservant.Types
Roboservant.Types.Breakdown
Roboservant.Types.BuildFrom
Roboservant.Types.Config
Roboservant.Types.FlattenServer
Roboservant.Types.Internal
Roboservant.Types.ReifiedApi
Roboservant.Types.ReifiedApi.Server
@ -76,13 +76,16 @@ test-suite example
build-tool-depends:
markdown-unlit:markdown-unlit
build-depends:
base >=4.7 && <5
aeson
, base >=4.7 && <5
, bytestring
, containers
, dependent-map
, dependent-sum
, hashable
, hspec
, hspec-core
, http-client
, lifted-base
, monad-control
, mtl
@ -97,6 +100,7 @@ test-suite example
, time
, unordered-containers
, vinyl
, warp
default-language: Haskell2010
test-suite roboservant-test
@ -126,7 +130,9 @@ test-suite roboservant-test
, hashable
, hspec
, hspec-core
, hspec-wai
, http-api-data
, http-client
, lifted-base
, monad-control
, mtl
@ -141,4 +147,6 @@ test-suite roboservant-test
, time
, unordered-containers
, vinyl
, wai
, warp
default-language: Haskell2010

117
src/Roboservant/Client.hs Normal file
View File

@ -0,0 +1,117 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns#-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
-- should all the NormalizeFunction instances be in one place?
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Roboservant.Client where
import Data.Proxy
import Servant.Client
import Roboservant.Types
import Roboservant(Report, fuzz')
import Servant
import Data.Bifunctor
import Data.List.NonEmpty (NonEmpty)
import Data.Dynamic (Dynamic,Typeable)
import qualified Data.Vinyl.Curry as V
import qualified Data.Text as T
import Control.Monad.Reader
import Data.Hashable
-- fuzz :: forall api.
-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>
-- Server api ->
-- Config ->
-- IO (Maybe Report)
-- fuzz s = fuzz' (reifyServer s)
-- -- todo: how do we pull reifyServer out?
-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
-- => Server api -> ReifiedApi
-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)
=> ClientEnv -> Config -> IO (Maybe Report)
fuzz clientEnv config = fuzz' (toReifiedClientApi (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv ) config
where apiClient = client (Proxy @api)
class ToReifiedClientApi api where
toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi
data ClientBundled endpoints where
AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)
NoClientEndpoints :: ClientBundled '[]
class FlattenClient api where
flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)
instance
( NormalizeFunction (Client ClientM endpoint)
, Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))
, ToReifiedClientApi endpoints
, V.RecordCurry' (EndpointArgs endpoint)
, ToReifiedEndpoint endpoint) =>
ToReifiedClientApi (endpoint : endpoints) where
toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =
(0, ReifiedEndpoint
{ reArguments = reifiedEndpointArguments @endpoint
, reEndpointFunc = foo (normalize endpoint)
}
)
: (map . first) (+1)
(toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)
where
foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)
-> V.Curried (EndpointArgs endpoint) (IO ResultType)
foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)
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
type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))
-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where
type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))
normalize c = ReaderT $
fmap (bimap (InteractionError . T.pack . show) breakdown) . runClientM c
--
instance ToReifiedClientApi '[] where
toReifiedClientApi NoClientEndpoints _ _ = []
instance
( FlattenClient api,
Endpoints endpoint ~ '[endpoint]
) =>
FlattenClient (endpoint :<|> api)
where
flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c
instance
(
Endpoints api ~ '[api]
) =>
FlattenClient (x :> api)
where
flattenClient c = c `AClientEndpoint` NoClientEndpoints
instance FlattenClient (Verb method statusCode contentTypes responseType)
where
flattenClient c = c `AClientEndpoint` NoClientEndpoints

View File

@ -65,6 +65,7 @@ import Roboservant.Types
TypedF,
)
import Roboservant.Types.Config
import System.Random (Random (randomR), StdGen, mkStdGen)
import qualified Type.Reflection as R

40
src/Roboservant/Server.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Roboservant.Server (fuzz, module Roboservant.Types ) where
import Roboservant.Direct(fuzz',Report)
import Roboservant.Types
( FlattenServer (..),
ReifiedApi,
)
import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))
import Servant (Endpoints, Proxy (Proxy), Server)
import Roboservant.Types.Config
fuzz :: forall api.
(FlattenServer api, ToReifiedApi (Endpoints api)) =>
Server api ->
Config ->
IO (Maybe Report)
fuzz s = fuzz' (reifyServer s)
-- todo: how do we pull reifyServer out?
where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
=> Server api -> ReifiedApi
reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))

View File

@ -10,18 +10,16 @@
module Roboservant.Types
( module Roboservant.Types.Breakdown,
module Roboservant.Types.BuildFrom,
module Roboservant.Types.FlattenServer,
module Roboservant.Types.ReifiedApi,
module Roboservant.Types.ReifiedApi.Server,
module Roboservant.Types.Internal,
module Roboservant.Types.Config,
Atom, Compound
)
where
import Roboservant.Types.Breakdown
import Roboservant.Types.BuildFrom
import Roboservant.Types.Config
import Roboservant.Types.FlattenServer
import Roboservant.Types.Internal
import Roboservant.Types.ReifiedApi
import Roboservant.Types.ReifiedApi.Server

View File

@ -1,40 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | terrible name, this really just pulls stuff out where we can fiddle with it.
module Roboservant.Types.FlattenServer where
import Servant
data Bundled endpoints where
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
NoEndpoints :: Bundled '[]
class FlattenServer api where
flattenServer :: Server api -> Bundled (Endpoints api)
instance
( FlattenServer api,
Endpoints endpoint ~ '[endpoint]
) =>
FlattenServer (endpoint :<|> api)
where
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
instance
(
Endpoints api ~ '[api]
) =>
FlattenServer (x :> api)
where
flattenServer server = server `AnEndpoint` NoEndpoints
instance FlattenServer (Verb method statusCode contentTypes responseType)
where
flattenServer server = server `AnEndpoint` NoEndpoints

View File

@ -1,3 +1,8 @@
-- | Description: ways to build a reified api from a servant description.
--
-- arguably this could be more general and be abstracted away from even relying on servant
-- but that's future work.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
@ -21,7 +26,12 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Typeable (Typeable)
import GHC.Generics ((:*:)(..))
import Roboservant.Types.Internal
import Roboservant.Types.Breakdown
import Roboservant.Types.BuildFrom
import Data.Kind
import Servant
import Servant.API.Modifiers(FoldRequired,FoldLenient)
import GHC.TypeLits (Symbol)
import qualified Data.Text as T
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
@ -42,7 +52,14 @@ data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpo
, reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
}
type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
class ( V.RecordToList (EndpointArgs endpoint)
, V.RMap (EndpointArgs endpoint)
) => ToReifiedEndpoint (endpoint :: *) where
type EndpointArgs endpoint :: [Type]
type EndpointRes endpoint :: Type
reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
tagType :: Typeable a => f a -> TypedF f a
tagType = (R.typeRep :*:)
@ -50,3 +67,112 @@ tagType = (R.typeRep :*:)
newtype InteractionError = InteractionError T.Text
deriving Show
instance Exception InteractionError
instance
(Typeable responseType, Breakdown responseType) =>
ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
where
type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
reifiedEndpointArguments = V.RNil
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint ((x :: Symbol) :> endpoint)
where
type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Description s :> endpoint)
where
type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Summary s :> endpoint)
where
type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(Typeable requestType
,BuildFrom requestType
,ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (QueryFlag name :> endpoint)
where
type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
instance
( BuildFrom (IfRequiredLenient T.Text mods paramType)
, ToReifiedEndpoint endpoint
) =>
ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
where
type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
V.:& reifiedEndpointArguments @endpoint
instance
( BuildFrom (IfRequiredLenient T.Text mods headerType)
, ToReifiedEndpoint endpoint
) =>
ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
where
type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
V.:& reifiedEndpointArguments @endpoint
#if MIN_VERSION_servant(0,17,0)
instance
( BuildFrom (IfLenient String mods captureType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
where
type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods captureType)))
V.:& reifiedEndpointArguments @endpoint
#else
instance
( BuildFrom captureType
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
where
type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(captureType)))
V.:& reifiedEndpointArguments @endpoint
#endif
instance
( BuildFrom (IfLenient String mods requestType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
where
type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods requestType)))
V.:& reifiedEndpointArguments @endpoint

View File

@ -17,47 +17,34 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
module Roboservant.Types.ReifiedApi.Server where
{-# LANGUAGE MultiParamTypeClasses #-}
module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
import Servant
import Servant.API.Modifiers(FoldRequired,FoldLenient)
import Control.Monad.Except (runExceptT)
import Data.Bifunctor
import Data.Dynamic (Dynamic)
import Data.Kind
import Data.List.NonEmpty (NonEmpty)
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
import Roboservant.Types.Breakdown
import Roboservant.Types.BuildFrom
import Roboservant.Types.FlattenServer
import Roboservant.Types.ReifiedApi
import qualified Data.Text as T
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import Data.Hashable(Hashable)
type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
class ToReifiedApi (endpoints ) where
class ToReifiedApi endpoints where
toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
class ( V.RecordToList (EndpointArgs endpoint)
, V.RMap (EndpointArgs endpoint)
) => ToReifiedEndpoint (endpoint :: *) where
type EndpointArgs endpoint :: [Type]
type EndpointRes endpoint :: Type
reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
instance ToReifiedApi '[] where
toReifiedApi NoEndpoints _ = []
instance
( Typeable (EndpointRes endpoint)
, NormalizeFunction (ServerT endpoint Handler)
( NormalizeFunction (ServerT endpoint Handler)
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
, ToReifiedEndpoint endpoint
, ToReifiedApi endpoints
@ -73,13 +60,6 @@ instance
: (map . first) (+1)
(toReifiedApi endpoints (Proxy @endpoints))
class NormalizeFunction m where
type Normal m
normalize :: m -> Normal m
instance NormalizeFunction x => NormalizeFunction (r -> x) where
type Normal (r -> x) = r -> Normal x
normalize = fmap normalize
instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
@ -91,114 +71,45 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x)
renderServerError = InteractionError . T.pack . show
Right x -> pure $ Right $ breakdown x
instance
(Typeable responseType, Breakdown responseType) =>
ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
where
type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
reifiedEndpointArguments = V.RNil
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint ((x :: Symbol) :> endpoint)
where
type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Description s :> endpoint)
where
type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Summary s :> endpoint)
where
type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(Typeable requestType
,BuildFrom requestType
,ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (QueryFlag name :> endpoint)
where
type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
instance
( BuildFrom (IfRequiredLenient T.Text mods paramType)
, ToReifiedEndpoint endpoint
) =>
ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
where
type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
V.:& reifiedEndpointArguments @endpoint
instance
( BuildFrom (IfRequiredLenient T.Text mods headerType)
, ToReifiedEndpoint endpoint
) =>
ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
where
type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
V.:& reifiedEndpointArguments @endpoint
#if MIN_VERSION_servant(0,17,0)
instance
( BuildFrom (IfLenient String mods captureType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
where
type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods captureType)))
V.:& reifiedEndpointArguments @endpoint
#else
instance
( BuildFrom captureType
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
where
type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(captureType)))
V.:& reifiedEndpointArguments @endpoint
#endif
instance
( BuildFrom (IfLenient String mods requestType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
where
type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods requestType)))
V.:& reifiedEndpointArguments @endpoint
-- case errHTTPCode serverError of
-- 500 -> throw serverError
-- _ ->
-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
data Bundled endpoints where
-- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
NoEndpoints :: Bundled '[]
class FlattenServer api where
flattenServer :: Server api -> Bundled (Endpoints api)
instance
( FlattenServer api,
Endpoints endpoint ~ '[endpoint]
) =>
FlattenServer (endpoint :<|> api)
where
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
instance
(
Endpoints api ~ '[api]
) =>
FlattenServer (x :> api)
where
flattenServer server = server `AnEndpoint` NoEndpoints
instance FlattenServer (Verb method statusCode contentTypes responseType)
where
flattenServer server = server `AnEndpoint` NoEndpoints
class NormalizeFunction m where
type Normal m
normalize :: m -> Normal m
instance NormalizeFunction x => NormalizeFunction (r -> x) where
type Normal (r -> x) = r -> Normal x
normalize = fmap normalize

View File

@ -4,7 +4,13 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
import qualified Breakdown
import Data.Dynamic (toDyn)
@ -16,100 +22,118 @@ import qualified Headers
import qualified Nested
import qualified Post
import qualified Product
import qualified Roboservant as RS
import qualified Roboservant as R
import qualified Roboservant.Server as RS
import qualified Roboservant.Client as RC
import qualified Seeded
import Test.Hspec
import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
import qualified Valid
import Servant(Server,Proxy(..), serve)
import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
import Network.Wai(Application)
import qualified Network.Wai.Handler.Warp as Warp
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant(Endpoints,HasServer)
main :: IO ()
main = hspec spec
fuzzBoth
:: forall a .
(R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
HasClient ClientM a)
=> String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
fuzzBoth name server config condition = do
it (name <> " via server") $ do
RS.fuzz @a server config >>= condition
around (withServer (serve (Proxy :: Proxy a) server)) $ do
it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
RC.fuzz @a clientEnv config >>= condition
withServer :: Application -> ActionWith ClientEnv -> IO ()
withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action)
where genClientEnv port = do
baseUrl <- parseBaseUrl "http://localhost"
manager <- newManager defaultManagerSettings
pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
spec :: Spec
spec = do
describe "Basic usage" $ do
describe "noError" $ do
it "finds no error in a valid app" $ do
RS.fuzz @Valid.Api Valid.server RS.defaultConfig
>>= (`shouldSatisfy` isNothing)
it "finds no error in a valid generic app" $ do
RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
>>= (`shouldSatisfy` isNothing)
it "does fail coverage check" $ do
r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}
fmap (RS.failureReason . RS.rsException) r
`shouldSatisfy` ( \case
Just (RS.InsufficientCoverage _) -> True
_ -> False
)
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 @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
(\r ->
fmap (R.failureReason . R.rsException) r
`shouldSatisfy` ( \case
Just (R.InsufficientCoverage _) -> True
_ -> False
))
describe "posted body" $ do
it "passes a coverage check using a posted body" $ do
RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
>>= (`shouldSatisfy` isNothing)
fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
(`shouldSatisfy` isNothing)
describe "seeded" $ do
shouldFail
$ it "finds an error using information passed in"
$ let res = Seeded.Seed 1
in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})
>>= (`shouldSatisfy` isNothing)
let res = Seeded.Seed 1
shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
(R.defaultConfig {R.seed = [(toDyn res, hash res)]})
(`shouldSatisfy` isNothing)
describe "Foo" $ do
it "finds an error in a basic app" $
RS.fuzz @Foo.Api Foo.server RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
describe "BuildFrom" $ do
describe "headers (and sum types)" $ do
it "should find a failure that's dependent on using header info" $ do
RS.fuzz @Headers.Api Headers.server RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
(`shouldSatisfy` serverFailure)
describe "product types" $ do
it "should find a failure that's dependent on creating a product" $ do
RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
>>= (`shouldSatisfy` serverFailure)
fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
(`shouldSatisfy` serverFailure)
describe "Breakdown" $ do
it "handles products" $ do
RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
it "handles sums" $ do
RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
(`shouldSatisfy` serverFailure)
fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
(`shouldSatisfy` serverFailure)
describe "flattening" $ do
-- we don't actually do much here, this is just here to document the appropriate response
-- if you get a type error with a nested api.
it "can handle nested apis" $ do
RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
>>= (`shouldSatisfy` isNothing)
fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
(`shouldSatisfy` isNothing)
serverFailure :: Maybe RS.Report -> Bool
serverFailure :: Maybe R.Report -> Bool
serverFailure = \case
Just RS.Report {..} ->
let RS.RoboservantException {..} = rsException
in failureReason /= RS.NoPossibleMoves
Just R.Report {..} ->
let R.RoboservantException {..} = rsException
in failureReason /= R.NoPossibleMoves
_ -> False
deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
deriving via (RS.Atom Void) instance RS.BuildFrom Void
deriving via (R.Atom Void) instance R.BuildFrom Void
deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
-- this is often useful when testing tests.