@@ -1,144 +1,130 @@
1+{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE StandaloneDeriving #-}
34{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE StandaloneDeriving #-}
46{-# LANGUAGE TypeApplications #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE DerivingVia #-}
7−
87{-# OPTIONS_GHC -fno-warn-orphans #-}
8+
9+import qualified Breakdown
10+import Data.Dynamic (toDyn)
11+import Data.Hashable (Hashable (hash))
12+import Data.Maybe (isNothing)
13+import Data.Void (Void)
914import qualified Foo
10−import qualified Seeded
11−import qualified Valid
1215import qualified Headers
16+import qualified Nested
1317import qualified Post
1418import qualified Product
15−import qualified Breakdown
16−import qualified Nested
17−
18−import Test.Hspec.Core.Spec(ResultStatus(Failure,Success),resultStatus,itemExample,FailureReason(Reason),mapSpecItem_)
19−import Data.Dynamic(toDyn)
2019import qualified Roboservant as RS
20+import qualified Seeded
2121import Test.Hspec
22−import Data.Void ( Void )
23−import Data.Maybe ( isNothing )
24−import Data.Hashable ( Hashable(hash) )
22+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
23+import qualified Valid
2524
2625main :: IO ()
2726main = hspec spec
2827
29−noCheck :: IO ()
30−noCheck = pure ()
31−
32−defaultConfig :: RS.Config
33−defaultConfig = RS.Config
34− { RS.seed = []
35− , RS.maxRuntime = 0.5
36− , RS.maxReps = 1000
37− , RS.rngSeed = 0
38− , RS.coverageThreshold = 0
39− }
40−
4128spec :: Spec
4229spec = do
4330 describe "Basic usage" $ do
4431 describe "noError" $ do
4532 it "finds no error in a valid app" $ do
46− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
33+ RS.fuzz @Valid.Api Valid.server RS.defaultConfig
4734 >>= (`shouldSatisfy` isNothing)
4835 it "finds no error in a valid generic app" $ do
49− RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
36+ RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
5037 >>= (`shouldSatisfy` isNothing)
51−
5238 it "does fail coverage check" $ do
53− r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
54− fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
55− (\case
56− Just (RS.InsufficientCoverage _) -> True
57− _ -> False)
58−
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+ )
5945 describe "posted body" $ do
6046 it "passes a coverage check using a posted body" $ do
61− RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
47+ RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
6248 >>= (`shouldSatisfy` isNothing)
63−
6449 describe "seeded" $ do
65− shouldFail $
66− it "finds an error using information passed in" $
67− let res = Seeded.Seed 1 in
68− RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
69− >>= (`shouldSatisfy` isNothing)
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)
7055 describe "Foo" $ do
7156 it "finds an error in a basic app" $
72− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
57+ RS.fuzz @Foo.Api Foo.server RS.defaultConfig
7358 >>= (`shouldSatisfy` serverFailure)
74−
7559 describe "BuildFrom" $ do
7660 describe "headers (and sum types)" $ do
7761 it "should find a failure that's dependent on using header info" $ do
78− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
62+ RS.fuzz @Headers.Api Headers.server RS.defaultConfig
7963 >>= (`shouldSatisfy` serverFailure)
80−
8164 describe "product types" $ do
8265 it "should find a failure that's dependent on creating a product" $ do
83− RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1::Int)]} noCheck
66+ RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
8467 >>= (`shouldSatisfy` serverFailure)
85−
8668 describe "Breakdown" $ do
8769 it "handles products" $ do
88− RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck
70+ RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
8971 >>= (`shouldSatisfy` serverFailure)
90−
9172 it "handles sums" $ do
92− RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck
73+ RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig
9374 >>= (`shouldSatisfy` serverFailure)
94−
9575 describe "flattening" $ do
96− -- | we don't actually do much here, this is just here to document the appropriate response
97− -- if you get a type error with a nested api.
76+ -- we don't actually do much here, this is just here to document the appropriate response
77+ -- if you get a type error with a nested api.
9878 it "can handle nested apis" $ do
99− RS.fuzz @(Nested.FlatApi) Nested.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
79+ RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
10080 >>= (`shouldSatisfy` isNothing)
10181
102−
103−
10482serverFailure :: Maybe RS.Report -> Bool
10583serverFailure = \case
106− Just RS.Report{..} ->
107− let RS.RoboservantException{..} = rsException
108− in failureReason /= RS.NoPossibleMoves
84+ Just RS.Report {..} ->
85+ let RS.RoboservantException {..} = rsException
86+ in failureReason /= RS.NoPossibleMoves
10987 _ -> False
11088
111−
11289deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
90+
11391deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
11492
11593deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
94+
11695deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
11796
11897deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
119−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
120−
12198
122−-- instance RS.BuildFrom Seeded.Seed
99+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
123100
124101deriving via (RS.Atom Void) instance RS.BuildFrom Void
125102
126−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
127103deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
128104
129−deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
105+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
106+
130107deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
108+
109+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
110+
131111deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
132112
133113-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
134114-- this is often useful when testing tests.
135115shouldFail :: SpecWith a -> SpecWith a
136−shouldFail = mapSpecItem_ (\i -> i {
137− itemExample = \p a cb -> do
138− r <- (itemExample i) p a cb
139− pure r {resultStatus = case resultStatus r of
140− Success -> Failure Nothing (Reason "Unexpected success")
141− Failure _ _ -> Success
142− x -> x
143− }
144− })
116+shouldFail =
117+ mapSpecItem_
118+ ( \i ->
119+ i
120+ { itemExample = \p a cb -> do
121+ r <- (itemExample i) p a cb
122+ pure
123+ r
124+ { resultStatus = case resultStatus r of
125+ Success -> Failure Nothing (Reason "Unexpected success")
126+ Failure _ _ -> Success
127+ x -> x
128+ }
129+ }
130+ )