git.iko.soy/roboservant
on master help sign in
dependency on seed working!
9d70cccMark Wotton
src/Roboservant/StateMachine.hs+38−35
compare with master
unifiedsplit
@@ -17,9 +17,10 @@
17{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
18
18
19module Roboservant.StateMachine
19module Roboservant.StateMachine
20−( prop_sequential
20+ ( prop_sequential,
21−, prop_concurrent
21+ prop_concurrent,
22+ )
22−) where
23+where
23
24
24import Control.Monad.IO.Class (MonadIO, liftIO)
25import Control.Monad.IO.Class (MonadIO, liftIO)
25import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
26import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
@@ -28,42 +29,45 @@ import qualified Data.List.NonEmpty as NEL
28import qualified Data.Map.Strict as Map
29import qualified Data.Map.Strict as Map
29import Data.Maybe (mapMaybe)
30import Data.Maybe (mapMaybe)
30import Data.Typeable (TypeRep)
31import Data.Typeable (TypeRep)
32+import Debug.Trace
31import GHC.IORef (readIORef)
33import GHC.IORef (readIORef)
32import Hedgehog
34import Hedgehog
33import qualified Hedgehog.Gen as Gen
35import qualified Hedgehog.Gen as Gen
34import qualified Hedgehog.Range as Range
36import qualified Hedgehog.Range as Range
37+import Roboservant.Hedgehog
38+import Roboservant.Types
35import Servant
39import Servant
36import Type.Reflection (SomeTypeRep)
40import Type.Reflection (SomeTypeRep)
37
41
38−import Roboservant.Types
39−import Roboservant.Hedgehog
40−
41−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> [Dynamic] -> Command n m State
42+callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
42−callEndpoint staticRoutes _seed =
43+callEndpoint staticRoutes =
43 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
44 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
44− gen State {..}
45+ gen State {..} = case preloads of
46+ (v : _) -> Just $ pure $ Preload (dynTypeRep v) v
47+ _ ->
45− | any null options = Nothing
48+ if any null options
49+ then Nothing
46− | otherwise = Just $ do
50+ else Just $ do
47− uncurry Op <$> chooseOne options
51+ uncurry Op <$> chooseOne options
48 where
52 where
49 chooseOne ::
53 chooseOne ::
50 MonadGen n =>
54 MonadGen n =>
51 [ ( ApiOffset,
55 [ ( ApiOffset,
52− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
56+ [[Var (Opaque (IORef Dynamic)) Symbolic]]
53 )
57 )
54 ] ->
58 ] ->
55 n
59 n
56 ( ApiOffset,
60 ( ApiOffset,
57− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
61+ [Var (Opaque (IORef Dynamic)) Symbolic]
58 )
62 )
59 chooseOne opts = do
63 chooseOne opts = do
60 (offset, args) <- elementOrFail opts
64 (offset, args) <- elementOrFail opts
61− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> elementOrFail argOpts) args
65+ (offset,) <$> mapM elementOrFail args
62− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
66+ options :: [(ApiOffset, [[Var (Opaque (IORef Dynamic)) Symbolic]])]
63 options =
67 options =
64 mapMaybe
68 mapMaybe
65 ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
69 ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
66− mapM (\x -> (x,) <$> fillableWith x) argreps
70+ mapM fillableWith argreps
67 )
71 )
68 staticRoutes
72 staticRoutes
69 fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
73 fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
@@ -72,14 +76,13 @@ callEndpoint staticRoutes _seed =
72 (MonadIO m) =>
76 (MonadIO m) =>
73 Op Concrete ->
77 Op Concrete ->
74 m (Opaque (IORef Dynamic))
78 m (Opaque (IORef Dynamic))
75− execute (Preload _tr v) = fmap Opaque . liftIO $ do
79+ execute (Preload _tr v) = Opaque <$> liftIO (newIORef v)
76− newIORef . concrete $ v
77 execute (Op (ApiOffset offset) args) = do
80 execute (Op (ApiOffset offset) args) = do
78 fmap Opaque . liftIO $ do
81 fmap Opaque . liftIO $ do
79− realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
82+ realArgs <- mapM (readIORef . opaque) args
80 let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
83 let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
81 -- now, magic happens: we apply some dynamic arguments to a dynamic
84 -- now, magic happens: we apply some dynamic arguments to a dynamic
82− -- function and hopefully somtehing useful pops out the end.
85+ -- function and hopefully something useful pops out the end.
83 func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
86 func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
84 let showable = map dynTypeRep (endpoint : realArgs)
87 let showable = map dynTypeRep (endpoint : realArgs)
85 case func of
88 case func of
@@ -95,9 +98,13 @@ callEndpoint staticRoutes _seed =
95 execute
98 execute
96 [ Update $ \s@State {..} op o' ->
99 [ Update $ \s@State {..} op o' ->
97 case op of
100 case op of
98− Preload tr _v -> s { stateRefs =
101+ Preload tr _v ->
102+ s
103+ { stateRefs =
99− Map.insertWith (<>) tr (pure o') stateRefs }
104+ Map.insertWith (<>) tr (pure o') stateRefs,
105+ preloads = drop 1 preloads
106+ }
100− (Op (ApiOffset offset) _args) ->
107+ (Op (ApiOffset offset) _args) ->
101 s
108 s
102 { stateRefs =
109 { stateRefs =
103 let (_, _, tr, _) = staticRoutes !! offset
110 let (_, _, tr, _) = staticRoutes !! offset
@@ -107,33 +114,29 @@ callEndpoint staticRoutes _seed =
107 (pure o')
114 (pure o')
108 stateRefs
115 stateRefs
109 }
116 }
110− -- , Ensure (no-500 here)
111 ]
117 ]
112
118
113prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
119prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
114prop_sequential server seed = do
120prop_sequential server seed = do
115 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
121 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
116−
117 actions <-
122 actions <-
118 forAll $ do
123 forAll $ do
119 Gen.sequential
124 Gen.sequential
120 (Range.linear 1 100)
125 (Range.linear 1 100)
121− (State mempty)
126+ (State mempty seed)
122− [callEndpoint reifiedApi seed]
127+ [callEndpoint reifiedApi]
123−
124− executeSequential (State mempty) actions
128+ executeSequential (State mempty seed) actions
125
129
126prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
130prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
127prop_concurrent server seed =
131prop_concurrent server seed =
128− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in
132+ let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
129− let initialState = State mempty
130 in do
133 in do
131 actions <-
134 actions <-
132 forAll $
135 forAll $
133 Gen.parallel
136 Gen.parallel
134 (Range.linear 1 50)
137 (Range.linear 1 50)
135 (Range.linear 1 10)
138 (Range.linear 1 10)
136− initialState
139+ (State mempty seed)
137− [callEndpoint reifiedApi seed]
140+ [callEndpoint reifiedApi]
138 test $
141 test $
139− executeParallel initialState actions
142+ executeParallel (State mempty seed) actions
src/Roboservant/Types.hs+9−5
@@ -33,18 +33,22 @@ import Roboservant.Types.ReifiedApi
33
33
34data State v
34data State v
35 = State
35 = State
36− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
36+ { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v)),
37+ preloads :: [Dynamic]
37 }
38 }
38
39
39-- | we need to specify an offset because it's entirely possible to have two
40-- | we need to specify an offset because it's entirely possible to have two
40-- functions with the same arguments that do different things.
41-- functions with the same arguments that do different things.
41data Op (v :: * -> *)
42data Op (v :: * -> *)
43+ = -- this needs to change - need a constructor offset and a list of vars inside,
44+ -- because a single argument to the api could be a sum type with many constructors and varying
45+ -- arguments itself.
42− = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
46+ Op ApiOffset [(Var (Opaque (IORef Dynamic)) v)]
43− | Preload TypeRep (Var Dynamic v)
47+ | Preload TypeRep Dynamic
44
48
45deriving instance Show (Op Symbolic)
49deriving instance Show (Op Symbolic)
46
50
47instance HTraversable Op where
51instance HTraversable Op where
48 htraverse r = \case
52 htraverse r = \case
49− Op offset args -> Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
53+ Op offset args -> Op offset <$> traverse (htraverse r) args
50− Preload tr v -> Preload tr <$> htraverse r v
54+ Preload tr v -> pure $ Preload tr v
test/Spec.hs+8−5
@@ -21,12 +21,15 @@ spec :: Spec
21spec = do
21spec = do
22 describe "Basic usage" $ do
22 describe "Basic usage" $ do
23 describe "seeded" $ do
23 describe "seeded" $ do
24+ modifyMaxSuccess (const 10000) $
24− shouldFail $
25+ shouldFail $
25− it "finds an error using information passed in" $
26+ it "finds an error using information passed in" $
26− hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]
27+ hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]
28+
29+ modifyMaxSuccess (const 10000) $
27
30
28− shouldFail $ it "finds an error in a basic app" $
31+ shouldFail $ it "finds an error in a basic app" $
29− hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
32+ hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
30
33
31 describe "Headers" $ do
34 describe "Headers" $ do
32 shouldFail $ it "should find a failure that's dependent on using header info" $ do
35 shouldFail $ it "should find a failure that's dependent on using header info" $ do