mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
add hash requirement to checker, for better state space exploration
This commit is contained in:
parent
6e0923194f
commit
bada8f05de
@ -17,6 +17,7 @@ dependencies:
|
||||
- bytestring
|
||||
- containers
|
||||
- random
|
||||
- hashable
|
||||
- lifted-base
|
||||
- monad-control
|
||||
- mtl
|
||||
@ -28,6 +29,7 @@ dependencies:
|
||||
- vinyl
|
||||
- dependent-sum
|
||||
- dependent-map
|
||||
- unordered-containers
|
||||
- text
|
||||
- time
|
||||
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 6420e658218cfbfe27ae6037534f3e63a37fb1c9dfbd1a48c5f5e435d959a5af
|
||||
-- hash: 0c7e475fb1182766bcb6f2b602d95ca2ce986757d1d23c061fb2800fee49f483
|
||||
|
||||
name: roboservant
|
||||
version: 0.1.0.2
|
||||
@ -46,6 +46,7 @@ library
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, hashable
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mtl
|
||||
@ -57,6 +58,7 @@ library
|
||||
, string-conversions
|
||||
, text
|
||||
, time
|
||||
, unordered-containers
|
||||
, vinyl
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -82,6 +84,7 @@ test-suite roboservant-test
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, hashable
|
||||
, hspec
|
||||
, hspec-core
|
||||
, http-api-data
|
||||
@ -97,5 +100,6 @@ test-suite roboservant-test
|
||||
, string-conversions
|
||||
, text
|
||||
, time
|
||||
, unordered-containers
|
||||
, vinyl
|
||||
default-language: Haskell2010
|
||||
|
@ -74,7 +74,7 @@ import Roboservant.Types
|
||||
import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
|
||||
import System.Random (StdGen, mkStdGen, randomR)
|
||||
import qualified Type.Reflection as R
|
||||
|
||||
import qualified Data.IntSet as IntSet
|
||||
|
||||
data RoboservantException
|
||||
= RoboservantException
|
||||
@ -101,7 +101,7 @@ data FuzzOp
|
||||
|
||||
data Config
|
||||
= Config
|
||||
{ seed :: [Dynamic],
|
||||
{ seed :: [(Dynamic,Int)],
|
||||
maxRuntime :: Double, -- seconds to test for
|
||||
maxReps :: Integer,
|
||||
rngSeed :: Int,
|
||||
@ -120,7 +120,7 @@ data EndpointOption
|
||||
= forall as.
|
||||
(V.RecordToList as, V.RMap as) =>
|
||||
EndpointOption
|
||||
{ eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),
|
||||
{ eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))),
|
||||
eoArgs :: V.Rec (TypedF StashValue) as
|
||||
}
|
||||
|
||||
@ -206,7 +206,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
|
||||
( forall as.
|
||||
(V.RecordToList as, V.RMap as) =>
|
||||
FuzzOp ->
|
||||
V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
|
||||
V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
|
||||
V.Rec (TypedF V.Identity) as ->
|
||||
m r
|
||||
) ->
|
||||
@ -216,7 +216,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
|
||||
(offset, EndpointOption {..}) <- elementOrFail . options =<< get
|
||||
r <-
|
||||
V.rtraverse
|
||||
( \(tr :*: StashValue svs) ->
|
||||
( \(tr :*: StashValue svs _) ->
|
||||
elementOrFail $
|
||||
zipWith
|
||||
(\i xy -> V.Const i :*: tr :*: xy)
|
||||
@ -247,19 +247,19 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
|
||||
execute ::
|
||||
(MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
|
||||
FuzzOp ->
|
||||
V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
|
||||
V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
|
||||
V.Rec (TypedF V.Identity) as ->
|
||||
m ()
|
||||
execute fuzzop func args = do
|
||||
(liftIO . print . (fuzzop,) . stash ) =<< get
|
||||
st <- get
|
||||
let showable = unlines $ ("args":map show argTypes)
|
||||
<> ["fuzzop"
|
||||
, show fuzzop
|
||||
-- ,"dyncall"
|
||||
-- ,show (dynTypeRep dyncall)
|
||||
,"state"
|
||||
]
|
||||
-- let showable = unlines $ ("args":map show argTypes)
|
||||
-- <> ["fuzzop"
|
||||
-- , show fuzzop
|
||||
-- -- ,"dyncall"
|
||||
-- -- ,show (dynTypeRep dyncall)
|
||||
-- ,"state"
|
||||
-- ]
|
||||
-- liftIO $ putStrLn showable
|
||||
liftIO (V.runcurry' func argVals) >>= \case
|
||||
-- parameterise this
|
||||
@ -268,7 +268,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
|
||||
500 -> throw serverError
|
||||
_ -> do
|
||||
liftIO $ print ("ignoring non-500 error", serverError)
|
||||
Right (dyn :: NEL.NonEmpty Dynamic) -> do
|
||||
Right (dyn :: NEL.NonEmpty (Dynamic,Int)) -> do
|
||||
-- liftIO $ print ("storing", fmap dynTypeRep dyn)
|
||||
modify' (\fs@FuzzState{..} ->
|
||||
fs { stash = addToStash (NEL.toList dyn) stash } )
|
||||
@ -289,14 +289,15 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
|
||||
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
|
||||
|
||||
addToStash ::
|
||||
[Dynamic] ->
|
||||
[(Dynamic,Int)] ->
|
||||
Stash ->
|
||||
Stash
|
||||
addToStash result stash =
|
||||
foldr
|
||||
( \(Dynamic tr x) (Stash dict) ->
|
||||
( \(Dynamic tr x,hashed) (Stash dict) ->
|
||||
Stash $
|
||||
DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| [])) dict
|
||||
DM.insertWith renumber tr
|
||||
(StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) dict
|
||||
)
|
||||
stash
|
||||
result
|
||||
@ -305,11 +306,17 @@ addToStash result stash =
|
||||
StashValue a ->
|
||||
StashValue a ->
|
||||
StashValue a
|
||||
renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
|
||||
[([Provenance tr _], dyn)] ->
|
||||
l
|
||||
<> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
|
||||
_ -> error "should be impossible"
|
||||
renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)
|
||||
| not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
|
||||
| otherwise =
|
||||
StashValue
|
||||
(case NEL.toList singleDyn of
|
||||
[([Provenance tr _], dyn)] ->
|
||||
l
|
||||
<> pure (([Provenance tr (length (NEL.last l) + 1)], dyn))
|
||||
_ -> error "should be impossible")
|
||||
|
||||
(IntSet.union singleHash intSet)
|
||||
|
||||
-- why isn't this in vinyl?
|
||||
recordToList' ::
|
||||
|
@ -29,22 +29,23 @@ import Data.Maybe (fromMaybe)
|
||||
import GHC.Generics(Generic)
|
||||
import Data.Typeable (Typeable)
|
||||
import Roboservant.Types.Internal
|
||||
import Data.Hashable
|
||||
|
||||
-- | only use this when we are using the internal typerep map.
|
||||
promisedDyn :: Typeable a => Dynamic -> a
|
||||
promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
|
||||
|
||||
class Breakdown x where
|
||||
breakdown :: x -> NonEmpty Dynamic
|
||||
breakdown :: x -> NonEmpty (Dynamic,Int)
|
||||
-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
|
||||
-- breakdown = pure . toDyn
|
||||
|
||||
|
||||
instance Typeable x => Breakdown (Atom x) where
|
||||
breakdown = pure . toDyn . unAtom
|
||||
instance (Hashable x, Typeable x) => Breakdown (Atom x) where
|
||||
breakdown (Atom x) = pure (toDyn x, hash x)
|
||||
|
||||
deriving via (Atom ()) instance Breakdown ()
|
||||
deriving via (Atom Int) instance Breakdown Int
|
||||
|
||||
instance (Typeable a, Breakdown a) => Breakdown [a] where
|
||||
breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
|
||||
-- instance (Typeable a, Breakdown a) => Breakdown [a] where
|
||||
-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
|
||||
|
@ -17,6 +17,7 @@ import qualified Data.Dependent.Map as DM
|
||||
import qualified Type.Reflection as R
|
||||
import Data.Kind
|
||||
import Roboservant.Types.Internal
|
||||
import Data.Hashable
|
||||
|
||||
class Typeable x => BuildFrom (x :: Type) where
|
||||
buildFrom :: Stash -> Maybe (StashValue x)
|
||||
@ -28,12 +29,13 @@ instance Typeable x => BuildFrom (Atom x) where
|
||||
|
||||
deriving via (Atom Bool) instance BuildFrom Bool
|
||||
|
||||
instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
|
||||
buildFrom dict = Just options
|
||||
where options :: StashValue (Maybe x)
|
||||
options = StashValue $
|
||||
([],Nothing) :|
|
||||
(maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
|
||||
)
|
||||
-- instance (BuildFrom a) => BuildFrom [a] -- where
|
||||
--breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
|
||||
-- instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) where
|
||||
-- buildFrom dict = Just options
|
||||
-- where options :: StashValue (Maybe x)
|
||||
-- options = StashValue
|
||||
-- ([],Nothing) :|
|
||||
-- (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
|
||||
-- )
|
||||
-- _
|
||||
-- -- instance (BuildFrom a) => BuildFrom [a] -- where
|
||||
-- --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
|
||||
|
@ -9,12 +9,15 @@ import qualified Data.Dependent.Map as DM
|
||||
import Data.Dependent.Map (DMap)
|
||||
import qualified Type.Reflection as R
|
||||
import Data.Dependent.Sum
|
||||
import Data.IntSet(IntSet)
|
||||
|
||||
data Provenance
|
||||
= Provenance R.SomeTypeRep Int
|
||||
deriving (Show,Eq)
|
||||
|
||||
newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
|
||||
data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)
|
||||
, stashHash :: IntSet
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
||||
-- wrap in newtype to give a custom Show instance, since the normal
|
||||
@ -24,7 +27,7 @@ newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
|
||||
|
||||
instance Show Stash where
|
||||
showsPrec i (Stash x) = showsPrec i $
|
||||
Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
|
||||
Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
|
||||
|
||||
-- | Can't be built up from parts, can't be broken down further.
|
||||
newtype Atom x = Atom { unAtom :: x }
|
||||
|
@ -53,7 +53,7 @@ newtype Argument a = Argument
|
||||
|
||||
data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
|
||||
{ reArguments :: V.Rec (TypedF Argument) as
|
||||
, reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
|
||||
, reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int))))
|
||||
}
|
||||
|
||||
type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
|
||||
@ -79,7 +79,7 @@ instance ToReifiedApi '[] where
|
||||
instance
|
||||
( Typeable (EndpointRes endpoint)
|
||||
, NormalizeFunction (ServerT endpoint Handler)
|
||||
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))
|
||||
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
|
||||
, ToReifiedEndpoint endpoint
|
||||
, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
|
||||
) =>
|
||||
@ -103,7 +103,7 @@ instance NormalizeFunction x => NormalizeFunction (r -> x) where
|
||||
normalize = fmap normalize
|
||||
|
||||
instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
|
||||
type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
|
||||
type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))
|
||||
normalize handler = (runExceptT . runHandler') handler >>= \case
|
||||
Left serverError -> pure (Left serverError)
|
||||
Right x -> pure $ Right $ breakdown x
|
||||
|
@ -11,13 +11,14 @@ import Data.Aeson
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Servant
|
||||
import Data.Hashable
|
||||
|
||||
newtype Foo = Foo Int
|
||||
deriving (Generic, Eq, Show, Typeable)
|
||||
deriving newtype (FromHttpApiData, ToHttpApiData)
|
||||
|
||||
instance Hashable Foo
|
||||
instance ToJSON Foo
|
||||
|
||||
instance FromJSON Foo
|
||||
|
||||
type Api =
|
||||
|
@ -11,13 +11,14 @@ import Data.Aeson
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Servant
|
||||
import Data.Hashable
|
||||
|
||||
newtype Foo = Foo Int
|
||||
deriving (Generic, Eq, Show, Typeable)
|
||||
deriving newtype (FromHttpApiData, ToHttpApiData)
|
||||
|
||||
instance Hashable Foo
|
||||
instance ToJSON Foo
|
||||
|
||||
instance FromJSON Foo
|
||||
|
||||
type Api =
|
||||
|
@ -10,6 +10,7 @@ module Post where
|
||||
import GHC.Generics (Generic)
|
||||
import Servant
|
||||
import Data.Aeson
|
||||
import Data.Hashable
|
||||
|
||||
type Api = Get '[JSON] FooPost
|
||||
:<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
|
||||
@ -17,6 +18,7 @@ type Api = Get '[JSON] FooPost
|
||||
data FooPost = FooPost
|
||||
deriving (Eq,Show,Generic)
|
||||
|
||||
instance Hashable FooPost
|
||||
instance ToJSON FooPost
|
||||
instance FromJSON FooPost
|
||||
|
||||
|
@ -11,6 +11,7 @@ import Data.Aeson
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Servant
|
||||
import Data.Hashable
|
||||
|
||||
newtype Seed = Seed Int
|
||||
deriving (Generic, Eq, Show, Typeable)
|
||||
@ -18,6 +19,7 @@ newtype Seed = Seed Int
|
||||
|
||||
instance ToJSON Seed
|
||||
instance FromJSON Seed
|
||||
instance Hashable Seed
|
||||
|
||||
type Api = Capture "seed" Seed :> Get '[JSON] ()
|
||||
:<|> Get '[JSON] ()
|
||||
|
12
test/Spec.hs
12
test/Spec.hs
@ -19,6 +19,7 @@ import qualified Roboservant as RS
|
||||
import Test.Hspec
|
||||
import Data.Void
|
||||
import Data.Maybe
|
||||
import Data.Hashable
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
@ -57,17 +58,18 @@ spec = do
|
||||
describe "seeded" $ do
|
||||
shouldFail $
|
||||
it "finds an error using information passed in" $
|
||||
RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
|
||||
let res = Seeded.Seed 1 in
|
||||
RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
|
||||
>>= (`shouldSatisfy` isNothing)
|
||||
describe "Foo" $ do
|
||||
it "finds an error in a basic app" $
|
||||
RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
|
||||
>>= (`shouldSatisfy` isJust)
|
||||
|
||||
describe "headers" $ do
|
||||
it "should find a failure that's dependent on using header info" $ do
|
||||
RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
|
||||
>>= (`shouldSatisfy` isJust)
|
||||
-- describe "headers" $ do
|
||||
-- it "should find a failure that's dependent on using header info" $ do
|
||||
-- RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
|
||||
-- >>= (`shouldSatisfy` isJust)
|
||||
|
||||
-- describe "can build from pieces" $ do
|
||||
-- it "should find a failure that requires some assembly" $ do
|
||||
|
Loading…
Reference in New Issue
Block a user