mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
direct
This commit is contained in:
parent
8e47f923de
commit
94b0f2e79c
@ -19,6 +19,9 @@ dependencies:
|
|||||||
- bytestring
|
- bytestring
|
||||||
- containers
|
- containers
|
||||||
- hedgehog
|
- hedgehog
|
||||||
|
- random
|
||||||
|
- lifted-base
|
||||||
|
- monad-control
|
||||||
- mtl
|
- mtl
|
||||||
- servant # >= 0.17
|
- servant # >= 0.17
|
||||||
- servant-client # >= 0.17
|
- servant-client # >= 0.17
|
||||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: eec4253f2196a058b05c08988d5c544f7238982abba63f6b0112014f043771b2
|
-- hash: 98b1024875f8d30a7818bbd16bf5f56375b76735f24931a17da3914852edcf6c
|
||||||
|
|
||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.2
|
version: 0.1.0.2
|
||||||
@ -32,7 +32,6 @@ library
|
|||||||
Roboservant
|
Roboservant
|
||||||
Roboservant.Direct
|
Roboservant.Direct
|
||||||
Roboservant.Hedgehog
|
Roboservant.Hedgehog
|
||||||
Roboservant.StateMachine
|
|
||||||
Roboservant.Types
|
Roboservant.Types
|
||||||
Roboservant.Types.Breakdown
|
Roboservant.Types.Breakdown
|
||||||
Roboservant.Types.FlattenServer
|
Roboservant.Types.FlattenServer
|
||||||
@ -47,7 +46,10 @@ library
|
|||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, hedgehog
|
, hedgehog
|
||||||
|
, lifted-base
|
||||||
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
|
, random
|
||||||
, servant
|
, servant
|
||||||
, servant-client
|
, servant-client
|
||||||
, servant-flatten
|
, servant-flatten
|
||||||
@ -76,7 +78,10 @@ test-suite roboservant-test
|
|||||||
, hspec
|
, hspec
|
||||||
, hspec-core
|
, hspec-core
|
||||||
, hspec-hedgehog
|
, hspec-hedgehog
|
||||||
|
, lifted-base
|
||||||
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
|
, random
|
||||||
, roboservant
|
, roboservant
|
||||||
, servant
|
, servant
|
||||||
, servant-client
|
, 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 OverloadedStrings #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
import qualified Foo
|
-- import qualified Foo
|
||||||
import qualified Seeded
|
-- import qualified Seeded
|
||||||
import qualified Headers
|
-- import qualified Headers
|
||||||
import qualified UnsafeIO
|
import qualified UnsafeIO
|
||||||
import qualified Roboservant as RS
|
import qualified Roboservant as RS
|
||||||
|
|
||||||
import Test.Hspec.Hedgehog
|
-- import Test.Hspec.Hedgehog
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.Core.Spec(shouldFail)
|
-- import Test.Hspec.Core.Spec(shouldFail)
|
||||||
|
|
||||||
import Data.Dynamic(toDyn)
|
import Data.Dynamic(toDyn)
|
||||||
|
|
||||||
@ -20,34 +20,35 @@ main = hspec spec
|
|||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "Basic usage" $ do
|
describe "Basic usage" $ do
|
||||||
describe "seeded" $ do
|
pure ()
|
||||||
modifyMaxSuccess (const 10000) $
|
-- describe "seeded" $ do
|
||||||
shouldFail $
|
-- modifyMaxSuccess (const 10000) $
|
||||||
it "finds an error using information passed in" $
|
-- shouldFail $
|
||||||
hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]
|
-- 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" $
|
-- shouldFail $ it "finds an error in a basic app" $
|
||||||
hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
|
-- hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
|
||||||
|
|
||||||
describe "Headers" $ do
|
-- describe "Headers" $ do
|
||||||
modifyMaxSuccess (const 10000) $
|
-- modifyMaxSuccess (const 10000) $
|
||||||
|
|
||||||
shouldFail $ it "should find a failure that's dependent on using header info" $ do
|
-- shouldFail $ it "should find a failure that's dependent on using header info" $ do
|
||||||
hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
|
-- hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
|
||||||
-- pending
|
-- -- pending
|
||||||
|
|
||||||
-- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
|
-- -- -- 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.
|
-- -- -- could: it's mostly here to show how to test for concurrency problems.
|
||||||
describe "concurrency bugs" $ do
|
-- describe "concurrency bugs" $ do
|
||||||
before UnsafeIO.makeServer $ do
|
-- before UnsafeIO.makeServer $ do
|
||||||
describe "sequential checking" $ do
|
-- describe "sequential checking" $ do
|
||||||
it "safe use" $ \unsafeServer -> do
|
-- it "safe use" $ \unsafeServer -> do
|
||||||
hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
|
-- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
|
||||||
|
|
||||||
modifyMaxSuccess (const 10000) $
|
-- modifyMaxSuccess (const 10000) $
|
||||||
shouldFail $
|
-- shouldFail $
|
||||||
describe "concurrent" $ do
|
-- describe "concurrent" $ do
|
||||||
it "concurrent, dangerous use" $ \unsafeServer -> do
|
-- it "concurrent, dangerous use" $ \unsafeServer -> do
|
||||||
RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
|
-- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
|
||||||
|
Loading…
Reference in New Issue
Block a user