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)
|
||||
|
||||
## example
|
||||
|
||||
# why?
|
||||
see full example [here](EXAMPLE.md)
|
||||
|
||||
## why?
|
||||
|
||||
Servant gives us a lot of information about what a server can do. We
|
||||
use this information to generate arbitrarily long request/response
|
||||
sessions and verify properties that should hold over them.
|
||||
|
||||
# example
|
||||
|
||||
Our api under test:
|
||||
|
||||
```
|
||||
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?
|
||||
## why not 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,
|
||||
|
10
package.yaml
10
package.yaml
@ -54,3 +54,13 @@ tests:
|
||||
- hspec
|
||||
- hspec-core
|
||||
- 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
|
||||
--
|
||||
-- hash: 3b8eaf26233853cd94e20de7f84c25d6124cd919072681c3287a761526f82b9e
|
||||
-- hash: 8de468df6e784f3723af9155bba9da9f43659b7d4e8e465fdac26eafcb0d4306
|
||||
|
||||
name: roboservant
|
||||
version: 0.1.0.2
|
||||
@ -62,6 +62,38 @@ library
|
||||
, vinyl
|
||||
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
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
|
@ -2,15 +2,9 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Roboservant.Types
|
||||
|
@ -31,7 +31,7 @@ class Breakdown x where
|
||||
breakdownExtras :: x -> [(Dynamic,Int)]
|
||||
|
||||
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 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
|
||||
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
||||
|
||||
|
||||
instance GBreakdown b => GBreakdown (M1 C a b) where
|
||||
gBreakdownExtras (M1 f) = gBreakdownExtras f
|
||||
|
||||
|
@ -9,13 +9,6 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
module Roboservant.Types.BuildFrom where
|
||||
|
||||
import Control.Monad(filterM)
|
||||
@ -29,8 +22,6 @@ import Roboservant.Types.Internal
|
||||
import Data.Hashable
|
||||
import qualified Data.IntSet as IntSet
|
||||
import GHC.Generics
|
||||
-- import Roboservant.Types.GBuildFrom(GBuildFrom(..))
|
||||
|
||||
|
||||
buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
|
||||
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.
|
||||
-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
|
||||
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
|
||||
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
|
||||
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 Char) instance BuildFrom Char
|
||||
|
||||
|
||||
class GBuildFrom (f :: k -> *) where
|
||||
gExtras :: Stash -> [([Provenance], f a)]
|
||||
|
||||
|
||||
instance GBuildFrom b => GBuildFrom (M1 D a b) where
|
||||
gExtras = fmap (fmap M1) . gExtras
|
||||
|
||||
-- not recursion safe!
|
||||
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
|
||||
gExtras stash = (fmap L1 <$> 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
|
||||
gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
|
||||
|
||||
|
||||
|
||||
|
||||
instance GBuildFrom b => GBuildFrom (M1 C a b) where
|
||||
gExtras =fmap (fmap M1) . gExtras
|
||||
|
||||
|
@ -11,7 +11,6 @@ module Roboservant.Types.FlattenServer where
|
||||
|
||||
import Servant
|
||||
|
||||
|
||||
data Bundled endpoints where
|
||||
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
|
||||
NoEndpoints :: Bundled '[]
|
||||
|
@ -7,10 +7,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
@ -18,10 +15,8 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Roboservant.Types.ReifiedApi where
|
||||
|
||||
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Data.Bifunctor
|
||||
-- import Data.Dependent.Sum
|
||||
import Data.Dynamic (Dynamic)
|
||||
import Data.Kind
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
@ -165,7 +160,6 @@ instance
|
||||
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
|
||||
V.:& reifiedEndpointArguments @endpoint
|
||||
|
||||
|
||||
instance
|
||||
( BuildFrom (IfRequiredLenient T.Text mods headerType)
|
||||
, ToReifiedEndpoint endpoint
|
||||
@ -178,8 +172,6 @@ instance
|
||||
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
|
||||
V.:& reifiedEndpointArguments @endpoint
|
||||
|
||||
|
||||
-- this isn't happy in 0.16.2
|
||||
#if MIN_VERSION_servant(0,17,0)
|
||||
instance
|
||||
( BuildFrom (IfLenient String mods captureType)
|
||||
@ -204,7 +196,6 @@ instance
|
||||
V.:& reifiedEndpointArguments @endpoint
|
||||
|
||||
#endif
|
||||
-- caching for merge
|
||||
|
||||
instance
|
||||
( BuildFrom (IfLenient String mods requestType)
|
||||
|
46
test/Spec.hs
46
test/Spec.hs
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
@ -15,14 +14,13 @@ import qualified Post
|
||||
import qualified Product
|
||||
import qualified Breakdown
|
||||
|
||||
import Test.Hspec.Core.Spec
|
||||
|
||||
import Data.Dynamic(toDyn,Typeable,Dynamic)
|
||||
import Test.Hspec.Core.Spec(ResultStatus(Failure,Success),resultStatus,itemExample,FailureReason(Reason),mapSpecItem_)
|
||||
import Data.Dynamic(toDyn)
|
||||
import qualified Roboservant as RS
|
||||
import Test.Hspec
|
||||
import Data.Void
|
||||
import Data.Maybe
|
||||
import Data.Hashable
|
||||
import Data.Void ( Void )
|
||||
import Data.Maybe ( isNothing )
|
||||
import Data.Hashable ( Hashable(hash) )
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
@ -101,27 +99,6 @@ serverFailure = \case
|
||||
in failureReason /= RS.NoPossibleMoves
|
||||
_ -> 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.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.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.
|
||||
-- this is often useful when testing tests.
|
||||
shouldFail :: SpecWith a -> SpecWith a
|
||||
|
Loading…
Reference in New Issue
Block a user