@@ -1,160 +1,170 @@
1+{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE StandaloneDeriving #-}
34{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE DerivingVia #-}
5+{-# LANGUAGE StandaloneDeriving #-}
56{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE DerivingVia #-}
8−
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
912{-# OPTIONS_GHC -fno-warn-orphans #-}
13+{-# LANGUAGE TypeFamilies #-}
14+
15+import qualified Breakdown
16+import Data.Dynamic (toDyn)
17+import Data.Hashable (Hashable (hash))
18+import Data.Maybe (isNothing)
19+import Data.Void (Void)
1020import qualified Foo
11−import qualified Seeded
12−import qualified Valid
1321import qualified Headers
22+import qualified Nested
1423import qualified Post
24+import qualified Put
1525import qualified Product
16−
17−import Test.Hspec.Core.Spec
18−
19−import Data.Dynamic(toDyn,Typeable,Dynamic)
20−import qualified Roboservant as RS
26+import qualified QueryParams
27+import qualified Roboservant as R
28+import qualified Roboservant.Server as RS
29+import qualified Roboservant.Client as RC
30+import qualified Seeded
2131import Test.Hspec
22−import Data.Void
23−import Data.Maybe
24−import Data.Hashable
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 )
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
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− }
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 })
4064
4165spec :: Spec
4266spec = do
4367 describe "Basic usage" $ do
4468 describe "noError" $ do
45− it "finds no error in a valid app" $ do
46− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
47− >>= (`shouldSatisfy` isNothing)
48− it "finds no error in a valid generic app" $ do
49− RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
50− >>= (`shouldSatisfy` isNothing)
51−
52− 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−
59− describe "posted body" $ do
60− it "passes a coverage check using a posted body" $ do
61− RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
62− >>= (`shouldSatisfy` isNothing)
63−
64− 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)
70− describe "Foo" $ do
71− it "finds an error in a basic app" $
72− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
73− >>= (`shouldSatisfy` serverFailure)
74−
75− describe "headers (and sum types)" $ do
76− it "should find a failure that's dependent on using header info" $ do
77− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
78− >>= (`shouldSatisfy` serverFailure)
79−
80− describe "product types" $ do
81− it "should find a failure that's dependent on creating a product" $ do
82− RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [hashedDyn 'a', hashedDyn (1::Int)]} noCheck
83− >>= (`shouldSatisfy` serverFailure)
84− -- >>= (`shouldSatisfy` isJust)
85−
86−hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
87−hashedDyn a = (toDyn a, hash a)
88−
89−serverFailure :: Maybe RS.Report -> Bool
90−serverFailure = \case
91− Just RS.Report{..} ->
92− let RS.RoboservantException{..} = rsException
93− in failureReason /= RS.NoPossibleMoves
94− _ -> False
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)
9581
96− -- describe "can build from pieces" $ do
97− -- it "should find a failure that requires some assembly" $ do
98− -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
99− -- >>= (`shouldSatisfy` isJust)
10082
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)
10186
10287
103− -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
104− -- -- -- could: it's mostly here to show how to test for concurrency problems.
105− -- describe "concurrency bugs" $ do
106− -- before UnsafeIO.makeServer $ do
107− -- describe "sequential checking" $ do
108− -- it "safe use" $ \unsafeServer -> do
109− -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
110−
111− -- modifyMaxSuccess (const 10000) $
112− -- shouldFail $
113− -- describe "concurrent" $ do
114− -- it "concurrent, dangerous use" $ \unsafeServer -> do
115− -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
116−
117−
118−deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
119−deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
88+ 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+
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)
117+
118+serverFailure :: Maybe R.Report -> Bool
119+serverFailure = \case
120+ Just R.Report {..} ->
121+ let R.RoboservantException {..} = rsException
122+ in failureReason /= R.NoPossibleMoves
123+ _ -> False
120124
121−deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
122−deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
123126
124−deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
125−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
126128
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
127130
128−-- instance RS.BuildFrom Seeded.Seed
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
129132
130−deriving via (RS.Atom Void) instance RS.BuildFrom Void
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
131134
132−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
133−deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
134136
135−deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
137+deriving via (R.Atom Void) instance R.BuildFrom Void
136138
139+deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
137141
138−--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
139−--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
140144
141145
142146
143−-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
144148
145−-- instance RS.Breakdown Post.FooPost
146−-- instance RS.BuildFrom Post.FooPost
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
147150
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
148152
149153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
150154-- this is often useful when testing tests.
151155shouldFail :: SpecWith a -> SpecWith a
152−shouldFail = mapSpecItem_ (\i -> i {
153− itemExample = \p a cb -> do
154− r <- (itemExample i) p a cb
155− pure r {resultStatus = case resultStatus r of
156− Success -> Failure Nothing (Reason "Unexpected success")
157− Failure _ _ -> Success
158− x -> x
159− }
160− })
156+shouldFail =
157+ mapSpecItem_
158+ ( \i ->
159+ i
160+ { itemExample = \p a cb -> do
161+ r <- itemExample i p a cb
162+ pure
163+ r
164+ { resultStatus = case resultStatus r of
165+ Success -> Failure Nothing (Reason "Unexpected success")
166+ Failure _ _ -> Success
167+ x -> x
168+ }
169+ }
170+ )