@@ -17,9 +17,10 @@
1717{-# LANGUAGE UndecidableInstances #-}
1818
1919module Roboservant.StateMachine
20−( prop_sequential
21−, prop_concurrent
22−) where
20+ ( prop_sequential,
21+ prop_concurrent,
22+ )
23+where
2324
2425import Control.Monad.IO.Class (MonadIO, liftIO)
2526import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
@@ -28,42 +29,45 @@ import qualified Data.List.NonEmpty as NEL
2829import qualified Data.Map.Strict as Map
2930import Data.Maybe (mapMaybe)
3031import Data.Typeable (TypeRep)
32+import Debug.Trace
3133import GHC.IORef (readIORef)
3234import Hedgehog
3335import qualified Hedgehog.Gen as Gen
3436import qualified Hedgehog.Range as Range
37+import Roboservant.Hedgehog
38+import Roboservant.Types
3539import Servant
3640import Type.Reflection (SomeTypeRep)
3741
38−import Roboservant.Types
39−import Roboservant.Hedgehog
40−
41−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> [Dynamic] -> Command n m State
42−callEndpoint staticRoutes _seed =
42+callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
43+callEndpoint staticRoutes =
4344 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
44− gen State {..}
45− | any null options = Nothing
46− | otherwise = Just $ do
47− uncurry Op <$> chooseOne options
45+ gen State {..} = case preloads of
46+ (v : _) -> Just $ pure $ Preload (dynTypeRep v) v
47+ _ ->
48+ if any null options
49+ then Nothing
50+ else Just $ do
51+ uncurry Op <$> chooseOne options
4852 where
4953 chooseOne ::
5054 MonadGen n =>
5155 [ ( ApiOffset,
52− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
56+ [[Var (Opaque (IORef Dynamic)) Symbolic]]
5357 )
5458 ] ->
5559 n
5660 ( ApiOffset,
57− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
61+ [Var (Opaque (IORef Dynamic)) Symbolic]
5862 )
5963 chooseOne opts = do
6064 (offset, args) <- elementOrFail opts
61− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> elementOrFail argOpts) args
62− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
65+ (offset,) <$> mapM elementOrFail args
66+ options :: [(ApiOffset, [[Var (Opaque (IORef Dynamic)) Symbolic]])]
6367 options =
6468 mapMaybe
6569 ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
66− mapM (\x -> (x,) <$> fillableWith x) argreps
70+ mapM fillableWith argreps
6771 )
6872 staticRoutes
6973 fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
@@ -72,14 +76,13 @@ callEndpoint staticRoutes _seed =
7276 (MonadIO m) =>
7377 Op Concrete ->
7478 m (Opaque (IORef Dynamic))
75− execute (Preload _tr v) = fmap Opaque . liftIO $ do
76− newIORef . concrete $ v
79+ execute (Preload _tr v) = Opaque <$> liftIO (newIORef v)
7780 execute (Op (ApiOffset offset) args) = do
7881 fmap Opaque . liftIO $ do
79− realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
82+ realArgs <- mapM (readIORef . opaque) args
8083 let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
8184 -- 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.
8386 func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
8487 let showable = map dynTypeRep (endpoint : realArgs)
8588 case func of
@@ -95,9 +98,13 @@ callEndpoint staticRoutes _seed =
9598 execute
9699 [ Update $ \s@State {..} op o' ->
97100 case op of
98− Preload tr _v -> s { stateRefs =
99− Map.insertWith (<>) tr (pure o') stateRefs }
100− (Op (ApiOffset offset) _args) ->
101+ Preload tr _v ->
102+ s
103+ { stateRefs =
104+ Map.insertWith (<>) tr (pure o') stateRefs,
105+ preloads = drop 1 preloads
106+ }
107+ (Op (ApiOffset offset) _args) ->
101108 s
102109 { stateRefs =
103110 let (_, _, tr, _) = staticRoutes !! offset
@@ -107,33 +114,29 @@ callEndpoint staticRoutes _seed =
107114 (pure o')
108115 stateRefs
109116 }
110− -- , Ensure (no-500 here)
111117 ]
112118
113119prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
114120prop_sequential server seed = do
115121 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
116−
117122 actions <-
118123 forAll $ do
119124 Gen.sequential
120125 (Range.linear 1 100)
121− (State mempty)
122− [callEndpoint reifiedApi seed]
123−
124− executeSequential (State mempty) actions
126+ (State mempty seed)
127+ [callEndpoint reifiedApi]
128+ executeSequential (State mempty seed) actions
125129
126130prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
127131prop_concurrent server seed =
128− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in
129− let initialState = State mempty
132+ let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
130133 in do
131134 actions <-
132135 forAll $
133136 Gen.parallel
134137 (Range.linear 1 50)
135138 (Range.linear 1 10)
136− initialState
137− [callEndpoint reifiedApi seed]
139+ (State mempty seed)
140+ [callEndpoint reifiedApi]
138141 test $
139− executeParallel initialState actions
142+ executeParallel (State mempty seed) actions