extract servant code from fuzz machinery

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

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:

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 {..} ->

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
 

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

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,7 +39,7 @@ 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 )]
@@ -55,156 +47,6 @@ 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

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)

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)