mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
cleanup and example
This commit is contained in:
parent
b32a660df2
commit
4d0e2216ae
1
EXAMPLE.md
Symbolic link
1
EXAMPLE.md
Symbolic link
@ -0,0 +1 @@
|
|||||||
|
Example.lhs
|
112
Example.lhs
Normal file
112
Example.lhs
Normal file
@ -0,0 +1,112 @@
|
|||||||
|
# Example
|
||||||
|
|
||||||
|
Our api under test:
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
-- Obligatory fancy-types pragma tax
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
|
{-# LANGUAGE DerivingVia #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
|
import Roboservant
|
||||||
|
import Test.Hspec
|
||||||
|
import Servant
|
||||||
|
import GHC.Generics
|
||||||
|
import Data.Typeable
|
||||||
|
import Data.Hashable
|
||||||
|
|
||||||
|
newtype A = A Int
|
||||||
|
deriving (Generic, Eq, Show, Typeable)
|
||||||
|
deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
|
||||||
|
|
||||||
|
newtype B = B Int
|
||||||
|
deriving (Generic, Eq, Show, Typeable)
|
||||||
|
deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
|
||||||
|
|
||||||
|
type Api =
|
||||||
|
"item" :> Get '[JSON] A
|
||||||
|
:<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B
|
||||||
|
:<|> "item" :> Capture "itemId" B :> Get '[JSON] ()
|
||||||
|
|
||||||
|
goodServer = server (pure $ A 0)
|
||||||
|
badServer = server (pure $ A 1)
|
||||||
|
|
||||||
|
server introduce = introduce :<|> combine :<|> eliminate
|
||||||
|
where
|
||||||
|
combine (B i) (B j) = pure $ B (i + j)
|
||||||
|
eliminate (B i)
|
||||||
|
| i > 10 = error "give up, eleven is way too big and probably not even real"
|
||||||
|
| otherwise = pure ()
|
||||||
|
```
|
||||||
|
|
||||||
|
Our tests would usually be in a separate file:
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
|
||||||
|
|
||||||
|
defaultConfig :: Config
|
||||||
|
defaultConfig = Config {
|
||||||
|
-- you can pass extra values in using the seed argument. This can be useful
|
||||||
|
-- for things that might not be produceable within the api, like auth tokens.
|
||||||
|
seed = []
|
||||||
|
, maxRuntime = 0.5
|
||||||
|
-- if we get to 1000 interactions with the api, call it quits.
|
||||||
|
, maxReps = 1000
|
||||||
|
-- if you're using this inside quickcheck or hedgehog, you might want to set this
|
||||||
|
-- from their seed to make sure it stays deterministic
|
||||||
|
, rngSeed = 0
|
||||||
|
-- 0 to 100: fail tests if we hit less than this percentage of endpoints.
|
||||||
|
, coverageThreshold = 0
|
||||||
|
}
|
||||||
|
|
||||||
|
spec = describe "example" $ do
|
||||||
|
it "good server should not fail" $ do
|
||||||
|
fuzz @Api goodServer defaultConfig { coverageThreshold = 0.99 } (pure ())
|
||||||
|
>>= (`shouldSatisfy` isNothing)
|
||||||
|
it "bad server should fail" $ do
|
||||||
|
fuzz @Api badServer defaultConfig { coverageThreshold = 0.99 } (pure ())
|
||||||
|
>>= (`shouldSatisfy` serverFailure)
|
||||||
|
```
|
||||||
|
|
||||||
|
And unless we want to ship roboservant and all its dependencies to production, we also need
|
||||||
|
some orphan instances: because As are the only value we can get without
|
||||||
|
an input, we need to be able to break them down.
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
deriving via (Compound A) instance Breakdown A
|
||||||
|
-- if we wanted to assemble As from parts as well, we'd derive using Compound
|
||||||
|
deriving via (Atom A) instance BuildFrom A
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to
|
||||||
|
build it up from components.
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
deriving via (Compound B) instance BuildFrom B
|
||||||
|
deriving via (Atom B) instance Breakdown B
|
||||||
|
|
||||||
|
|
||||||
|
main = hspec spec
|
||||||
|
```
|
||||||
|
|
||||||
|
finally some uninteresting utilities
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
serverFailure :: Maybe Report -> Bool
|
||||||
|
serverFailure c = case c of
|
||||||
|
Just Report{..} ->
|
||||||
|
let RoboservantException{..} = rsException
|
||||||
|
in failureReason /= NoPossibleMoves
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
isNothing x = case x of
|
||||||
|
Nothing -> True
|
||||||
|
_ -> False
|
||||||
|
```
|
35
README.md
35
README.md
@ -4,43 +4,18 @@ Automatically fuzz your servant apis in a contextually-aware way.
|
|||||||
|
|
||||||
![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
|
![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
|
||||||
|
|
||||||
|
## example
|
||||||
|
|
||||||
# why?
|
see full example [here](EXAMPLE.md)
|
||||||
|
|
||||||
|
## why?
|
||||||
|
|
||||||
Servant gives us a lot of information about what a server can do. We
|
Servant gives us a lot of information about what a server can do. We
|
||||||
use this information to generate arbitrarily long request/response
|
use this information to generate arbitrarily long request/response
|
||||||
sessions and verify properties that should hold over them.
|
sessions and verify properties that should hold over them.
|
||||||
|
|
||||||
# example
|
|
||||||
|
|
||||||
Our api under test:
|
## why not servant-quickcheck?
|
||||||
|
|
||||||
```
|
|
||||||
newtype Foo = Foo Int
|
|
||||||
deriving (Generic, Eq, Show, Typeable)
|
|
||||||
deriving newtype (FromHttpApiData, ToHttpApiData)
|
|
||||||
|
|
||||||
type FooApi =
|
|
||||||
"item" :> Get '[JSON] Foo
|
|
||||||
:<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
|
|
||||||
:<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
|
|
||||||
```
|
|
||||||
|
|
||||||
From the tests:
|
|
||||||
|
|
||||||
```
|
|
||||||
assert "should find an error in Foo" . not
|
|
||||||
=<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])
|
|
||||||
```
|
|
||||||
|
|
||||||
We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:
|
|
||||||
there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing
|
|
||||||
`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or
|
|
||||||
similar as keys, which make it impossible to cover a useful section of the state space without
|
|
||||||
using the values returned by the API
|
|
||||||
|
|
||||||
|
|
||||||
# why not servant-quickcheck?
|
|
||||||
|
|
||||||
[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
|
[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
|
||||||
is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
|
is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
|
||||||
|
10
package.yaml
10
package.yaml
@ -54,3 +54,13 @@ tests:
|
|||||||
- hspec
|
- hspec
|
||||||
- hspec-core
|
- hspec-core
|
||||||
- http-api-data
|
- http-api-data
|
||||||
|
|
||||||
|
example:
|
||||||
|
main: Example.lhs
|
||||||
|
source-dirs: .
|
||||||
|
|
||||||
|
dependencies:
|
||||||
|
- roboservant
|
||||||
|
- hspec
|
||||||
|
build-depends: base, markdown-unlit
|
||||||
|
ghc-options: -pgmL markdown-unlit
|
||||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 3b8eaf26233853cd94e20de7f84c25d6124cd919072681c3287a761526f82b9e
|
-- hash: 8de468df6e784f3723af9155bba9da9f43659b7d4e8e465fdac26eafcb0d4306
|
||||||
|
|
||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.2
|
version: 0.1.0.2
|
||||||
@ -62,6 +62,38 @@ library
|
|||||||
, vinyl
|
, vinyl
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite example
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Example.lhs
|
||||||
|
other-modules:
|
||||||
|
Paths_roboservant
|
||||||
|
hs-source-dirs:
|
||||||
|
./.
|
||||||
|
ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
|
, dependent-map
|
||||||
|
, dependent-sum
|
||||||
|
, hashable
|
||||||
|
, hspec
|
||||||
|
, lifted-base
|
||||||
|
, monad-control
|
||||||
|
, mtl
|
||||||
|
, random
|
||||||
|
, roboservant
|
||||||
|
, servant
|
||||||
|
, servant-client
|
||||||
|
, servant-flatten
|
||||||
|
, servant-server
|
||||||
|
, string-conversions
|
||||||
|
, text
|
||||||
|
, time
|
||||||
|
, unordered-containers
|
||||||
|
, vinyl
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite roboservant-test
|
test-suite roboservant-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
|
@ -2,15 +2,9 @@
|
|||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Roboservant.Types
|
module Roboservant.Types
|
||||||
|
@ -31,7 +31,7 @@ class Breakdown x where
|
|||||||
breakdownExtras :: x -> [(Dynamic,Int)]
|
breakdownExtras :: x -> [(Dynamic,Int)]
|
||||||
|
|
||||||
instance (Hashable x, Typeable x) => Breakdown (Atom x) where
|
instance (Hashable x, Typeable x) => Breakdown (Atom x) where
|
||||||
breakdownExtras (Atom x) = [(toDyn x, hash x)]
|
breakdownExtras _ = []
|
||||||
|
|
||||||
deriving via (Atom ()) instance Breakdown ()
|
deriving via (Atom ()) instance Breakdown ()
|
||||||
deriving via (Atom Int) instance Breakdown Int
|
deriving via (Atom Int) instance Breakdown Int
|
||||||
@ -49,7 +49,6 @@ instance GBreakdown f => GBreakdown (M1 S c f ) where
|
|||||||
instance GBreakdown b => GBreakdown (M1 D a b) where
|
instance GBreakdown b => GBreakdown (M1 D a b) where
|
||||||
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
||||||
|
|
||||||
|
|
||||||
instance GBreakdown b => GBreakdown (M1 C a b) where
|
instance GBreakdown b => GBreakdown (M1 C a b) where
|
||||||
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
||||||
|
|
||||||
|
@ -9,13 +9,6 @@
|
|||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
module Roboservant.Types.BuildFrom where
|
module Roboservant.Types.BuildFrom where
|
||||||
|
|
||||||
import Control.Monad(filterM)
|
import Control.Monad(filterM)
|
||||||
@ -29,8 +22,6 @@ import Roboservant.Types.Internal
|
|||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
import qualified Data.IntSet as IntSet
|
import qualified Data.IntSet as IntSet
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
-- import Roboservant.Types.GBuildFrom(GBuildFrom(..))
|
|
||||||
|
|
||||||
|
|
||||||
buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
|
buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
|
||||||
buildFrom = buildStash . buildFrom'
|
buildFrom = buildStash . buildFrom'
|
||||||
@ -73,9 +64,9 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)
|
|||||||
-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
|
-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
|
||||||
-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
|
-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
|
||||||
instance (BuildFrom x) => BuildFrom [x] where
|
instance (BuildFrom x) => BuildFrom [x] where
|
||||||
extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ take 3 $ extras @x stash
|
extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ extras @x stash
|
||||||
where
|
where
|
||||||
powerset xs = filterM (\_ -> [True, False]) xs
|
powerset xs = filterM (const [True, False]) xs
|
||||||
|
|
||||||
instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where
|
instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where
|
||||||
extras stash = fmap (Compound . to) <$> gExtras stash
|
extras stash = fmap (Compound . to) <$> gExtras stash
|
||||||
@ -83,14 +74,13 @@ instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (C
|
|||||||
deriving via (Atom Int) instance BuildFrom Int
|
deriving via (Atom Int) instance BuildFrom Int
|
||||||
deriving via (Atom Char) instance BuildFrom Char
|
deriving via (Atom Char) instance BuildFrom Char
|
||||||
|
|
||||||
|
|
||||||
class GBuildFrom (f :: k -> *) where
|
class GBuildFrom (f :: k -> *) where
|
||||||
gExtras :: Stash -> [([Provenance], f a)]
|
gExtras :: Stash -> [([Provenance], f a)]
|
||||||
|
|
||||||
|
|
||||||
instance GBuildFrom b => GBuildFrom (M1 D a b) where
|
instance GBuildFrom b => GBuildFrom (M1 D a b) where
|
||||||
gExtras = fmap (fmap M1) . gExtras
|
gExtras = fmap (fmap M1) . gExtras
|
||||||
|
|
||||||
|
-- not recursion safe!
|
||||||
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
|
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
|
||||||
gExtras stash = (fmap L1 <$> gExtras stash)
|
gExtras stash = (fmap L1 <$> gExtras stash)
|
||||||
<> (fmap R1 <$> gExtras stash)
|
<> (fmap R1 <$> gExtras stash)
|
||||||
@ -98,9 +88,6 @@ instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
|
|||||||
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
|
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
|
||||||
gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
|
gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
instance GBuildFrom b => GBuildFrom (M1 C a b) where
|
instance GBuildFrom b => GBuildFrom (M1 C a b) where
|
||||||
gExtras =fmap (fmap M1) . gExtras
|
gExtras =fmap (fmap M1) . gExtras
|
||||||
|
|
||||||
|
@ -11,7 +11,6 @@ module Roboservant.Types.FlattenServer where
|
|||||||
|
|
||||||
import Servant
|
import Servant
|
||||||
|
|
||||||
|
|
||||||
data Bundled endpoints where
|
data Bundled endpoints where
|
||||||
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
|
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
|
||||||
NoEndpoints :: Bundled '[]
|
NoEndpoints :: Bundled '[]
|
||||||
|
@ -7,10 +7,7 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
@ -18,10 +15,8 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
module Roboservant.Types.ReifiedApi where
|
module Roboservant.Types.ReifiedApi where
|
||||||
|
|
||||||
|
|
||||||
import Control.Monad.Except (runExceptT)
|
import Control.Monad.Except (runExceptT)
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
-- import Data.Dependent.Sum
|
|
||||||
import Data.Dynamic (Dynamic)
|
import Data.Dynamic (Dynamic)
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
@ -165,7 +160,6 @@ instance
|
|||||||
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
|
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
|
||||||
V.:& reifiedEndpointArguments @endpoint
|
V.:& reifiedEndpointArguments @endpoint
|
||||||
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( BuildFrom (IfRequiredLenient T.Text mods headerType)
|
( BuildFrom (IfRequiredLenient T.Text mods headerType)
|
||||||
, ToReifiedEndpoint endpoint
|
, ToReifiedEndpoint endpoint
|
||||||
@ -178,8 +172,6 @@ instance
|
|||||||
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
|
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
|
||||||
V.:& reifiedEndpointArguments @endpoint
|
V.:& reifiedEndpointArguments @endpoint
|
||||||
|
|
||||||
|
|
||||||
-- this isn't happy in 0.16.2
|
|
||||||
#if MIN_VERSION_servant(0,17,0)
|
#if MIN_VERSION_servant(0,17,0)
|
||||||
instance
|
instance
|
||||||
( BuildFrom (IfLenient String mods captureType)
|
( BuildFrom (IfLenient String mods captureType)
|
||||||
@ -204,7 +196,6 @@ instance
|
|||||||
V.:& reifiedEndpointArguments @endpoint
|
V.:& reifiedEndpointArguments @endpoint
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
-- caching for merge
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( BuildFrom (IfLenient String mods requestType)
|
( BuildFrom (IfLenient String mods requestType)
|
||||||
|
46
test/Spec.hs
46
test/Spec.hs
@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
@ -15,14 +14,13 @@ import qualified Post
|
|||||||
import qualified Product
|
import qualified Product
|
||||||
import qualified Breakdown
|
import qualified Breakdown
|
||||||
|
|
||||||
import Test.Hspec.Core.Spec
|
import Test.Hspec.Core.Spec(ResultStatus(Failure,Success),resultStatus,itemExample,FailureReason(Reason),mapSpecItem_)
|
||||||
|
import Data.Dynamic(toDyn)
|
||||||
import Data.Dynamic(toDyn,Typeable,Dynamic)
|
|
||||||
import qualified Roboservant as RS
|
import qualified Roboservant as RS
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Data.Void
|
import Data.Void ( Void )
|
||||||
import Data.Maybe
|
import Data.Maybe ( isNothing )
|
||||||
import Data.Hashable
|
import Data.Hashable ( Hashable(hash) )
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec spec
|
main = hspec spec
|
||||||
@ -101,27 +99,6 @@ serverFailure = \case
|
|||||||
in failureReason /= RS.NoPossibleMoves
|
in failureReason /= RS.NoPossibleMoves
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
-- describe "can build from pieces" $ do
|
|
||||||
-- it "should find a failure that requires some assembly" $ do
|
|
||||||
-- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
|
|
||||||
-- >>= (`shouldSatisfy` isJust)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
|
|
||||||
-- -- -- could: it's mostly here to show how to test for concurrency problems.
|
|
||||||
-- describe "concurrency bugs" $ do
|
|
||||||
-- before UnsafeIO.makeServer $ do
|
|
||||||
-- describe "sequential checking" $ do
|
|
||||||
-- it "safe use" $ \unsafeServer -> do
|
|
||||||
-- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
|
|
||||||
|
|
||||||
-- modifyMaxSuccess (const 10000) $
|
|
||||||
-- shouldFail $
|
|
||||||
-- describe "concurrent" $ do
|
|
||||||
-- it "concurrent, dangerous use" $ \unsafeServer -> do
|
|
||||||
-- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
|
|
||||||
|
|
||||||
|
|
||||||
deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
|
deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
|
||||||
deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
|
deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
|
||||||
@ -144,19 +121,6 @@ deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
|
|||||||
deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
|
deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
|
||||||
deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
|
deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
|
|
||||||
--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
|
|
||||||
|
|
||||||
-- instance RS.Breakdown Post.FooPost
|
|
||||||
-- instance RS.BuildFrom Post.FooPost
|
|
||||||
|
|
||||||
|
|
||||||
-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
|
-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
|
||||||
-- this is often useful when testing tests.
|
-- this is often useful when testing tests.
|
||||||
shouldFail :: SpecWith a -> SpecWith a
|
shouldFail :: SpecWith a -> SpecWith a
|
||||||
|
Loading…
Reference in New Issue
Block a user