@@ -4,13 +4,7 @@
44{-# LANGUAGE RecordWildCards #-}
55{-# LANGUAGE StandaloneDeriving #-}
66{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE AllowAmbiguousTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DataKinds #-}
127{-# OPTIONS_GHC -fno-warn-orphans #-}
13−{-# LANGUAGE TypeFamilies #-}
148
159import qualified Breakdown
1610import Data.Dynamic (toDyn)
@@ -21,134 +15,101 @@ import qualified Foo
2115import qualified Headers
2216import qualified Nested
2317import qualified Post
24−import qualified Put
2518import qualified Product
26−import qualified QueryParams
27−import qualified Roboservant as R
19+import qualified Roboservant as RS
2820import qualified Roboservant.Server as RS
29−import qualified Roboservant.Client as RC
3021import qualified Seeded
3122import Test.Hspec
3223import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
3324import 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((>=>))
4125
4226main :: IO ()
4327main = hspec spec
4428
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−
6529spec :: Spec
6630spec = do
6731 describe "Basic usage" $ do
6832 describe "noError" $ do
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−
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)
8850 describe "seeded" $ do
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−
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)
10160 describe "BuildFrom" $ do
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)
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)
10969 describe "Breakdown" $ do
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
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
11984serverFailure = \case
120− Just R.Report {..} ->
121− let R.RoboservantException {..} = rsException
122− in failureReason /= R.NoPossibleMoves
85+ Just RS.Report {..} ->
86+ let RS.RoboservantException {..} = rsException
87+ in failureReason /= RS.NoPossibleMoves
12388 _ -> False
12489
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
90+deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
13091
131−deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
92+deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
13293
133−deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
94+deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
13495
135−deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
96+deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
13697
137−deriving via (R.Atom Void) instance R.BuildFrom Void
98+deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
13899
139−deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140−deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
100+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
141101
142−deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143−deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
102+deriving via (RS.Atom Void) instance RS.BuildFrom Void
144103
104+deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
145105
106+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
146107
147−deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
108+deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
148109
149−deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
110+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
150111
151−deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
112+deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
152113
153114-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
154115-- this is often useful when testing tests.
@@ -158,7 +119,7 @@ shouldFail =
158119 ( \i ->
159120 i
160121 { itemExample = \p a cb -> do
161− r <- itemExample i p a cb
122+ r <- (itemExample i) p a cb
162123 pure
163124 r
164125 { resultStatus = case resultStatus r of