mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-08-15 19:10:24 +03:00
direct
This commit is contained in:
Mark Wotton
parent
8e47f923de
commit
94b0f2e79c
@ -19,6 +19,9 @@ dependencies:
|
||||
- bytestring
|
||||
- containers
|
||||
- hedgehog
|
||||
- random
|
||||
- lifted-base
|
||||
- monad-control
|
||||
- mtl
|
||||
- servant # >= 0.17
|
||||
- servant-client # >= 0.17
|
||||
|
||||
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: eec4253f2196a058b05c08988d5c544f7238982abba63f6b0112014f043771b2
|
||||
-- hash: 98b1024875f8d30a7818bbd16bf5f56375b76735f24931a17da3914852edcf6c
|
||||
|
||||
name: roboservant
|
||||
version: 0.1.0.2
|
||||
@ -32,7 +32,6 @@ library
|
||||
Roboservant
|
||||
Roboservant.Direct
|
||||
Roboservant.Hedgehog
|
||||
Roboservant.StateMachine
|
||||
Roboservant.Types
|
||||
Roboservant.Types.Breakdown
|
||||
Roboservant.Types.FlattenServer
|
||||
@ -47,7 +46,10 @@ library
|
||||
, bytestring
|
||||
, containers
|
||||
, hedgehog
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mtl
|
||||
, random
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-flatten
|
||||
@ -76,7 +78,10 @@ test-suite roboservant-test
|
||||
, hspec
|
||||
, hspec-core
|
||||
, hspec-hedgehog
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mtl
|
||||
, random
|
||||
, roboservant
|
||||
, servant
|
||||
, servant-client
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
module Roboservant (module Roboservant.StateMachine) where
|
||||
module Roboservant (module Roboservant.Direct) where
|
||||
|
||||
import Roboservant.StateMachine
|
||||
import Roboservant.Direct
|
||||
|
||||
229
src/Roboservant/Direct.hs
Normal file
229
src/Roboservant/Direct.hs
Normal file
@ -0,0 +1,229 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Roboservant.Direct
|
||||
( fuzz
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Exception.Lifted(throw,Exception,SomeException,catch)
|
||||
import System.Random
|
||||
import System.Timeout.Lifted
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
|
||||
import qualified Data.List.NonEmpty as NEL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Map.Strict(Map)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Typeable (TypeRep)
|
||||
import Hedgehog
|
||||
( Callback (Update),
|
||||
Command (Command),
|
||||
Concrete,
|
||||
MonadGen,
|
||||
Opaque (Opaque),
|
||||
PropertyT,
|
||||
Symbolic,
|
||||
Var,
|
||||
executeSequential,
|
||||
forAll,
|
||||
opaque,
|
||||
)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Roboservant.Hedgehog (elementOrFail)
|
||||
import Roboservant.Types
|
||||
( ApiOffset (..),
|
||||
FlattenServer (..),
|
||||
Op (..),
|
||||
ReifiedApi,
|
||||
State (..),
|
||||
ToReifiedApi (..),
|
||||
emptyState,
|
||||
)
|
||||
import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
|
||||
import Type.Reflection (SomeTypeRep)
|
||||
|
||||
-- prop_concurrent,
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
|
||||
import qualified Data.List.NonEmpty as NEL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Typeable (TypeRep)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Roboservant.Hedgehog (elementOrFail)
|
||||
import Roboservant.Types
|
||||
( ApiOffset (..),
|
||||
FlattenServer (..),
|
||||
Op (..),
|
||||
ReifiedApi,
|
||||
State (..),
|
||||
ToReifiedApi (..),
|
||||
emptyState,
|
||||
)
|
||||
import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
|
||||
import Type.Reflection (SomeTypeRep)
|
||||
|
||||
data RoboservantException
|
||||
= RoboservantException FailureType SomeException FuzzOp FuzzState
|
||||
deriving (Show)
|
||||
-- we believe in nussink, lebowski
|
||||
instance Exception RoboservantException
|
||||
|
||||
data FailureType
|
||||
= ServerCrashed
|
||||
| CheckerFailed
|
||||
| NoPossibleMoves
|
||||
deriving (Show,Eq)
|
||||
|
||||
-- update :: Callback Op (Opaque (NEL.NonEmpty Dynamic)) State
|
||||
-- update = Update $ \s@State {..} op o' ->
|
||||
-- case op of
|
||||
-- Chewable offset tr v -> case _extract offset trs chewable of
|
||||
-- Nothing -> error "internal error"
|
||||
-- Just (tr, _extracted, rest) ->
|
||||
-- s
|
||||
-- { stateRefs =
|
||||
-- -- so, what's going on here... we need to be able to grab and merge
|
||||
-- -- a list of (typeref, var). this means that we need to be able to pull
|
||||
-- -- out typereps symbolically too, we can't just rely on the dynamic being there.
|
||||
-- -- Map.insertWith (<>) (dynTypeRep v) _ (pure o') stateRefs,
|
||||
-- Map.insertWith (<>) tr (_ o') stateRefs,
|
||||
-- chewable = rest
|
||||
-- }
|
||||
-- (Op (ApiOffset _offset) _args) ->
|
||||
-- s
|
||||
-- { chewable = _ o' : chewable
|
||||
-- -- Map.insertWith
|
||||
-- -- (<>)
|
||||
-- -- tr
|
||||
-- -- (pure o')
|
||||
-- -- stateRefs
|
||||
-- }
|
||||
|
||||
|
||||
data Reference = Reference
|
||||
{ tr :: TypeRep
|
||||
, offset :: Int
|
||||
} deriving (Show,Eq)
|
||||
|
||||
data FuzzOp = FuzzOp ApiOffset [Reference]
|
||||
deriving (Show,Eq)
|
||||
|
||||
data Config
|
||||
= Config
|
||||
{ seed :: [Dynamic]
|
||||
, maxRuntime :: Int -- seconds to test for
|
||||
, rngSeed :: Int
|
||||
, currentRng :: StdGen
|
||||
}
|
||||
|
||||
data FuzzState = FuzzState
|
||||
{ path :: [FuzzOp]
|
||||
, stash :: Map TypeRep (NEL.NonEmpty (Reference,Dynamic))
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
|
||||
=> Server api
|
||||
-> Config
|
||||
-> IO ()
|
||||
-> IO ()
|
||||
fuzz server Config{..} checker =
|
||||
-- either we time out without finding an error, which is fine, or we find an error
|
||||
-- and throw an exception that propagates through this.
|
||||
void $ timeout (maxRuntime * 1000000) ( execStateT (forever go) FuzzState{..})
|
||||
|
||||
where
|
||||
|
||||
reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
|
||||
|
||||
elementOrFail :: MonadState FuzzState m
|
||||
=> [a] -> m a
|
||||
elementOrFail = undefined
|
||||
|
||||
genOp :: MonadState FuzzState m
|
||||
=> m FuzzOp
|
||||
genOp = do -- fs@FuzzState{..} = do
|
||||
-- choose a call to make, from the endpoints with fillable arguments.
|
||||
(offset, args) <- elementOrFail . options =<< get
|
||||
-- choose a (symbolic) argument from each. we drop the Dynamic here because it's
|
||||
-- not showable, which is no good for tests - though possibly it would make sense
|
||||
-- to use the constrained-dynamic stuff here? (or even just stash the string form)
|
||||
r <- (FuzzOp offset) <$> mapM (elementOrFail . fmap fst . NEL.toList) args
|
||||
modify' (\f -> f { path = r:path f })
|
||||
pure r
|
||||
|
||||
|
||||
-- chooseOne opts = do
|
||||
--
|
||||
-- (offset,) <$> mapM elementOrFail args
|
||||
where
|
||||
options :: FuzzState -> [(ApiOffset, [NEL.NonEmpty (Reference, Dynamic)])]
|
||||
options FuzzState{..} =
|
||||
mapMaybe
|
||||
( \(offset, (argreps, _dynCall)) -> (offset,) <$> do
|
||||
mapM (flip Map.lookup stash) argreps
|
||||
)
|
||||
reifiedApi
|
||||
execute :: MonadState FuzzState m
|
||||
=> FuzzOp -> m ()
|
||||
execute = undefined
|
||||
|
||||
|
||||
|
||||
-- execute (Op (ApiOffset offset) args) = do
|
||||
-- fmap Opaque . liftIO $ do
|
||||
-- let realArgs = map opaque args
|
||||
-- let (_offset, (_staticArgs, endpoint)) = staticRoutes !! offset
|
||||
-- -- now, magic happens: we apply some dynamic arguments to a dynamic
|
||||
-- -- function and hopefully something useful pops out the end.
|
||||
-- func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
|
||||
-- let showable = "blah" -- map dynTypeRep (_endpoint : realArgs)
|
||||
-- case func of
|
||||
-- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
-- Just (f') -> do
|
||||
-- case fromDynamic f' of
|
||||
-- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
-- Just f -> liftIO f >>= \case
|
||||
-- Left (serverError :: ServerError) -> error (show serverError)
|
||||
-- Right (_typeRep :: SomeTypeRep, (dyn :: NEL.NonEmpty Dynamic)) -> pure dyn
|
||||
|
||||
|
||||
go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
|
||||
=> m ()
|
||||
go = do
|
||||
fuzzOp <- genOp
|
||||
catch (execute fuzzOp)
|
||||
(\(e :: SomeException) -> throw . RoboservantException ServerCrashed e fuzzOp =<< get)
|
||||
catch (liftIO checker)
|
||||
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed e fuzzOp =<< get)
|
||||
|
||||
-- actions <-
|
||||
-- forAll $ do
|
||||
-- Gen.sequential
|
||||
-- (Range.linear 1 100)
|
||||
-- emptyState
|
||||
-- (fmap preload seed <> [callEndpoint reifiedApi])
|
||||
-- executeSequential emptyState actions
|
||||
@ -1,176 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Roboservant.StateMachine
|
||||
( prop_sequential,
|
||||
)
|
||||
where
|
||||
|
||||
-- prop_concurrent,
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
|
||||
import qualified Data.List.NonEmpty as NEL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Typeable (TypeRep)
|
||||
import Hedgehog
|
||||
( Callback (Update),
|
||||
Command (Command),
|
||||
Concrete,
|
||||
MonadGen,
|
||||
Opaque (Opaque),
|
||||
PropertyT,
|
||||
Symbolic,
|
||||
Var,
|
||||
executeSequential,
|
||||
forAll,
|
||||
opaque,
|
||||
)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Roboservant.Hedgehog (elementOrFail)
|
||||
import Roboservant.Types
|
||||
( ApiOffset (..),
|
||||
FlattenServer (..),
|
||||
Op (..),
|
||||
ReifiedApi,
|
||||
State (..),
|
||||
ToReifiedApi (..),
|
||||
emptyState,
|
||||
)
|
||||
import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
|
||||
import Type.Reflection (SomeTypeRep)
|
||||
|
||||
callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
|
||||
callEndpoint staticRoutes =
|
||||
let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
|
||||
gen State {..} = case chewable of
|
||||
(_ : _) -> Just $ do
|
||||
(offset, v) <- Gen.element (zip [0 ..] chewable)
|
||||
pure $ Chewable offset _ _
|
||||
_ -> do
|
||||
guard $ not $ null options
|
||||
pure $ uncurry Op <$> chooseOne options
|
||||
where
|
||||
chooseOne ::
|
||||
MonadGen n =>
|
||||
[ ( a,
|
||||
[[b]]
|
||||
)
|
||||
] ->
|
||||
n
|
||||
( a,
|
||||
[b]
|
||||
)
|
||||
chooseOne opts = do
|
||||
(offset, args) <- elementOrFail opts
|
||||
(offset,) <$> mapM elementOrFail args
|
||||
options :: [(ApiOffset, [[Var (Opaque Dynamic) Symbolic]])]
|
||||
options =
|
||||
mapMaybe
|
||||
( \(offset, (argreps, _dynCall)) -> (offset,) <$> do
|
||||
mapM fillableWith argreps
|
||||
)
|
||||
staticRoutes
|
||||
fillableWith :: TypeRep -> Maybe [Var (Opaque Dynamic) Symbolic]
|
||||
fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
|
||||
execute ::
|
||||
(MonadIO m) =>
|
||||
Op Concrete ->
|
||||
m (Opaque (NEL.NonEmpty Dynamic))
|
||||
-- bit subtle here - a chewable v _also_ gets a var, because chewing it should
|
||||
-- only give subcomponents.
|
||||
execute (Chewable offset trs v) = _ -- pure . Opaque $ opaque $ pure v -- pure $ Opaque v -- <$> liftIO (newIORef v)
|
||||
execute (Op (ApiOffset offset) args) = do
|
||||
fmap Opaque . liftIO $ do
|
||||
let realArgs = map opaque args
|
||||
let (_offset, (_staticArgs, endpoint)) = staticRoutes !! offset
|
||||
-- now, magic happens: we apply some dynamic arguments to a dynamic
|
||||
-- function and hopefully something useful pops out the end.
|
||||
func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
|
||||
let showable = "blah" -- map dynTypeRep (_endpoint : realArgs)
|
||||
case func of
|
||||
Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
Just (f') -> do
|
||||
case fromDynamic f' of
|
||||
Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
Just f -> liftIO f >>= \case
|
||||
Left (serverError :: ServerError) -> error (show serverError)
|
||||
Right (_typeRep :: SomeTypeRep, (dyn :: NEL.NonEmpty Dynamic)) -> pure dyn
|
||||
in Command
|
||||
gen
|
||||
execute
|
||||
[ update
|
||||
]
|
||||
|
||||
update :: Callback Op (Opaque (NEL.NonEmpty Dynamic)) State
|
||||
update = Update $ \s@State {..} op o' ->
|
||||
case op of
|
||||
Chewable offset tr v -> case _extract offset trs chewable of
|
||||
Nothing -> error "internal error"
|
||||
Just (tr, _extracted, rest) ->
|
||||
s
|
||||
{ stateRefs =
|
||||
-- so, what's going on here... we need to be able to grab and merge
|
||||
-- a list of (typeref, var). this means that we need to be able to pull
|
||||
-- out typereps symbolically too, we can't just rely on the dynamic being there.
|
||||
-- Map.insertWith (<>) (dynTypeRep v) _ (pure o') stateRefs,
|
||||
Map.insertWith (<>) tr (_ o') stateRefs,
|
||||
chewable = rest
|
||||
}
|
||||
(Op (ApiOffset _offset) _args) ->
|
||||
s
|
||||
{ chewable = _ o' : chewable
|
||||
-- Map.insertWith
|
||||
-- (<>)
|
||||
-- tr
|
||||
-- (pure o')
|
||||
-- stateRefs
|
||||
}
|
||||
|
||||
extract :: Int -> [a] -> Maybe (a, [a])
|
||||
extract = undefined
|
||||
|
||||
preload :: (MonadGen n, MonadIO m) => Dynamic -> Command n m State
|
||||
preload = undefined
|
||||
|
||||
prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
|
||||
prop_sequential server seed = do
|
||||
let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
|
||||
actions <-
|
||||
forAll $ do
|
||||
Gen.sequential
|
||||
(Range.linear 1 100)
|
||||
emptyState
|
||||
(fmap preload seed <> [callEndpoint reifiedApi])
|
||||
executeSequential emptyState actions
|
||||
-- prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
|
||||
-- prop_concurrent server seed =
|
||||
-- let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
|
||||
-- in do
|
||||
-- actions <-
|
||||
-- forAll $
|
||||
-- Gen.parallel
|
||||
-- (Range.linear 1 50)
|
||||
-- (Range.linear 1 10)
|
||||
-- (emptyState {chewable = seed})
|
||||
-- [callEndpoint reifiedApi]
|
||||
-- test $
|
||||
-- executeParallel (emptyState {chewable = seed}) actions
|
||||
61
test/Spec.hs
61
test/Spec.hs
@ -2,15 +2,15 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
import qualified Foo
|
||||
import qualified Seeded
|
||||
import qualified Headers
|
||||
-- import qualified Foo
|
||||
-- import qualified Seeded
|
||||
-- import qualified Headers
|
||||
import qualified UnsafeIO
|
||||
import qualified Roboservant as RS
|
||||
|
||||
import Test.Hspec.Hedgehog
|
||||
-- import Test.Hspec.Hedgehog
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Core.Spec(shouldFail)
|
||||
-- import Test.Hspec.Core.Spec(shouldFail)
|
||||
|
||||
import Data.Dynamic(toDyn)
|
||||
|
||||
@ -20,34 +20,35 @@ main = hspec spec
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Basic usage" $ do
|
||||
describe "seeded" $ do
|
||||
modifyMaxSuccess (const 10000) $
|
||||
shouldFail $
|
||||
it "finds an error using information passed in" $
|
||||
hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]
|
||||
pure ()
|
||||
-- describe "seeded" $ do
|
||||
-- modifyMaxSuccess (const 10000) $
|
||||
-- shouldFail $
|
||||
-- it "finds an error using information passed in" $
|
||||
-- hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]
|
||||
|
||||
modifyMaxSuccess (const 10000) $
|
||||
-- modifyMaxSuccess (const 10000) $
|
||||
|
||||
shouldFail $ it "finds an error in a basic app" $
|
||||
hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
|
||||
-- shouldFail $ it "finds an error in a basic app" $
|
||||
-- hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
|
||||
|
||||
describe "Headers" $ do
|
||||
modifyMaxSuccess (const 10000) $
|
||||
-- describe "Headers" $ do
|
||||
-- modifyMaxSuccess (const 10000) $
|
||||
|
||||
shouldFail $ it "should find a failure that's dependent on using header info" $ do
|
||||
hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
|
||||
-- pending
|
||||
-- shouldFail $ it "should find a failure that's dependent on using header info" $ do
|
||||
-- hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
|
||||
-- -- pending
|
||||
|
||||
-- -- 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 []
|
||||
-- -- -- 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 []
|
||||
-- modifyMaxSuccess (const 10000) $
|
||||
-- shouldFail $
|
||||
-- describe "concurrent" $ do
|
||||
-- it "concurrent, dangerous use" $ \unsafeServer -> do
|
||||
-- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
|
||||
|
||||
Loading…
Reference in New Issue
Block a user