make servant-client work

EXAMPLE.md

@@ -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 })
+```

benchmarks/genFile.sh

@@ -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 )"
+
+

benchmarks/prelude

@@ -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
-  }

benchmarks/runTiming.sh

@@ -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;

package.yaml

@@ -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

roboservant.cabal

@@ -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

src/Roboservant/Client.hs

@@ -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

src/Roboservant/Direct.hs

@@ -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
 

src/Roboservant/Server.hs

@@ -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))
+
+

src/Roboservant/Types.hs

@@ -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

src/Roboservant/Types/FlattenServer.hs

@@ -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

src/Roboservant/Types/ReifiedApi.hs

@@ -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

src/Roboservant/Types/ReifiedApi/Server.hs

@@ -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

test/Spec.hs

@@ -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
+      fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
-        RS.fuzz @Valid.Api Valid.server RS.defaultConfig
+      fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app"   Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
-          >>= (`shouldSatisfy` isNothing)
+      fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
-      it "finds no error in a valid generic app" $ do
+        (\r ->
-        RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
+           fmap (R.failureReason . R.rsException) r
-          >>= (`shouldSatisfy` isNothing)
+           `shouldSatisfy` ( \case
-      it "does fail coverage check" $ do
+                               Just (R.InsufficientCoverage _) -> True
-        r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}
+                               _ -> False
-        fmap (RS.failureReason . RS.rsException) r
+                           ))
-          `shouldSatisfy` ( \case
-                              Just (RS.InsufficientCoverage _) -> True
-                              _ -> False
-                          )
     describe "posted body" $ do
-      it "passes a coverage check using a posted body" $ do
+      fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
-        RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
+        (`shouldSatisfy` isNothing)
-          >>= (`shouldSatisfy` isNothing)
+        
     describe "seeded" $ do
-      shouldFail
+      let res = Seeded.Seed 1
-        $ it "finds an error using information passed in"
+      shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
-        $ let res = Seeded.Seed 1
+        (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
-           in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})
+        (`shouldSatisfy` isNothing)
-                >>= (`shouldSatisfy` isNothing)
+        
     describe "Foo" $ do
-      it "finds an error in a basic app" $
+      fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
-        RS.fuzz @Foo.Api Foo.server RS.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
+      fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
-        RS.fuzz @Headers.Api Headers.server RS.defaultConfig
+        (`shouldSatisfy` serverFailure)
-          >>= (`shouldSatisfy` serverFailure)
     describe "product types" $ do
-      it "should find a failure that's dependent on creating a product" $ do
+      fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server 
-        RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
+        R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
-          >>= (`shouldSatisfy` serverFailure)
+        (`shouldSatisfy` serverFailure)
   describe "Breakdown" $ do
-    it "handles products" $ do
+    fuzzBoth @Breakdown.ProductApi "handles products"  Breakdown.productServer R.defaultConfig
-      RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
+      (`shouldSatisfy` serverFailure)
-        >>= (`shouldSatisfy` serverFailure)
+    fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
-    it "handles sums" $ do
+      (`shouldSatisfy` serverFailure)
-      RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.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
+    fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
-      RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
+      (`shouldSatisfy` isNothing)
-        >>= (`shouldSatisfy` isNothing)
 
-serverFailure :: Maybe RS.Report -> Bool
+serverFailure :: Maybe R.Report -> Bool
 serverFailure = \case
-  Just RS.Report {..} ->
+  Just R.Report {..} ->
-    let RS.RoboservantException {..} = rsException
+    let R.RoboservantException {..} = rsException
-     in failureReason /= RS.NoPossibleMoves
+     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.