@@ -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)
@@ -16,99 +22,119 @@ import qualified Headers
1622import qualified Nested
1723import qualified Post
1824import qualified Product
19−import qualified Roboservant as RS
25+import qualified Roboservant as R
26+import qualified Roboservant.Server as RS
27+import qualified Roboservant.Client as RC
2028import qualified Seeded
2129import Test.Hspec
2230import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
2331import qualified Valid
32+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
33+
34+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
35+import Network.Wai(Application)
36+import qualified Network.Wai.Handler.Warp as Warp
37+import Network.HTTP.Client (newManager, defaultManagerSettings)
38+import Servant(Endpoints,HasServer)
2439
2540main :: IO ()
2641main = hspec spec
2742
43+fuzzBoth
44+ :: forall a .
45+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
46+ HasClient ClientM a)
47+ => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
48+fuzzBoth name server config condition = do
49+ it (name <> " via server") $ do
50+ RS.fuzz @a server config >>= condition
51+
52+ around (withServer (serve (Proxy :: Proxy a) server)) $ do
53+ it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
54+ RC.fuzz @a clientEnv config >>= condition
55+
56+withServer :: Application -> ActionWith ClientEnv -> IO ()
57+withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action)
58+ where genClientEnv port = do
59+ baseUrl <- parseBaseUrl "http://localhost"
60+ manager <- newManager defaultManagerSettings
61+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
62+
2863spec :: Spec
2964spec = do
3065 describe "Basic usage" $ do
3166 describe "noError" $ do
32− it "finds no error in a valid app" $ do
33− RS.fuzz @Valid.Api Valid.server RS.defaultConfig
34− >>= (`shouldSatisfy` isNothing)
35− it "finds no error in a valid generic app" $ do
36− RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
37− >>= (`shouldSatisfy` isNothing)
38− it "does fail coverage check" $ do
39− r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}
40− fmap (RS.failureReason . RS.rsException) r
41− `shouldSatisfy` ( \case
42− Just (RS.InsufficientCoverage _) -> True
43− _ -> False
44− )
67+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
68+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
69+ fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
70+ (\r ->
71+ fmap (R.failureReason . R.rsException) r
72+ `shouldSatisfy` ( \case
73+ Just (R.InsufficientCoverage _) -> True
74+ _ -> False
75+ ))
4576 describe "posted body" $ do
46− it "passes a coverage check using a posted body" $ do
47− RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
48− >>= (`shouldSatisfy` isNothing)
77+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
78+ (`shouldSatisfy` isNothing)
79+
4980 describe "seeded" $ do
50− shouldFail
51− $ it "finds an error using information passed in"
52− $ let res = Seeded.Seed 1
53− in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})
54− >>= (`shouldSatisfy` isNothing)
81+ let res = Seeded.Seed 1
82+ shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
83+ (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
84+ (`shouldSatisfy` isNothing)
85+
5586 describe "Foo" $ do
56− it "finds an error in a basic app" $
57− RS.fuzz @Foo.Api Foo.server RS.defaultConfig
58− >>= (`shouldSatisfy` serverFailure)
87+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
88+
5989 describe "BuildFrom" $ do
6090 describe "headers (and sum types)" $ do
61− it "should find a failure that's dependent on using header info" $ do
62− RS.fuzz @Headers.Api Headers.server RS.defaultConfig
63− >>= (`shouldSatisfy` serverFailure)
91+ fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
92+ (`shouldSatisfy` serverFailure)
6493 describe "product types" $ do
65− it "should find a failure that's dependent on creating a product" $ do
66− RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
67− >>= (`shouldSatisfy` serverFailure)
94+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
95+ R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
96+ (`shouldSatisfy` serverFailure)
6897 describe "Breakdown" $ do
69− it "handles products" $ do
70− RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
71− >>= (`shouldSatisfy` serverFailure)
72− it "handles sums" $ do
73− RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig
74− >>= (`shouldSatisfy` serverFailure)
98+ fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
99+ (`shouldSatisfy` serverFailure)
100+ fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
101+ (`shouldSatisfy` serverFailure)
75102 describe "flattening" $ do
76103 -- we don't actually do much here, this is just here to document the appropriate response
77104 -- if you get a type error with a nested api.
78− it "can handle nested apis" $ do
79− RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
80− >>= (`shouldSatisfy` isNothing)
105+ fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
106+ (`shouldSatisfy` isNothing)
81107
82−serverFailure :: Maybe RS.Report -> Bool
108+serverFailure :: Maybe R.Report -> Bool
83109serverFailure = \case
84− Just RS.Report {..} ->
85− let RS.RoboservantException {..} = rsException
86− in failureReason /= RS.NoPossibleMoves
110+ Just R.Report {..} ->
111+ let R.RoboservantException {..} = rsException
112+ in failureReason /= R.NoPossibleMoves
87113 _ -> False
88114
89−deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
115+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
90116
91−deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
117+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
92118
93−deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
119+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
94120
95−deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
121+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
96122
97−deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
123+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
98124
99−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
125+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
100126
101−deriving via (RS.Atom Void) instance RS.BuildFrom Void
127+deriving via (R.Atom Void) instance R.BuildFrom Void
102128
103−deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
129+deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
104130
105−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
131+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
106132
107−deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
133+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
108134
109−deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
135+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
110136
111−deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
137+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
112138
113139-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
114140-- this is often useful when testing tests.