From 53ab47e4c115a9f99342b71ca8db1b8ee0761bdd Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Mon, 15 Mar 2021 11:18:14 -0400 Subject: [PATCH] extract servant code from fuzz machinery --- Makefile | 2 +- roboservant.cabal | 4 +- src/Roboservant/Direct.hs | 37 ++-- src/Roboservant/Types.hs | 2 + src/Roboservant/Types/BuildFrom.hs | 1 - src/Roboservant/Types/ReifiedApi.hs | 172 +---------------- src/Roboservant/Types/ReifiedApi/Server.hs | 204 +++++++++++++++++++++ test/Spec.hs | 1 + 8 files changed, 236 insertions(+), 187 deletions(-) create mode 100644 src/Roboservant/Types/ReifiedApi/Server.hs diff --git a/Makefile b/Makefile index e9c0d9d..d165b11 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ testwatch: - ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W + ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W pedanticwatch: ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W diff --git a/roboservant.cabal b/roboservant.cabal index c7bfeb1..17406bf 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 48773018ec618e9eba02a126e3aeb93781a1d68ce28e2c405c35e9536bf94f70 +-- hash: fa8c07f0c2fc10f18d3e925b8f702612c0c9fd81faa7942f901af388d509c231 name: roboservant version: 0.1.0.2 @@ -29,6 +29,7 @@ library exposed-modules: Roboservant Roboservant.Direct + Roboservant.Server Roboservant.Types Roboservant.Types.Breakdown Roboservant.Types.BuildFrom @@ -36,6 +37,7 @@ library Roboservant.Types.FlattenServer Roboservant.Types.Internal Roboservant.Types.ReifiedApi + Roboservant.Types.ReifiedApi.Server other-modules: Paths_roboservant hs-source-dirs: diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs index 48cdfc1..3a83653 100644 --- a/src/Roboservant/Direct.hs +++ b/src/Roboservant/Direct.hs @@ -12,7 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} module Roboservant.Direct - ( fuzz, + ( fuzz', Config (..), -- TODO come up with something smarter than exporting all this, we should -- have some nice error-display functions @@ -56,16 +56,15 @@ import GHC.Generics ((:*:) (..)) import Roboservant.Types ( ApiOffset (..), Argument (..), - FlattenServer (..), + InteractionError, Provenance (..), + ReifiedApi, ReifiedEndpoint (..), Stash (..), StashValue (..), - ToReifiedApi (..), TypedF, ) import Roboservant.Types.Config -import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..)) import System.Random (Random (randomR), StdGen, mkStdGen) import qualified Type.Reflection as R @@ -105,7 +104,7 @@ data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption - { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))), + { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))), eoArgs :: V.Rec (TypedF StashValue) as } @@ -121,13 +120,18 @@ data Report } deriving (Show) -fuzz :: - forall api. - (FlattenServer api, ToReifiedApi (Endpoints api)) => - Server api -> + + +-- fuzzClient :: Client api -> Config -> IO (Maybe Report) +-- fuzzClient = undefined + + + +fuzz' :: + ReifiedApi -> Config -> IO (Maybe Report) -fuzz server Config {..} = handle (pure . Just . formatException) $ do +fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do let path = [] stash = addToStash seed mempty currentRng = mkStdGen rngSeed @@ -173,7 +177,7 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do else do _ <- action untilDone (n -1, deadline) action - reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) + routeCount = length reifiedApi elementOrFail :: (MonadState FuzzState m, MonadIO m) => @@ -190,7 +194,7 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do ( forall as. (V.RecordToList as, V.RMap as) => FuzzOp -> - V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) -> + V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) -> V.Rec (TypedF V.Identity) as -> m r ) -> @@ -231,18 +235,13 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) => FuzzOp -> - V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) -> + V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) -> V.Rec (TypedF V.Identity) as -> m () execute fuzzop func args = do (liftIO . logInfo . show . (fuzzop,) . stash) =<< get liftIO (V.runcurry' func argVals) >>= \case - -- parameterise this - Left (serverError :: ServerError) -> - case errHTTPCode serverError of - 500 -> throw serverError - _ -> - liftIO . logInfo . show $ ("ignoring non-500 error", serverError) + Left (e::InteractionError) -> throw e Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do modify' ( \fs@FuzzState {..} -> diff --git a/src/Roboservant/Types.hs b/src/Roboservant/Types.hs index 4e68f71..1030712 100644 --- a/src/Roboservant/Types.hs +++ b/src/Roboservant/Types.hs @@ -14,6 +14,8 @@ module Roboservant.Types module Roboservant.Types.ReifiedApi, module Roboservant.Types.Internal, module Roboservant.Types.Config, + Atom, Compound + ) where diff --git a/src/Roboservant/Types/BuildFrom.hs b/src/Roboservant/Types/BuildFrom.hs index c17eeee..c3cc5b8 100644 --- a/src/Roboservant/Types/BuildFrom.hs +++ b/src/Roboservant/Types/BuildFrom.hs @@ -12,7 +12,6 @@ module Roboservant.Types.BuildFrom where -import Control.Monad (filterM) import qualified Data.Dependent.Map as DM import Data.Hashable import qualified Data.IntSet as IntSet diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs index 6e118d6..59fa9a9 100644 --- a/src/Roboservant/Types/ReifiedApi.hs +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -15,25 +15,17 @@ {-# LANGUAGE CPP #-} module Roboservant.Types.ReifiedApi where -import Control.Monad.Except (runExceptT) -import Data.Bifunctor import Data.Dynamic (Dynamic) -import Data.Kind +import Control.Exception(Exception) import Data.List.NonEmpty (NonEmpty) import Data.Typeable (Typeable) import GHC.Generics ((:*:)(..)) -import GHC.TypeLits (Symbol) import Roboservant.Types.Internal -import Roboservant.Types.Breakdown -import Roboservant.Types.BuildFrom -import Roboservant.Types.FlattenServer -import Servant -import Servant.API.Modifiers(FoldRequired,FoldLenient) + import qualified Data.Text as T import qualified Data.Vinyl as V import qualified Data.Vinyl.Curry as V import qualified Type.Reflection as R -import Data.Hashable(Hashable) newtype ApiOffset = ApiOffset Int deriving (Eq, Show, Ord) @@ -47,164 +39,14 @@ newtype Argument a = Argument data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint { reArguments :: V.Rec (TypedF Argument) as - , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) + , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int)))) } -type ReifiedApi = [(ApiOffset, ReifiedEndpoint)] +type ReifiedApi = [(ApiOffset, ReifiedEndpoint )] tagType :: Typeable a => f a -> TypedF f a tagType = (R.typeRep :*:) -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) - , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int)))) - , ToReifiedEndpoint endpoint - , ToReifiedApi endpoints - ) => - ToReifiedApi (endpoint : endpoints) - where - toReifiedApi (endpoint `AnEndpoint` endpoints) _ = - (0, ReifiedEndpoint - { reArguments = reifiedEndpointArguments @endpoint - , reEndpointFunc = normalize endpoint - } - ) - : (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 ServerError (NonEmpty (Dynamic,Int))) - normalize handler = (runExceptT . runHandler') handler >>= \case - Left serverError -> pure (Left serverError) - 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 +newtype InteractionError = InteractionError T.Text + deriving Show +instance Exception InteractionError diff --git a/src/Roboservant/Types/ReifiedApi/Server.hs b/src/Roboservant/Types/ReifiedApi/Server.hs new file mode 100644 index 0000000..b70b34d --- /dev/null +++ b/src/Roboservant/Types/ReifiedApi/Server.hs @@ -0,0 +1,204 @@ +{-# 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 #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +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) + + +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) + , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int)))) + , ToReifiedEndpoint endpoint + , ToReifiedApi endpoints + ) => + ToReifiedApi (endpoint : endpoints) + where + toReifiedApi (endpoint `AnEndpoint` endpoints) _ = + (0, ReifiedEndpoint + { reArguments = reifiedEndpointArguments @endpoint + , reEndpointFunc = normalize endpoint + } + ) + : (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))) + normalize handler = (runExceptT . runHandler') handler >>= \case + Left serverError -> pure (Left (renderServerError serverError)) + where + -- | TODO improve this + renderServerError :: ServerError -> InteractionError + 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) diff --git a/test/Spec.hs b/test/Spec.hs index 24cd8c7..4c95625 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,6 +17,7 @@ import qualified Nested import qualified Post import qualified Product import qualified Roboservant as RS +import qualified Roboservant.Server as RS import qualified Seeded import Test.Hspec import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)