diff --git a/Makefile b/Makefile index 56b5eb9..c09f36c 100644 --- a/Makefile +++ b/Makefile @@ -1,2 +1,2 @@ testwatch: - ghcid -c 'stack repl --test --ghc-options=-fobject-code roboservant' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W + ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code roboservant --ghc-options="+RTS -N4"' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W diff --git a/package.yaml b/package.yaml index cb76841..e72a343 100644 --- a/package.yaml +++ b/package.yaml @@ -42,3 +42,6 @@ tests: dependencies: - roboservant - aeson + - hspec + - hspec-core + - hspec-hedgehog diff --git a/roboservant.cabal b/roboservant.cabal index 8b99c00..cec8f00 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 54c16a0abf993f08c909111fc8c7a86a3e633745bc93734d36b3bf9ccb93062a +-- hash: c6f561e011d580d9e17888decc01e0d8d54c8508b04d3dfff3cfcb7f37e5f2e1 name: roboservant version: 0.1.0.2 @@ -67,6 +67,9 @@ test-suite roboservant-test , bytestring , containers , hedgehog + , hspec + , hspec-core + , hspec-hedgehog , mtl , roboservant , servant diff --git a/src/Roboservant/StateMachine.hs b/src/Roboservant/StateMachine.hs index 4388730..102acf0 100644 --- a/src/Roboservant/StateMachine.hs +++ b/src/Roboservant/StateMachine.hs @@ -37,8 +37,8 @@ import Type.Reflection (SomeTypeRep) import Roboservant.Types -callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State -callEndpoint staticRoutes = +callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> [Dynamic] -> Command n m State +callEndpoint staticRoutes seed = let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic)) gen State {..} | any null options = Nothing @@ -71,6 +71,10 @@ callEndpoint staticRoutes = (MonadIO m) => Op Concrete -> m (Opaque (IORef Dynamic)) + execute (Preload tr v) = fmap Opaque . liftIO $ do + newIORef . concrete $ v + --fmap Opaque . liftIO $ +-- _ v execute (Op (ApiOffset offset) args) = do -- traceM (show (offset, args)) fmap Opaque . liftIO $ do @@ -91,43 +95,48 @@ callEndpoint staticRoutes = in Command gen execute - [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' -> - s - { stateRefs = - let (_, _, tr, _) = staticRoutes !! offset - in Map.insertWith - (<>) - tr - (pure o') - stateRefs - } + [ Update $ \s@State {..} op o' -> + case op of + Preload tr v -> s { stateRefs = + Map.insertWith (<>) tr (pure o') stateRefs } + (Op (ApiOffset offset) _args) -> + s + { stateRefs = + let (_, _, tr, _) = staticRoutes !! offset + in Map.insertWith + (<>) + tr + (pure o') + stateRefs + } -- , Ensure (no-500 here) ] -prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property -prop_sequential server = do +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)) - property $ do - let initialState = State mempty - actions <- - forAll $ - Gen.sequential - (Range.linear 1 100) - initialState - [callEndpoint reifiedApi] - executeSequential initialState actions + -- refs <- Map.fromList <$> mapM (\d -> (dynTypeRep d,) <$> newIORef d) seed -prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property + actions <- + forAll $ do + Gen.sequential + (Range.linear 1 100) + (State mempty) + [callEndpoint reifiedApi seed] + + executeSequential (undefined) actions + +prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> PropertyT IO () prop_concurrent server = let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in let initialState = State mempty - in withTests 1000 . withRetries 10 . property $ do + in do actions <- forAll $ Gen.parallel (Range.linear 1 50) (Range.linear 1 10) initialState - [callEndpoint reifiedApi] + [callEndpoint reifiedApi []] test $ executeParallel initialState actions diff --git a/src/Roboservant/Types.hs b/src/Roboservant/Types.hs index 4908905..126fc4d 100644 --- a/src/Roboservant/Types.hs +++ b/src/Roboservant/Types.hs @@ -179,8 +179,11 @@ newtype ApiOffset = ApiOffset Int -- | we need to specify an offset because it's entirely possible to have two -- functions with the same arguments that do different things. data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)] + | Preload TypeRep (Var Dynamic v) deriving instance Show (Op Symbolic) instance HTraversable Op where - htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args + htraverse r = \case + Op offset args -> Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args + Preload tr v -> Preload tr <$> htraverse r v diff --git a/stack.yaml b/stack.yaml index b87ecea..fb790cc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,13 +1,23 @@ -resolver: lts-15.15 +resolver: lts-16.14 packages: - . extra-deps: - servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 -- quickcheck-state-machine-0.7.0@sha256:4fc4467380e35b88aab72c278856aacebbf95688059d8ad70eb82fe048df476b,4958 - markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112 -- servant-0.17 -- servant-client-0.17 -- servant-client-core-0.17 -- servant-server-0.17 -- constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207 +- servant-0.18 +- servant-client-0.18 +- servant-client-core-0.18 +- servant-server-0.18 +# - hspec-hedgehog-0.0.1.2@sha256:aaeeb50a43d2bce8a1850baa3ddf934a964bfe38c64efd59306b0c1421e55b45,1405 +- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736 +- random-1.2.0 +- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253 +- git: https://github.com/hedgehogqa/haskell-hedgehog.git + commit: 03714682586e43b5ddf5c00391035471a6e01238 + subdirs: + - hedgehog +- git: https://github.com/mwotton/hspec + commit: cd9012414a93cf08f86e409544d4d3a8f282b507 + subdirs: + - hspec-core diff --git a/stack.yaml.lock b/stack.yaml.lock index 7c85543..4e262d5 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,13 +11,6 @@ packages: sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 original: hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 -- completed: - hackage: quickcheck-state-machine-0.7.0@sha256:4fc4467380e35b88aab72c278856aacebbf95688059d8ad70eb82fe048df476b,4958 - pantry-tree: - size: 3022 - sha256: 045794fff983e385560b321ff5576f6ec5c2821748c3042053f72daaca7beba8 - original: - hackage: quickcheck-state-machine-0.7.0@sha256:4fc4467380e35b88aab72c278856aacebbf95688059d8ad70eb82fe048df476b,4958 - completed: hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112 pantry-tree: @@ -26,43 +19,83 @@ packages: original: hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112 - completed: - hackage: servant-0.17@sha256:e78734cb6b75c5d1e52e8f5e16bc3f557154a580bbde4932a7e1a6a90da7eb04,5029 + hackage: servant-0.18@sha256:2b5c81089540c208b1945b5ca0c3551c862138d71b224a39fa275a62852a5c75,5068 pantry-tree: - size: 2392 - sha256: 36561a606c35393386aa48b7cc2407fa4013aba62a19d69f004ec9c2010209aa + size: 2458 + sha256: 701b6443e486601dd127b92a28ca052278dea8dc528f013781c1304826e117d8 original: - hackage: servant-0.17 + hackage: servant-0.18 - completed: - hackage: servant-client-0.17@sha256:433be65dd541b9a387eaaced22715a028ea846d72d141419c40ddf6fd5e3409b,4573 + hackage: servant-client-0.18@sha256:3e3b8d145cf811e19849744ad305aa0bd42301d01ff75e1dac169bc9f5d18221,4589 pantry-tree: size: 1299 - sha256: 1f8f57c6ce96ed4f1316460aaab48f3765b2addbf1e2cd363c72bbc41fdcf907 + sha256: 445c610d83a6e356ed2a7808af8deac84708be3e44d38cbf76e60fd6105f9715 original: - hackage: servant-client-0.17 + hackage: servant-client-0.18 - completed: - hackage: servant-client-core-0.17@sha256:d64622d68d8a6934abc821171582d601a99ef0277f3d8b8ba9b483c2617e3df6,3577 + hackage: servant-client-core-0.18@sha256:6702f04f3e5ac47abace5b26ab1948480437334747895407f0697502a403b96a,3593 pantry-tree: size: 1444 - sha256: 89461980a2562d9943f4bb84077d8c4a8c5bac76c8c16577c9344e404b2e9fb1 + sha256: 20f538ae12091696073a2ac5f3301a4a56686f5e2889b2a9e539c0d61a332cd1 original: - hackage: servant-client-core-0.17 + hackage: servant-client-core-0.18 - completed: - hackage: servant-server-0.17@sha256:1a5adf564f0b703535eb733f249b282ef2ca7b587a303c357b549fb88e7a6dcd,5388 + hackage: servant-server-0.18@sha256:ec7f361bc9848968b1fff8091fa2213b721d3f47549421945c6a7ca1702e22e6,5424 pantry-tree: - size: 2460 - sha256: ea65ba54acb4362efedbfa7db616a51023579a6c83f18ab6d2ea6a84dea56021 + size: 2546 + sha256: c2470cd8665742cee13faae1db7e3d49d70b027d57c4578e3f7ba66ffc8dc7b4 original: - hackage: servant-server-0.17 + hackage: servant-server-0.18 - completed: - hackage: constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207 + hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736 pantry-tree: - size: 576 - sha256: 93e4777d88e75cb1b3efef47654880304ce6fd2af12e31b0c7bd279f95abb449 + size: 2315 + sha256: 21961d0875fc156cdd97110a6fb277f37aa31faa3c7910895f84c82630e7ba46 original: - hackage: constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207 + hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736 +- completed: + hackage: random-1.2.0@sha256:4321209c8faedc034810ea8ed0dbc4a36f1a1df97b75af024219f2f533da57de,6094 + pantry-tree: + size: 1259 + sha256: 29ff0a7ec5bf123e2c40f849b7af163950854a6c08c68b4a1b4364ce7a515af0 + original: + hackage: random-1.2.0 +- completed: + hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253 + pantry-tree: + size: 1149 + sha256: b9a0c60e2d4786bbb276ce6606027a99615bf703fa3e0f01911e8c6a656c5161 + original: + hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253 +- completed: + subdir: hedgehog + name: hedgehog + version: 1.0.3 + git: https://github.com/hedgehogqa/haskell-hedgehog.git + pantry-tree: + size: 2575 + sha256: 7e69930fef281dfeb47b2f7c745c26234768e56ffb5490065f607c57146ffbab + commit: 03714682586e43b5ddf5c00391035471a6e01238 + original: + subdir: hedgehog + git: https://github.com/hedgehogqa/haskell-hedgehog.git + commit: 03714682586e43b5ddf5c00391035471a6e01238 +- completed: + subdir: hspec-core + name: hspec-core + version: 2.7.4 + git: https://github.com/mwotton/hspec + pantry-tree: + size: 3899 + sha256: 6ece11ad28a7f122a502e766eb1b3ef950815c2d16babb0ea8744646f1c1bd70 + commit: cd9012414a93cf08f86e409544d4d3a8f282b507 + original: + subdir: hspec-core + git: https://github.com/mwotton/hspec + commit: cd9012414a93cf08f86e409544d4d3a8f282b507 snapshots: - completed: - size: 496112 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/15.yaml - sha256: 86169722ad0056ffc9eacc157ef80ee21d7024f92c0d2961c89ccf432db230a3 - original: lts-15.15 + size: 532382 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/14.yaml + sha256: 1ef27e36f38824abafc43224ca612211b3828fa9ffd31ba0fc2867ae2e19ba90 + original: lts-16.14 diff --git a/test/Spec.hs b/test/Spec.hs index c2c3037..fecfc46 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,27 +7,40 @@ import Hedgehog (Group (..), checkSequential, withTests) import qualified Roboservant as RS import qualified UnsafeIO import Control.Monad(when) +import Test.Hspec.Hedgehog +import Test.Hspec +import Test.Hspec.Core.Spec(shouldFail) +import Control.Monad.Trans (MonadIO(liftIO)) --- | this is pretty bad. hopefully Jacob knows a better way of doing this. --- https://twitter.com/mwotton/status/1305189249646460933 -assert :: String -> Bool -> IO () -assert _ True = pure () -assert err False = ioError $ userError err +-- -- | this is pretty bad. hopefully Jacob knows a better way of doing this. +-- -- https://twitter.com/mwotton/status/1305189249646460933 +-- assert :: String -> Bool -> IO () +-- assert _ True = pure () +-- assert err False = ioError $ userError err --- | This is horribly laid out, sorry. Will fix at some point. -main :: IO () -main = do - assert "should find an error in Foo" . not - =<< checkSequential (Group "Foo" [("Foo", withTests 100000 $ RS.prop_sequential @Foo.FooApi Foo.fooServer)]) - when False $ do - assert "should find an error in Headers" . not - =<< checkSequential (Group "Headers" [("Headers", withTests 10000 $ RS.prop_sequential @Headers.Api Headers.server)]) +main = hspec spec - -- 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. - unsafeServer <- UnsafeIO.makeServer - -- this will not detect the error, as it requires concurrency. - assert "should find nothing" =<< checkSequential (Group "Unsafe" [("Sequential", RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer)]) - -- this will! - assert "should find with parallel check" . not - =<< checkSequential (Group "Unsafe" [("Parallel", withTests 100000 $ RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer)]) +spec :: Spec +spec = do + describe "Foo" $ do + -- + shouldFail $ it "finds an error" $ + (hedgehog $ RS.prop_sequential @Foo.FooApi Foo.fooServer []) + + describe "Headers" $ do + shouldFail $ it "should find a failure that's dependent on using header info" $ do + liftIO $ pendingWith "doesn't yet work" + (hedgehog $ RS.prop_sequential @Headers.Api Headers.server []) + + -- -- 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. + 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