@@ -1,170 +1,171 @@
1−{-# LANGUAGE DerivingVia #-}
2−{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE StandaloneDeriving #-}
2{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE DerivingVia #-}
6{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE AllowAmbiguousTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE DerivingVia #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−{-# LANGUAGE TypeFamilies #-}
15−import qualified Breakdown
9+{-# OPTIONS_GHC -fno-warn-orphans #-}
16−import Data.Dynamic (toDyn)
17−import Data.Hashable (Hashable (hash))
18−import Data.Maybe (isNothing)
19−import Data.Void (Void)
20import qualified Foo
10import qualified Foo
11+import qualified Seeded
12+import qualified Valid
21import qualified Headers
13import qualified Headers
22−import qualified Nested
23import qualified Post
14import qualified Post
25import qualified Product
15import qualified Product
26−import qualified QueryParams
16+import qualified Breakdown
27−import qualified Roboservant as R
28−import qualified Roboservant.Server as RS
29−import qualified Roboservant.Client as RC
30−import qualified Seeded
32−import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33−import qualified Valid
34−import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
36−import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
18+import Test.Hspec.Core.Spec
37−import Network.Wai(Application)
19+
20+import Data.Dynamic(toDyn,Typeable,Dynamic)
38−import qualified Network.Wai.Handler.Warp as Warp
21+import qualified Roboservant as RS
39−import Network.HTTP.Client (newManager, defaultManagerSettings)
22+import Test.Hspec
40−import Control.Monad((>=>))
23+import Data.Void
42main :: IO ()
27main :: IO ()
43main = hspec spec
28main = hspec spec
45−fuzzBoth
30+noCheck :: IO ()
46− :: forall a .
31+noCheck = pure ()
47− (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
32+
48− HasClient ClientM a)
33+defaultConfig :: RS.Config
49− => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
34+defaultConfig = RS.Config
50−fuzzBoth name server config condition = do
35+ { RS.seed = []
51− it (name <> " via server") $
36+ , RS.maxRuntime = 0.5
52− RS.fuzz @a server config >>= condition
37+ , RS.maxReps = 1000
54− around (withServer (serve (Proxy :: Proxy a) server)) $
39+ , RS.coverageThreshold = 0
55− it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
40+ }
56− RC.fuzz @a clientEnv config >>= condition
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 })
65spec :: Spec
42spec :: Spec
67 describe "Basic usage" $ do
44 describe "Basic usage" $ do
68 describe "noError" $ do
45 describe "noError" $ do
46+ it "finds no error in a valid app" $ do
47+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
69− fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
48+ >>= (`shouldSatisfy` isNothing)
49+ it "finds no error in a valid generic app" $ do
70− fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
50+ RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
51+ >>= (`shouldSatisfy` isNothing)
53+ it "does fail coverage check" $ do
71− fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
54+ r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
73− fmap (R.failureReason . R.rsException) r
55+ fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
74− `shouldSatisfy` ( \case
56+ (\case
75− Just (R.InsufficientCoverage _) -> True
57+ Just (RS.InsufficientCoverage _) -> True
76− _ -> False
58+ _ -> False)
78− describe "posted body" $
60+ describe "posted body" $ do
79− fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
61+ it "passes a coverage check using a posted body" $ do
62+ RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
80− (`shouldSatisfy` isNothing)
63+ >>= (`shouldSatisfy` isNothing)
65+ describe "seeded" $ do
67+ it "finds an error using information passed in" $
68+ let res = Seeded.Seed 1 in
69+ RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
70+ >>= (`shouldSatisfy` isNothing)
72+ it "finds an error in a basic app" $
73+ RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
74+ >>= (`shouldSatisfy` serverFailure)
83− describe "PUTted body" $
76+ describe "BuildFrom" $ do
84− fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
77+ describe "headers (and sum types)" $ do
78+ it "should find a failure that's dependent on using header info" $ do
79+ RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
85− (`shouldSatisfy` isNothing)
80+ >>= (`shouldSatisfy` serverFailure)
82+ describe "product types" $ do
83+ it "should find a failure that's dependent on creating a product" $ do
84+ RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1::Int)]} noCheck
85+ >>= (`shouldSatisfy` serverFailure)
88− describe "seeded" $ do
87+ describe "Breakdown" $ do
89− let res = Seeded.Seed 1
88+ it "handles products" $ do
90− shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
89+ RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck
91− (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
92− (`shouldSatisfy` isNothing)
90+ >>= (`shouldSatisfy` serverFailure)
94− describe "Foo" $
92+ it "handles sums" $ do
93+ RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck
95− fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
94+ >>= (`shouldSatisfy` serverFailure)
97− describe "QueryParams" $
98− fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
99− (`shouldSatisfy` isNothing)
101− 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)
109− 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)
118−serverFailure :: Maybe R.Report -> Bool
97+serverFailure :: Maybe RS.Report -> Bool
119serverFailure = \case
98serverFailure = \case
120− Just R.Report {..} ->
99+ Just RS.Report{..} ->
121− let R.RoboservantException {..} = rsException
100+ let RS.RoboservantException{..} = rsException
122− in failureReason /= R.NoPossibleMoves
101+ in failureReason /= RS.NoPossibleMoves
123 _ -> False
102 _ -> False
104+ -- describe "can build from pieces" $ do
105+ -- it "should find a failure that requires some assembly" $ do
106+ -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
107+ -- >>= (`shouldSatisfy` isJust)
111+ -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
112+ -- -- -- could: it's mostly here to show how to test for concurrency problems.
113+ -- describe "concurrency bugs" $ do
114+ -- before UnsafeIO.makeServer $ do
115+ -- describe "sequential checking" $ do
116+ -- it "safe use" $ \unsafeServer -> do
117+ -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
119+ -- modifyMaxSuccess (const 10000) $
121+ -- describe "concurrent" $ do
122+ -- it "concurrent, dangerous use" $ \unsafeServer -> do
123+ -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
125−deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
126+deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
127+deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
129+deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
130+deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
132+deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
133+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
127−deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
129−deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
136+-- instance RS.BuildFrom Seeded.Seed
131−deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
138+deriving via (RS.Atom Void) instance RS.BuildFrom Void
133−deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
140+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
141+deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
135−deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
143+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
144+deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
145+deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
137−deriving via (R.Atom Void) instance R.BuildFrom Void
139−deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140−deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
142−deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
149+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
143−deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
150+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
147−deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
154+-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
149−deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
156+-- instance RS.Breakdown Post.FooPost
157+-- instance RS.BuildFrom Post.FooPost
151−deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
160-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
154-- this is often useful when testing tests.
161-- this is often useful when testing tests.
155shouldFail :: SpecWith a -> SpecWith a
162shouldFail :: SpecWith a -> SpecWith a
157− mapSpecItem_
163+shouldFail = mapSpecItem_ (\i -> i {
160− { itemExample = \p a cb -> do
164+ itemExample = \p a cb -> do
161− r <- itemExample i p a cb
165+ r <- (itemExample i) p a cb
164− { resultStatus = case resultStatus r of
166+ pure r {resultStatus = case resultStatus r of
165− Success -> Failure Nothing (Reason "Unexpected success")
167+ Success -> Failure Nothing (Reason "Unexpected success")
166− Failure _ _ -> Success
168+ Failure _ _ -> Success