git.iko.soy/roboservant
on master help sign in
roboservant/test/Spec.hs
170 lines 6.6 kB history raw
1{-# LANGUAGE DerivingVia #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE AllowAmbiguousTypes #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE DataKinds #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
13{-# LANGUAGE TypeFamilies #-}
15import qualified Breakdown
16import Data.Dynamic (toDyn)
17import Data.Hashable (Hashable (hash))
18import Data.Maybe (isNothing)
19import Data.Void (Void)
20import qualified Foo
21import qualified Headers
22import qualified Nested
23import qualified Post
24import qualified Put
25import qualified Product
26import qualified QueryParams
27import qualified Roboservant as R
28import qualified Roboservant.Server as RS
29import qualified Roboservant.Client as RC
30import qualified Seeded
31import Test.Hspec
32import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33import qualified Valid
34import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
36import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
37import Network.Wai(Application)
38import qualified Network.Wai.Handler.Warp as Warp
39import Network.HTTP.Client (newManager, defaultManagerSettings)
40import Control.Monad((>=>))
42main :: IO ()
43main = hspec spec
45fuzzBoth
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
50fuzzBoth name server config condition = do
51 it (name <> " via server") $
52 RS.fuzz @a server config >>= condition
54 around (withServer (serve (Proxy :: Proxy a) server)) $
55 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
56 RC.fuzz @a clientEnv config >>= condition
58withServer :: Application -> ActionWith ClientEnv -> IO ()
59withServer 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
66spec = do
67 describe "Basic usage" $ do
68 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)
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)
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)
94 describe "Foo" $
95 fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`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)
118serverFailure :: Maybe R.Report -> Bool
119serverFailure = \case
120 Just R.Report {..} ->
121 let R.RoboservantException {..} = rsException
122 in failureReason /= R.NoPossibleMoves
123 _ -> False
125deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
127deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
129deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
131deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
133deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
135deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
137deriving via (R.Atom Void) instance R.BuildFrom Void
139deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
142deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
147deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
149deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
151deriving 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.
154-- this is often useful when testing tests.
155shouldFail :: SpecWith a -> SpecWith a
156shouldFail =
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 )