@@ -21,7 +21,9 @@ import qualified Foo
2121import qualified Headers
2222import qualified Nested
2323import qualified Post
24+import qualified Put
2425import qualified Product
26+import qualified QueryParams
2527import qualified Roboservant as R
2628import qualified Roboservant.Server as RS
2729import qualified Roboservant.Client as RC
@@ -29,31 +31,32 @@ import qualified Seeded
2931import Test.Hspec
3032import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
3133import qualified Valid
32−import Servant(Server,Proxy(..), serve)
34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
35+
3336import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
3437import Network.Wai(Application)
3538import qualified Network.Wai.Handler.Warp as Warp
3639import Network.HTTP.Client (newManager, defaultManagerSettings)
37−import Servant(Endpoints,HasServer)
40+import Control.Monad((>=>))
3841
3942main :: IO ()
4043main = hspec spec
4144
4245fuzzBoth
43− :: forall a .
46+ :: forall a .
4447 (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
4548 HasClient ClientM a)
4649 => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
4750fuzzBoth name server config condition = do
48− it (name <> " via server") $ do
51+ it (name <> " via server") $
4952 RS.fuzz @a server config >>= condition
5053
51− around (withServer (serve (Proxy :: Proxy a) server)) $ do
54+ around (withServer (serve (Proxy :: Proxy a) server)) $
5255 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
53− RC.fuzz @a clientEnv config >>= condition
56+ RC.fuzz @a clientEnv config >>= condition
5457
5558withServer :: Application -> ActionWith ClientEnv -> IO ()
56−withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action)
59+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)
5760 where genClientEnv port = do
5861 baseUrl <- parseBaseUrl "http://localhost"
5962 manager <- newManager defaultManagerSettings
@@ -72,37 +75,45 @@ spec = do
7275 Just (R.InsufficientCoverage _) -> True
7376 _ -> False
7477 ))
75− describe "posted body" $ do
78+ describe "posted body" $
7679 fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
77− (`shouldSatisfy` isNothing)
78−
80+ (`shouldSatisfy` isNothing)
81+
82+
83+ describe "PUTted body" $
84+ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
85+ (`shouldSatisfy` isNothing)
86+
87+
7988 describe "seeded" $ do
8089 let res = Seeded.Seed 1
8190 shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
8291 (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
8392 (`shouldSatisfy` isNothing)
84−
85− describe "Foo" $ do
93+
94+ describe "Foo" $
8695 fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
8796
97+ describe "QueryParams" $
98+ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
99+ (`shouldSatisfy` isNothing)
100+
88101 describe "BuildFrom" $ do
89− describe "headers (and sum types)" $ do
102+ describe "headers (and sum types)" $
90103 fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
91− (`shouldSatisfy` serverFailure)
92− describe "product types" $ do
93− fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
94− R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
95− (`shouldSatisfy` serverFailure)
104+ (`shouldSatisfy` serverFailure)
105+ describe "product types" $
106+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
107+ R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
108+ (`shouldSatisfy` serverFailure)
96109 describe "Breakdown" $ do
97110 fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
98111 (`shouldSatisfy` serverFailure)
99112 fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
100113 (`shouldSatisfy` serverFailure)
101− describe "flattening" $ do
102− -- we don't actually do much here, this is just here to document the appropriate response
103− -- if you get a type error with a nested api.
114+ describe "flattening" $
104115 fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
105− (`shouldSatisfy` isNothing)
116+ (`shouldSatisfy` isNothing)
106117
107118serverFailure :: Maybe R.Report -> Bool
108119serverFailure = \case
@@ -126,9 +137,13 @@ deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
126137deriving via (R.Atom Void) instance R.BuildFrom Void
127138
128139deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
129−
130140deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
131141
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
144+
145+
146+
132147deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
133148
134149deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
@@ -143,7 +158,7 @@ shouldFail =
143158 ( \i ->
144159 i
145160 { itemExample = \p a cb -> do
146− r <- (itemExample i) p a cb
161+ r <- itemExample i p a cb
147162 pure
148163 r
149164 { resultStatus = case resultStatus r of