@@ -4,7 +4,13 @@
44{-# LANGUAGE RecordWildCards #-}
55{-# LANGUAGE StandaloneDeriving #-}
66{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
712{-# OPTIONS_GHC -fno-warn-orphans #-}
13+{-# LANGUAGE TypeFamilies #-}
814
915import qualified Breakdown
1016import Data.Dynamic (toDyn)
@@ -15,101 +21,134 @@ import qualified Foo
1521import qualified Headers
1622import qualified Nested
1723import qualified Post
24+import qualified Put
1825import qualified Product
19−import qualified Roboservant as RS
26+import qualified QueryParams
27+import qualified Roboservant as R
2028import qualified Roboservant.Server as RS
29+import qualified Roboservant.Client as RC
2130import qualified Seeded
2231import Test.Hspec
2332import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
2433import qualified Valid
34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
35+
36+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
37+import Network.Wai(Application)
38+import qualified Network.Wai.Handler.Warp as Warp
39+import Network.HTTP.Client (newManager, defaultManagerSettings)
40+import Control.Monad((>=>))
2541
2642main :: IO ()
2743main = hspec spec
2844
45+fuzzBoth
46+ :: forall a .
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
48+ HasClient ClientM a)
49+ => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
50+fuzzBoth name server config condition = do
51+ it (name <> " via server") $
52+ RS.fuzz @a server config >>= condition
53+
54+ around (withServer (serve (Proxy :: Proxy a) server)) $
55+ it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
56+ RC.fuzz @a clientEnv config >>= condition
57+
58+withServer :: Application -> ActionWith ClientEnv -> IO ()
59+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)
60+ where genClientEnv port = do
61+ baseUrl <- parseBaseUrl "http://localhost"
62+ manager <- newManager defaultManagerSettings
63+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
64+
2965spec :: Spec
3066spec = do
3167 describe "Basic usage" $ do
3268 describe "noError" $ do
33− it "finds no error in a valid app" $ do
34− RS.fuzz @Valid.Api Valid.server RS.defaultConfig
35− >>= (`shouldSatisfy` isNothing)
36− it "finds no error in a valid generic app" $ do
37− RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
38− >>= (`shouldSatisfy` isNothing)
39− it "does fail coverage check" $ do
40− r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}
41− fmap (RS.failureReason . RS.rsException) r
42− `shouldSatisfy` ( \case
43− Just (RS.InsufficientCoverage _) -> True
44− _ -> False
45− )
46− describe "posted body" $ do
47− it "passes a coverage check using a posted body" $ do
48− RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
49− >>= (`shouldSatisfy` isNothing)
69+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
70+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
71+ fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
72+ (\r ->
73+ fmap (R.failureReason . R.rsException) r
74+ `shouldSatisfy` ( \case
75+ Just (R.InsufficientCoverage _) -> True
76+ _ -> False
77+ ))
78+ describe "posted body" $
79+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
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+
5088 describe "seeded" $ do
51− shouldFail
52− $ it "finds an error using information passed in"
53− $ let res = Seeded.Seed 1
54− in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})
55− >>= (`shouldSatisfy` isNothing)
56− describe "Foo" $ do
57− it "finds an error in a basic app" $
58− RS.fuzz @Foo.Api Foo.server RS.defaultConfig
59− >>= (`shouldSatisfy` serverFailure)
89+ let res = Seeded.Seed 1
90+ shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
91+ (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
92+ (`shouldSatisfy` isNothing)
93+
94+ describe "Foo" $
95+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
96+
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+
60101 describe "BuildFrom" $ do
61− describe "headers (and sum types)" $ do
62− it "should find a failure that's dependent on using header info" $ do
63− RS.fuzz @Headers.Api Headers.server RS.defaultConfig
64− >>= (`shouldSatisfy` serverFailure)
65− describe "product types" $ do
66− it "should find a failure that's dependent on creating a product" $ do
67− RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
68− >>= (`shouldSatisfy` serverFailure)
102+ describe "headers (and sum types)" $
103+ fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
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)
69109 describe "Breakdown" $ do
70− it "handles products" $ do
71− RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
72− >>= (`shouldSatisfy` serverFailure)
73− it "handles sums" $ do
74− RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig
75− >>= (`shouldSatisfy` serverFailure)
76− describe "flattening" $ do
77− -- we don't actually do much here, this is just here to document the appropriate response
78− -- if you get a type error with a nested api.
79− it "can handle nested apis" $ do
80− RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
81− >>= (`shouldSatisfy` isNothing)
82−
83−serverFailure :: Maybe RS.Report -> Bool
110+ fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
111+ (`shouldSatisfy` serverFailure)
112+ fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
113+ (`shouldSatisfy` serverFailure)
114+ describe "flattening" $
115+ fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
116+ (`shouldSatisfy` isNothing)
117+
118+serverFailure :: Maybe R.Report -> Bool
84119serverFailure = \case
85− Just RS.Report {..} ->
86− let RS.RoboservantException {..} = rsException
87− in failureReason /= RS.NoPossibleMoves
120+ Just R.Report {..} ->
121+ let R.RoboservantException {..} = rsException
122+ in failureReason /= R.NoPossibleMoves
88123 _ -> False
89124
90−deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
126+
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
128+
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
91130
92−deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
93132
94−deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
95134
96−deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
97136
98−deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
137+deriving via (R.Atom Void) instance R.BuildFrom Void
99138
100−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
139+deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
101141
102−deriving via (RS.Atom Void) instance RS.BuildFrom Void
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
103144
104−deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
105145
106−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
107146
108−deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
109148
110−deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
111150
112−deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
113152
114153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
115154-- this is often useful when testing tests.
@@ -119,7 +158,7 @@ shouldFail =
119158 ( \i ->
120159 i
121160 { itemExample = \p a cb -> do
122− r <- (itemExample i) p a cb
161+ r <- itemExample i p a cb
123162 pure
124163 r
125164 { resultStatus = case resultStatus r of