quickcheck-state-machine 0.6.0 → 0.7.0
raw patch · 42 files changed
+7194/−761 lines, 42 filesdep +HTTPdep +aesondep +arraydep ~QuickCheckdep ~basedep ~bytestring
Dependencies added: HTTP, aeson, array, bifunctors, generic-data, graphviz, hashable, hashtables, hs-rqlite, markov-chain-usage-model, persistent-sqlite, postgresql-simple, resource-pool, sop-core, split, stm, time, unliftio-core
Dependency ranges changed: QuickCheck, base, bytestring, containers, directory, doctest, filelock, filepath, http-client, monad-logger, network, persistent, persistent-postgresql, persistent-template, pretty-show, process, quickcheck-instances, resourcet, servant, servant-client, servant-server, tasty, tasty-hunit, tasty-quickcheck, text, tree-diff, unliftio, wai, warp
Files
- CHANGELOG.md +32/−0
- LICENSE +3/−2
- README.md +76/−21
- quickcheck-state-machine.cabal +79/−38
- src/Test/StateMachine.hs +30/−2
- src/Test/StateMachine/BoxDrawer.hs +4/−3
- src/Test/StateMachine/DotDrawing.hs +146/−0
- src/Test/StateMachine/Labelling.hs +148/−0
- src/Test/StateMachine/Lockstep/Auxiliary.hs +93/−0
- src/Test/StateMachine/Lockstep/NAry.hs +416/−0
- src/Test/StateMachine/Lockstep/Simple.hs +238/−0
- src/Test/StateMachine/Logic.hs +110/−60
- src/Test/StateMachine/Markov.hs +536/−0
- src/Test/StateMachine/Parallel.hs +550/−131
- src/Test/StateMachine/Sequential.hs +337/−141
- src/Test/StateMachine/Types.hs +66/−13
- src/Test/StateMachine/Types/Environment.hs +5/−4
- src/Test/StateMachine/Types/GenSym.hs +5/−3
- src/Test/StateMachine/Types/History.hs +49/−9
- src/Test/StateMachine/Types/References.hs +14/−9
- src/Test/StateMachine/Utils.hs +88/−82
- src/Test/StateMachine/Z.hs +1/−1
- test/Bookstore.hs +483/−0
- test/CircularBuffer.hs +19/−22
- test/Cleanup.hs +325/−0
- test/CrudWebserverDb.hs +35/−30
- test/DieHard.hs +9/−10
- test/Echo.hs +31/−16
- test/ErrorEncountered.hs +21/−17
- test/Hanoi.hs +137/−0
- test/IORefs.hs +125/−0
- test/MemoryReference.hs +152/−34
- test/Mock.hs +124/−0
- test/Overflow.hs +156/−0
- test/ProcessRegistry.hs +578/−0
- test/RQlite.hs +771/−0
- test/SQLite.hs +487/−0
- test/Schema.hs +66/−0
- test/ShrinkingProps.hs +198/−45
- test/Spec.hs +173/−38
- test/TicketDispenser.hs +49/−30
- test/UnionFind.hs +229/−0
CHANGELOG.md view
@@ -1,3 +1,35 @@+#### 0.7.0 (2020-3-17)++ * Add Stack resolver lts-15 and drop lts-11;++ * High-level interface to the state machine API (PR #355) -- this+ captures the patterns described in+ http://www.well-typed.com/blog/2019/01/qsm-in-depth/ as a proper+ Haskell abstraction;++ * Experimental support for Markov chain-base command generation and+ reliability calculations;++ * forAllParallelCommands now gets another argument with type Maybe+ Int, indicating the minimum number of commands we want a test case+ to have. `Nothing` provides old functionality;++ * Fixed a bug in the parallel case for the mock function (PR #348) and+ other bugs related to references in the parallel case;++ * Add a new field in the StateMachine called cleanup. This function+ can be used to ensure resources are cleaned between tests.+ `noCleanup` can be used to achieve the older functionality;++ * Improved labelling;++ * Generalize parallelism, so that more than two threads can be used+ (PR #324);++ * Option to print dot visualisation of failed examples;++ * Handle exceptions better and provide better output.+ #### 0.6.0 (2019-1-15) This is a breaking release. See mentioned PRs for how to upgrade your code,
LICENSE view
@@ -1,5 +1,6 @@-Copyright (c) 2017-2019 Stevan Andjelkovic, Daniel Gustafsson, Jacob Stanley,- Xia Li-yao, Robert Danitz, Thomas Winant, Edsko de Vries+Copyright (c) 2017-2020 Stevan Andjelkovic, Daniel Gustafsson, Jacob Stanley,+ Xia Li-yao, Robert Danitz, Thomas Winant, Edsko de Vries,+ Momoko Hattori, Kostas Dermentzis, Adam Boniecki All rights reserved.
README.md view
@@ -66,8 +66,8 @@ where -- One of the problems is a bug that writes a wrong value to the -- reference.- i' | i `Prelude.elem` [5..10] = if bug == Logic then i + 1 else i- | otherwise = i+ i' | bug == Logic && i `elem` [5..10] = i + 1+ | otherwise = i Increment ref -> do -- The other problem is that we introduce a possible race condition -- when incrementing.@@ -104,9 +104,9 @@ precondition :: Model Symbolic -> Command Symbolic -> Logic precondition (Model m) cmd = case cmd of Create -> Top- Read ref -> ref `elem` domain m- Write ref _ -> ref `elem` domain m- Increment ref -> ref `elem` domain m+ Read ref -> ref `member` map fst m+ Write ref _ -> ref `member` map fst m+ Increment ref -> ref `member` map fst m ``` The transition function explains how actions change the model. Note that the@@ -144,10 +144,11 @@ ```haskell generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))-generator (Model model) = Just $ frequency+generator (Model []) = Just (pure Create)+generator model = Just $ frequency [ (1, pure Create)- , (4, Read <$> elements (domain model))- , (4, Write <$> elements (domain model) <*> arbitrary)+ , (4, Read <$> elements (map fst model))+ , (4, Write <$> elements (map fst model) <*> arbitrary) , (4, Increment <$> elements (domain model)) ] @@ -181,7 +182,7 @@ ```haskell sm :: Bug -> StateMachine Model Command IO Response sm bug = StateMachine initModel transition precondition postcondition- Nothing generator Nothing shrinker (semantics bug) mock+ Nothing generator shrinker (semantics bug) mock ``` We can now define a sequential property as follows.@@ -205,9 +206,9 @@ *** Failed! Falsifiable (after 12 tests and 2 shrinks): Commands { unCommands =- [ Command Create (fromList [ Var 0 ])- , Command (Write (Reference (Symbolic (Var 0))) 5) (fromList [])- , Command (Read (Reference (Symbolic (Var 0)))) (fromList [])+ [ Command Create [ Var 0 ]+ , Command (Write (Reference (Symbolic (Var 0))) 5) []+ , Command (Read (Reference (Symbolic (Var 0)))) [] ] } @@ -256,20 +257,20 @@ *** Failed! Falsifiable (after 26 tests and 6 shrinks): ParallelCommands { prefix =- Commands { unCommands = [ Command Create (fromList [ Var 0 ]) ] }+ Commands { unCommands = [ Command Create [ Var 0 ] ] } , suffixes = [ Pair { proj1 = Commands { unCommands =- [ Command (Increment (Reference (Symbolic (Var 0)))) (fromList [])- , Command (Read (Reference (Symbolic (Var 0)))) (fromList [])+ [ Command (Increment (Reference (Symbolic (Var 0)))) []+ , Command (Read (Reference (Symbolic (Var 0)))) [] ] } , proj2 = Commands { unCommands =- [ Command (Increment (Reference (Symbolic (Var 0)))) (fromList [])+ [ Command (Increment (Reference (Symbolic (Var 0)))) [] ] } }@@ -382,6 +383,12 @@ TLA+ [solution](https://github.com/tlaplus/Examples/blob/master/specifications/DieHard/DieHard.tla); + * The Tower of Hanoi puzzle -- this+ [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/Hanoi.hs) uses+ property based testing in a very similar manner to the+ Die Hard [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/DieHard.hs)+ to find a solution to the classic [Tower of Hanoi puzzle](https://en.wikipedia.org/wiki/Tower_of_Hanoi);+ * Mutable reference [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/MemoryReference.hs) --@@ -394,8 +401,19 @@ different kind of bugs. This example is borrowed from the paper *Testing the Hard Stuff and Staying Sane* [[PDF](http://publications.lib.chalmers.se/records/fulltext/232550/local_232550.pdf),- [video](https://www.youtube.com/watch?v=zi0rHwfiX1Q)];+ [video](https://www.youtube.com/watch?v=zi0rHwfiX1Q)]. For a more direct+ translation from the paper, see the following+ [variant](https://github.com/polux/qsm-ffi-demo) which uses the C FFI; + * The union-find+ [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/UnionFind.hs)+ -- an imperative implementation of the union-find algorithm. It could be+ useful to compare the solution to the one that appears in the paper *Testing+ Monadic Code with QuickCheck*+ [[PS](http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps)], which the+ [`Test.QuickCheck.Monadic`](https://hackage.haskell.org/package/QuickCheck/docs/Test-QuickCheck-Monadic.html)+ module is based on;+ * Ticket dispenser [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/TicketDispenser.hs) --@@ -416,8 +434,26 @@ using [Servant](https://github.com/haskell-servant/servant). Creating a user will return a unique id, which subsequent reads, updates, and deletes need to use. In this example, unlike in the last one, the server is setup and- torn down once per property rather than generate program.+ torn down once per property rather than generate program; + * Bookstore [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/Bookstore.hs)+ -- another database application, that uses simple SQL queries to manage a bookstore.+ It is based on a+ [case study](https://propertesting.com/book_case_study_stateful_properties_with_a_bookstore.html)+ in Erlang from online version of Fred Hebert's [PropEr Testing](https://propertesting.com/toc.html)+ book;++ * Process registry+ [example](https://github.com/advancedtelematic/quickcheck-state-machine/blob/master/test/ProcessRegistry.hs)+ -- an example often featured in the Erlang QuickCheck papers. This example+ shows how one can tag the specification with which requirements are covered+ and then generate (minimal) examples of test cases that cover each+ requirement, as shown in the *How well are your requirements tested?*+ [[PDF](https://publications.lib.chalmers.se/records/fulltext/232552/local_232552.pdf)]+ and *Understanding Formal Specifications through Good Examples*+ [[PDF](https://doi.org/10.1145/3239332.3242763),+ [video](https://www.youtube.com/watch?v=w2fin2V83e8)] papers.+ All properties from the examples can be found in the [`Spec`](https://github.com/advancedtelematic/quickcheck-state-machine/tree/master/test/Spec.hs) module located in the@@ -434,9 +470,22 @@ More examples from the "real world": - * Adjoint's implementation of the Raft consensus algorithm, contains state- machine- [tests](https://github.com/adjoint-io/raft/blob/master/test/QuickCheckStateMachine.hs)+ * IOHK are using a state machine models in several+ [places](https://github.com/search?l=Haskell&q=org%3Ainput-output-hk+Test.StateMachine&type=Code).+ For example+ [here](https://github.com/input-output-hk/ouroboros-network/blob/master/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/FS/StateMachine.hs)+ is a test of a mock file system that they in turn use to simulate file+ system errors when testing a blockchain database. The following blog+ [post](http://www.well-typed.com/blog/2019/01/qsm-in-depth/) describes their+ tests in more detail;++ * Wire are using a state machine model to+ [test](https://github.com/wireapp/wire-server/blob/master/services/gundeck/test/unit/ThreadBudget.hs)+ the lower bound of running threads in their push notification system;++ * Adjoint's (now abandoned?) implementation of the Raft consensus algorithm,+ contains state machine+ [tests](https://github.com/stevana/raft/blob/master/test/QuickCheckStateMachine.hs) combined with fault injection (node and network failures). ### How to contribute@@ -452,6 +501,12 @@ [issue](https://github.com/nick8325/quickcheck/issues/139) -- where the initial discussion about how to add state machine based testing to QuickCheck started;++ * John Hughes' Midlands Graduate School 2019+ [course](http://www.cse.chalmers.se/~rjmh/MGS2019/) on property-based+ testing, which covers the basics of state machine modelling and testing. It+ also contains a minimal implementation of a state machine testing library+ built on top of Haskell's QuickCheck; * *Finding Race Conditions in Erlang with QuickCheck and PULSE*
quickcheck-state-machine.cabal view
@@ -1,13 +1,14 @@ cabal-version: >=1.10 name: quickcheck-state-machine-version: 0.6.0+version: 0.7.0 license: BSD3 license-file: LICENSE copyright: Copyright (C) 2017-2018, ATS Advanced Telematic Systems GmbH;- 2018-2019, HERE Europe B.V.-maintainer: Stevan Andjelkovic <stevan.andjelkovic@here.com>+ 2018-2019, HERE Europe B.V.;+ 2019-2020, Stevan Andjelkovic.+maintainer: Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> author: Stevan Andjelkovic-tested-with: ghc ==8.2.2 ghc ==8.4.3 ghc ==8.6.3+tested-with: ghc ==8.4.3 ghc ==8.6.5 ghc ==8.8.3 homepage: https://github.com/advancedtelematic/quickcheck-state-machine#readme synopsis: Test monadic programs using state machine based models description:@@ -28,7 +29,13 @@ Test.StateMachine Test.StateMachine.BoxDrawer Test.StateMachine.ConstructorName+ Test.StateMachine.DotDrawing+ Test.StateMachine.Labelling+ Test.StateMachine.Lockstep.Auxiliary+ Test.StateMachine.Lockstep.NAry+ Test.StateMachine.Lockstep.Simple Test.StateMachine.Logic+ Test.StateMachine.Markov Test.StateMachine.Parallel Test.StateMachine.Sequential Test.StateMachine.Types@@ -51,13 +58,23 @@ ansi-wl-pprint >=0.6.7.3, base >=4.10 && <5, containers >=0.5.7.1,+ directory >=1.0.0.0, exceptions >=0.8.3,+ filepath >=1.0,+ generic-data >=0.3.0.0,+ graphviz >=2999.20.0.3,+ markov-chain-usage-model >=0.0.0, matrix >=0.3.5.0, mtl >=2.2.1,- pretty-show >=1.9.5,- QuickCheck >=2.9.2,- tree-diff >=0.0.2,- vector >=0.12.0.1,+ time >=1.7,+ pretty-show >=1.6.16,+ process >=1.2.0.0,+ QuickCheck >=2.12,+ random >=1.1,+ sop-core >=0.5.0.0,+ split >=0.2.3.4,+ text >=1.2.4.0,+ tree-diff >=0.0.2.1, unliftio >=0.2.7.0 test-suite quickcheck-state-machine-test@@ -65,14 +82,25 @@ main-is: Spec.hs hs-source-dirs: test other-modules:+ Bookstore CircularBuffer+ Cleanup CrudWebserverDb DieHard Echo ErrorEncountered+ Hanoi+ IORefs MemoryReference- TicketDispenser+ Mock+ Overflow+ ProcessRegistry+ Schema+ RQlite ShrinkingProps+ SQLite+ TicketDispenser+ UnionFind default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Weverything -Wno-missing-exported-signatures@@ -80,39 +108,52 @@ -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction build-depends:- base >=4.12.0.0,- bytestring >=0.10.8.2,- containers >=0.6.0.1,- directory >=1.3.3.0,- doctest >=0.16.0.1,- filelock >=0.1.1.2,+ aeson >=1.4.6.0,+ array >=0.5.4.0,+ base >=4.13.0.0,+ bifunctors >=5.5.7,+ bytestring >=0.10.10.0,+ containers >=0.6.2.1,+ directory >=1.3.6.0,+ doctest >=0.16.2,+ filelock >=0.1.1.4, filepath >=1.4.2.1,- http-client >=0.5.14,- matrix >=0.3.5.0,- monad-logger >=0.3.30,+ hashable >=1.3.0.0,+ hashtables >=1.2.3.4,+ hs-rqlite >=0.1.2.0,+ HTTP >=4000.3.14,+ http-client >=0.6.4.1,+ monad-logger >=0.3.32, mtl >=2.2.2,- network >=2.8.0.0,- persistent >=2.9.0,- persistent-postgresql >=2.9.0,- persistent-template >=2.5.4,- pretty-show >=1.9.5,- process >=1.6.3.0,- QuickCheck >=2.9.2,- quickcheck-instances >=0.3.19,+ network >=3.1.1.1,+ persistent >=2.10.3,+ persistent-postgresql >=2.10.1,+ persistent-sqlite >=2.10.2,+ persistent-template >=2.8.2.3,+ postgresql-simple >=0.6.2,+ pretty-show >=1.10,+ process >=1.6.8.0,+ QuickCheck >=2.13.2,+ quickcheck-instances >=0.3.22, quickcheck-state-machine -any, random >=1.1,- resourcet >=1.2.2,- servant >=0.15,- servant-client >=0.15,- servant-server >=0.15,+ resourcet >=1.2.3,+ resource-pool >=0.2.3.2,+ servant >=0.16.2,+ servant-client >=0.16.0.1,+ servant-server >=0.16.2,+ split >=0.2.3.4,+ stm >=2.5.0.0, strict >=0.3.2, string-conversions >=0.4.0.1,- tasty >=1.2,- tasty-hunit >=0.10.0.1,- tasty-quickcheck >=0.10,- text >=1.2.3.1,- tree-diff >=0.0.2,+ tasty >=1.2.3,+ tasty-hunit >=0.10.0.2,+ tasty-quickcheck >=0.10.1.1,+ text >=1.2.4.0,+ tree-diff >=0.0.2.1,+ time >=1.9.3, vector >=0.12.0.1,- wai >=3.2.1.2,- warp >=3.2.25,- unliftio >=0.2.10+ wai >=3.2.2.1,+ warp >=3.3.9,+ unliftio >=0.2.12.1,+ unliftio-core >=0.1.2.0
src/Test/StateMachine.hs view
@@ -4,7 +4,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -17,18 +17,37 @@ ( -- * Sequential property combinators forAllCommands- , transitionMatrix+ , existsCommands , runCommands , prettyCommands+ , prettyCommands' , checkCommandNames+ , coverCommandNames , commandNames , commandNamesInOrder+ , saveCommands+ , runSavedCommands+ , showLabelledExamples+ , showLabelledExamples'+ , noCleanup -- * Parallel property combinators , forAllParallelCommands+ , forAllNParallelCommands+ , runNParallelCommands , runParallelCommands+ , runParallelCommands' , runParallelCommandsNTimes+ , runNParallelCommandsNTimes'+ , runParallelCommandsNTimes'+ , runNParallelCommandsNTimes+ , prettyNParallelCommands , prettyParallelCommands+ , prettyParallelCommandsWithOpts+ , prettyNParallelCommandsWithOpts+ , checkCommandNamesParallel+ , coverCommandNamesParallel+ , commandNamesParallel -- * Types , StateMachine(StateMachine)@@ -45,13 +64,22 @@ , CommandNames(..) , module Test.StateMachine.Logic+ , module Test.StateMachine.Markov + -- * Re-export+ , ToExpr+ , toExpr+ ) where +import Data.TreeDiff+ (ToExpr, toExpr) import Prelude ()+ import Test.StateMachine.ConstructorName import Test.StateMachine.Logic+import Test.StateMachine.Markov import Test.StateMachine.Parallel import Test.StateMachine.Sequential import Test.StateMachine.Types
src/Test/StateMachine/BoxDrawer.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-} ----------------------------------------------------------------------------- -- |@@ -32,7 +33,7 @@ -- | Event invocation or response. data EventType = Open | Close- deriving (Show)+ deriving stock (Show) data Event = Event EventType Pid String @@ -95,7 +96,7 @@ compilePrefix [cmd] = error $ "compilePrefix: doesn't have response for cmd: " ++ cmd data Fork a = Fork a a a- deriving Functor+ deriving stock Functor -- | Given a history, and output from processes generate Doc with boxes exec :: [(EventType, Pid)] -> Fork [String] -> Doc
+ src/Test/StateMachine/DotDrawing.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.StateMachine.DotDrawing+ ( GraphOptions (..)+ , GraphvizOutput (..)+ , Rose (..)+ , printDotGraph+ ) where++import Control.Exception+import Control.Monad+import Data.GraphViz.Attributes.Complete+import Data.GraphViz.Commands+import Data.GraphViz.Exception+import Data.GraphViz.Types.Canonical+import Data.List+ (uncons)+import Data.List.Split+import Data.Map hiding+ (null)+import Data.Maybe+import Data.Text.Lazy+ (pack)+import Prelude+import Test.StateMachine.Types.History++------------------------------------------------------------------------++data GraphOptions = GraphOptions {+ filePath :: FilePath -- Where to store the graph+ -- (note: file extensions are not checked)+ , graphvizOutput :: GraphvizOutput -- output formats (like Jpeg, Png ..)+ }++data Rose a = Rose a (Map Pid a)+ deriving stock (Functor, Show)++printDotGraph :: GraphOptions -> Rose [String] -> IO ()+printDotGraph GraphOptions{..} (Rose pref sfx) = do+ let++ -- create barrier nodes++ nThreads = size sfx+ barrierRecord = (\n -> PortName (PN {portName = pack $ show n})) <$> [1..nThreads]+ barrierNode = DotNode {+ nodeID = "barrier"+ , nodeAttributes =+ [Shape Record,FixedSize SetNodeSize,Width 4.0,+ Height 0.0,+ Label (RecordLabel barrierRecord)]+ }++ -- create preffix++ prefixWithResp = zip [1..] $ byTwoUnsafe "prefix" pref+ prefixNodes = toDotNode "prefix" <$> prefixWithResp+ prefixEdges = connectNodes prefixNodes++ -- create suffixes++ nodesAndEdges = flip Prelude.map (toList sfx) $ \(pid, str) ->+ let p = unPid pid+ s = zip [1..] $ byTwoUnsafe (show p) str+ n = toDotNode (show p) <$> s+ e = connectNodes n+ in (p, n, e)+ nodes = concatMap (\(_,n,_) -> n) nodesAndEdges+ edges = concatMap (\(_,_,e) -> e) nodesAndEdges+ firstOfEachPid = (\(p, n, _) -> (p, fmap fst $ uncons n)) <$> nodesAndEdges++ -- create barrier edges++ edgesFromBarrier = concat $ (\(p, mn) -> case mn of+ Nothing -> []+ Just n -> [DotEdge {+ fromNode = nodeID barrierNode+ , toNode = nodeID n+ , edgeAttributes = [TailPort (LabelledPort (PN {portName = pack $ show p}) Nothing)]+ }]) <$> firstOfEachPid+ prefixToBarrier = case prefixNodes of+ [] -> []+ _ -> [DotEdge {+ fromNode = nodeID (last prefixNodes)+ , toNode = nodeID barrierNode+ , edgeAttributes = [] -- [HeadPort (LabelledPort (PN {portName = "1"}) Nothing)]]+ }]++ -- create dot graph++ dotStmts = DotStmts {+ attrStmts = [NodeAttrs {attrs = [Shape BoxShape,Width 4.0]}]+ , subGraphs = [] -- do we want to put commands with same pid on the same group?+ , nodeStmts = barrierNode : (prefixNodes ++ nodes)+ , edgeStmts = prefixToBarrier ++ prefixEdges ++ edges ++ edgesFromBarrier+ }++ dg = DotGraph {+ strictGraph = False+ , directedGraph = True+ , graphID = Just (Str $ pack "G")+ , graphStatements = dotStmts+ }++ err <- try $ try $ runGraphviz dg graphvizOutput filePath+ case err of+ Left (e :: GraphvizException) ->+ putStrLn $ displayException e+ Right (Left (e :: IOException)) ->+ putStrLn $ displayException e+ Right (Right _) ->+ return ()++toDotNode :: String -> (Int, (String,String)) -> DotNode String+toDotNode nodeIdGroup (n, (invocation, resp)) =+ DotNode {+ nodeID = (nodeIdGroup ++ "-" ++ show n)+ , nodeAttributes = [Label $ StrLabel $ pack $+ (newLinesAfter "\\l" 60 invocation)+ ++ "\\n"+ ++ (newLinesAfter "\\r" 60 resp)]+ }++byTwoUnsafe :: String -> [a] -> [(a,a)]+byTwoUnsafe str ls = fromMaybe (error $ "couldn't split " ++ if null str then " " else str ++ " in pairs") $ byTwo ls++byTwo :: [a] -> Maybe [(a,a)]+byTwo = go []+ where+ go acc [] = Just $ reverse acc+ go _acc [_] = Nothing+ go acc (a: b : rest) = go ((a,b) : acc) rest++connectNodes :: [DotNode a] -> [DotEdge a]+connectNodes = go []+ where+ go acc [] = reverse acc+ go acc [_] = reverse acc+ go acc (a:b:rest) = go (DotEdge (nodeID a) (nodeID b) [] : acc) (b:rest)++newLinesAfter :: String -> Int -> String -> String+newLinesAfter esc n str = concatMap (++ esc) (chunksOf n str)
+ src/Test/StateMachine/Labelling.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Test.StateMachine.Labelling+-- Copyright : (C) 2019, Edsko de Vries+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- This module exports helpers that are useful for labelling properties.+--+-----------------------------------------------------------------------------++module Test.StateMachine.Labelling+ ( Predicate(..)+ , predicate+ , maximum+ , classify+ , Event(..)+ , execCmds+ , execHistory+ )+ where++import Data.Either+ (partitionEithers)+import Data.Kind+ (Type)+import Data.Maybe+ (mapMaybe)+import Prelude hiding+ (maximum)++import Test.StateMachine.Types+ (Command(..), Commands(..), Concrete, History,+ Operation(..), StateMachine(..), Symbolic,+ makeOperations, unHistory)++------------------------------------------------------------------------++data Predicate a b = Predicate {+ -- | Given an @a@, either successfully classify as @b@ or continue looking+ predApply :: a -> Either b (Predicate a b)++ -- | End of the string+ --+ -- The predicate is given a final chance to return a value.+ , predFinish :: Maybe b+ }++instance Functor (Predicate a) where+ fmap f Predicate{..} = Predicate {+ predApply = either (Left . f) (Right . fmap f) . predApply+ , predFinish = f <$> predFinish+ }++-- | Construct simply predicate that returns 'Nothing' on termination+predicate :: (a -> Either b (Predicate a b)) -> Predicate a b+predicate f = Predicate f Nothing++-- | Maximum value found, if any+maximum :: forall a b. Ord b => (a -> Maybe b) -> Predicate a b+maximum f = go Nothing+ where+ go :: Maybe b -> Predicate a b+ go maxSoFar = Predicate {+ predApply = Right . go . upd maxSoFar . f+ , predFinish = maxSoFar+ }++ upd :: Maybe b -> Maybe b -> Maybe b+ upd Nothing mb = mb+ upd (Just maxSoFar) Nothing = Just maxSoFar+ upd (Just maxSoFar) (Just b) = Just (max maxSoFar b)++-- | Do a linear scan over the list, returning all successful classifications+classify :: forall a b. [Predicate a b] -> [a] -> [b]+classify = go []+ where+ go :: [b] -> [Predicate a b] -> [a] -> [b]+ go acc ps [] = acc ++ bs+ where+ bs = mapMaybe predFinish ps+ go acc ps (a : as) = go (acc ++ bs) ps' as+ where+ (bs, ps') = partitionEithers $ map (`predApply` a) ps++------------------------------------------------------------------------++data Event model cmd resp (r :: Type -> Type) = Event+ { eventBefore :: model r+ , eventCmd :: cmd r+ , eventAfter :: model r+ , eventResp :: resp r+ }+ deriving stock Show++-- | Step the model using a 'Command' (i.e., a command associated with an+-- explicit set of variables).+execCmd :: StateMachine model cmd m resp+ -> model Symbolic -> Command cmd resp -> Event model cmd resp Symbolic+execCmd StateMachine { transition } model (Command cmd resp _vars) =+ Event+ { eventBefore = model+ , eventCmd = cmd+ , eventAfter = transition model cmd resp+ , eventResp = resp+ }++-- | 'execCmds' is just the repeated form of 'execCmd'.+execCmds :: forall model cmd m resp. StateMachine model cmd m resp+ -> Commands cmd resp -> [Event model cmd resp Symbolic]+execCmds sm@StateMachine { initModel } = go initModel . unCommands+ where+ go :: model Symbolic -> [Command cmd resp] -> [Event model cmd resp Symbolic]+ go _ [] = []+ go m (c : cs) = let ev = execCmd sm m c in ev : go (eventAfter ev) cs++execOp :: StateMachine model cmd m resp -> model Concrete -> Operation cmd resp+ -> Maybe (Event model cmd resp Concrete)+execOp _sm _model (Crash _cmd _err _pid) = Nothing+execOp StateMachine { transition } model (Operation cmd resp _pid) = Just $+ Event+ { eventBefore = model+ , eventCmd = cmd+ , eventAfter = transition model cmd resp+ , eventResp = resp+ }++execHistory :: forall model cmd m resp. StateMachine model cmd m resp+ -> History cmd resp -> [Event model cmd resp Concrete]+execHistory sm@StateMachine { initModel } = go initModel . makeOperations . unHistory+ where+ go :: model Concrete -> [Operation cmd resp] -> [Event model cmd resp Concrete]+ go _ [] = []+ go m (o : os) = let mev = execOp sm m o in+ case (mev, os) of+ (Nothing, []) -> []+ (Nothing, _) -> error "execHistory: impossible, there are no more ops after a crash."+ (Just ev, _) -> ev : go (eventAfter ev) os
+ src/Test/StateMachine/Lockstep/Auxiliary.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.StateMachine.Lockstep.Auxiliary (+ Elem(..)+ , npAt+ , NTraversable(..)+ , ntraverse+ , ncfmap+ , nfmap+ , ncfoldMap+ , nfoldMap+ ) where++import Control.Monad.State+import Data.Kind+ (Type)+import Prelude+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid+ (Monoid)+#endif+import Data.Proxy+import Data.SOP++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++-- TODO: Could simulate by using @NS xs (K ())@+data Elem (xs :: [k]) (a :: k) where+ ElemHead :: Elem (k ': ks) k+ ElemTail :: Elem ks k -> Elem (k' ': ks) k++npAt' :: Elem xs a -> NP f xs -> f a+npAt' ElemHead (f :* _) = f+npAt' (ElemTail ix) (_ :* fs) = npAt' ix fs++npAt :: NP f xs -> Elem xs a -> f a+npAt = flip npAt'++-- | N-ary traversable functors+--+-- TODO: Don't provide Elem explicitly (just instantiate @c@)?+-- TODO: Introduce HTraverse into SOP?+class NTraversable (f :: (k -> Type) -> [k] -> Type) where+ nctraverse :: (Applicative m, All c xs)+ => proxy c+ -> (forall a. c a => Elem xs a -> g a -> m (h a))+ -> f g xs -> m (f h xs)++ntraverse :: (NTraversable f, Applicative m, SListI xs)+ => (forall a. Elem xs a -> g a -> m (h a))+ -> f g xs -> m (f h xs)+ntraverse = nctraverse (Proxy @Top)++ncfmap :: (NTraversable f, All c xs)+ => proxy c+ -> (forall a. c a => Elem xs a -> g a -> h a)+ -> f g xs -> f h xs+ncfmap p f xs = unI $ nctraverse p (\ix -> I . f ix) xs++nfmap :: (NTraversable f, SListI xs)+ => (forall a. Elem xs a -> g a -> h a)+ -> f g xs -> f h xs+nfmap f xs = ncfmap (Proxy @Top) f xs++ncfoldMap :: forall proxy f g m c xs.+ (NTraversable f, Monoid m, All c xs)+ => proxy c+ -> (forall a. c a => Elem xs a -> g a -> m)+ -> f g xs -> m+ncfoldMap p f = \xs -> execState (aux xs) mempty+ where+ aux :: f g xs -> State m (f g xs)+ aux xs = nctraverse p aux' xs++ aux' :: c a => Elem xs a -> g a -> State m (g a)+ aux' ix ga = modify (f ix ga `mappend`) >> return ga++nfoldMap :: (NTraversable f, Monoid m, SListI xs)+ => (forall a. Elem xs a -> g a -> m)+ -> f g xs -> m+nfoldMap f xs = ncfoldMap (Proxy @Top) f xs
+ src/Test/StateMachine/Lockstep/NAry.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.StateMachine.Lockstep.NAry (+ -- * Test type-level parameters+ MockState+ , Cmd+ , Resp+ , RealHandles+ , MockHandle+ , RealMonad+ , Test+ -- * Test term-level parameters+ , StateMachineTest(..)+ -- * Handle instantiation+ , At(..)+ , (:@)+ -- * Model state+ , Model(..)+ , Refs(..)+ , Refss(..)+ , FlipRef(..)+ -- * Running the tests+ , prop_sequential+ , prop_parallel+ ) where++import Data.Functor.Classes+import Data.Kind+ (Type)+import Data.Maybe+ (fromJust)+import Data.Semigroup hiding+ (All)+import Data.SOP+import Data.Typeable+import GHC.Generics+ (Generic)+import Prelude+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.StateMachine++import qualified Data.Monoid as M+import qualified Data.TreeDiff as TD+import qualified Test.StateMachine.Types as QSM+import qualified Test.StateMachine.Types.Rank2 as Rank2++import Test.StateMachine.Lockstep.Auxiliary++{-------------------------------------------------------------------------------+ Test type-level parameters+-------------------------------------------------------------------------------}++type family MockState t :: Type+data family Cmd t :: (Type -> Type) -> [Type] -> Type+data family Resp t :: (Type -> Type) -> [Type] -> Type+type family RealHandles t :: [Type]+data family MockHandle t a :: Type+type family RealMonad t :: Type -> Type++{-------------------------------------------------------------------------------+ Reference environments+-------------------------------------------------------------------------------}++-- | Relation between real and mock references for single handle type @a@+newtype Refs t r a = Refs { unRefs :: [(Reference a r, MockHandle t a)] }+ deriving newtype (Semigroup, Monoid, Generic)++deriving+ stock+ instance (Show1 r, Show a, Show (MockHandle t a)) => Show (Refs t r a)++deriving+ newtype+ instance (ToExpr a, ToExpr (MockHandle t a)) => ToExpr (Refs t Concrete a)++-- | Relation between real and mock references for /all/ handle types+newtype Refss t r = Refss { unRefss :: NP (Refs t r) (RealHandles t) }++instance ( Show1 r+ , All (And Show (Compose Show (MockHandle t))) (RealHandles t)+ ) => Show (Refss t r) where+ show = unlines+ . hcollapse+ . hcmap (Proxy @(And Show (Compose Show (MockHandle t)))) showOne+ . unRefss+ where+ showOne :: (Show a, Show (MockHandle t a))+ => Refs t r a -> K String a+ showOne = K . show++instance All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)+ => ToExpr (Refss t Concrete) where+ toExpr = TD.Lst+ . hcollapse+ . hcmap (Proxy @(And ToExpr (Compose ToExpr (MockHandle t)))) toExprOne+ . unRefss+ where+ toExprOne :: (ToExpr a, ToExpr (MockHandle t a))+ => Refs t Concrete a -> K (TD.Expr) a+ toExprOne = K . toExpr++instance SListI (RealHandles t) => Semigroup (Refss t r) where+ Refss rss <> Refss rss' = Refss $ hzipWith (<>) rss rss'++instance SListI (RealHandles t) => Monoid (Refss t r) where+ mempty = Refss $ hpure (Refs mempty)++{-------------------------------------------------------------------------------+ Default instantiation to handles+-------------------------------------------------------------------------------}++type family Test (f :: (Type -> Type) -> [Type] -> Type) :: Type where+ Test (Cmd t) = t+ Test (Resp t) = t++newtype FlipRef r h = FlipRef { unFlipRef :: Reference h r }+ deriving stock (Show)++-- @f@ will be instantiated with @Cmd@ or @Resp@+-- @r@ will be instantiated with 'Symbolic' or 'Concrete'+newtype At f r = At { unAt :: f (FlipRef r) (RealHandles (Test f)) }+type f :@ r = At f r++deriving+ stock+ instance (Show (f (FlipRef r) (RealHandles (Test f)))) => Show (At f r)++{-------------------------------------------------------------------------------+ Model+-------------------------------------------------------------------------------}++data Model t r = Model {+ modelState :: MockState t+ , modelRefss :: Refss t r+ }+ deriving stock (Generic)++deriving stock instance ( Show1 r+ , Show (MockState t)+ , All (And Show (Compose Show (MockHandle t))) (RealHandles t)+ ) => Show (Model t r)++instance ( ToExpr (MockState t)+ , All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)+ ) => ToExpr (Model t Concrete)++initModel :: StateMachineTest t -> Model t r+initModel StateMachineTest{..} = Model initMock (Refss (hpure (Refs [])))++{-------------------------------------------------------------------------------+ High level API+-------------------------------------------------------------------------------}++data StateMachineTest t =+ ( Monad (RealMonad t)+ -- Requirements on the handles+ , All Typeable (RealHandles t)+ , All Eq (RealHandles t)+ , All (And Show (Compose Show (MockHandle t))) (RealHandles t)+ , All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)+ -- Response+ , NTraversable (Resp t)+ , Eq (Resp t (MockHandle t) (RealHandles t))+ , Show (Resp t (MockHandle t) (RealHandles t))+ , Show (Resp t (FlipRef Symbolic) (RealHandles t))+ , Show (Resp t (FlipRef Concrete) (RealHandles t))+ -- Command+ , NTraversable (Cmd t)+ , Show (Cmd t (FlipRef Symbolic) (RealHandles t))+ , Show (Cmd t (FlipRef Concrete) (RealHandles t))+ -- MockState+ , Show (MockState t)+ , ToExpr (MockState t)+ ) => StateMachineTest {+ runMock :: Cmd t (MockHandle t) (RealHandles t) -> MockState t -> (Resp t (MockHandle t) (RealHandles t), MockState t)+ , runReal :: Cmd t I (RealHandles t) -> RealMonad t (Resp t I (RealHandles t))+ , initMock :: MockState t+ , newHandles :: forall f. Resp t f (RealHandles t) -> NP ([] :.: f) (RealHandles t)+ , generator :: Model t Symbolic -> Maybe (Gen (Cmd t :@ Symbolic))+ , shrinker :: Model t Symbolic -> Cmd t :@ Symbolic -> [Cmd t :@ Symbolic]+ , cleanup :: Model t Concrete -> RealMonad t ()+ }++semantics :: StateMachineTest t+ -> Cmd t :@ Concrete+ -> RealMonad t (Resp t :@ Concrete)+semantics StateMachineTest{..} (At c) =+ (At . ncfmap (Proxy @Typeable) (const wrapConcrete)) <$>+ runReal (nfmap (const unwrapConcrete) c)++unwrapConcrete :: FlipRef Concrete a -> I a+unwrapConcrete = I . concrete . unFlipRef++wrapConcrete :: Typeable a => I a -> FlipRef Concrete a+wrapConcrete = FlipRef . reference . unI++-- | Turn @Cmd@ or @Resp@ in terms of (symbolic or concrete) references to+-- real handles into a command in terms of mock handles.+--+-- This is isomorphic to+--+-- > toMock :: Refss t Symbolic+-- -> Cmd (FlipRef r) (Handles t)+-- -> Cmd ToMock (Handles t)+toMockHandles :: (NTraversable f, t ~ Test f, All Eq (RealHandles t), Eq1 r)+ => Refss t r -> f :@ r -> f (MockHandle t) (RealHandles t)+toMockHandles rss (At fr) =+ ncfmap (Proxy @Eq) (\pf -> find (unRefss rss) pf . unFlipRef) fr+ where+ find :: (Eq a, Eq1 r)+ => NP (Refs t r) (RealHandles t)+ -> Elem (RealHandles t) a+ -> Reference a r -> MockHandle t a+ find refss ix r = unRefs (npAt refss ix) ! r++step :: Eq1 r+ => StateMachineTest t+ -> Model t r+ -> Cmd t :@ r+ -> (Resp t (MockHandle t) (RealHandles t), MockState t)+step StateMachineTest{..} (Model st rss) cmd =+ runMock (toMockHandles rss cmd) st++data Event t r = Event {+ before :: Model t r+ , cmd :: Cmd t :@ r+ , after :: Model t r+ , mockResp :: Resp t (MockHandle t) (RealHandles t)+ }++lockstep :: forall t r. Eq1 r+ => StateMachineTest t+ -> Model t r+ -> Cmd t :@ r+ -> Resp t :@ r+ -> Event t r+lockstep sm@StateMachineTest{..} m@(Model _ rss) c (At resp) = Event {+ before = m+ , cmd = c+ , after = Model st' (rss <> rss')+ , mockResp = resp'+ }+ where+ (resp', st') = step sm m c++ rss' :: Refss t r+ rss' = zipHandles (newHandles resp) (newHandles resp')++transition :: Eq1 r+ => StateMachineTest t+ -> Model t r+ -> Cmd t :@ r+ -> Resp t :@ r+ -> Model t r+transition sm m c = after . lockstep sm m c++postcondition :: StateMachineTest t+ -> Model t Concrete+ -> Cmd t :@ Concrete+ -> Resp t :@ Concrete+ -> Logic+postcondition sm@StateMachineTest{} m c r =+ toMockHandles (modelRefss $ after e) r .== mockResp e+ where+ e = lockstep sm m c r++symbolicResp :: StateMachineTest t+ -> Model t Symbolic+ -> Cmd t :@ Symbolic+ -> GenSym (Resp t :@ Symbolic)+symbolicResp sm@StateMachineTest{} m c =+ At <$> nctraverse (Proxy @Typeable) (\_ _ -> FlipRef <$> genSym) resp+ where+ (resp, _mock') = step sm m c++precondition :: forall t. (NTraversable (Cmd t), All Eq (RealHandles t))+ => Model t Symbolic+ -> Cmd t :@ Symbolic+ -> Logic+precondition (Model _ (Refss hs)) (At c) =+ Boolean (M.getAll $ nfoldMap check c) .// "No undefined handles"+ where+ check :: Elem (RealHandles t) a -> FlipRef Symbolic a -> M.All+ check ix (FlipRef a) = M.All $ any (sameRef a) $ map fst (unRefs (hs `npAt` ix))++ -- TODO: Patch QSM+ sameRef :: Reference a Symbolic -> Reference a Symbolic -> Bool+ sameRef (QSM.Reference (QSM.Symbolic v)) (QSM.Reference (QSM.Symbolic v')) = v == v'++toStateMachine :: StateMachineTest t+ -> StateMachine (Model t) (At (Cmd t)) (RealMonad t) (At (Resp t))+toStateMachine sm@StateMachineTest{} = StateMachine {+ initModel = initModel sm+ , transition = transition sm+ , precondition = precondition+ , postcondition = postcondition sm+ , generator = generator sm+ , shrinker = shrinker sm+ , semantics = semantics sm+ , mock = symbolicResp sm+ , cleanup = cleanup sm+ , invariant = Nothing+ }++prop_sequential :: RealMonad t ~ IO+ => StateMachineTest t+ -> Maybe Int -- ^ (Optional) minimum number of commands+ -> Property+prop_sequential sm@StateMachineTest{} mMinSize =+ forAllCommands sm' mMinSize $ \cmds ->+ monadicIO $ do+ (hist, _model, res) <- runCommands sm' cmds+ prettyCommands sm' hist+ $ res === Ok+ where+ sm' = toStateMachine sm++prop_parallel :: RealMonad t ~ IO+ => StateMachineTest t+ -> Maybe Int -- ^ (Optional) minimum number of commands+ -> Property+prop_parallel sm@StateMachineTest{} mMinSize =+ forAllParallelCommands sm' mMinSize $ \cmds ->+ monadicIO $+ prettyParallelCommands cmds+ =<< runParallelCommands sm' cmds+ where+ sm' = toStateMachine sm++{-------------------------------------------------------------------------------+ Rank2 instances+-------------------------------------------------------------------------------}++instance (NTraversable (Cmd t), SListI (RealHandles t))+ => Rank2.Functor (At (Cmd t)) where+ fmap :: forall p q. (forall a. p a -> q a) -> At (Cmd t) p -> At (Cmd t) q+ fmap f (At cmd) = At $ nfmap (const f') cmd+ where+ f' :: FlipRef p a -> FlipRef q a+ f' = FlipRef . Rank2.fmap f . unFlipRef++instance (NTraversable (Cmd t), SListI (RealHandles t))+ => Rank2.Foldable (At (Cmd t)) where+ foldMap :: forall p m. Monoid m => (forall a. p a -> m) -> At (Cmd t) p -> m+ foldMap f (At cmd) = nfoldMap (const f') cmd+ where+ f' :: FlipRef p a -> m+ f' = Rank2.foldMap f . unFlipRef++instance (NTraversable (Cmd t), SListI (RealHandles t))+ => Rank2.Traversable (At (Cmd t)) where+ traverse :: forall f p q. Applicative f+ => (forall a. p a -> f (q a)) -> At (Cmd t) p -> f (At (Cmd t) q)+ traverse f (At cmd) = At <$> ntraverse (const f') cmd+ where+ f' :: FlipRef p a -> f (FlipRef q a)+ f' = fmap FlipRef . Rank2.traverse f . unFlipRef++instance (NTraversable (Resp t), SListI (RealHandles t))+ => Rank2.Functor (At (Resp t)) where+ fmap :: forall p q. (forall a. p a -> q a) -> At (Resp t) p -> At (Resp t) q+ fmap f (At cmd) = At $ nfmap (const f') cmd+ where+ f' :: FlipRef p a -> FlipRef q a+ f' = FlipRef . Rank2.fmap f . unFlipRef++instance (NTraversable (Resp t), SListI (RealHandles t))+ => Rank2.Foldable (At (Resp t)) where+ foldMap :: forall p m. Monoid m => (forall a. p a -> m) -> At (Resp t) p -> m+ foldMap f (At cmd) = nfoldMap (const f') cmd+ where+ f' :: FlipRef p a -> m+ f' = Rank2.foldMap f . unFlipRef++instance (NTraversable (Resp t), SListI (RealHandles t))+ => Rank2.Traversable (At (Resp t)) where+ traverse :: forall f p q. Applicative f+ => (forall a. p a -> f (q a)) -> At (Resp t) p -> f (At (Resp t) q)+ traverse f (At cmd) = At <$> ntraverse (const f') cmd+ where+ f' :: FlipRef p a -> f (FlipRef q a)+ f' = fmap FlipRef . Rank2.traverse f . unFlipRef++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++(!) :: Eq k => [(k, a)] -> k -> a+env ! r = fromJust (lookup r env)++zipHandles :: SListI (RealHandles t)+ => NP ([] :.: FlipRef r) (RealHandles t)+ -> NP ([] :.: MockHandle t) (RealHandles t)+ -> Refss t r+zipHandles = \real mock -> Refss $ hzipWith zip' real mock+ where+ zip' :: (:.:) [] (FlipRef r) a -> (:.:) [] (MockHandle t) a -> Refs t r a+ zip' (Comp real) (Comp mock) = Refs $ zip (map unFlipRef real) mock
+ src/Test/StateMachine/Lockstep/Simple.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Test.StateMachine.Lockstep.Simple (+ -- * Test type-level parameters+ MockState+ , Cmd+ , Resp+ , RealHandle+ , MockHandle+ , Test+ -- * Test term-level parameters+ , StateMachineTest(..)+ -- * Handle instantiation+ , At(..)+ , (:@)+ -- * Model state+ , Model(..)+ -- * Running the tests+ , prop_sequential+ , prop_parallel+ -- * Translate to n-ary model model+ , fromSimple+ ) where++import Data.Bifunctor+import Data.Functor.Classes+import Data.Kind+ (Type)+import Data.SOP+import Data.Typeable+import Prelude+import Test.QuickCheck+import Test.StateMachine+import Test.StateMachine.Lockstep.Auxiliary+import Test.StateMachine.Lockstep.NAry+ (MockState)++import qualified Test.StateMachine.Lockstep.NAry as NAry++{-------------------------------------------------------------------------------+ Top-level parameters+-------------------------------------------------------------------------------}++data family Cmd t :: Type -> Type+data family Resp t :: Type -> Type+data family RealHandle t :: Type+data family MockHandle t :: Type++{-------------------------------------------------------------------------------+ Default handle instantiation+-------------------------------------------------------------------------------}++type family Test (f :: Type -> Type) :: Type where+ Test (Cmd t) = t+ Test (Resp t) = t++-- @f@ will be instantiated with @Cmd@ or @Resp@+-- @r@ will be instantiated with 'Symbolic' or 'Concrete'+newtype At f r = At { unAt :: f (Reference (RealHandle (Test f)) r) }+type f :@ r = At f r++{-------------------------------------------------------------------------------+ Simplified model+-------------------------------------------------------------------------------}++data Model t r = Model {+ modelState :: MockState t+ , modelRefs :: [(Reference (RealHandle t) r, MockHandle t)]+ }++modelToSimple :: NAry.Model (Simple t) r -> Model t r+modelToSimple NAry.Model{modelRefss = NAry.Refss (NAry.Refs rs :* Nil), ..} = Model {+ modelState = modelState+ , modelRefs = map (second unSimpleToMock) rs+ }++{-------------------------------------------------------------------------------+ Wrap and unwrap+-------------------------------------------------------------------------------}++cmdAtFromSimple :: Functor (Cmd t)+ => Cmd t :@ Symbolic -> NAry.Cmd (Simple t) NAry.:@ Symbolic+cmdAtFromSimple = NAry.At . SimpleCmd . fmap NAry.FlipRef . unAt++cmdAtToSimple :: Functor (Cmd t)+ => NAry.Cmd (Simple t) NAry.:@ Symbolic -> Cmd t :@ Symbolic+cmdAtToSimple = At . fmap (NAry.unFlipRef) . unSimpleCmd . NAry.unAt++cmdMockToSimple :: Functor (Cmd t)+ => NAry.Cmd (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]+ -> Cmd t (MockHandle t)+cmdMockToSimple = fmap unSimpleToMock . unSimpleCmd++cmdRealToSimple :: Functor (Cmd t)+ => NAry.Cmd (Simple t) I '[RealHandle t]+ -> Cmd t (RealHandle t)+cmdRealToSimple = fmap unI . unSimpleCmd++respMockFromSimple :: Functor (Resp t)+ => Resp t (MockHandle t)+ -> NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]+respMockFromSimple = SimpleResp . fmap SimpleToMock++respRealFromSimple :: Functor (Resp t)+ => Resp t (RealHandle t)+ -> NAry.Resp (Simple t) I '[RealHandle t]+respRealFromSimple = SimpleResp . fmap I++{-------------------------------------------------------------------------------+ User defined values+-------------------------------------------------------------------------------}++data StateMachineTest t =+ ( Typeable t+ -- Response+ , Eq (Resp t (MockHandle t))+ , Show (Resp t (Reference (RealHandle t) Symbolic))+ , Show (Resp t (Reference (RealHandle t) Concrete))+ , Show (Resp t (MockHandle t))+ , Traversable (Resp t)+ -- Command+ , Show (Cmd t (Reference (RealHandle t) Symbolic))+ , Show (Cmd t (Reference (RealHandle t) Concrete))+ , Traversable (Cmd t)+ -- Real handles+ , Eq (RealHandle t)+ , Show (RealHandle t)+ , ToExpr (RealHandle t)+ -- Mock handles+ , Eq (MockHandle t)+ , Show (MockHandle t)+ , ToExpr (MockHandle t)+ -- Mock state+ , Show (MockState t)+ , ToExpr (MockState t)+ ) => StateMachineTest {+ runMock :: Cmd t (MockHandle t) -> MockState t -> (Resp t (MockHandle t), MockState t)+ , runReal :: Cmd t (RealHandle t) -> IO (Resp t (RealHandle t))+ , initMock :: MockState t+ , newHandles :: forall h. Resp t h -> [h]+ , generator :: Model t Symbolic -> Maybe (Gen (Cmd t :@ Symbolic))+ , shrinker :: Model t Symbolic -> Cmd t :@ Symbolic -> [Cmd t :@ Symbolic]+ , cleanup :: Model t Concrete -> IO ()+ }++data Simple t++type instance NAry.MockState (Simple t) = MockState t+type instance NAry.RealHandles (Simple t) = '[RealHandle t]+type instance NAry.RealMonad (Simple _) = IO++data instance NAry.Cmd (Simple _) _f _hs where+ SimpleCmd :: Cmd t (f h) -> NAry.Cmd (Simple t) f '[h]++data instance NAry.Resp (Simple _) _f _hs where+ SimpleResp :: Resp t (f h) -> NAry.Resp (Simple t) f '[h]++newtype instance NAry.MockHandle (Simple t) (RealHandle t) =+ SimpleToMock { unSimpleToMock :: MockHandle t }++unSimpleCmd :: NAry.Cmd (Simple t) f '[h] -> Cmd t (f h)+unSimpleCmd (SimpleCmd cmd) = cmd++unSimpleResp :: NAry.Resp (Simple t) f '[h] -> Resp t (f h)+unSimpleResp (SimpleResp resp) = resp++instance ( Functor (Resp t)+ , Eq (Resp t (MockHandle t))+ , Eq (MockHandle t)+ ) => Eq (NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]) where+ SimpleResp r == SimpleResp r' = (unSimpleToMock <$> r) == (unSimpleToMock <$> r')++instance ( Functor (Resp t)+ , Show (Resp t (MockHandle t))+ ) => Show (NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]) where+ show (SimpleResp r) = show (unSimpleToMock <$> r)++instance ( Functor (Resp t)+ , Show (Resp t (Reference (RealHandle t) r))+ , Show1 r+ ) => Show (NAry.Resp (Simple t) (NAry.FlipRef r) '[RealHandle t]) where+ show (SimpleResp r) = show (NAry.unFlipRef <$> r)++instance ( Functor (Cmd t)+ , Show (Cmd t (Reference (RealHandle t) r))+ , Show1 r+ ) => Show (NAry.Cmd (Simple t) (NAry.FlipRef r) '[RealHandle t]) where+ show (SimpleCmd r) = show (NAry.unFlipRef <$> r)++deriving stock instance Eq (MockHandle t) => Eq (NAry.MockHandle (Simple t) (RealHandle t))+deriving stock instance Show (MockHandle t) => Show (NAry.MockHandle (Simple t) (RealHandle t))++instance Traversable (Resp t) => NTraversable (NAry.Resp (Simple t)) where+ nctraverse _ f (SimpleResp x) = SimpleResp <$> traverse (f ElemHead) x++instance Traversable (Cmd t) => NTraversable (NAry.Cmd (Simple t)) where+ nctraverse _ f (SimpleCmd x) = SimpleCmd <$> traverse (f ElemHead) x++instance ToExpr (MockHandle t)+ => ToExpr (NAry.MockHandle (Simple t) (RealHandle t)) where+ toExpr (SimpleToMock h) = toExpr h++fromSimple :: StateMachineTest t -> NAry.StateMachineTest (Simple t)+fromSimple StateMachineTest{..} = NAry.StateMachineTest {+ runMock = \cmd st -> first respMockFromSimple (runMock (cmdMockToSimple cmd) st)+ , runReal = \cmd -> respRealFromSimple <$> (runReal (cmdRealToSimple cmd))+ , initMock = initMock+ , newHandles = \r -> Comp (newHandles (unSimpleResp r)) :* Nil+ , generator = \m -> fmap cmdAtFromSimple <$> generator (modelToSimple m)+ , shrinker = \m cmd -> cmdAtFromSimple <$> shrinker (modelToSimple m) (cmdAtToSimple cmd)+ , cleanup = cleanup . modelToSimple+ }++{-------------------------------------------------------------------------------+ Running the tests+-------------------------------------------------------------------------------}++prop_sequential :: StateMachineTest t+ -> Maybe Int -- ^ (Optional) minimum number of commands+ -> Property+prop_sequential = NAry.prop_sequential . fromSimple++prop_parallel :: StateMachineTest t+ -> Maybe Int -- ^ (Optional) minimum number of commands+ -> Property+prop_parallel = NAry.prop_parallel . fromSimple
src/Test/StateMachine/Logic.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} @@ -7,7 +8,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -18,22 +19,23 @@ module Test.StateMachine.Logic ( Logic(..)- , Predicate(..)+ , LogicPredicate(..) , dual , strongNeg , Counterexample(..) , Value(..) , boolean , logic- , predicate+ , evalLogicPredicate+ , gatherAnnotations , (.==) , (./=) , (.<) , (.<=) , (.>) , (.>=)- , elem- , notElem+ , member+ , notMember , (.//) , (.&&) , (.||)@@ -43,9 +45,7 @@ ) where -import Prelude hiding- (elem, notElem)-import qualified Prelude+import Prelude ------------------------------------------------------------------------ @@ -56,49 +56,49 @@ | Logic :|| Logic | Logic :=> Logic | Not Logic- | Predicate Predicate+ | LogicPredicate LogicPredicate | forall a. Show a => Forall [a] (a -> Logic) | forall a. Show a => Exists [a] (a -> Logic) | Boolean Bool | Annotate String Logic -data Predicate+data LogicPredicate = forall a. (Eq a, Show a) => a :== a | forall a. (Eq a, Show a) => a :/= a | forall a. (Ord a, Show a) => a :< a | forall a. (Ord a, Show a) => a :<= a | forall a. (Ord a, Show a) => a :> a | forall a. (Ord a, Show a) => a :>= a- | forall a. (Eq a, Show a) => Elem a [a]- | forall a. (Eq a, Show a) => NotElem a [a]+ | forall t a. (Foldable t, Eq a, Show a, Show (t a)) => Member a (t a)+ | forall t a. (Foldable t, Eq a, Show a, Show (t a)) => NotMember a (t a) -deriving instance Show Predicate+deriving stock instance Show LogicPredicate -dual :: Predicate -> Predicate+dual :: LogicPredicate -> LogicPredicate dual p = case p of- x :== y -> x :/= y- x :/= y -> x :== y- x :< y -> x :>= y- x :<= y -> x :> y- x :> y -> x :<= y- x :>= y -> x :< y- x `Elem` xs -> x `NotElem` xs- x `NotElem` xs -> x `Elem` xs+ x :== y -> x :/= y+ x :/= y -> x :== y+ x :< y -> x :>= y+ x :<= y -> x :> y+ x :> y -> x :<= y+ x :>= y -> x :< y+ x `Member` xs -> x `NotMember` xs+ x `NotMember` xs -> x `Member` xs -- See Yuri Gurevich's "Intuitionistic logic with strong negation" (1977). strongNeg :: Logic -> Logic strongNeg l0 = case l0 of- Bot -> Top- Top -> Bot- l :&& r -> strongNeg l :|| strongNeg r- l :|| r -> strongNeg l :&& strongNeg r- l :=> r -> l :&& strongNeg r- Not l -> l- Predicate p -> Predicate (dual p)- Forall xs p -> Exists xs (strongNeg . p)- Exists xs p -> Forall xs (strongNeg . p)- Boolean b -> Boolean (not b)- Annotate s l -> Annotate s (strongNeg l)+ Bot -> Top+ Top -> Bot+ l :&& r -> strongNeg l :|| strongNeg r+ l :|| r -> strongNeg l :&& strongNeg r+ l :=> r -> l :&& strongNeg r+ Not l -> l+ LogicPredicate p -> LogicPredicate (dual p)+ Forall xs p -> Exists xs (strongNeg . p)+ Exists xs p -> Forall xs (strongNeg . p)+ Boolean b -> Boolean (not b)+ Annotate s l -> Annotate s (strongNeg l) data Counterexample = BotC@@ -107,18 +107,18 @@ | EitherC Counterexample Counterexample | ImpliesC Counterexample | NotC Counterexample- | PredicateC Predicate+ | PredicateC LogicPredicate | forall a. Show a => ForallC a Counterexample | forall a. Show a => ExistsC [a] [Counterexample] | BooleanC | AnnotateC String Counterexample -deriving instance Show Counterexample+deriving stock instance Show Counterexample data Value = VFalse Counterexample | VTrue- deriving Show+ deriving stock Show boolean :: Logic -> Bool boolean l = case logic l of@@ -146,7 +146,7 @@ logic (Not l) = case logic (strongNeg l) of VTrue -> VTrue VFalse ce -> VFalse (NotC ce)-logic (Predicate p) = predicate p+logic (LogicPredicate p) = evalLogicPredicate p logic (Forall xs0 p) = go xs0 where go [] = VTrue@@ -164,21 +164,71 @@ VTrue -> VTrue VFalse ce -> VFalse (AnnotateC s ce) -predicate :: Predicate -> Value-predicate p0 = let b = go p0 in case p0 of- x :== y -> b (x == y)- x :/= y -> b (x /= y)- x :< y -> b (x < y)- x :<= y -> b (x <= y)- x :> y -> b (x > y)- x :>= y -> b (x >= y)- x `Elem` xs -> b (x `Prelude.elem` xs)- x `NotElem` xs -> b (x `Prelude.notElem` xs)+evalLogicPredicate :: LogicPredicate -> Value+evalLogicPredicate p0 = let b = go p0 in case p0 of+ x :== y -> b (x == y)+ x :/= y -> b (x /= y)+ x :< y -> b (x < y)+ x :<= y -> b (x <= y)+ x :> y -> b (x > y)+ x :>= y -> b (x >= y)+ x `Member` xs -> b (x `elem` xs)+ x `NotMember` xs -> b (x `notElem` xs) where- go :: Predicate -> Bool -> Value+ go :: LogicPredicate -> Bool -> Value go _ True = VTrue go p False = VFalse (PredicateC (dual p)) +-- | Gather user annotations of a true logic expression.+--+-- >>> gatherAnnotations (Top .// "top")+-- ["top"]+--+-- >>> gatherAnnotations ((Bot .// "bot") .|| (Top .// "top"))+-- ["top"]+--+-- >>> gatherAnnotations (Top .// "top1" .&& Top .// "top2")+-- ["top1","top2"]+--+-- >>> gatherAnnotations (Bot .// "bot" .&& Top .// "top")+-- []+--+-- >>> gatherAnnotations (forall [1,2,3] (\i -> 0 .< i .// "positive"))+-- ["positive","positive","positive"]+--+-- >>> gatherAnnotations (forall [0,1,2,3] (\i -> 0 .< i .// "positive"))+-- []+--+-- >>> gatherAnnotations (exists [1,2,3] (\i -> 0 .< i .// "positive"))+-- ["positive"]+gatherAnnotations :: Logic -> [String]+gatherAnnotations = go []+ where+ go _acc Bot = []+ go acc Top = acc+ go acc (l :&& r) | boolean l && boolean r = go (go acc l) r+ | otherwise = acc+ go acc (l :|| r) | boolean l = go acc l+ | boolean r = go acc r+ | otherwise = acc+ go acc (l :=> r) | boolean (l :=> r) = go (go acc l) r+ | otherwise = acc+ go acc (Not l) | not (boolean l) = go acc l+ | otherwise = acc+ go acc (LogicPredicate _p) = acc+ go acc (Forall xs p)+ | boolean (Forall xs p) = acc ++ concat [ go [] (p x)+ | x <- xs, boolean (p x)+ ]+ | otherwise = acc+ go acc (Exists xs p)+ | boolean (Exists xs p) = acc ++ concat (take 1 [ go [] (p x)+ | x <- xs, boolean (p x)+ ])+ | otherwise = acc+ go acc (Boolean _b) = acc+ go acc (Annotate s l) = go (acc ++ [s]) l+ ------------------------------------------------------------------------ infix 5 .==@@ -187,36 +237,36 @@ infix 5 .<= infix 5 .> infix 5 .>=-infix 8 `elem`-infix 8 `notElem`+infix 8 `member`+infix 8 `notMember` infixl 4 .// infixr 3 .&& infixr 2 .|| infixr 1 .=> (.==) :: (Eq a, Show a) => a -> a -> Logic-x .== y = Predicate (x :== y)+x .== y = LogicPredicate (x :== y) (./=) :: (Eq a, Show a) => a -> a -> Logic-x ./= y = Predicate (x :/= y)+x ./= y = LogicPredicate (x :/= y) (.<) :: (Ord a, Show a) => a -> a -> Logic-x .< y = Predicate (x :< y)+x .< y = LogicPredicate (x :< y) (.<=) :: (Ord a, Show a) => a -> a -> Logic-x .<= y = Predicate (x :<= y)+x .<= y = LogicPredicate (x :<= y) (.>) :: (Ord a, Show a) => a -> a -> Logic-x .> y = Predicate (x :> y)+x .> y = LogicPredicate (x :> y) (.>=) :: (Ord a, Show a) => a -> a -> Logic-x .>= y = Predicate (x :>= y)+x .>= y = LogicPredicate (x :>= y) -elem :: (Eq a, Show a) => a -> [a] -> Logic-elem x xs = Predicate (Elem x xs)+member :: (Foldable t, Eq a, Show a, Show (t a)) => a -> t a -> Logic+member x xs = LogicPredicate (Member x xs) -notElem :: (Eq a, Show a) => a -> [a] -> Logic-notElem x xs = Predicate (NotElem x xs)+notMember :: (Foldable t, Eq a, Show a, Show (t a)) => a -> t a -> Logic+notMember x xs = LogicPredicate (NotMember x xs) (.//) :: Logic -> String -> Logic l .// s = Annotate s l
+ src/Test/StateMachine/Markov.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------+-- |+-- Module : Test.StateMachine.Markov+-- Copyright : (C) 2019, Stevan Andjelkovic+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- This module contains helper functions for testing using Markov chains.+--+-----------------------------------------------------------------------------++module Test.StateMachine.Markov+ ( Markov+ , makeMarkov+ , toAdjacencyMap+ , (-<)+ , (>-)+ , (/-)+ , markovGenerator+ , coverMarkov+ , tabulateMarkov+ , transitionMatrix+ , stimulusMatrix+ , historyObservations+ , markovToDot+ , markovToPs+ , StatsDb(..)+ , PropertyName+ , nullStatsDb+ , fileStatsDb+ , persistStats+ , computeReliability+ , printReliability+ , quickCheckReliability+ , testChainToDot+ )+ where++import Control.Arrow+ ((&&&))+import Data.Bifunctor+ (bimap)+import Data.Either+ (partitionEithers)+import Data.List+ (genericLength)+import qualified Data.Set as Set+import Data.Map+ (Map)+import qualified Data.Map as Map+import Data.Matrix+ (Matrix, elementwise, fromLists, matrix, ncols,+ nrows, submatrix, toLists, zero, getElem)+import Data.Maybe+ (fromMaybe)+import Generic.Data+ (FiniteEnum, GBounded, GEnum, gfiniteEnumFromTo,+ gmaxBound, gminBound, gtoFiniteEnum, gfromFiniteEnum)+import GHC.Generics+ (Generic, Rep)+import Prelude hiding+ (readFile)+import System.Directory+ (removeFile)+import System.FilePath.Posix+ (replaceExtension)+import System.IO+ (IOMode(ReadWriteMode), hGetContents, openFile)+import System.Process+ (callProcess)+import Test.QuickCheck+ (Gen, Property, Testable, coverTable, frequency,+ property, quickCheck, tabulate)+import Test.QuickCheck.Monadic+ (PropertyM, run)+import Test.QuickCheck.Property+ (Callback(PostTest),+ CallbackKind(NotCounterexample), callback)+import Text.Read+ (readMaybe)++import MarkovChain++import Test.StateMachine.Logic+ (boolean)+import Test.StateMachine.Types+ (Command, Commands, Counter, History, Operation(..),+ StateMachine(..), getCommand, makeOperations,+ newCounter, unCommands, unHistory)+import Test.StateMachine.Types.GenSym+ (runGenSym)+import Test.StateMachine.Types.References+ (Concrete, Symbolic)++------------------------------------------------------------------------++-- | Markov chain.+newtype Markov state cmd_ prob = Markov+ { unMarkov :: Map state [Transition state cmd_ prob] }++data Transition state cmd_ prob = Transition+ { command :: cmd_+ , probability :: prob+ , to :: state+ }++-- | Constructor for 'Markov' chains.+makeMarkov :: Ord state+ => [Map state [Transition state cmd_ prob]] -> Markov state cmd_ prob+makeMarkov = Markov . Map.unions++-- | Expose inner graph structure of markov chain+toAdjacencyMap+ :: Ord state+ => Markov state cmd_ prob+ -> Map state (Map state (cmd_, prob))+toAdjacencyMap (Markov m) =+ fmap (foldr f mempty) m+ where+ f Transition{..} = Map.insert to (command, probability)++infixl 5 -<++-- | Infix operator for starting to creating a transition in the 'Markov' chain,+-- finish the transition with one of '(>-)' or '(/-)' depending on whether the+-- transition has a specific or a uniform probability.+(-<) :: Fractional prob+ => state -> [Either (cmd_, state) ((cmd_, prob), state)]+ -> Map state [Transition state cmd_ prob]+from -< es = Map.singleton from (map go es)+ where+ go (Left (command, to)) = Transition command uniform to+ go (Right ((command, probability), to)) = Transition {..}++ (ls, rs) = partitionEithers es+ uniform = (100 - sum (map snd (map fst rs))) / genericLength ls+ -- ^ Note: If `length ls == 0` then `uniform` is not used, so division by+ -- zero doesn't happen.++infixl 5 >-++-- | Finish making a transition with a specified probability distribution.+(>-) :: (cmd_, prob) -> state -> Either (cmd_, state) ((cmd_, prob), state)+(cmd, prob) >- state = Right ((cmd, prob), state)++infixl 5 /-++-- | Finish making a transition with an uniform probability distribution.+(/-) :: cmd_ -> state -> Either (cmd_, state) ((cmd_, prob), state)+cmd /- state = Left (cmd, state)++------------------------------------------------------------------------++-- | Create a generator from a 'Markov' chain.+markovGenerator :: forall state cmd_ cmd model. (Show state, Show cmd_)+ => (Ord state, Ord cmd_)+ => Markov state cmd_ Double+ -> Map cmd_ (model Symbolic -> Gen (cmd Symbolic))+ -> (model Symbolic -> state)+ -> (state -> Bool)+ -> (model Symbolic -> Maybe (Gen (cmd Symbolic)))+markovGenerator markov gens partition isSink model+ | isSink (partition model) = Nothing+ | otherwise = Just (frequency (go (partition model)))+ where+ go :: state -> [(Int, Gen (cmd Symbolic))]+ go state+ = map (round . probability+ &&& (\cmd_ -> fromMaybe (errMissing cmd_) (Map.lookup cmd_ gens) model) . command)+ . fromMaybe errDeadlock+ . Map.lookup state+ . unMarkov+ $ markov+ where+ errDeadlock = error+ ("markovGenerator: deadlock, no commands can be generated in given state: "+ ++ show state)++ errMissing cmd_ = error+ ("markovGenerator: don't know how to generate the command: "+ ++ show cmd_)++-- | Variant of QuickCheck's 'coverTable' which works on 'Markov' chains.+coverMarkov :: (Show state, Show cmd_, Testable prop)+ => Markov state cmd_ Double -> prop -> Property+coverMarkov markov prop = foldr go (property prop) (Map.toList (unMarkov markov))+ where+ go (from, ts) ih =+ coverTable (show from)+ (map (\Transition{..} -> (toTransitionString command to, probability)) ts) ih++toTransitionString :: (Show state, Show cmd_) => cmd_ -> state -> String+toTransitionString cmd to = "-< " ++ show cmd ++ " >- " ++ show to++-- | Variant of QuickCheck's 'tabulate' which works for 'Markov' chains.+tabulateMarkov :: forall model state cmd cmd_ m resp prop. Testable prop+ => (Show state, Show cmd_)+ => StateMachine model cmd m resp+ -> (model Symbolic -> state)+ -> (cmd Symbolic -> cmd_)+ -> Commands cmd resp+ -> prop+ -> Property+tabulateMarkov sm partition constructor cmds0 =+ tabulateTransitions (commandsToTransitions sm cmds0)+ where+ tabulateTransitions :: [(state, Transition state cmd_ prob)]+ -> prop+ -> Property+ tabulateTransitions ts prop = foldr go (property prop) ts+ where+ go (from, Transition {..}) ih =+ tabulate (show from) [ toTransitionString command to ] ih++ commandsToTransitions :: StateMachine model cmd m resp+ -> Commands cmd resp+ -> [(state, Transition state cmd_ ())]+ commandsToTransitions StateMachine { initModel, transition, mock } =+ go initModel newCounter [] . unCommands+ where+ go :: model Symbolic -> Counter -> [(state, Transition state cmd_ ())]+ -> [Command cmd resp] -> [(state, Transition state cmd_ ())]+ go _model _counter acc [] = acc+ go model counter acc (cmd : cmds) = go model' counter' ((from, t) : acc) cmds+ where+ from = partition model+ cmd' = getCommand cmd+ model' = transition model cmd' resp++ (resp, counter') = runGenSym (mock model cmd') counter++ t = Transition+ { command = constructor cmd'+ , probability = ()+ , to = partition model'+ }++------------------------------------------------------------------------++enumMatrix :: forall e a. (Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e))+ => ((e, e) -> a)+ -> Matrix a+enumMatrix f = matrix dimension dimension (f . bimap g g)+ where+ g :: Int -> e+ g = gtoFiniteEnum . pred -- We need the predecessor because 'matrix' starts+ -- indexing from 1.++ dimension :: Int+ dimension = length es++ es :: [e]+ es = gfiniteEnumFromTo gminBound gmaxBound++transitionMatrix :: forall state cmd_. Ord state+ => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))+ => Markov state cmd_ Double+ -> Matrix Double+transitionMatrix markov = enumMatrix go+ where+ go :: (state, state) -> Double+ go (state, state') = fromMaybe 0+ (Map.lookup state' =<< Map.lookup state availableStates)++ availableStates :: Map state (Map state Double)+ availableStates+ = fmap (Map.fromList . map (to &&& (/ 100) . probability))+ . unMarkov+ $ markov++enumMatrix'+ :: forall state cmd a+ . (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))+ => (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))+ => ((state, cmd) -> a)+ -> Matrix a+enumMatrix' f = matrix m n (f . bimap g h)+ where+ g :: Int -> state+ g = gtoFiniteEnum . pred -- We need the predecessor because 'matrix' starts+ -- indexing from 1.++ h :: Int -> cmd+ h = gtoFiniteEnum . pred++ m :: Int+ m = length states++ n :: Int+ n = length cmds++ states :: [state]+ states = gfiniteEnumFromTo gminBound gmaxBound++ cmds :: [cmd]+ cmds = gfiniteEnumFromTo gminBound gmaxBound++stimulusMatrix+ :: forall state cmd. (Ord state, Ord cmd)+ => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))+ => (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))+ => Markov state cmd Double+ -> Matrix Double+stimulusMatrix markov = enumMatrix' go+ where+ go :: (state, cmd) -> Double+ go (state, cmd) = fromMaybe 0+ (Map.lookup cmd =<< Map.lookup state availableCmds)++ availableCmds :: Map state (Map cmd Double)+ availableCmds+ = fmap (Map.fromList . map (command &&& (/ 100) . probability))+ . unMarkov+ $ markov++------------------------------------------------------------------------++historyObservations :: forall model cmd m resp state cmd_ prob. Ord state+ => Ord cmd_+ => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))+ => StateMachine model cmd m resp+ -> Markov state cmd_ prob+ -> (model Concrete -> state)+ -> (cmd Concrete -> cmd_)+ -> History cmd resp+ -> ( Matrix Double+ , Matrix Double+ )+historyObservations StateMachine { initModel, transition, postcondition } markov partition constructor+ = go initModel Map.empty Map.empty . makeOperations . unHistory+ where+ go _model ss fs [] =+ ( enumMatrix @state (fromMaybe 0 . flip Map.lookup ss)+ , enumMatrix @state (fromMaybe 0 . flip Map.lookup fs)+ )+ go model ss fs (op : ops) = case op of+ Operation cmd resp _pid ->+ let+ state = partition model+ model' = transition model cmd resp+ state' = partition model'+ incr = Map.insertWith (\_new old -> old + 1) (state, state') 1+ in+ if boolean (postcondition model cmd resp)+ then go model' (incr ss) fs ops+ else go model' ss (incr fs) ops++ Crash cmd _err _pid ->+ let+ state = partition model+ state' = fromMaybe err+ (Map.lookup (constructor cmd) =<< Map.lookup state nextState)+ incr = Map.insertWith (\_new old -> old + 1) (state, state') 1+ in+ go model ss (incr fs) ops+ where+ err = error "historyObservations: impossible."++ nextState :: Map state (Map cmd_ state)+ nextState+ = fmap (Map.fromList . map (command &&& to))+ . unMarkov+ $ markov++------------------------------------------------------------------------++markovToDot :: (Show state, Show cmd_, Show prob)+ => state -> state -> Markov state cmd_ prob -> String+markovToDot source sink = go ("digraph g {\n" ++ nodeColours) . Map.toList . unMarkov+ where+ nodeColours :: String+ nodeColours = string (show source) ++ " [color=\"green\"]\n" +++ string (show sink) ++ " [color=\"red\"]\n"++ go acc [] = acc ++ "}"+ go acc ((from, via) : more) = go acc' more+ where+ acc' :: String+ acc' = acc +++ unlines [ string (show from) +++ " -> " +++ string (show to) +++ " [label=" ++ string (show cmd ++ "\\n(" ++ show prob ++ "%)") ++ "]"+ | Transition cmd prob to <- via+ ]++string :: String -> String+string s = "\"" ++ s ++ "\""++markovToPs :: (Show state, Show cmd_, Show prob)+ => state -> state -> Markov state cmd_ prob -> FilePath -> IO ()+markovToPs source sink markov out = do+ let dotFile = replaceExtension out "dot"+ writeFile dotFile (markovToDot source sink markov)+ callProcess "dot" ["-Tps", dotFile, "-o", out]++------------------------------------------------------------------------++data StatsDb m = StatsDb+ { store :: (Matrix Double, Matrix Double) -> m ()+ , load :: m (Maybe (Matrix Double, Matrix Double))+ }++type PropertyName = String++nullStatsDb :: Monad m => StatsDb m+nullStatsDb = StatsDb+ { store = const (return ())+ , load = return Nothing+ }++fileStatsDb :: FilePath -> PropertyName -> StatsDb IO+fileStatsDb fp name = StatsDb+ { store = store+ , load = load+ }+ where+ store :: (Matrix Double, Matrix Double) -> IO ()+ store observed = do+ appendFile (fp ++ "-" ++ name) (show (bimap toLists toLists observed) ++ "\n")++ load :: IO (Maybe (Matrix Double, Matrix Double))+ load = do+ mprior <- parse <$> readFile' (fp ++ "-" ++ name ++ "-cache")+ mnew <- parseMany <$> readFile' (fp ++ "-" ++ name)++ let sumElem :: [Matrix Double] -> Matrix Double+ sumElem = foldl1 (elementwise (+))++ let mprior' = case (mprior, mnew) of+ (Just (sprior, fprior), Just new) ->+ Just (bimap sumElem sumElem (bimap (sprior :) (fprior :) (unzip new)))+ (Nothing, Just new) -> Just (bimap sumElem sumElem (unzip new))+ (Just prior, Nothing) -> Just prior+ (Nothing, Nothing) -> Nothing++ case mprior' of+ Just prior' -> writeFile (fp ++ "-" ++ name ++ "-cache") (show (bimap toLists toLists prior'))+ Nothing -> return ()++ removeFile (fp ++ "-" ++ name)++ return mprior'++ where+ parseMany :: String -> Maybe ([(Matrix Double, Matrix Double)])+ parseMany = sequence+ . map parse+ . lines++ parse :: String -> Maybe (Matrix Double, Matrix Double)+ parse = fmap (bimap fromLists fromLists) . readMaybe++ readFile' :: FilePath -> IO String+ readFile' file = hGetContents =<< openFile file ReadWriteMode++persistStats :: Monad m+ => StatsDb m -> (Matrix Double, Matrix Double) -> PropertyM m ()+persistStats StatsDb { store } = run . store++computeReliability :: Monad m+ => StatsDb m -> Matrix Double -> (Matrix Double, Matrix Double)+ -> m (Double, Double)+computeReliability StatsDb { load } usage observed = do+ mpriors <- load++ return (singleUseReliability (reduce usage) mpriors (bimap reduce reduce observed))+ where+ n = ncols usage+ m = pred n+ reduce = submatrix 1 m 1 n++printReliability :: Testable prop+ => StatsDb IO -> Matrix Double -> (Matrix Double, Matrix Double)+ -> prop -> Property+printReliability sdb usage observed = callback $ PostTest NotCounterexample $ \_state _result ->+ print =<< computeReliability sdb usage observed++quickCheckReliability :: Testable prop+ => StatsDb IO -> Matrix Double -> prop -> IO ()+quickCheckReliability sdb usage prop = do+ quickCheck prop+ print =<< computeReliability sdb usage observed+ where+ observed = ( zero (nrows usage) (ncols usage)+ , zero (nrows usage) (ncols usage)+ )++testChainToDot :: forall state cmd_ prob m. (Show state, Ord state, Monad m)+ => (Generic state, GEnum FiniteEnum (Rep state))+ => StatsDb m -> state -> state -> Markov state cmd_ prob -> m String+testChainToDot StatsDb { load } source sink markov = do+ mpriors <- load+ case mpriors of+ Nothing -> error "testChainToDot: no test chain exists"+ Just priors -> return+ (go ("digraph g {\n" ++ nodeColours) priors markovStatePairs)+ where+ nodeColours :: String+ nodeColours = string (show source) ++ " [color=\"green\"]\n" +++ string (show sink) ++ " [color=\"red\"]\n"++ go :: String -> (Matrix Double, Matrix Double) -> [(state, state)] -> String+ go acc _priors [] = acc ++ "}"+ go acc (successes, failures) ((from, to) : more) = go acc' (successes, failures) more+ where+ acc' :: String+ acc' = acc +++ string (show from) +++ " -> " +++ string (show to) +++ " [label=<(<font color='green'>" ++ show (lookupStates from to successes) ++ "</font>"+ ++ ", <font color='red'>" ++ show (lookupStates from to failures) ++ "</font>)>]\n"++ markovStatePairs :: [(state, state)]+ markovStatePairs+ = Set.toList+ . foldl (\ih (from, tos) -> ih `Set.union`+ foldl (\ih' to -> Set.insert (from, to) ih') Set.empty tos)+ Set.empty+ . map (fmap (map to))+ . Map.toList+ . unMarkov+ $ markov++ lookupStates :: state -> state -> Matrix Double -> Int+ lookupStates from to = round . getElem (gfromFiniteEnum from + 1) (gfromFiniteEnum to + 1)
src/Test/StateMachine/Parallel.hs view
@@ -9,7 +9,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -19,34 +19,51 @@ ----------------------------------------------------------------------------- module Test.StateMachine.Parallel- ( forAllParallelCommands+ ( forAllNParallelCommands+ , forAllParallelCommands+ , generateNParallelCommands , generateParallelCommands+ , shrinkNParallelCommands , shrinkParallelCommands+ , shrinkAndValidateNParallel , shrinkAndValidateParallel+ , shrinkCommands'+ , runNParallelCommands , runParallelCommands+ , runParallelCommands'+ , runNParallelCommandsNTimes , runParallelCommandsNTimes+ , runNParallelCommandsNTimes'+ , runParallelCommandsNTimes' , executeParallelCommands , linearise , toBoxDrawings+ , prettyNParallelCommands , prettyParallelCommands+ , prettyParallelCommandsWithOpts+ , prettyNParallelCommandsWithOpts , advanceModel+ , checkCommandNamesParallel+ , coverCommandNamesParallel+ , commandNamesParallel ) where -import Control.Arrow- ((***)) import Control.Monad- (foldM, replicateM)+ (replicateM, when) import Control.Monad.Catch- (MonadCatch)-import Control.Monad.State+ (MonadMask, mask, onException)+import Control.Monad.State.Strict (runStateT) import Data.Bifunctor (bimap)+import Data.Foldable+ (toList) import Data.List- (partition, permutations)+ (find, partition, permutations) import qualified Data.Map.Strict as Map+import Data.Maybe+ (fromMaybe, mapMaybe) import Data.Monoid- ((<>)) import Data.Set (Set) import qualified Data.Set as S@@ -54,7 +71,8 @@ (Tree(Node)) import Prelude import Test.QuickCheck- (Gen, Property, Testable, choose, property, sized)+ (Gen, Property, Testable, choose, forAllShrinkShow,+ property, sized) import Test.QuickCheck.Monadic (PropertyM, run) import Text.PrettyPrint.ANSI.Leijen@@ -62,10 +80,12 @@ import Text.Show.Pretty (ppShow) import UnliftIO- (MonadIO, MonadUnliftIO, concurrently, newTChanIO)+ (MonadIO, MonadUnliftIO, concurrently,+ forConcurrently, newTChanIO) import Test.StateMachine.BoxDrawer import Test.StateMachine.ConstructorName+import Test.StateMachine.DotDrawing import Test.StateMachine.Logic import Test.StateMachine.Sequential import Test.StateMachine.Types@@ -76,14 +96,26 @@ forAllParallelCommands :: Testable prop => (Show (cmd Symbolic), Show (resp Symbolic), Show (model Symbolic))- => CommandNames cmd => (Rank2.Traversable cmd, Rank2.Foldable resp) => StateMachine model cmd m resp+ -> Maybe Int -> (ParallelCommands cmd resp -> prop) -- ^ Predicate. -> Property-forAllParallelCommands sm =- forAllShrinkShow (generateParallelCommands sm) (shrinkParallelCommands sm) ppShow+forAllParallelCommands sm mminSize =+ forAllShrinkShow (generateParallelCommands sm mminSize) (shrinkParallelCommands sm) ppShow ++forAllNParallelCommands :: Testable prop+ => (Show (cmd Symbolic), Show (resp Symbolic), Show (model Symbolic))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => StateMachine model cmd m resp+ -> Int -- ^ Number of threads+ -> (NParallelCommands cmd resp -> prop) -- ^ Predicate.+ -> Property+forAllNParallelCommands sm np =+ forAllShrinkShow (generateNParallelCommands sm np) (shrinkNParallelCommands sm) ppShow++ -- | Generate parallel commands. -- -- Parallel commands are generated as follows. We begin by generating@@ -124,13 +156,14 @@ -- > [A, B] ─┤ ├──┤ │ -- > └ [D, E] ┘ └ [H, I] ┘ ---generateParallelCommands :: forall model cmd m resp- . (Rank2.Foldable resp, Show (model Symbolic))- => CommandNames cmd+generateParallelCommands :: forall model cmd m resp. Rank2.Foldable resp+ => Show (model Symbolic)+ => (Show (cmd Symbolic), Show (resp Symbolic)) => StateMachine model cmd m resp+ -> Maybe Int -> Gen (ParallelCommands cmd resp)-generateParallelCommands sm@StateMachine { initModel } = do- Commands cmds <- generateCommands sm Nothing+generateParallelCommands sm@StateMachine { initModel } mminSize = do+ Commands cmds <- generateCommands sm mminSize prefixLength <- sized (\k -> choose (0, k `div` 3)) let (prefix, rest) = bimap Commands Commands (splitAt prefixLength cmds) return (ParallelCommands prefix@@ -144,39 +177,86 @@ (Pair (Commands safe1) (Commands safe2) : acc) rest where- (safe, rest) = spanSafe model [] cmds+ (safe, rest) = spanSafe sm model [] cmds (safe1, safe2) = splitAt (length safe `div` 2) safe - suffixLength = 5+-- Split the list of commands in two such that the first half is a+-- list of commands for which the preconditions of all commands hold+-- for permutation of the list, i.e. it is parallel safe. The other+-- half is the remainder of the input list.+spanSafe :: Rank2.Foldable resp+ => StateMachine model cmd m resp+ -> model Symbolic -> [Command cmd resp] -> [Command cmd resp]+ -> ([Command cmd resp], [Command cmd resp])+spanSafe _ _ safe [] = (reverse safe, [])+spanSafe sm model safe (cmd : cmds)+ | length safe <= 5+ , parallelSafe sm model (Commands (cmd : safe))+ = spanSafe sm model (cmd : safe) cmds+ | otherwise+ = (reverse safe, cmd : cmds) - -- Split the list of commands in two such that the first half is a- -- list of commands for which the preconditions of all commands hold- -- for permutation of the list, i.e. it is parallel safe. The other- -- half is the remainder of the input list.- spanSafe :: model Symbolic -> [Command cmd resp] -> [Command cmd resp]- -> ([Command cmd resp], [Command cmd resp])- spanSafe _ safe [] = (reverse safe, [])- spanSafe model safe (cmd : cmds)- | length safe <= suffixLength- , parallelSafe sm model (Commands (cmd : safe))- = spanSafe model (cmd : safe) cmds- | otherwise- = (reverse safe, cmd : cmds)+-- Generate Parallel commands. The length of each suffix, indicates how many thread can+-- concurrently execute the commands safely.+generateNParallelCommands :: forall model cmd m resp. Rank2.Foldable resp+ => Show (model Symbolic)+ => (Show (cmd Symbolic), Show (resp Symbolic))+ => StateMachine model cmd m resp+ -> Int+ -> Gen (NParallelCommands cmd resp)+generateNParallelCommands sm@StateMachine { initModel } np =+ if np <= 0 then error "number of threads must be positive" else do+ Commands cmds <- generateCommands sm Nothing+ prefixLength <- sized (\k -> choose (0, k `div` 3))+ let (prefix, rest) = bimap Commands Commands (splitAt prefixLength cmds)+ return (ParallelCommands prefix+ (makeSuffixes (advanceModel sm initModel prefix) rest))+ where+ makeSuffixes :: model Symbolic -> Commands cmd resp -> [[(Commands cmd resp)]]+ makeSuffixes model0 = go model0 [] . unCommands+ where+ go :: model Symbolic+ -> [[(Commands cmd resp)]]+ -> [(Command cmd resp)]+ -> [[(Commands cmd resp)]]+ go _ acc [] = reverse acc+ go model acc cmds = go (advanceModel sm model (Commands safe))+ (safes : acc)+ rest+ where+ (safe, rest) = spanSafe sm model [] cmds+ safes = Commands <$> chunksOf np (length safe `div` np) safe + -- Split the list in n sublists, whose concat is the initial list.+ -- We try to keep the length of each sublist len.+ --+ -- It is important that we miss no elements here or else executeCommands may fail, because+ -- of missing references. It is also important that the final list has the correct length+ -- n, or else there will be different number of threads than the user specified.+ chunksOf :: Int -> Int -> [a] -> [[a]]+ chunksOf 1 _ xs = [xs]+ chunksOf n len xs = as : chunksOf (n-1) len bs+ where (as, bs) = splitAt len xs++ -- | A list of commands is parallel safe if the pre-conditions for all commands -- hold in all permutations of the list.-parallelSafe :: StateMachine model cmd m resp -> model Symbolic+parallelSafe :: Rank2.Foldable resp+ => StateMachine model cmd m resp -> model Symbolic -> Commands cmd resp -> Bool-parallelSafe StateMachine { precondition, transition } model0- = and- . map (preconditionsHold model0)+parallelSafe StateMachine { precondition, transition, mock } model0+ = all (preconditionsHold model0) . permutations . unCommands where- preconditionsHold _ [] = True- preconditionsHold model (Command cmd resp _vars : cmds) =+ preconditionsHold _ [] = True+ preconditionsHold model (Command cmd resp vars : cmds) = boolean (precondition model cmd) &&- preconditionsHold (transition model cmd resp) cmds+ preconditionsHold (transition model cmd resp) cmds &&+ -- This makes sure that in all permutations the length of variables created is the same.+ -- By doing so, we try to avoid MockSemanticsMismatch errors.+ -- More https://github.com/advancedtelematic/quickcheck-state-machine/pull/348+ length vars == length (getUsedVars $ fst $ runGenSym (mock model cmd) newCounter) -- | Apply the transition of some commands to a model. advanceModel :: StateMachine model cmd m resp@@ -199,8 +279,7 @@ => Rank2.Foldable resp => StateMachine model cmd m resp -> (ParallelCommands cmd resp -> [ParallelCommands cmd resp])-shrinkParallelCommands sm@StateMachine { initModel }- (ParallelCommands prefix suffixes)+shrinkParallelCommands sm (ParallelCommands prefix suffixes) = concatMap go [ Shrunk s (ParallelCommands prefix' (map toPair suffixes')) | Shrunk s (prefix', suffixes') <- shrinkPairS shrinkCommands' shrinkSuffixes@@ -213,12 +292,8 @@ go (Shrunk shrunk cmds) = shrinkAndValidateParallel sm (if shrunk then DontShrink else MustShrink)- (initValidateEnv initModel) cmds - shrinkCommands' :: Commands cmd resp -> [Shrunk (Commands cmd resp)]- shrinkCommands' = map (fmap Commands) . shrinkListS' . unCommands- shrinkSuffixes :: [(Commands cmd resp, Commands cmd resp)] -> [Shrunk [(Commands cmd resp, Commands cmd resp)]] shrinkSuffixes = shrinkListS (shrinkPairS' shrinkCommands')@@ -234,43 +309,65 @@ unCommands (proj2 suffix)) ] - -- > pickOneReturnRest [] == []- -- > pickOneReturnRest [1] == [ (1,[]) ]- -- > pickOneReturnRest [1..3] == [ (1,[2,3]), (2,[1,3]), (3,[1,2]) ]- pickOneReturnRest :: [a] -> [(a, [a])]- pickOneReturnRest [] = []- pickOneReturnRest (x : xs) = (x, xs) : map (id *** (x :)) (pickOneReturnRest xs)+-- | Shrink a parallel program in a pre-condition and scope respecting+-- way.+shrinkNParallelCommands+ :: forall cmd model m resp. Rank2.Traversable cmd+ => Rank2.Foldable resp+ => StateMachine model cmd m resp+ -> (NParallelCommands cmd resp -> [NParallelCommands cmd resp])+shrinkNParallelCommands sm (ParallelCommands prefix suffixes)+ = concatMap go+ [ Shrunk s (ParallelCommands prefix' suffixes')+ | Shrunk s (prefix', suffixes') <- shrinkPairS shrinkCommands' shrinkSuffixes+ (prefix, suffixes)+ ]+ +++ shrinkMoveSuffixToPrefix+ where+ go :: Shrunk (NParallelCommands cmd resp) -> [NParallelCommands cmd resp]+ go (Shrunk shrunk cmds) =+ shrinkAndValidateNParallel sm+ (if shrunk then DontShrink else MustShrink)+ cmds - -- > pickOneReturnRest2 ([], []) == []- -- > pickOneReturnRest2 ([1,2], [3,4])- -- > == [ (1,([2],[3,4])), (2,([1],[3,4])), (3,([1,2],[4])), (4,([1,2],[3])) ]- pickOneReturnRest2 :: ([a], [a]) -> [(a, ([a],[a]))]- pickOneReturnRest2 (xs, ys) =- map (id *** flip (,) ys) (pickOneReturnRest xs) ++- map (id *** (,) xs) (pickOneReturnRest ys)+ shrinkSuffixes :: [[Commands cmd resp]]+ -> [Shrunk [[Commands cmd resp]]]+ shrinkSuffixes = shrinkListS (shrinkListS'' shrinkCommands') + -- Moving a command from a suffix to the prefix preserves validity+ shrinkMoveSuffixToPrefix :: [NParallelCommands cmd resp]+ shrinkMoveSuffixToPrefix = case suffixes of+ [] -> []+ (suffix : suffixes') ->+ [ ParallelCommands (prefix <> Commands [prefix'])+ (fmap Commands suffix' : suffixes')+ | (prefix', suffix') <- pickOneReturnRestL (unCommands <$> suffix)+ ]++-- | Shrinks Commands in a way that it has strictly less number of commands.+shrinkCommands' :: Commands cmd resp -> [Shrunk (Commands cmd resp)]+shrinkCommands' = map (fmap Commands) . shrinkListS' . unCommands+ shrinkAndValidateParallel :: forall model cmd m resp. (Rank2.Traversable cmd, Rank2.Foldable resp) => StateMachine model cmd m resp -> ShouldShrink- -> ValidateEnv model -> ParallelCommands cmd resp -> [ParallelCommands cmd resp]-shrinkAndValidateParallel sm = \shouldShrink env (ParallelCommands prefix suffixes) ->- let go' shouldShrink' (env', prefix') = go prefix' env' shouldShrink' suffixes in+shrinkAndValidateParallel sm@StateMachine { initModel } = \shouldShrink (ParallelCommands prefix suffixes) ->+ let env = initValidateEnv initModel+ curryGo shouldShrink' (env', prefix') = go prefix' env' shouldShrink' suffixes in case shouldShrink of- DontShrink -> concatMap (go' DontShrink) (shrinkAndValidate sm DontShrink env prefix)- MustShrink -> concatMap (go' DontShrink) (shrinkAndValidate sm MustShrink env prefix)- ++ concatMap (go' MustShrink) (shrinkAndValidate sm DontShrink env prefix)+ DontShrink -> concatMap (curryGo DontShrink) (shrinkAndValidate sm DontShrink env prefix)+ MustShrink -> concatMap (curryGo DontShrink) (shrinkAndValidate sm MustShrink env prefix)+ ++ concatMap (curryGo MustShrink) (shrinkAndValidate sm DontShrink env prefix) where- withCounterFrom :: ValidateEnv model -> ValidateEnv model -> ValidateEnv model- e `withCounterFrom` e' = e { veCounter = veCounter e' }- go :: Commands cmd resp -- validated prefix -> ValidateEnv model -- environment after the prefix -> ShouldShrink -- should we /still/ shrink something? -> [Pair (Commands cmd resp)] -- suffixes to validate -> [ParallelCommands cmd resp]- go prefix' envAfterPrefix = go' [] envAfterPrefix+ go prefix' = go' [] where go' :: [Pair (Commands cmd resp)] -- accumulated validated suffixes (in reverse order) -> ValidateEnv model -- environment after the validated suffixes@@ -279,19 +376,12 @@ -> [ParallelCommands cmd resp] go' _ _ MustShrink [] = [] -- Failed to shrink something go' acc _ DontShrink [] = [ParallelCommands prefix' (reverse acc)]- go' acc env shouldShrink (Pair l r : suffixes) =- flip concatMap shrinkOpts $ \((shrinkL, shrinkR), shrinkRest) -> concat- [ go' (Pair l' r' : acc) (combineEnv envL envR) shrinkRest suffixes- | (envL, l') <- shrinkAndValidate sm shrinkL env l- , (envR, r') <- shrinkAndValidate sm shrinkR (env `withCounterFrom` envL) r- ]+ go' acc env shouldShrink (Pair l r : suffixes) = do+ ((shrinkL, shrinkR), shrinkRest) <- shrinkOpts+ (envL, l') <- shrinkAndValidate sm shrinkL env l+ (envR, r') <- shrinkAndValidate sm shrinkR (env `withCounterFrom` envL) r+ go' (Pair l' r' : acc) (combineEnv sm envL envR r') shrinkRest suffixes where- combineEnv :: ValidateEnv model -> ValidateEnv model -> ValidateEnv model- combineEnv envL envR = ValidateEnv {- veModel = advanceModel sm (veModel envL) r- , veScope = Map.union (veScope envL) (veScope envR)- , veCounter = veCounter envR- } shrinkOpts :: [((ShouldShrink, ShouldShrink), ShouldShrink)] shrinkOpts =@@ -301,67 +391,305 @@ , ((DontShrink, MustShrink), DontShrink) , ((DontShrink, DontShrink), MustShrink) ] +combineEnv :: StateMachine model cmd m resp+ -> ValidateEnv model+ -> ValidateEnv model+ -> Commands cmd resp+ -> ValidateEnv model+combineEnv sm envL envR cmds = ValidateEnv {+ veModel = advanceModel sm (veModel envL) cmds+ , veScope = Map.union (veScope envL) (veScope envR)+ , veCounter = veCounter envR+ }++withCounterFrom :: ValidateEnv model -> ValidateEnv model -> ValidateEnv model+withCounterFrom e e' = e { veCounter = veCounter e' }++shrinkAndValidateNParallel :: forall model cmd m resp. (Rank2.Traversable cmd, Rank2.Foldable resp)+ => StateMachine model cmd m resp+ -> ShouldShrink+ -> NParallelCommands cmd resp+ -> [NParallelCommands cmd resp]+shrinkAndValidateNParallel sm = \shouldShrink (ParallelCommands prefix suffixes) ->+ let env = initValidateEnv $ initModel sm+ curryGo shouldShrink' (env', prefix') = go prefix' env' shouldShrink' suffixes in+ case shouldShrink of+ DontShrink -> concatMap (curryGo DontShrink) (shrinkAndValidate sm DontShrink env prefix)+ MustShrink -> concatMap (curryGo DontShrink) (shrinkAndValidate sm MustShrink env prefix)+ ++ concatMap (curryGo MustShrink) (shrinkAndValidate sm DontShrink env prefix)+ where++ go :: Commands cmd resp -- validated prefix+ -> ValidateEnv model -- environment after the prefix+ -> ShouldShrink -- should we /still/ shrink something?+ -> [[Commands cmd resp]] -- suffixes to validate+ -> [NParallelCommands cmd resp]+ go prefix' = go' []+ where+ go' :: [[Commands cmd resp]] -- accumulated validated suffixes (in reverse order)+ -> ValidateEnv model -- environment after the validated suffixes+ -> ShouldShrink -- should we /still/ shrink something?+ -> [[Commands cmd resp]] -- suffixes to validate+ -> [NParallelCommands cmd resp]+ go' _ _ MustShrink [] = [] -- Failed to shrink something+ go' acc _ DontShrink [] = [ParallelCommands prefix' (reverse acc)]+ go' acc env shouldShrink (suffix : suffixes) = do+ (suffixWithShrinks, shrinkRest) <- shrinkOpts suffix+ (envFinal, suffix') <- snd $ foldl f (True, [(env,[])]) suffixWithShrinks+ go' ((reverse suffix') : acc) envFinal shrinkRest suffixes+ where++ f :: (Bool, [(ValidateEnv model, [Commands cmd resp])])+ -> (ShouldShrink, Commands cmd resp)+ -> (Bool, [(ValidateEnv model, [Commands cmd resp])])+ f (firstCall, acc') (shrink, cmds) = (False, acc'')+ where+ acc'' = do+ (envPrev, cmdsPrev) <- acc'+ let envUsed = if firstCall then env else env `withCounterFrom` envPrev+ (env', cmd') <- shrinkAndValidate sm shrink envUsed cmds+ let env'' = if firstCall then env' else+ combineEnv sm envPrev env' cmd'+ return (env'', cmd' : cmdsPrev)++ shrinkOpts :: [a] -> [([(ShouldShrink, a)], ShouldShrink)]+ shrinkOpts ls =+ let len = length ls+ dontShrink = replicate len DontShrink+ shrinks = if len == 0+ then error "Invariant violation! A suffix should never be an empty list"+ else flip map [1..len] $ \n ->+ (replicate (n - 1) DontShrink) ++ [MustShrink] ++ (replicate (len - n) DontShrink)+ in case shouldShrink of+ DontShrink -> [(zip dontShrink ls, DontShrink)]+ MustShrink -> fmap (\shrinkLs -> (zip shrinkLs ls, DontShrink)) shrinks+ ++ [(zip dontShrink ls, MustShrink)]+ ------------------------------------------------------------------------ runParallelCommands :: (Show (cmd Concrete), Show (resp Concrete)) => (Rank2.Traversable cmd, Rank2.Foldable resp)- => (MonadCatch m, MonadUnliftIO m)+ => (MonadMask m, MonadUnliftIO m) => StateMachine model cmd m resp -> ParallelCommands cmd resp -> PropertyM m [(History cmd resp, Logic)]-runParallelCommands sm = runParallelCommandsNTimes 10 sm+runParallelCommands = runParallelCommandsNTimes 10 +runParallelCommands' :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => StateMachine model cmd m resp+ -> (cmd Concrete -> resp Concrete)+ -> ParallelCommands cmd resp+ -> PropertyM m [(History cmd resp, Logic)]+runParallelCommands' = runParallelCommandsNTimes' 10++runNParallelCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => StateMachine model cmd m resp+ -> NParallelCommands cmd resp+ -> PropertyM m [(History cmd resp, Logic)]+runNParallelCommands = runNParallelCommandsNTimes 10+ runParallelCommandsNTimes :: (Show (cmd Concrete), Show (resp Concrete)) => (Rank2.Traversable cmd, Rank2.Foldable resp)- => (MonadCatch m, MonadUnliftIO m)+ => (MonadMask m, MonadUnliftIO m) => Int -- ^ How many times to execute the parallel program. -> StateMachine model cmd m resp -> ParallelCommands cmd resp -> PropertyM m [(History cmd resp, Logic)] runParallelCommandsNTimes n sm cmds = replicateM n $ do- (hist, _reason) <- run (executeParallelCommands sm cmds)- return (hist, linearise sm hist)+ (hist, reason1, reason2) <- run (executeParallelCommands sm cmds True)+ return (hist, logicReason (combineReasons [reason1, reason2]) .&& linearise sm hist) -executeParallelCommands :: (Rank2.Traversable cmd, Rank2.Foldable resp)- => (MonadCatch m, MonadUnliftIO m)- => StateMachine model cmd m resp- -> ParallelCommands cmd resp- -> m (History cmd resp, Reason)-executeParallelCommands sm@StateMachine{ initModel } (ParallelCommands prefix suffixes) = do+runParallelCommandsNTimes' :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => Int -- ^ How many times to execute the parallel program.+ -> StateMachine model cmd m resp+ -> (cmd Concrete -> resp Concrete)+ -> ParallelCommands cmd resp+ -> PropertyM m [(History cmd resp, Logic)]+runParallelCommandsNTimes' n sm complete cmds =+ replicateM n $ do+ (hist, _reason1, _reason2) <- run (executeParallelCommands sm cmds False)+ let hist' = completeHistory complete hist+ return (hist', linearise sm hist') - hchan <- newTChanIO+runNParallelCommandsNTimes :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => Int -- ^ How many times to execute the parallel program.+ -> StateMachine model cmd m resp+ -> NParallelCommands cmd resp+ -> PropertyM m [(History cmd resp, Logic)]+runNParallelCommandsNTimes n sm cmds =+ replicateM n $ do+ (hist, reason) <- run (executeNParallelCommands sm cmds True)+ return (hist, logicReason reason .&& linearise sm hist) - (reason0, (env0, _smodel, _counter, _cmodel)) <- runStateT- (executeCommands sm hchan (Pid 0) True prefix)- (emptyEnvironment, initModel, newCounter, initModel)+runNParallelCommandsNTimes' :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => Int -- ^ How many times to execute the parallel program.+ -> StateMachine model cmd m resp+ -> (cmd Concrete -> resp Concrete)+ -> NParallelCommands cmd resp+ -> PropertyM m [(History cmd resp, Logic)]+runNParallelCommandsNTimes' n sm complete cmds =+ replicateM n $ do+ (hist, _reason) <- run (executeNParallelCommands sm cmds True)+ let hist' = completeHistory complete hist+ return (hist, linearise sm hist') - if reason0 /= Ok- then do- hist <- getChanContents hchan- return (History hist, reason0)- else do- (reason, _) <- foldM (go hchan) (reason0, env0) suffixes- hist <- getChanContents hchan- return (History hist, reason)+executeParallelCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadUnliftIO m)+ => StateMachine model cmd m resp+ -> ParallelCommands cmd resp+ -> Bool+ -> m (History cmd resp, Reason, Reason)+executeParallelCommands sm@StateMachine{ initModel, cleanup } (ParallelCommands prefix suffixes) stopOnError =+ mask $ \restore -> do+ hchan <- restore newTChanIO+ (reason0, (env0, _smodel, _counter, _cmodel)) <- restore (runStateT+ (executeCommands sm hchan (Pid 0) CheckEverything prefix)+ (emptyEnvironment, initModel, newCounter, initModel))+ `onException` (getChanContents hchan >>= cleanup . mkModel sm . History)+ if reason0 /= Ok+ then do+ hist <- getChanContents hchan+ cleanup $ mkModel sm $ History hist+ return (History hist, reason0, reason0)+ else do+ (reason1, reason2, _) <- restore (go hchan (Ok, Ok, env0) suffixes)+ `onException` (getChanContents hchan >>= cleanup . mkModel sm . History)+ hist <- getChanContents hchan+ cleanup $ mkModel sm $ History hist+ return (History hist, reason1, reason2) where- go hchan (_, env) (Pair cmds1 cmds2) = do+ go _hchan (res1, res2, env) [] = return (res1, res2, env)+ go hchan (Ok, Ok, env) (Pair cmds1 cmds2 : pairs) = do+ ((reason1, (env1, _, _, _)), (reason2, (env2, _, _, _))) <- concurrently -- XXX: Post-conditions not checked, so we can pass in initModel here...- -- It would be better if we made executeCommands take a Maybe model- -- instead of the boolean...+ -- It would be better if we made executeCommands take a Maybe Environment+ -- instead of the Check... - (runStateT (executeCommands sm hchan (Pid 1) False cmds1) (env, initModel, newCounter, initModel))- (runStateT (executeCommands sm hchan (Pid 2) False cmds2) (env, initModel, newCounter, initModel))- return ( reason1 `combineReason` reason2- , env1 <> env2- )- where- combineReason :: Reason -> Reason -> Reason- combineReason Ok r2 = r2- combineReason r1 _ = r1+ (runStateT (executeCommands sm hchan (Pid 1) CheckNothing cmds1) (env, initModel, newCounter, initModel))+ (runStateT (executeCommands sm hchan (Pid 2) CheckNothing cmds2) (env, initModel, newCounter, initModel))+ case (isOK $ combineReasons [reason1, reason2], stopOnError) of+ (False, True) -> return (reason1, reason2, env1 <> env2)+ _ -> go hchan ( reason1+ , reason2+ , env1 <> env2+ ) pairs+ go hchan (Ok, ExceptionThrown e, env) (Pair cmds1 _cmds2 : pairs) = do + -- XXX: It's possible that pre-conditions fail at this point, because+ -- commands may depend on references that never got created in the crashed+ -- process. For example, consider:+ --+ -- x <- Create+ -- ------------+----------+ -- Write 1 x | Write 2 x+ -- y <- Create |+ -- ------------+----------+ -- Write 3 x | Write 4 y+ -- | Read x+ --+ -- If the @Write 1 x@ fails, @y@ will never be created and the+ -- pre-condition for @Write 4 y@ will fail. This also means that @Read x@+ -- will never get executed, and so there could be a bug in @Write@ that+ -- never gets discovered. Not sure if we can do something better here?+ --+ (reason1, (env1, _, _, _)) <- runStateT (executeCommands sm hchan (Pid 1) CheckPrecondition cmds1)+ (env, initModel, newCounter, initModel)+ go hchan ( reason1+ , ExceptionThrown e+ , env1+ ) pairs+ go hchan (ExceptionThrown e, Ok, env) (Pair _cmds1 cmds2 : pairs) = do++ (reason2, (env2, _, _, _)) <- runStateT (executeCommands sm hchan (Pid 2) CheckPrecondition cmds2)+ (env, initModel, newCounter, initModel)+ go hchan ( ExceptionThrown e+ , reason2+ , env2+ ) pairs+ go _hchan out@(ExceptionThrown _, ExceptionThrown _, _env) (_ : _) = return out+ go _hchan out@(PreconditionFailed {}, ExceptionThrown _, _env) (_ : _) = return out+ go _hchan out@(ExceptionThrown _, PreconditionFailed {}, _env) (_ : _) = return out+ go _hchan (res1, res2, _env) (Pair _cmds1 _cmds2 : _pairs) =+ error ("executeParallelCommands, unexpected result: " ++ show (res1, res2))++logicReason :: Reason -> Logic+logicReason Ok = Top+logicReason r = Annotate (show r) Bot++executeNParallelCommands :: (Rank2.Traversable cmd, Show (cmd Concrete), Rank2.Foldable resp)+ => Show (resp Concrete)+ => (MonadMask m, MonadUnliftIO m)+ => StateMachine model cmd m resp+ -> NParallelCommands cmd resp+ -> Bool+ -> m (History cmd resp, Reason)+executeNParallelCommands sm@StateMachine{ initModel, cleanup } (ParallelCommands prefix suffixes) stopOnError =+ mask $ \restore -> do+ hchan <- restore newTChanIO+ (reason0, (env0, _smodel, _counter, _cmodel)) <- restore (runStateT+ (executeCommands sm hchan (Pid 0) CheckEverything prefix)+ (emptyEnvironment, initModel, newCounter, initModel))+ `onException` (getChanContents hchan >>= cleanup . mkModel sm . History)+ if reason0 /= Ok+ then do+ hist <- getChanContents hchan+ cleanup $ mkModel sm $ History hist+ return (History hist, reason0)+ else do+ (errors, _) <- restore (go hchan (Map.empty, env0) suffixes)+ `onException` (getChanContents hchan >>= cleanup . mkModel sm . History)+ hist <- getChanContents hchan+ cleanup $ mkModel sm $ History hist+ return (History hist, combineReasons $ Map.elems errors)+ where+ go _ res [] = return res+ go hchan (previousErrors, env) (suffix : rest) = do+ when (isInvalid $ Map.elems previousErrors) $+ error ("executeNParallelCommands, unexpected result: " ++ show previousErrors)++ let noError = Map.null previousErrors+ check = if noError then CheckNothing else CheckPrecondition+ res <- forConcurrently (zip [1..] suffix) $ \(i, cmds) ->+ case Map.lookup i previousErrors of+ Nothing -> do+ (reason, (env', _, _, _)) <- runStateT (executeCommands sm hchan (Pid i) check cmds) (env, initModel, newCounter, initModel)+ return (if isOK reason then Nothing else Just (i, reason), env')+ Just _ -> return (Nothing, env)+ let newErrors = Map.fromList $ mapMaybe fst res+ errors = Map.union previousErrors newErrors+ newEnv = mconcat $ snd <$> res+ case (stopOnError, Map.null errors) of+ (True, False) -> return (errors, newEnv)+ _ -> go hchan (errors, newEnv) rest++combineReasons :: [Reason] -> Reason+combineReasons ls = fromMaybe Ok (find (/= Ok) ls)++isInvalid :: [Reason] -> Bool+isInvalid ls = any isPreconditionFailed ls &&+ all notException ls+ where+ notException (ExceptionThrown _) = False+ notException _ = True++isPreconditionFailed :: Reason -> Bool+isPreconditionFailed PreconditionFailed {} = True+isPreconditionFailed _ = False+ ------------------------------------------------------------------------ -- | Try to linearise a history of a parallel program execution using a@@ -390,28 +718,74 @@ -- | Takes the output of parallel program runs and pretty prints a -- counterexample if any of the runs fail.-prettyParallelCommands :: (MonadIO m, Rank2.Foldable cmd)- => (Show (cmd Concrete), Show (resp Concrete))+prettyParallelCommandsWithOpts :: (MonadIO m, Rank2.Foldable cmd)+ => (Show (cmd Concrete), Show (resp Concrete))+ => ParallelCommands cmd resp+ -> Maybe GraphOptions+ -> [(History cmd resp, Logic)] -- ^ Output of 'runParallelCommands'.+ -> PropertyM m ()+prettyParallelCommandsWithOpts cmds mGraphOptions =+ mapM_ (\(h, l) -> printCounterexample h (logic l) `whenFailM` property (boolean l))+ where+ printCounterexample hist' (VFalse ce) = do+ putStrLn ""+ print (toBoxDrawings cmds hist')+ putStrLn ""+ print (simplify ce)+ putStrLn ""+ case mGraphOptions of+ Nothing -> return ()+ Just gOptions -> createAndPrintDot cmds gOptions hist'+ printCounterexample _hist _+ = error "prettyParallelCommands: impossible, because `boolean l` was False."++simplify :: Counterexample -> Counterexample+simplify (Fst ce@(AnnotateC _ BotC)) = ce+simplify (Snd ce) = simplify ce+simplify (ExistsC [] []) = BotC+simplify (ExistsC _ [Fst ce]) = ce+simplify (ExistsC x (Fst ce : ces)) = ce `EitherC` simplify (ExistsC x ces)+simplify (ExistsC _ (Snd ce : _)) = simplify ce+simplify _ = error "simplify: impossible,\+ \ because of the structure of linearise."++prettyParallelCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => MonadIO m+ => Rank2.Foldable cmd => ParallelCommands cmd resp- -> [(History cmd resp, Logic)] -- ^ Output of 'runParallelCommands'.+ -> [(History cmd resp, Logic)] -- ^ Output of 'runNParallelCommands'. -> PropertyM m ()-prettyParallelCommands cmds =- mapM_ (\(hist, l) -> printCounterexample hist (logic l) `whenFailM` property (boolean l))+prettyParallelCommands cmds = prettyParallelCommandsWithOpts cmds Nothing++-- | Takes the output of parallel program runs and pretty prints a+-- counterexample if any of the runs fail.+prettyNParallelCommandsWithOpts :: (Show (cmd Concrete), Show (resp Concrete))+ => MonadIO m+ => Rank2.Foldable cmd+ => NParallelCommands cmd resp+ -> Maybe GraphOptions+ -> [(History cmd resp, Logic)] -- ^ Output of 'runNParallelCommands'.+ -> PropertyM m ()+prettyNParallelCommandsWithOpts cmds mGraphOptions =+ mapM_ (\(h, l) -> printCounterexample h (logic l) `whenFailM` property (boolean l)) where- printCounterexample hist (VFalse ce) = do- print (toBoxDrawings cmds hist)+ printCounterexample hist' (VFalse ce) = do putStrLn "" print (simplify ce) putStrLn ""+ case mGraphOptions of+ Nothing -> return ()+ Just gOptions -> createAndPrintDot cmds gOptions hist' printCounterexample _hist _- = error "prettyParallelCommands: impossible, because `boolean l` was False."+ = error "prettyNParallelCommands: impossible, because `boolean l` was False." - simplify :: Counterexample -> Counterexample- simplify (ExistsC _ [Fst ce]) = ce- simplify (ExistsC x (Fst ce : ces)) = ce `EitherC` simplify (ExistsC x ces)- simplify (ExistsC _ (Snd ce : _)) = simplify ce- simplify _ = error "simplify: impossible,\- \ because of the structure of linearise."+prettyNParallelCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => MonadIO m+ => Rank2.Foldable cmd+ => NParallelCommands cmd resp+ -> [(History cmd resp, Logic)] -- ^ Output of 'runNParallelCommands'.+ -> PropertyM m ()+prettyNParallelCommands cmds = prettyNParallelCommandsWithOpts cmds Nothing -- | Draw an ASCII diagram of the history of a parallel program. Useful for -- seeing how a race condition might have occured.@@ -447,5 +821,50 @@ evT :: [(EventType, Pid)] evT = toEventType (filter (\e -> fst e `Prelude.elem` map Pid [1, 2]) h) +createAndPrintDot :: forall cmd resp t. Foldable t => Rank2.Foldable cmd+ => (Show (cmd Concrete), Show (resp Concrete))+ => ParallelCommandsF t cmd resp+ -> GraphOptions+ -> History cmd resp+ -> IO ()+createAndPrintDot (ParallelCommands prefix suffixes) gOptions = toDotGraph allVars+ where+ allVars = getAllUsedVars prefix `S.union`+ foldMap (foldMap getAllUsedVars) suffixes++ toDotGraph :: Set Var -> History cmd resp -> IO ()+ toDotGraph knownVars (History h) = printDotGraph gOptions $ (fmap out) <$> (Rose (snd <$> prefixMessages) groupByPid)+ where+ (prefixMessages, h') = partition (\e -> fst e == Pid 0) h+ alterF a Nothing = Just [a]+ alterF a (Just ls) = Just $ a : ls+ groupByPid = foldr (\(p,e) m -> Map.alter (alterF e) p m) Map.empty h'++ out :: HistoryEvent cmd resp -> String+ out (Invocation cmd vars)+ | vars `S.isSubsetOf` knownVars = show (S.toList vars) ++ " ← " ++ show cmd+ | otherwise = show cmd+ out (Response resp) = " → " ++ show resp+ out (Exception err) = " → " ++ err++ getAllUsedVars :: Rank2.Foldable cmd => Commands cmd resp -> Set Var getAllUsedVars = S.fromList . foldMap (\(Command cmd _ _) -> getUsedVars cmd) . unCommands++-- | Print the percentage of each command used. The prefix check is+-- an unfortunate remaining for backwards compatibility.+checkCommandNamesParallel :: forall cmd resp t. Foldable t => CommandNames cmd+ => ParallelCommandsF t cmd resp -> Property -> Property+checkCommandNamesParallel cmds = checkCommandNames $ toSequential cmds++-- | Fail if some commands have not been executed.+coverCommandNamesParallel :: forall cmd resp t. Foldable t => CommandNames cmd+ => ParallelCommandsF t cmd resp -> Property -> Property+coverCommandNamesParallel cmds = coverCommandNames $ toSequential cmds++commandNamesParallel :: forall cmd resp t. Foldable t => CommandNames cmd+ => ParallelCommandsF t cmd resp -> [(String, Int)]+commandNamesParallel = commandNames . toSequential++toSequential :: Foldable t => ParallelCommandsF t cmd resp -> Commands cmd resp+toSequential cmds = prefix cmds <> mconcat (concatMap toList (suffixes cmds))
src/Test/StateMachine/Sequential.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-}@@ -14,7 +13,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -25,10 +24,10 @@ module Test.StateMachine.Sequential ( forAllCommands+ , existsCommands , generateCommands , generateCommandsState- , measureFrequency- , calculateFrequency+ , deadlockError , getUsedVars , shrinkCommands , shrinkAndValidate@@ -36,22 +35,32 @@ , ShouldShrink(..) , initValidateEnv , runCommands+ , runCommands' , getChanContents+ , Check(..) , executeCommands , prettyPrintHistory+ , prettyPrintHistory' , prettyCommands+ , prettyCommands'+ , saveCommands+ , runSavedCommands , commandNames , commandNamesInOrder+ , coverCommandNames , checkCommandNames- , transitionMatrix+ , showLabelledExamples+ , showLabelledExamples' ) where import Control.Exception- (ErrorCall, IOException, displayException)+ (SomeException, SomeAsyncException (..), displayException,+ fromException)+import Control.Monad (when) import Control.Monad.Catch- (MonadCatch, catch)-import Control.Monad.State+ (MonadCatch, MonadMask, catch, mask, onException)+import Control.Monad.State.Strict (StateT, evalStateT, get, lift, put, runStateT) import Data.Bifunctor (second)@@ -60,38 +69,49 @@ import Data.Either (fromRight) import Data.List- (elemIndex)+ (inits) import qualified Data.Map as M import Data.Map.Strict (Map)-import Data.Matrix- (Matrix, getRow, matrix) import Data.Maybe (fromMaybe) import Data.Monoid- ((<>)) import Data.Proxy (Proxy(..)) import qualified Data.Set as S+import Data.Time+ (defaultTimeLocale, formatTime, getZonedTime) import Data.TreeDiff (ToExpr, ansiWlBgEditExprCompact, ediff)-import qualified Data.Vector as V import Prelude+import System.Directory+ (createDirectoryIfMissing)+import System.FilePath+ ((</>))+import System.Random+ (getStdRandom, randomR) import Test.QuickCheck- (Gen, Property, Testable, choose, collect, generate,- resize, sized, suchThat)+ (Gen, Property, Testable, choose, cover,+ forAllShrinkShow, labelledExamplesWith, maxSuccess,+ once, property, replay, sized, stdArgs, tabulate,+ whenFail) import Test.QuickCheck.Monadic (PropertyM, run)+import Test.QuickCheck.Random+ (mkQCGen) import Text.PrettyPrint.ANSI.Leijen (Doc) import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Show.Pretty (ppShow) import UnliftIO- (MonadIO, TChan, atomically, newTChanIO,+ (MonadIO, TChan, atomically, liftIO, newTChanIO, tryReadTChan, writeTChan)+import UnliftIO.Exception (throwIO) import Test.StateMachine.ConstructorName+import Test.StateMachine.Labelling+ (Event(..), execCmds) import Test.StateMachine.Logic import Test.StateMachine.Types import qualified Test.StateMachine.Types.Rank2 as Rank2@@ -101,96 +121,83 @@ forAllCommands :: Testable prop => (Show (cmd Symbolic), Show (resp Symbolic), Show (model Symbolic))- => CommandNames cmd => (Rank2.Traversable cmd, Rank2.Foldable resp) => StateMachine model cmd m resp -> Maybe Int -- ^ Minimum number of commands. -> (Commands cmd resp -> prop) -- ^ Predicate. -> Property-forAllCommands sm mnum =- forAllShrinkShow (generateCommands sm mnum) (shrinkCommands sm) ppShow+forAllCommands sm mminSize =+ forAllShrinkShow (generateCommands sm mminSize) (shrinkCommands sm) ppShow +-- | Generate commands from a list of generators.+existsCommands :: forall model cmd m resp prop. (Testable prop, Rank2.Foldable resp)+ => (Show (model Symbolic), Show (cmd Symbolic), Show (resp Symbolic))+ => StateMachine model cmd m resp+ -> [model Symbolic -> Gen (cmd Symbolic)] -- ^ Generators.+ -> (Commands cmd resp -> prop) -- ^ Predicate.+ -> Property+existsCommands StateMachine { initModel, precondition, transition, mock } gens0 =+ once . forAllShrinkShow (go gens0 initModel newCounter []) (const []) ppShow+ where+ go :: [model Symbolic -> Gen (cmd Symbolic)] -> model Symbolic -> Counter+ -> [Command cmd resp] -> Gen (Commands cmd resp)+ go [] _model _counter acc = return (Commands (reverse acc))+ go (gen : gens) model counter acc = do+ cmd <- either (deadlockError model acc . ppShow) id <$>+ gen model `suchThatEither` (boolean . precondition model)+ let (resp, counter') = runGenSym (mock model cmd) counter+ go gens (transition model cmd resp) counter'+ (Command cmd resp (getUsedVars resp) : acc)++deadlockError :: (Show (model Symbolic), Show (cmd Symbolic), Show (resp Symbolic))+ => model Symbolic -> [Command cmd resp] -> String -> b+deadlockError model generated counterexamples = error $ concat+ [ "\n"+ , "A deadlock occured while generating commands.\n"+ , "No pre-condition holds in the following model:\n\n"+ , " " ++ ppShow model+ , "\n\nThe following commands have been generated so far:\n\n"+ , " " ++ ppShow generated+ , "\n\n"+ , "Example commands generated whose pre-condition doesn't hold:\n\n"+ , " " ++ counterexamples+ , "\n"+ ]+ generateCommands :: (Rank2.Foldable resp, Show (model Symbolic))- => CommandNames cmd+ => (Show (cmd Symbolic), Show (resp Symbolic)) => StateMachine model cmd m resp -> Maybe Int -- ^ Minimum number of commands. -> Gen (Commands cmd resp)-generateCommands sm@StateMachine { initModel } mnum =- evalStateT (generateCommandsState sm newCounter mnum) (initModel, Nothing)+generateCommands sm@StateMachine { initModel } mminSize =+ evalStateT (generateCommandsState sm newCounter mminSize) initModel generateCommandsState :: forall model cmd m resp. Rank2.Foldable resp- => Show (model Symbolic)- => CommandNames cmd+ => (Show (model Symbolic), Show (cmd Symbolic), Show (resp Symbolic)) => StateMachine model cmd m resp -> Counter -> Maybe Int -- ^ Minimum number of commands.- -> StateT (model Symbolic, Maybe (cmd Symbolic)) Gen (Commands cmd resp)-generateCommandsState StateMachine { precondition, generator, transition- , mock, distribution } counter0 mnum = do- size0 <- lift (sized (\k -> choose (fromMaybe 0 mnum, k)))- Commands <$> go size0 counter0 []+ -> StateT (model Symbolic) Gen (Commands cmd resp)+generateCommandsState StateMachine { precondition, generator, transition, mock } counter0 mminSize = do+ let minSize = fromMaybe 0 mminSize+ size0 <- lift (sized (\k -> choose (minSize, k + minSize)))+ go size0 counter0 [] where go :: Int -> Counter -> [Command cmd resp]- -> StateT (model Symbolic, Maybe (cmd Symbolic)) Gen [Command cmd resp]- go 0 _ cmds = return (reverse cmds)+ -> StateT (model Symbolic) Gen (Commands cmd resp)+ go 0 _ cmds = return (Commands (reverse cmds)) go size counter cmds = do- (model, mprevious) <- get+ model <- get case generator model of- Nothing -> return (reverse cmds)- Just cmd -> do- mnext <- lift $ commandFrequency cmd distribution mprevious- `suchThatOneOf` (boolean . precondition model)- case mnext of- Nothing -> error $ concat- [ "A deadlock occured while generating commands.\n"- , "No pre-condition holds in the following model:\n"- , ppShow model- -- XXX: show trace of commands generated so far?- ]- Just next -> do- let (resp, counter') = runGenSym (mock model next) counter- put (transition model next resp, Just next)- go (size - 1) counter' (Command next resp (getUsedVars resp) : cmds)--commandFrequency :: forall cmd. CommandNames cmd- => Gen (cmd Symbolic) -> Maybe (Matrix Int) -> Maybe (cmd Symbolic)- -> [(Int, Gen (cmd Symbolic))]-commandFrequency gen Nothing _ = [ (1, gen) ]-commandFrequency gen (Just distribution) mprevious =- [ (freq, gen `suchThat` ((== con) . cmdName)) | (freq, con) <- weights ]- where- idx = case mprevious of- Nothing -> 1- Just previous ->- let- con = cmdName previous- err = "genetateCommandState: no command: " <> con- in- fromMaybe (error err) ((+ 2) <$>- elemIndex con (cmdNames (Proxy :: Proxy (cmd Symbolic))))- row = V.toList (getRow idx distribution)- weights = zip row (cmdNames (Proxy :: Proxy (cmd Symbolic)))--measureFrequency :: (Rank2.Foldable resp, Show (model Symbolic))- => CommandNames cmd- => StateMachine model cmd m resp- -> Maybe Int -- ^ Minimum number of commands.- -> Int -- ^ Maximum number of commands.- -> IO (Map (String, Maybe String) Int)-measureFrequency sm min0 size = do- cmds <- generate (sequence [ resize n (generateCommands sm min0) | n <- [0, 2..size] ])- return (M.unions (map calculateFrequency cmds))--calculateFrequency :: CommandNames cmd- => Commands cmd resp -> Map (String, Maybe String) Int-calculateFrequency = go M.empty . unCommands- where- go m [] = m- go m [cmd]- = M.insertWith (\_ old -> old + 1) (commandName cmd, Nothing) 1 m- go m (cmd1 : cmd2 : cmds)- = go (M.insertWith (\_ old -> old + 1) (commandName cmd1,- Just (commandName cmd2)) 1 m) cmds+ Nothing -> return (Commands (reverse cmds))+ Just gen -> do+ enext <- lift $ gen `suchThatEither` (boolean . precondition model)+ case enext of+ Left ces -> deadlockError model (reverse cmds) (ppShow ces)+ Right next -> do+ let (resp, counter') = runGenSym (mock model next) counter+ put (transition model next resp)+ go (size - 1) counter' (Command next resp (getUsedVars resp) : cmds) getUsedVars :: Rank2.Foldable f => f Symbolic -> [Var] getUsedVars = Rank2.foldMap (\(Symbolic v) -> [v])@@ -259,7 +266,7 @@ -- -- > [ -- outermost list recording all the shrink possibilities -- > [A', B1', C', D', E' , F', G', H'] -- B shrunk to B1--- > , [A', B1', C', D', E' , F', G', H'] -- B shrunk to B2+-- > , [A', B2', C', D', E' , F', G', H'] -- B shrunk to B2 -- > , [A', B' , C', D', E1', F', G', H'] -- E shrunk to E1 -- > , [A', B' , C', D', E2', F', G', H'] -- E shrunk to E2 -- > , [A', B' , C', D', E3', F', G', H'] -- E shrunk to E3@@ -312,21 +319,37 @@ remapVars :: Map Var Var -> Symbolic a -> Maybe (Symbolic a) remapVars scope (Symbolic v) = Symbolic <$> M.lookup v scope -runCommands :: (Rank2.Traversable cmd, Rank2.Foldable resp)- => (MonadCatch m, MonadIO m)+runCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadIO m) => StateMachine model cmd m resp -> Commands cmd resp -> PropertyM m (History cmd resp, model Concrete, Reason)-runCommands sm@StateMachine { initModel } = run . go- where- go cmds = do- hchan <- newTChanIO- (reason, (_, _, _, model)) <- runStateT- (executeCommands sm hchan (Pid 0) True cmds)- (emptyEnvironment, initModel, newCounter, initModel)- hist <- getChanContents hchan+runCommands sm cmds = run $ runCommands' sm cmds++runCommands' :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadIO m)+ => StateMachine model cmd m resp+ -> Commands cmd resp+ -> m (History cmd resp, model Concrete, Reason)+runCommands' sm@StateMachine { initModel, cleanup } cmds =+ mask $ \restore -> do+ hchan <- restore newTChanIO+ (reason, (_, _, _, model)) <- restore+ (runStateT+ (executeCommands sm hchan (Pid 0) CheckEverything cmds)+ (emptyEnvironment, initModel, newCounter, initModel))+ `onException` (getChanContents hchan >>= cleanup . mkModel sm . History)+ -- if sequential execution ends normally, we have the correct and+ -- deterministic final model ready, so no need to use history for cleanup.+ cleanup model+ -- we have cleaned up, so we can restore noe+ hist <- restore $ getChanContents hchan return (History hist, model, reason) +-- We should try our best to not let this function fail,+-- since it is used to cleanup resources, in parallel programs. getChanContents :: MonadIO m => TChan a -> m [a] getChanContents chan = reverse <$> atomically (go' []) where@@ -336,12 +359,18 @@ Just x -> go' (x : acc) Nothing -> return acc -executeCommands :: (Rank2.Traversable cmd, Rank2.Foldable resp)+data Check+ = CheckPrecondition+ | CheckEverything+ | CheckNothing++executeCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp) => (MonadCatch m, MonadIO m) => StateMachine model cmd m resp -> TChan (Pid, HistoryEvent cmd resp) -> Pid- -> Bool -- ^ Check invariant and post-condition?+ -> Check -> Commands cmd resp -> StateT (Environment, model Symbolic, Counter, model Concrete) m Reason executeCommands StateMachine {..} hchan pid check =@@ -351,34 +380,75 @@ go (Command scmd _ vars : cmds) = do (env, smodel, counter, cmodel) <- get case (check, logic (precondition smodel scmd)) of- (True, VFalse ce) -> return (PreconditionFailed (show ce))- _ -> do+ (CheckPrecondition, VFalse ce) -> return (PreconditionFailed (show ce))+ (CheckEverything, VFalse ce) -> return (PreconditionFailed (show ce))+ _otherwise -> do let ccmd = fromRight (error "executeCommands: impossible") (reify env scmd) atomically (writeTChan hchan (pid, Invocation ccmd (S.fromList vars)))- !ecresp <- lift (fmap Right (semantics ccmd))- `catch` (\(err :: IOException) ->- return (Left (displayException err)))- `catch` (\(err :: ErrorCall) ->- return (Left (displayException err)))+ !ecresp <- lift $ fmap Right (semantics ccmd) `catch`+ \(err :: SomeException) -> do+ when (isSomeAsyncException err) (liftIO (putStrLn $ displayException err) >> throwIO err)+ return (Left (displayException err)) case ecresp of Left err -> do atomically (writeTChan hchan (pid, Exception err))- return ExceptionThrown+ return $ ExceptionThrown err Right cresp -> do- atomically (writeTChan hchan (pid, Response cresp))- let (sresp, counter') = runGenSym (mock smodel scmd) counter- case (check, logic (postcondition cmodel ccmd cresp)) of- (True, VFalse ce) -> return (PostconditionFailed (show ce))- _ -> case (check, logic (fromMaybe (const Top) invariant cmodel)) of- (True, VFalse ce') -> return (InvariantBroken (show ce'))- _ -> do- put ( insertConcretes vars (getUsedConcrete cresp) env- , transition smodel scmd sresp- , counter'- , transition cmodel ccmd cresp- )- go cmds+ let cvars = getUsedConcrete cresp+ if length vars /= length cvars+ then do+ let err = mockSemanticsMismatchError (ppShow ccmd) (ppShow vars) (ppShow cresp) (ppShow cvars)+ atomically (writeTChan hchan (pid, Exception err))+ return MockSemanticsMismatch+ else do+ atomically (writeTChan hchan (pid, Response cresp))+ case (check, logic (postcondition cmodel ccmd cresp)) of+ (CheckEverything, VFalse ce) -> return (PostconditionFailed (show ce))+ _otherwise ->+ case (check, logic (fromMaybe (const Top) invariant cmodel)) of+ (CheckEverything, VFalse ce') -> return (InvariantBroken (show ce'))+ _otherwise -> do+ let (sresp, counter') = runGenSym (mock smodel scmd) counter+ put ( insertConcretes vars cvars env+ , transition smodel scmd sresp+ , counter'+ , transition cmodel ccmd cresp+ )+ go cmds + isSomeAsyncException :: SomeException -> Bool+ isSomeAsyncException se = case fromException se of+ Just (SomeAsyncException _) -> True+ _ -> False++ mockSemanticsMismatchError :: String -> String -> String -> String -> String+ mockSemanticsMismatchError cmd svars cresp cvars = unlines+ [ ""+ , "Mismatch between `mock` and `semantics`."+ , ""+ , "The definition of `mock` for the command:"+ , ""+ , " ", cmd+ , ""+ , "returns the following references:"+ , ""+ , " ", svars+ , ""+ , "while the response from `semantics`:"+ , ""+ , " ", cresp+ , ""+ , "returns the following references:"+ , ""+ , " ", cvars+ , ""+ , "Continuing to execute commands at this point could result in scope"+ , "errors, because we might have commands that use references (returned"+ , "by `mock`) that are not available (returned by `semantics`), to avoid"+ , "this please fix the mismatch."+ , ""+ ]+ getUsedConcrete :: Rank2.Foldable f => f Concrete -> [Dynamic] getUsedConcrete = Rank2.foldMap (\(Concrete x) -> [toDyn x]) @@ -397,7 +467,7 @@ . unHistory where go :: model Concrete -> Maybe (model Concrete) -> [Operation cmd resp] -> Doc- go current previous [] =+ go current previous [] = PP.line <> modelDiff current previous <> PP.line <> PP.line go current previous [Crash cmd err pid] = mconcat@@ -405,7 +475,7 @@ , modelDiff current previous , PP.line, PP.line , PP.string " == "- , PP.string (show cmd)+ , PP.string (ppShow cmd) , PP.string " ==> " , PP.string err , PP.string " [ "@@ -419,9 +489,9 @@ , modelDiff current previous , PP.line, PP.line , PP.string " == "- , PP.string (show cmd)+ , PP.string (ppShow cmd) , PP.string " ==> "- , PP.string (show resp)+ , PP.string (ppShow resp) , PP.string " [ " , PP.int (unPid pid) , PP.string " ]"@@ -438,16 +508,115 @@ -> PropertyM m () prettyCommands sm hist prop = prettyPrintHistory sm hist `whenFailM` prop -------------------------------------------------------------------------+prettyPrintHistory' :: forall model cmd m resp tag. ToExpr (model Concrete)+ => (Show (cmd Concrete), Show (resp Concrete), ToExpr tag)+ => StateMachine model cmd m resp+ -> ([Event model cmd resp Symbolic] -> [tag])+ -> Commands cmd resp+ -> History cmd resp+ -> IO ()+prettyPrintHistory' sm@StateMachine { initModel, transition } tag cmds+ = PP.putDoc+ . go initModel Nothing [] (map tag (drop 1 (inits (execCmds sm cmds))))+ . makeOperations+ . unHistory+ where+ tagsDiff :: [tag] -> [tag] -> Doc+ tagsDiff old new = ansiWlBgEditExprCompact (ediff old new) + go :: model Concrete -> Maybe (model Concrete) -> [tag] -> [[tag]]+ -> [Operation cmd resp] -> Doc+ go current previous _seen _tags [] =+ PP.line <> modelDiff current previous <> PP.line <> PP.line+ go current previous seen (tags : _) [Crash cmd err pid] =+ mconcat+ [ PP.line+ , modelDiff current previous+ , PP.line, PP.line+ , PP.string " == "+ , PP.string (ppShow cmd)+ , PP.string " ==> "+ , PP.string err+ , PP.string " [ "+ , PP.int (unPid pid)+ , PP.string " ]"+ , PP.line+ , if not (null tags)+ then PP.line <> PP.string " " <> tagsDiff seen tags <> PP.line+ else PP.empty+ ]+ go current previous seen (tags : tagss) (Operation cmd resp pid : ops) =+ mconcat+ [ PP.line+ , modelDiff current previous+ , PP.line, PP.line+ , PP.string " == "+ , PP.string (ppShow cmd)+ , PP.string " ==> "+ , PP.string (ppShow resp)+ , PP.string " [ "+ , PP.int (unPid pid)+ , PP.string " ]"+ , PP.line+ , if not (null tags)+ then PP.line <> PP.string " " <> tagsDiff seen tags <> PP.line+ else PP.empty+ , go (transition current cmd resp) (Just current) tags tagss ops+ ]+ go _ _ _ _ _ = error "prettyPrintHistory': impossible." --- | Print distribution of commands and fail if some commands have not--- been executed.+-- | Variant of 'prettyCommands' that also prints the @tag@s covered by each+-- command.+prettyCommands' :: (MonadIO m, ToExpr (model Concrete), ToExpr tag)+ => (Show (cmd Concrete), Show (resp Concrete))+ => StateMachine model cmd m resp+ -> ([Event model cmd resp Symbolic] -> [tag])+ -> Commands cmd resp+ -> History cmd resp+ -> Property+ -> PropertyM m ()+prettyCommands' sm tag cmds hist prop =+ prettyPrintHistory' sm tag cmds hist `whenFailM` prop++saveCommands :: (Show (cmd Symbolic), Show (resp Symbolic))+ => FilePath -> Commands cmd resp -> Property -> Property+saveCommands dir cmds prop = go `whenFail` prop+ where+ go :: IO ()+ go = do+ createDirectoryIfMissing True dir+ file <- formatTime defaultTimeLocale "%F_%T" <$> getZonedTime+ let fp = dir </> file+ writeFile fp (ppShow cmds)+ putStrLn ("Saved counterexample in: " ++ fp)+ putStrLn ""++runSavedCommands :: (Show (cmd Concrete), Show (resp Concrete))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => (MonadMask m, MonadIO m)+ => (Read (cmd Symbolic), Read (resp Symbolic))+ => StateMachine model cmd m resp+ -> FilePath+ -> PropertyM m (Commands cmd resp, History cmd resp, model Concrete, Reason)+runSavedCommands sm fp = do+ cmds <- read <$> liftIO (readFile fp)+ (hist, model, res) <- runCommands sm cmds+ return (cmds, hist, model, res)++------------------------------------------------------------------------++-- | Print the percentage of each command used. The prefix check is+-- an unfortunate remaining for backwards compatibility. checkCommandNames :: forall cmd resp. CommandNames cmd => Commands cmd resp -> Property -> Property-checkCommandNames cmds- = collect names- . oldCover (length names == numOfConstructors) 1 "coverage"+checkCommandNames cmds =+ tabulate "Commands" (fst <$> commandNames cmds)++-- | Fail if some commands have not been executed.+coverCommandNames :: forall cmd resp. CommandNames cmd+ => Commands cmd resp -> Property -> Property+coverCommandNames cmds+ = cover 1 (length names == numOfConstructors) "coverage" where names = commandNames cmds numOfConstructors = length (cmdNames (Proxy :: Proxy (cmd Symbolic)))@@ -466,14 +635,41 @@ go :: [String] -> Command cmd resp -> [String] go ih cmd = commandName cmd : ih +------------------------------------------------------------------------ -transitionMatrix :: forall cmd. CommandNames cmd- => Proxy (cmd Symbolic)- -> (String -> String -> Int) -> Matrix Int-transitionMatrix _ f =- let cons = cmdNames (Proxy :: Proxy (cmd Symbolic))- n = length cons- m = succ n- in matrix m n $ \case- (1, j) -> f "<START>" (cons !! pred j)- (i, j) -> f (cons !! pred (pred i)) (cons !! pred j)+-- | Show minimal examples for each of the generated tags.+showLabelledExamples' :: (Show tag, Show (model Symbolic))+ => (Show (cmd Symbolic), Show (resp Symbolic))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => StateMachine model cmd m resp+ -> Maybe Int+ -- ^ Seed+ -> Int+ -- ^ Number of tests to run to find examples+ -> ([Event model cmd resp Symbolic] -> [tag])+ -> (tag -> Bool)+ -- ^ Tag filter (can be @const True@)+ -> IO ()+showLabelledExamples' sm mReplay numTests tag focus = do+ replaySeed <- case mReplay of+ Nothing -> getStdRandom (randomR (1, 999999))+ Just seed -> return seed++ labelledExamplesWith (stdArgs { replay = Just (mkQCGen replaySeed, 0)+ , maxSuccess = numTests+ }) $+ forAllShrinkShow (generateCommands sm Nothing)+ (shrinkCommands sm)+ ppShow $ \cmds ->+ collects (filter focus . tag . execCmds sm $ cmds) $+ property True++ putStrLn $ "Used replaySeed " ++ show replaySeed++showLabelledExamples :: (Show tag, Show (model Symbolic))+ => (Show (cmd Symbolic), Show (resp Symbolic))+ => (Rank2.Traversable cmd, Rank2.Foldable resp)+ => StateMachine model cmd m resp+ -> ([Event model cmd resp Symbolic] -> [tag])+ -> IO ()+showLabelledExamples sm tag = showLabelledExamples' sm Nothing 1000 tag (const True)
src/Test/StateMachine/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MonoLocalBinds #-}@@ -14,7 +15,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -23,14 +24,20 @@ module Test.StateMachine.Types ( StateMachine(..) , Command(..)+ , getCommand , Commands(..)+ , NParallelCommands , lengthCommands , ParallelCommandsF(..) , ParallelCommands , Pair(..) , fromPair , toPair+ , fromPair'+ , toPairUnsafe' , Reason(..)+ , isOK+ , noCleanup , module Test.StateMachine.Types.Environment , module Test.StateMachine.Types.GenSym , module Test.StateMachine.Types.History@@ -39,10 +46,7 @@ import Data.Functor.Classes (Ord1, Show1)-import Data.Matrix- (Matrix) import Data.Semigroup- (Semigroup) import Prelude import Test.QuickCheck (Gen)@@ -62,25 +66,51 @@ , postcondition :: model Concrete -> cmd Concrete -> resp Concrete -> Logic , invariant :: Maybe (model Concrete -> Logic) , generator :: model Symbolic -> Maybe (Gen (cmd Symbolic))- , distribution :: Maybe (Matrix Int) , shrinker :: model Symbolic -> cmd Symbolic -> [cmd Symbolic] , semantics :: cmd Concrete -> m (resp Concrete) , mock :: model Symbolic -> cmd Symbolic -> GenSym (resp Symbolic)+ , cleanup :: model Concrete -> m () } +noCleanup :: Monad m => model Concrete -> m ()+noCleanup _ = return ()+ -- | Previously symbolically executed command -- -- Invariant: the variables must be the variables in the response. data Command cmd resp = Command !(cmd Symbolic) !(resp Symbolic) ![Var] -deriving instance (Show (cmd Symbolic), Show (resp Symbolic)) => Show (Command cmd resp)+getCommand :: Command cmd resp -> cmd Symbolic+getCommand (Command cmd _resp _vars) = cmd +deriving+ stock+ instance (Show (cmd Symbolic), Show (resp Symbolic)) => Show (Command cmd resp)++deriving+ stock+ instance (Read (cmd Symbolic), Read (resp Symbolic)) => Read (Command cmd resp)++deriving+ stock+ instance ((Eq (cmd Symbolic)), (Eq (resp Symbolic))) => Eq (Command cmd resp)+ newtype Commands cmd resp = Commands { unCommands :: [Command cmd resp] }- deriving (Semigroup, Monoid)+ deriving newtype (Semigroup, Monoid) -deriving instance (Show (cmd Symbolic), Show (resp Symbolic)) => Show (Commands cmd resp)+deriving+ stock+ instance (Show (cmd Symbolic), Show (resp Symbolic)) => Show (Commands cmd resp) +deriving+ stock+ instance (Read (cmd Symbolic), Read (resp Symbolic)) => Read (Commands cmd resp)++deriving+ stock+ instance ((Eq (cmd Symbolic)), (Eq (resp Symbolic))) => Eq (Commands cmd resp)+ lengthCommands :: Commands cmd resp -> Int lengthCommands = length . unCommands @@ -89,22 +119,34 @@ | PreconditionFailed String | PostconditionFailed String | InvariantBroken String- | ExceptionThrown- deriving (Eq, Show)+ | ExceptionThrown String+ | MockSemanticsMismatch+ deriving stock (Eq, Show) +isOK :: Reason -> Bool+isOK Ok = True+isOK _ = False+ data ParallelCommandsF t cmd resp = ParallelCommands { prefix :: !(Commands cmd resp) , suffixes :: [t (Commands cmd resp)] } -deriving instance (Show (cmd Symbolic), Show (resp Symbolic), Show (t (Commands cmd resp))) =>- Show (ParallelCommandsF t cmd resp)+deriving+ stock+ instance (Eq (cmd Symbolic), Eq (resp Symbolic), Eq (t (Commands cmd resp)))+ => Eq (ParallelCommandsF t cmd resp) +deriving+ stock+ instance (Show (cmd Symbolic), Show (resp Symbolic), Show (t (Commands cmd resp)))+ => Show (ParallelCommandsF t cmd resp)+ data Pair a = Pair { proj1 :: !a , proj2 :: !a }- deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+ deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) fromPair :: Pair a -> (a, a) fromPair (Pair x y) = (x, y)@@ -113,3 +155,14 @@ toPair (x, y) = Pair x y type ParallelCommands = ParallelCommandsF Pair++type NParallelCommands = ParallelCommandsF []++fromPair' :: ParallelCommandsF Pair cmd resp -> ParallelCommandsF [] cmd resp+fromPair' p = p { suffixes = (\(Pair l r) -> [l, r]) <$> suffixes p}++toPairUnsafe' :: ParallelCommandsF [] cmd resp -> ParallelCommandsF Pair cmd resp+toPairUnsafe' p = p { suffixes = unsafePair <$> suffixes p}+ where+ unsafePair [a,b] = Pair a b+ unsafePair _ = error "invariant violation! Shrunk list should always have 2 elements."
src/Test/StateMachine/Types/Environment.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,7 +9,7 @@ -- Copyright : (C) 2017, Jacob Stanley -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -35,7 +36,6 @@ (Map) import qualified Data.Map as M import Data.Semigroup- (Semigroup) import Data.Typeable (Proxy(Proxy), TypeRep, typeRep) import Prelude@@ -49,13 +49,14 @@ newtype Environment = Environment { unEnvironment :: Map Var Dynamic }- deriving (Semigroup, Monoid, Show)+ deriving stock (Show)+ deriving newtype (Semigroup, Monoid) -- | Environment errors. data EnvironmentError = EnvironmentValueNotFound !Var | EnvironmentTypeError !TypeRep !TypeRep- deriving (Eq, Ord, Show)+ deriving stock (Eq, Ord, Show) -- | Create an empty environment. emptyEnvironment :: Environment
src/Test/StateMachine/Types/GenSym.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -----------------------------------------------------------------------------@@ -6,7 +7,7 @@ -- Copyright : (C) 2018, HERE Europe B.V. -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -32,10 +33,10 @@ ------------------------------------------------------------------------ newtype GenSym a = GenSym (State Counter a)- deriving (Functor, Applicative, Monad)+ deriving newtype (Functor, Applicative, Monad) runGenSym :: GenSym a -> Counter -> (a, Counter)-runGenSym (GenSym m) counter = runState m counter+runGenSym (GenSym m) = runState m genSym :: Typeable a => GenSym (Reference a Symbolic) genSym = GenSym $ do@@ -44,6 +45,7 @@ return (Reference (Symbolic (Var i))) newtype Counter = Counter Int+ deriving stock Show newCounter :: Counter newCounter = Counter 0
src/Test/StateMachine/Types/History.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} -----------------------------------------------------------------------------@@ -6,7 +8,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -23,9 +25,13 @@ , Operation(..) , makeOperations , interleavings+ , operationsPath+ , completeHistory ) where +import Data.List+ ((\\)) import Data.Set (Set) import Data.Tree@@ -39,26 +45,26 @@ newtype History cmd resp = History { unHistory :: History' cmd resp } -deriving instance (Eq (cmd Concrete), Eq (resp Concrete)) =>+deriving stock instance (Eq (cmd Concrete), Eq (resp Concrete)) => Eq (History cmd resp) -deriving instance (Show (cmd Concrete), Show (resp Concrete)) =>+deriving stock instance (Show (cmd Concrete), Show (resp Concrete)) => Show (History cmd resp) type History' cmd resp = [(Pid, HistoryEvent cmd resp)] newtype Pid = Pid { unPid :: Int }- deriving (Eq, Show)+ deriving stock (Eq, Show, Ord) data HistoryEvent cmd resp = Invocation !(cmd Concrete) !(Set Var) | Response !(resp Concrete) | Exception !String -deriving instance (Eq (cmd Concrete), Eq (resp Concrete)) =>+deriving stock instance (Eq (cmd Concrete), Eq (resp Concrete)) => Eq (HistoryEvent cmd resp) -deriving instance (Show (cmd Concrete), Show (resp Concrete)) =>+deriving stock instance (Show (cmd Concrete), Show (resp Concrete)) => Show (HistoryEvent cmd resp) ------------------------------------------------------------------------@@ -83,9 +89,11 @@ = Operation (cmd Concrete) (resp Concrete) Pid | Crash (cmd Concrete) String Pid -deriving instance (Show (cmd Concrete), Show (resp Concrete)) =>+deriving stock instance (Show (cmd Concrete), Show (resp Concrete)) => Show (Operation cmd resp) +-- | Given a sequential history, group invocation and response events into+-- operations. makeOperations :: History' cmd resp -> [Operation cmd resp] makeOperations [] = [] makeOperations [(pid1, Invocation cmd _), (pid2, Exception err)]@@ -96,9 +104,9 @@ | otherwise = error "makeOperations: impossible, pid mismatch." makeOperations _ = error "makeOperations: impossible." --- | Given a history, return all possible interleavings of invocations+-- | Given a parallel history, return all possible interleavings of invocations -- and corresponding response events.-interleavings :: [(Pid, HistoryEvent cmd resp)] -> Forest (Operation cmd resp)+interleavings :: History' cmd resp -> Forest (Operation cmd resp) interleavings [] = [] interleavings es = [ Node (Operation cmd resp pid) (interleavings es')@@ -113,3 +121,35 @@ filter1 _ [] = [] filter1 p (x : xs) | p x = x : filter1 p xs | otherwise = xs++operationsPath :: Forest (Operation cmd resp) -> [Operation cmd resp]+operationsPath = go []+ where+ go :: [a] -> Forest a -> [a]+ go acc [] = reverse acc+ go acc (Node a f : _) = go (a:acc) f++------------------------------------------------------------------------++crashingInvocations :: History' cmd resp -> History' cmd resp+crashingInvocations = go [] [] . reverse+ where+ go :: [Pid] -> History' cmd resp -> History' cmd resp -> History' cmd resp+ go _crashedPids crashedInvs [] = reverse crashedInvs+ go crashedPids crashedInvs ((pid, Exception _err) : es)+ | pid `elem` crashedPids = error "impossible, a process cannot crash more than once."+ | otherwise = go (pid : crashedPids) crashedInvs es+ go crashedPids crashedInvs (e@(pid, Invocation {}) : es)+ | pid `elem` crashedPids = go (crashedPids \\ [pid]) (e : crashedInvs) es+ | otherwise = go crashedPids crashedInvs es+ go crashedPids crashedInvs ((_pid, Response {}) : es) =+ go crashedPids crashedInvs es++completeHistory :: (cmd Concrete -> resp Concrete) -> History cmd resp+ -> History cmd resp+completeHistory complete hist = History (hist' ++ resps)+ where+ hist' = unHistory hist+ resps = [ (pid, Response (complete cmd))+ | (pid, Invocation cmd _vars) <- crashingInvocations hist'+ ]
src/Test/StateMachine/Types/References.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -11,7 +12,7 @@ -- Copyright : (C) 2017, Jacob Stanley -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -49,14 +50,16 @@ ------------------------------------------------------------------------ newtype Var = Var Int- deriving (Eq, Ord, Show, Generic, ToExpr)+ deriving stock (Eq, Ord, Show, Generic, Read)+ deriving newtype (ToExpr) data Symbolic a where Symbolic :: Typeable a => Var -> Symbolic a -deriving instance Show (Symbolic a)-deriving instance Eq (Symbolic a)-deriving instance Ord (Symbolic a)+deriving stock instance Show (Symbolic a)+deriving stock instance Typeable a => Read (Symbolic a)+deriving stock instance Eq (Symbolic a)+deriving stock instance Ord (Symbolic a) instance Show1 Symbolic where liftShowsPrec _ _ p (Symbolic x) =@@ -78,7 +81,7 @@ data Concrete a where Concrete :: Typeable a => a -> Concrete a -deriving instance Show a => Show (Concrete a)+deriving stock instance Show a => Show (Concrete a) instance Show1 Concrete where liftShowsPrec sp _ p (Concrete x) =@@ -97,9 +100,11 @@ instance ToExpr a => ToExpr (Concrete a) where toExpr (Concrete x) = toExpr x -data Reference a r = Reference (r a)- deriving Generic+newtype Reference a r = Reference (r a)+ deriving stock Generic +deriving stock instance Typeable a => Read (Reference a Symbolic)+ instance ToExpr (r a) => ToExpr (Reference a r) instance Rank2.Functor (Reference a) where@@ -135,7 +140,7 @@ newtype Opaque a = Opaque { unOpaque :: a }- deriving (Eq, Ord)+ deriving stock (Eq, Ord) instance Show (Opaque a) where showsPrec _ (Opaque _) = showString "Opaque"
src/Test/StateMachine/Utils.hs view
@@ -1,7 +1,6 @@-{-# OPTIONS_GHC -Wno-orphans #-}--{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -----------------------------------------------------------------------------@@ -10,7 +9,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH, Li-yao Xia -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -22,37 +21,37 @@ module Test.StateMachine.Utils ( liftProperty , whenFailM- , forAllShrinkShow , anyP- , shrinkPair- , shrinkPair'- , suchThatOneOf- , oldCover+ , suchThatEither+ , collects , Shrunk(..) , shrinkS , shrinkListS , shrinkListS'+ , shrinkListS'' , shrinkPairS , shrinkPairS'+ , pickOneReturnRest+ , pickOneReturnRest2+ , pickOneReturnRestL+ , mkModel ) where import Prelude +import Control.Arrow+ ((***))+import Data.List+ (foldl') import Test.QuickCheck- (Arbitrary, Gen, Property, Testable, again,- counterexample, frequency, resize, shrink,- shrinkList, shrinking, sized, suchThatMaybe,- whenFail)+ (Arbitrary, Gen, Property, collect, resize, shrink,+ shrinkList, sized, whenFail) import Test.QuickCheck.Monadic (PropertyM(MkPropertyM)) import Test.QuickCheck.Property- (Property(MkProperty), cover, property, unProperty,- (.&&.), (.||.))-#if !MIN_VERSION_QuickCheck(2,10,0)-import Test.QuickCheck.Property- (succeeded)-#endif+ (property, (.&&.), (.||.))+import Test.StateMachine.Types ------------------------------------------------------------------------ @@ -64,73 +63,26 @@ whenFailM :: Monad m => IO () -> Property -> PropertyM m () whenFailM m prop = liftProperty (m `whenFail` prop) --- | A variant of 'Test.QuickCheck.Monadic.forAllShrink' with an--- explicit show function.-forAllShrinkShow- :: Testable prop- => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property-forAllShrinkShow gen shrinker shower pf =- again $- MkProperty $- gen >>= \x ->- unProperty $- shrinking shrinker x $ \x' ->- counterexample (shower x') (pf x')- -- | Lifts 'Prelude.any' to properties. anyP :: (a -> Property) -> [a] -> Property anyP p = foldr (\x ih -> p x .||. ih) (property False) --- | Given shrinkers for the components of a pair we can shrink the pair.-shrinkPair' :: (a -> [a]) -> (b -> [b]) -> ((a, b) -> [(a, b)])-shrinkPair' shrinkerA shrinkerB (x, y) =- [ (x', y) | x' <- shrinkerA x ] ++- [ (x, y') | y' <- shrinkerB y ]---- | Same above, but for homogeneous pairs.-shrinkPair :: (a -> [a]) -> ((a, a) -> [(a, a)])-shrinkPair shrinker = shrinkPair' shrinker shrinker--#if !MIN_VERSION_QuickCheck(2,10,0)-instance Testable () where- property = property . liftUnit- where- liftUnit () = succeeded-#endif---- | Like 'Test.QuickCheck.suchThatMaybe', but retries @n@ times.-suchThatMaybeN :: Int -> Gen a -> (a -> Bool) -> Gen (Maybe a)-suchThatMaybeN 0 _ _ = return Nothing-suchThatMaybeN n gen p = do- mx <- gen `suchThatMaybe` p- case mx of- Just x -> return (Just x)- Nothing -> sized (\m -> resize (m + 1) (suchThatMaybeN (n - 1) gen p))--suchThatOneOf :: [(Int, Gen a)] -> (a -> Bool) -> Gen (Maybe a)-gens0 `suchThatOneOf` p = go gens0 (length gens0 - 1)+suchThatEither :: forall a. Gen a -> (a -> Bool) -> Gen (Either [a] a)+gen `suchThatEither` p = sized (try [] 0 . max 100) where- go [] _ = return Nothing- go gens n = do- i <- frequency (zip (map fst gens) (map return [0 .. n]))- case splitAt i gens of- (_, []) -> error ("suchThatOneOf: impossible, as we" ++- " split the list on its length - 1.")- (gens', gen : gens'') -> do- mx <- suchThatMaybeN 20 (snd gen) p- case mx of- Just x -> return (Just x)- Nothing -> go (gens' ++ gens'') (n - 1)+ try :: [a] -> Int -> Int -> Gen (Either [a] a)+ try ces _ 0 = return (Left (reverse ces))+ try ces k n = do+ x <- resize (2 * k + n) gen+ if p x+ then return (Right x)+ else try (x : ces) (k + 1) (n - 1) --- QuickCheck-2.12.0 introduced a breaking change in the cover combinator, see--- issue #248 for details.-oldCover :: Testable prop => Bool -> Int -> String -> prop -> Property-oldCover x n s p =-#if !MIN_VERSION_QuickCheck(2,12,0)- cover x n s p-#else- cover (fromIntegral n) x s p-#endif+collects :: Show a => [a] -> Property -> Property+collects = repeatedly collect+ where+ repeatedly :: (a -> b -> b) -> ([a] -> b -> b)+ repeatedly = flip . foldl' . flip ----------------------------------------------------------------------------- @@ -160,7 +112,7 @@ -- > , Shrunk False [(1,3),(2,4)] -- the original unchanged list -- > ] data Shrunk a = Shrunk { wasShrunk :: Bool, shrunk :: a }- deriving (Show, Functor)+ deriving stock (Eq, Show, Functor) shrinkS :: Arbitrary a => a -> [Shrunk a] shrinkS a = map (Shrunk True) (shrink a) ++ [Shrunk False a]@@ -177,10 +129,17 @@ shrinkOne (x:xs) = [Shrunk True (x' : xs) | Shrunk True x' <- f x] ++ [Shrunk True (x : xs') | Shrunk True xs' <- shrinkOne xs] --- | Shrink list without shrinking elements+-- | Shrink list without shrinking elements. shrinkListS' :: [a] -> [Shrunk [a]] shrinkListS' = shrinkListS (\a -> [Shrunk False a]) +-- | Shrink list by only shrinking elements.+shrinkListS'' :: forall a. (a -> [Shrunk a]) -> [a] -> [Shrunk [a]]+shrinkListS'' f xs =+ let shr = shrinkListS f xs+ len = length xs+ in filter (\s -> length (shrunk s) == len) shr+ shrinkPairS :: (a -> [Shrunk a]) -> (b -> [Shrunk b]) -> (a, b) -> [Shrunk (a, b)]@@ -191,3 +150,50 @@ shrinkPairS' :: (a -> [Shrunk a]) -> (a, a) -> [Shrunk (a, a)] shrinkPairS' f = shrinkPairS f f++-- > pickOneReturnRest2 ([], []) == []+-- > pickOneReturnRest2 ([1,2], [3,4])+-- > == [ (1,([2],[3,4])), (2,([1],[3,4])), (3,([1,2],[4])), (4,([1,2],[3])) ]+pickOneReturnRest2 :: ([a], [a]) -> [(a, ([a],[a]))]+pickOneReturnRest2 (xs, ys) =+ map (id *** flip (,) ys) (pickOneReturnRest xs) +++ map (id *** (,) xs) (pickOneReturnRest ys)++-- > pickOneReturnRest [] == []+-- > pickOneReturnRest [1] == [ (1,[]) ]+-- > pickOneReturnRest [1..3] == [ (1,[2,3]), (2,[1,3]), (3,[1,2]) ]+pickOneReturnRest :: [a] -> [(a, [a])]+pickOneReturnRest [] = []+pickOneReturnRest (x : xs) = (x, xs) : map (id *** (x :)) (pickOneReturnRest xs)++-- > pickOneReturnRestL [[]] == []+-- > pickOneReturnRestL [[1]] == [(1,[[]])]+-- > pickOneReturnRestL [[1],[],[]] == [(1,[[],[],[]])]+-- > pickOneReturnRestL [[1,2]] == [(1,[[2]]), (2,[[1]])]+-- > pickOneReturnRestL [[1,2], [3,4]]+-- > == [ (1,[[2],[3,4]]), (2,[[1],[3,4]]), (3,[[1,2],[4]]), (4,[[1,2],[3]]) ]+pickOneReturnRestL :: [[a]] -> [(a, [[a]])]+pickOneReturnRestL ls = concatMap+ (\(prev, as, next) -> fmap (\(a, rest) -> (a, prev ++ [rest] ++ next)) $ pickOneReturnRest as)+ $ splitEach ls+ where+ splitEach :: [a] -> [([a], a, [a])]+ splitEach [] = []+ splitEach (a : as) = fmap (\(prev, a', next) -> (prev, a', next)) $+ go' [([], a, as)] ([], a, as)+ where+ go' :: [([a], a, [a])] -> ([a], a, [a]) -> [([a], a, [a])]+ go' acc (_, _, []) = reverse acc+ go' acc (prev, a', b : next) =+ let newElem = (a' : prev, b, next)+ in go' (newElem : acc) newElem++-----------------------------------------------------------------------------++mkModel :: StateMachine model cmd m resp -> History cmd resp -> model Concrete+mkModel StateMachine {transition, initModel} =+ go initModel . operationsPath . interleavings . unHistory+ where+ go m [] = m+ go m (Operation cmd resp _ : rest) = go (transition m cmd resp) rest+ go m (Crash _ _ _ : rest) = go m rest
src/Test/StateMachine/Z.hs view
@@ -6,7 +6,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : portable --
+ test/Bookstore.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Bookstore+ ( Bug(..)+ , prop_bookstore+ , cleanup+ , setup+ )+ where++import Control.Concurrent+ (threadDelay)+import Control.Monad.Reader+ (ReaderT, ask, runReaderT)+import Data.Int+ (Int64)+import Data.Kind+ (Type)+import Data.List+ (dropWhileEnd, group, inits, isInfixOf, sort, tails)+import Data.Maybe+ (fromJust)+import Database.PostgreSQL.Simple as PS+ (ConnectInfo, Connection, Query, close, connect,+ connectDatabase, connectHost, connectPassword,+ connectPort, connectUser, defaultConnectInfo,+ execute, execute_, query)+import Database.PostgreSQL.Simple.Errors+ (ConstraintViolation(..), catchViolation)+import Database.PostgreSQL.Simple.FromRow+ (FromRow(fromRow), field)+import GHC.Generics+ (Generic, Generic1)+import Network.Socket as Sock+ (AddrInfoFlag(AI_NUMERICHOST, AI_NUMERICSERV),+ Socket, SocketType(Stream), addrAddress, addrFamily,+ addrFlags, addrProtocol, addrSocketType, close,+ connect, defaultHints, getAddrInfo, socket)+import Prelude+import System.Process+ (callProcess, readProcess)+import Test.QuickCheck+ (Arbitrary(arbitrary), Gen, Property,+ arbitraryPrintableChar, choose, elements, frequency,+ ioProperty, listOf, oneof, shrink, suchThat,+ vectorOf, (===))+import Test.QuickCheck.Monadic+ (monadic)+import UnliftIO+ (IOException, bracket, catch, liftIO, onException,+ throwIO)++import Test.StateMachine+import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.Z+ (codomain, domain)++------------------------------------------------------------------------++-- Based on Bookstore case study from:+-- https://propertesting.com/book_case_study_stateful_properties_with_a_bookstore.html++-- System under test: Parametrized SQL statements++data Book = Book {+ isbn :: String+ , title :: String+ , author :: String+ , owned :: Int+ , avail :: Int+ } deriving stock (Eq, Show, Generic)++instance ToExpr Book where++instance FromRow Book where+ fromRow = Book <$> field <*> field <*> field <*> field <*> field++handleViolations+ :: (Connection -> IO a)+ -> Connection+ -> IO (Maybe a)+handleViolations fn cn = catchViolation catcher (Just <$> fn cn)+ where+ catcher _ (UniqueViolation _) = return Nothing+ catcher e _ = throwIO e++setupTable :: Connection -> IO (Maybe Int64)+setupTable = handleViolations $ \cn ->+ execute_ cn "CREATE TABLE books (\+ \ isbn varchar(20) PRIMARY KEY,\+ \ title varchar(256) NOT NULL,\+ \ author varchar(256) NOT NULL,\+ \ owned smallint DEFAULT 0,\+ \ available smallint DEFAULT 0\+ \ )"++teardown :: Connection -> IO (Maybe Int64)+teardown = handleViolations $ \cn -> execute_ cn "DROP TABLE books"++addBook+ :: String -> String -> String+ -> Connection+ -> IO (Maybe Int64)+addBook isbn_ title_ auth = handleViolations $ \cn ->+ execute cn templ (isbn_, title_, auth)+ where templ = "INSERT INTO books (isbn, title, author, owned, available)\+ \ VALUES ( ?, ?, ?, 0, 0 )"++update :: Query -> String -> Connection -> IO Int64+update prepStmt param cn = execute cn prepStmt [param]++addCopy :: String -> Connection -> IO (Maybe Int64)+addCopy isbn_ = handleViolations $ update templ isbn_+ where templ = "UPDATE books SET\+ \ owned = owned + 1,\+ \ available = available + 1\+ \ WHERE isbn = ?"++borrowCopy :: String -> Connection -> IO (Maybe Int64)+borrowCopy isbn_ = handleViolations (update templ isbn_)+ where templ = "UPDATE books SET available = available - 1 \+ \ WHERE isbn = ? AND available > 0"++returnCopy :: Bug -> String -> Connection -> IO (Maybe Int64)+returnCopy bug isbn_ = handleViolations (update templ isbn_)+ where+ templ = if bug == Bug+ then "UPDATE books SET available = available + 1 WHERE isbn = ?;"+ else "UPDATE books SET available = available + 1\+ \ WHERE isbn = ? AND available < owned;"++select :: Query -> String -> Connection -> IO [Book]+select prepStmt param cn = query cn prepStmt [param]++findByAuthor, findByTitle+ :: Bug -> String -> Connection -> IO (Maybe [Book])+findByAuthor bug s = case bug of+ Injection -> handleViolations (select templ $ "%"++s++"%")+ _ -> handleViolations (select templ $ "%"++(sanitize s)++"%")+ where templ = "SELECT * FROM books WHERE author LIKE ?"++findByTitle bug s = case bug of+ Injection -> handleViolations (select templ $ "%"++s++"%")+ _ -> handleViolations (select templ $ "%"++(sanitize s)++"%")+ where templ = "SELECT * FROM books WHERE title LIKE ?"++findByIsbn :: String -> Connection -> IO (Maybe [Book])+findByIsbn s = handleViolations $ select "SELECT * FROM books WHERE isbn = ?" s++-- XXX+sanitize :: String -> String+sanitize = concatMap (\c -> if c `elem` ['_', '%', '\\'] then '\\':[c] else [c])++withConnection :: ConnectInfo -> (Connection -> IO a) -> IO a+withConnection connInfo = bracket (PS.connect connInfo) PS.close++-- Modeling++newtype Model r = Model [(Isbn, Book)]+ deriving stock (Generic, Show)++instance ToExpr (Model Concrete) where++initModel :: Model v+initModel = Model []++newtype Isbn = Isbn { getString :: String } deriving stock (Eq, Show)++instance ToExpr Isbn where+ toExpr = toExpr . show++instance Arbitrary Isbn where+ arbitrary = oneof [isbn10, isbn13]+ where+ isbn10 = do+ gr <- isbnGroup+ t <- pubTitle (9 - length gr)+ c <- elements ('X':['0'..'9'])+ return $ Isbn (gr ++ "-" ++ t ++ "-" ++ [c])+ isbn13 = do+ code <- elements ["978", "979"]+ Isbn x <- isbn10+ return $ Isbn (code ++ "-" ++ x)++isbnGroup :: Gen String+isbnGroup = elements $ show <$> concat [+ [0..5] :: [Integer]+ , [7]+ , [80..94]+ , [600..621]+ , [950..989]+ , [9926..9989]+ , [99901..99976]+ ]++pubTitle :: Int -> Gen String+pubTitle size = do+ i <- choose (1, size - 1)+ v1 <- vectorOf i $ choose ('0', '9')+ v2 <- vectorOf (size - i) $ choose ('0', '9')+ return $ v1 ++ "-" ++ v2++data Tag+ = New+ | Exist+ | Invalid+ | Avail+ | Unavail+ | Taken+ | Full+ deriving stock (Eq, Show)++data Command (r :: Type -> Type)+ = NewBook Tag Isbn String String+ | AddCopy Tag Isbn+ | Borrow Tag Isbn+ | Return Tag Isbn+ | FindByAuthor Tag String+ | FindByTitle Tag String+ | FindByIsbn Tag Isbn+ deriving stock (Show, Generic1)++instance Rank2.Foldable Command where+instance Rank2.Functor Command where+instance Rank2.Traversable Command where++data Response (r :: Type -> Type)+ = Rows [Book]+ | Updated+ | Inserted+ | NotFound+ | UniqueError+ | OtherError+ deriving stock (Eq, Show, Generic1)++instance Rank2.Foldable Response where++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator (Model m) = Just $ oneof $ [+ NewBook New <$> newIsbn <*> stringGen <*> stringGen+ , AddCopy Invalid <$> newIsbn+ , Borrow Invalid <$> newIsbn+ , Return Invalid <$> newIsbn+ , FindByIsbn Invalid <$> newIsbn+ , FindByTitle Invalid <$> searchStringGen+ , FindByAuthor Invalid <$> searchStringGen+ ] ++ if null m then [] else [+ NewBook Exist <$> existIsbn <*> stringGen <*> stringGen+ , AddCopy Exist <$> existIsbn+ , Borrow Avail <$> existIsbn+ , Borrow Unavail <$> existIsbn+ , Return Taken <$> existIsbn+ , Return Full <$> existIsbn+ , FindByIsbn Exist <$> existIsbn+ , FindByTitle Exist <$> genTitle+ , FindByAuthor Exist <$> genAuthor+ ]+ where+ newIsbn = arbitrary `suchThat` \x -> x `notElem` domain m+ existIsbn = elements $ domain m+ genTitle = elements $ (title <$> codomain m) >>= infixes+ genAuthor = elements $ (author <$> codomain m) >>= infixes++stringGen :: Gen String+stringGen = listOf arbitraryPrintableChar++searchStringGen :: Gen String+searchStringGen = listOf $ frequency [ (7, arbitraryPrintableChar)+ , (3, elements ['_', '%']) ]++infixes :: Ord a => [a] -> [[a]]+infixes l = map head . group . sort $ inits l >>= tails++-- How to shrink Commands++shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic]+shrinker _ (NewBook tag key x y) = [ NewBook tag key x y' | y' <- shrink y ] +++ [ NewBook tag key x' y | x' <- shrink x ]+shrinker _ (FindByAuthor tag a) = [ FindByAuthor tag a' | a' <- shrink a ]+shrinker _ (FindByTitle tag t) = [ FindByTitle tag t' | t' <- shrink t ]+shrinker _ _ = []++++-- Pre-requisites and invariants++preconditions :: Model Symbolic -> Command Symbolic -> Logic+preconditions (Model m) cmd = case cmd of+ AddCopy Invalid key -> Not $ hasKey key+ Borrow Invalid key -> Not $ hasKey key+ Return Invalid key -> Not $ hasKey key+ FindByIsbn Invalid key -> Not $ hasKey key+ NewBook New key _ _ -> Not $ hasKey key+ NewBook Exist key _ _ -> hasKey key+ AddCopy Exist key -> hasKey key+ FindByIsbn Exist key -> hasKey key+ Borrow Avail key -> keyPred key (\b -> avail b .> 0)+ Borrow Unavail key -> keyPred key (\b -> avail b .== 0)+ Return Taken key -> keyPred key (\b -> owned b .> avail b)+ Return Full key -> keyPred key (\b -> owned b .== avail b)+ FindByAuthor Invalid x -> Not $ Exists values (Boolean . isInfixOf x . author)+ FindByTitle Invalid x -> Not $ Exists values (Boolean . isInfixOf x . title)+ FindByTitle Exist x -> Exists values (Boolean . isInfixOf x . title)+ _ -> Top+ where+ values = codomain m+ hasKey key = key `member` (domain m)+ keyPred key p = maybe Bot p (lookup key m)++postconditions :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postconditions (Model m) cmd resp = case cmd of+ NewBook Exist _ _ _ -> resp .== UniqueError+ NewBook New _ _ _ -> resp .== Inserted+ AddCopy Invalid _ -> resp .== NotFound+ Return Invalid _ -> resp .== NotFound+ Borrow Invalid _ -> resp .== NotFound+ Return Full _ -> resp .== NotFound+ Borrow Unavail _ -> resp .== NotFound+ Borrow Avail _ -> resp .== Updated+ AddCopy Exist _ -> resp .== Updated+ Return Taken _ -> resp .== Updated+ FindByIsbn Invalid _ -> resp .== Rows []+ FindByAuthor Invalid _ -> resp .== Rows []+ FindByTitle Invalid _ -> resp .== Rows []+ FindByIsbn Exist key -> case lookup key m of+ Just x -> Rows [x] .== resp+ _ -> error "Should not happen"+ FindByAuthor Exist x -> case resp of+ Rows rs -> Forall rs (Boolean . isInfixOf x . author) .&&+ Forall rs (\b -> Just b .== lookup (Isbn $ isbn b) m)+ _ -> Bot .// "findByAuthor returned " ++ (show resp)+ FindByTitle Exist x -> case resp of+ Rows rs -> Forall rs (Boolean . isInfixOf x . title) .&&+ Forall rs (\b -> Just b .== lookup (Isbn $ isbn b) m)+ _ -> Bot .// "findByTitle returned " ++ (show resp)+ _ -> Bot++-- Transitions of the state machine that models SUT++transitions :: Model r -> Command r -> Response r -> Model r+transitions (Model m) cmd _ = Model $ case cmd of+ NewBook New key t a -> (key, Book (getString key) t a 0 0):m+ AddCopy Exist key -> map (applyForKey key $ incOwned . incAvail) m+ Borrow Avail key -> map (applyForKey key decAvail) m+ Return Taken key -> map (applyForKey key incAvail) m+ _ -> m+ where+ applyForKey key fn (k, v) = (k, if k == key then fn v else v)+ incOwned row = row { owned = 1 + owned row }+ incAvail row = row { avail = 1 + avail row }+ decAvail row = row { avail = (avail row) - 1 }++-- Semantics++data Bug = Bug | NoBug | Injection deriving stock Eq++semantics :: Bug -> Command Concrete -> ReaderT ConnectInfo IO (Response Concrete)+semantics bug cmd = do+ connInfo <- ask+ liftIO $ withConnection connInfo $ \cn -> case cmd of+ NewBook _ (Isbn key) t a -> toResp insertRes <$> addBook key t a cn+ AddCopy _ (Isbn key) -> toResp updateRes <$> addCopy key cn+ Borrow _ (Isbn key) -> toResp updateRes <$> borrowCopy key cn+ Return _ (Isbn key) -> toResp updateRes <$> returnCopy bug key cn+ FindByAuthor _ x -> toResp Rows <$> findByAuthor bug x cn+ FindByTitle _ x -> toResp Rows <$> findByTitle bug x cn+ FindByIsbn _ (Isbn key) -> toResp Rows <$> findByIsbn key cn+ where toResp = maybe UniqueError+ updateRes 0 = NotFound+ updateRes 1 = Updated+ updateRes _ = OtherError+ insertRes 1 = Inserted+ insertRes _ = OtherError++-- Mock is currently not used by the library++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock (Model m) cmd = return $ case cmd of+ NewBook New _ _ _ -> Inserted+ NewBook Exist _ _ _ -> UniqueError+ AddCopy Invalid _ -> NotFound+ AddCopy Exist _ -> Updated+ Borrow Invalid _ -> NotFound+ Borrow Avail _ -> Updated+ Borrow Unavail _ -> NotFound+ Return Invalid _ -> NotFound+ Return Taken _ -> Updated+ Return Full _ -> NotFound+ FindByTitle Exist x -> Rows $ filter (isInfixOf x . title) (codomain m)+ FindByAuthor Exist x -> Rows $ filter (isInfixOf x . author) (codomain m)+ FindByIsbn Exist key -> Rows [fromJust (lookup key m)]+ FindByTitle Invalid _ -> Rows []+ FindByIsbn Invalid _ -> Rows []+ FindByAuthor Invalid _ -> Rows []+ _ -> error $ (show cmd) ++ " should not happen"++-- Property++sm :: Bug -> StateMachine Model Command (ReaderT ConnectInfo IO) Response+sm bug = StateMachine initModel transitions preconditions postconditions+ Nothing generator shrinker (semantics bug) mock noCleanup++runner :: IO String -> ReaderT ConnectInfo IO Property -> IO Property+runner io p = do+ dbIp <- io+ let connInfo = defaultConnectInfo {+ connectUser = "postgres"+ , connectPassword = "mysecretpassword"+ , connectDatabase = "postgres"+ , connectPort = 5432+ , connectHost = dbIp+ }+ bracket (withConnection connInfo setupTable)+ (const (withConnection connInfo teardown))+ (const (runReaderT p connInfo))++prop_bookstore :: Bug -> IO String -> Property+prop_bookstore bug io =+ forAllCommands sm' Nothing $ \cmds -> monadic (ioProperty . runner io) $ do+ (hist, _, res) <- runCommands sm' cmds++ prettyCommands sm' hist $ res === Ok+ where+ sm' = sm bug++-- Setup PostgreSQL db in Docker++setup :: IO (String, String)+setup = do+ pid <- trim <$> readProcess "docker"+ [ "run"+ , "-d"+ , "-e", "POSTGRES_PASSWORD=mysecretpassword"+ , "postgres:10.2"+ ] ""+ ip <- trim <$> readProcess "docker"+ [ "inspect"+ , pid+ , "--format"+ , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"+ ] ""+ healthyDb pid ip `onException` callProcess "docker" [ "rm", "-f", "-v", pid ]+ return (pid, ip)+ where+ trim :: String -> String+ trim = dropWhileEnd isGarbage . dropWhile isGarbage+ where+ isGarbage = flip elem ['\'', '\n']++ healthyDb :: String -> String -> IO ()+ healthyDb pid ip = do+ sock <- go 10+ Sock.close sock+ where+ go :: Int -> IO Socket+ go 0 = error "healthyDb: db isn't healthy"+ go n = do+ let hints = defaultHints+ { addrFlags = [AI_NUMERICHOST , AI_NUMERICSERV]+ , addrSocketType = Stream+ }+ addr : _ <- getAddrInfo (Just hints) (Just ip) (Just "5432")+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ (Sock.connect sock (addrAddress addr) >>+ readProcess "docker"+ [ "exec"+ , "-u", "postgres"+ , pid+ , "psql", "-U", "postgres", "-d", "postgres", "-c", "SELECT 1 + 1"+ ] "" >> return sock)+ `catch` (\(_ :: IOException) -> do+ threadDelay 1000000+ go (n - 1))++cleanup :: (String, String) -> IO ()+cleanup (pid, _) = callProcess "docker" [ "rm", "-f", "-v", pid ]
test/CircularBuffer.hs view
@@ -1,15 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -50,16 +48,12 @@ (Type) import Data.Maybe (isJust)-import Data.TreeDiff- (ToExpr) import Data.Vector.Unboxed.Mutable (IOVector) import qualified Data.Vector.Unboxed.Mutable as V import GHC.Generics (Generic, Generic1)-import Prelude hiding- (elem)-import qualified Prelude as P+import Prelude import Test.QuickCheck (Gen, Positive(..), Property, arbitrary, elements, frequency, shrink, (===))@@ -79,11 +73,11 @@ -- See 'unpropNoSizeCheck', 'unpropFullIsEmpty', 'unpropBadRem', -- and 'unpropStillBadRem'. data Bug = NoSizeCheck | FullIsEmpty | BadRem | StillBadRem- deriving (Eq, Enum)+ deriving stock (Eq, Enum) -- | Switch to disable or enable testing of the 'lenBuffer' function. data Version = NoLen | YesLen- deriving Eq+ deriving stock Eq ------------------------------------------------------------------------ @@ -109,7 +103,7 @@ newBuffer bugs n = Buffer <$> newIORef 0 <*> newIORef 0- <*> V.new (if FullIsEmpty `P.elem` bugs then n else n + 1)+ <*> V.new (if FullIsEmpty `elem` bugs then n else n + 1) -- | See 'Put'. putBuffer :: Int -> Buffer -> IO ()@@ -132,9 +126,9 @@ i <- readIORef top j <- readIORef bot return $- if BadRem `P.elem` bugs then+ if BadRem `elem` bugs then (i - j) `rem` V.length arr- else if StillBadRem `P.elem` bugs then+ else if StillBadRem `elem` bugs then abs ((i - j) `rem` V.length arr) else (i - j) `mod` V.length arr@@ -154,14 +148,16 @@ -- | Get the number of elements in the buffer. | Len (Reference (Opaque Buffer) r)- deriving (Show, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames) data Response (r :: Type -> Type) = NewR (Reference (Opaque Buffer) r) | PutR | GetR Int | LenR Int- deriving (Show, Generic1, Rank2.Foldable)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable) ------------------------------------------------------------------------ @@ -173,7 +169,8 @@ { specSize :: Int -- ^ Maximum number of elements , specContents :: [Int] -- ^ Contents of the buffer }- deriving (Generic, Show, ToExpr)+ deriving stock (Generic, Show)+ deriving anyclass (ToExpr) emptySpecBuffer :: Int -> SpecBuffer emptySpecBuffer n = SpecBuffer n []@@ -188,9 +185,9 @@ -- | The model is a map from buffer references to their values. newtype Model r = Model [(Reference (Opaque Buffer) r, SpecBuffer)]- deriving (Generic, Show)+ deriving stock (Generic, Show) -deriving instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr (Model Concrete) -- | Initially, there are no references to buffers. initModel :: Model v@@ -198,15 +195,15 @@ precondition :: Bugs -> Model Symbolic -> Action Symbolic -> Logic precondition _ _ (New n) = n .> 0-precondition bugs (Model m) (Put _ buffer) | NoSizeCheck `P.elem` bugs =- buffer `elem` map fst m+precondition bugs (Model m) (Put _ buffer) | NoSizeCheck `elem` bugs =+ buffer `member` map fst m precondition _ (Model m) (Put _ buffer) = Boolean $ isJust $ do specBuffer <- lookup buffer m guard $ length (specContents specBuffer) < specSize specBuffer precondition _ (Model m) (Get buffer) = Boolean $ isJust $ do specBuffer <- lookup buffer m guard $ not (null (specContents specBuffer))-precondition _ (Model m) (Len buffer) = buffer `elem` map fst m+precondition _ (Model m) (Len buffer) = buffer `member` map fst m transition :: Eq1 r => Model r -> Action r -> Response r -> Model r transition (Model m) (New n) (NewR ref) =@@ -285,7 +282,7 @@ sm :: Version -> Bugs -> StateMachine Model Action IO Response sm version bugs = StateMachine initModel transition (precondition bugs) postcondition- Nothing (generator version) Nothing shrinker (semantics bugs) mock+ Nothing (generator version) shrinker (semantics bugs) mock noCleanup -- | Property parameterized by spec version and bugs. prepropcircularBuffer :: Version -> Bugs -> Property
+ test/Cleanup.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Cleanup (+ Bug (..)+ , DoubleCleanup (..)+ , FinalTest (..)+ , prop_sequential_clean+ , prop_parallel_clean+ , prop_nparallel_clean+ ) where++import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.Functor.Classes+ (Ord1, Show1)+import Data.List+ ((\\))+import Data.Map.Strict+ (Map)+import qualified Data.Map.Strict as Map+import GHC.Generics+ (Generic, Generic1)+import Prelude+import System.Directory+import System.IO+import System.Random+import Test.QuickCheck+import Test.QuickCheck.Monadic+ (monadicIO)+import Test.StateMachine+import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.Utils+ (liftProperty, mkModel, whenFailM)+import Text.Show.Pretty+ (ppShow)++{-----------------------------------------------------------------------------------+ This example in mainly used to check how well cleanup of recourses works. In our+ case recourses are files created on the @testDirectory@ (not open handles, just+ files). So it is easy, by the end of the tests to test if there any any recourses+ which are not cleaned up, by the end of the tests.++ We also test different scenarios, like injected exceptions in semantics+ (before and after the recourse is created). Tests also reveal what happens when+ cleaning up a recourse for the second time is not a no-op.++-----------------------------------------------------------------------------------}+data Command r+ = Create String+ | Delete (Reference (Opaque FileRef) r)+ | Ls+ | Write Int+ | Increment+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++deriving stock instance Show (Command Symbolic)+deriving stock instance Read (Command Symbolic)+deriving stock instance Show (Command Concrete)++data Response r+ = Created (Reference (Opaque FileRef) r)+ | Deleted+ | Contents [String]+ | ChangedValue Int+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Foldable)++deriving stock instance Show (Response Symbolic)+deriving stock instance Read (Response Symbolic)+deriving stock instance Show (Response Concrete)++data Model r = Model {+ files :: Map (Reference (Opaque FileRef) r) String+ , counter :: Int+ , semanticsCounter :: Opaque (MVar Int)+ , ref :: Opaque (MVar Int)+ , value :: Int+ }+ deriving stock (Generic, Show, Eq)++instance ToExpr (Model Symbolic)+instance ToExpr (Model Concrete)++initModel :: MVar Int -> MVar Int -> Model r+initModel sc ref = Model Map.empty 0 (Opaque sc) (Opaque ref) 0++transition :: Ord1 r => Model r -> Command r -> Response r -> Model r+transition m@Model {..} cmd resp = case (cmd, resp) of+ (Create p, Created rf) -> m {files = Map.insert rf p files, counter = counter + 1}+ (Delete rf, Deleted) -> m {files = Map.delete rf files}+ (Ls, Contents _) -> m+ (Write n, ChangedValue _) -> m {value = n}+ (Increment, ChangedValue _) -> m {value = value + 1}+ _ -> error "transition impossible"++precondition :: Model Symbolic -> Command Symbolic -> Logic+precondition Model {..} cmd = case cmd of+ Create p -> Boolean $ notElem p (Map.elems files)+ Delete rf -> Boolean $ Map.member rf files+ Ls -> Top+ Write _ -> Top+ Increment -> Top++sameElements :: Eq a => [a] -> [a] -> Bool+sameElements x y = null (x \\ y) && null (y \\ x)++postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postcondition Model{..} cmd resp = case (cmd, resp) of+ (Create _, Created _) -> Top+ (Delete _, Deleted) -> Top+ (Ls, Contents ls) -> if sameElements ls (Map.elems files) then Top+ else Annotate ("Not same elements between " ++ show ls ++ "and " ++ show (Map.elems files)) Bot+ (Increment, ChangedValue _) -> Top+ (Write n, ChangedValue m) -> m .== n+ _ -> Bot++data MVarC a = MVarC (MVar a) Int+type FileRef = MVarC (String, Bool)++removeFileRef :: DoubleCleanup -> FileRef -> IO ()+removeFileRef dc (MVarC r _) = modifyMVar_ r $ \(file, isHere) -> do+ case (isHere, dc) of+ (_, ReDo) -> removeFile file+ (True, _) -> removeFile file+ (False, NoOp) -> return ()+ return (file, False)++instance Eq (MVarC a) where+ MVarC _ a == MVarC _ b = a == b++instance Ord (MVarC a) where+ compare (MVarC _ a) (MVarC _ b) = compare a b++semantics :: MVar Int -> MVar Int -> String -> Bug -> Command Concrete -> IO (Response Concrete)+semantics counter ref tstDir bug cmd = case cmd of+ Create f -> createFile f+ `onException` removePathForcibly (makePath tstDir f)+ Delete rf -> do+ let MVarC lockedFile _ = unOpaque $ concrete rf+ modifyMVar_ lockedFile $ \(file, _) -> do+ removeFile file+ return (file, False)+ return Deleted+ Ls -> do+ ls <- listDirectory tstDir+ return $ Contents ls+ Write n ->+ modifyMVar ref (\_ -> return (n, ChangedValue n))+ Increment ->+ modifyMVar ref (\m -> return (m + 1, ChangedValue $ m + 1))+ where+ createFile :: String -> IO (Response Concrete)+ createFile f = do+ let path = makePath tstDir f+ c <- modifyMVar counter $ \n -> return (n + 1, n)+ when (c > 3 && bug == Exception) $+ throwIO $ userError "semantics injected bug"+ withFile path WriteMode (\_ -> return ())+ when (c > 3 && bug == ExcAfter) $+ throwIO $ userError "semantics injected bug"+ rf <- newMVar (path, True)+ return $ Created $ reference $ Opaque $ MVarC rf c++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock Model{..} cmd = case cmd of+ Create _ -> Created <$> genSym+ Delete _ -> return Deleted+ Ls -> return $ Contents $ Map.elems files+ Write n -> return $ ChangedValue n+ Increment -> return $ ChangedValue $ value + 1++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator Model{..} = Just $ do+ n <- choose (1,10)+ frequency+ [ (7, return $ Create $ mkFileName counter)+ , (if Map.null files then 0 else 3, Delete . fst <$> elements (Map.toList files))+ , (1, return Ls)+ , (1, return $ Write n)+ , (1, return Increment)+ ]++shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic]+shrinker _ _ = []++cleanup :: String -> DoubleCleanup -> Model Concrete -> IO ()+cleanup testDir dc Model{..} = do+ let cl = do+ forM_ (Map.keys files) $ \rf ->+ removeFileRef dc $ unOpaque $ concrete rf+ modifyMVar_ (unOpaque semanticsCounter) (\_ -> return 0)+ modifyMVar_ (unOpaque ref) (\_ -> return 0)+ -- onException here does not affect any tests. It just makes sure+ -- no leftover directories remain after the end of tests.+ -- We have it here, because we found no other way to handle the+ -- exceptions in the ProperyM level.+ cl `onException` removePathForcibly testDir++sm :: MVar Int -> MVar Int -> String -> Bug -> DoubleCleanup -> StateMachine Model Command IO Response+sm counter ref tstDir bug dc = StateMachine (initModel counter ref) transition precondition postcondition+ Nothing generator shrinker (semantics counter ref tstDir bug) mock (cleanup tstDir dc)++smUnused :: StateMachine Model Command IO Response+smUnused = sm undefined undefined undefined undefined undefined++prop_sequential_clean :: FinalTest -> Bug -> DoubleCleanup -> Property+prop_sequential_clean testing bug dc = forAllCommands smUnused Nothing $ \cmds -> monadicIO $ do+ folderId :: Word <- liftIO randomIO+ let testDir = testDirectoryBase ++ "-" ++ show folderId+ liftIO $ do+ removePathForcibly testDir+ createDirectory testDir+ c <- liftIO $ newMVar 0+ ref <- liftIO $ newMVar 0+ let sm' = sm c ref testDir bug dc+ (hist, model, res) <- runCommands sm' cmds+ ls <- liftIO $ listDirectory testDir+ liftIO $ removePathForcibly testDir+ case testing of+ Regular -> prettyCommands sm' hist $ checkCommandNames cmds (res === Ok)+ Files -> printFiles ls `whenFailM` (ls === [])+ Eq _ -> liftProperty $ mkModel sm' hist === model++prop_parallel_clean :: FinalTest -> Bug -> DoubleCleanup -> Property+prop_parallel_clean testing bug dc = forAllParallelCommands smUnused Nothing $ \cmds -> monadicIO $ do+ folderId :: Word <- liftIO randomIO+ let testDir = testDirectoryBase ++ "-" ++ show folderId+ liftIO $ do+ removePathForcibly testDir+ createDirectory testDir+ c <- liftIO $ newMVar 0+ ref <- liftIO $ newMVar 0+ let sm' = sm c ref testDir bug dc+ ret <- runParallelCommandsNTimes 2 sm' cmds+ ls <- liftIO $ listDirectory testDir+ liftIO $ removePathForcibly testDir+ case testing of+ Regular -> prettyParallelCommands cmds ret+ Files -> printFiles ls `whenFailM` (ls === [])+ Eq bl -> do+ let (a, b) = case mkModel sm' . fst <$> ret of+ (x : y : _) -> (x,y)+ _ -> error "expected at least two histories"+ liftProperty $ printModels a b `whenFail`+ property (modelEquivalence bl a b)++prop_nparallel_clean :: Int -> FinalTest -> Bug -> DoubleCleanup -> Property+prop_nparallel_clean np testing bug dc = forAllNParallelCommands smUnused np $ \cmds -> monadicIO $ do+ folderId :: Word <- liftIO randomIO+ let testDir = testDirectoryBase ++ "-" ++ show folderId+ liftIO $ do+ removePathForcibly testDir+ createDirectory testDir+ c <- liftIO $ newMVar 0+ ref <- liftIO $ newMVar 0+ let sm' = sm c ref testDir bug dc+ ret <- runNParallelCommandsNTimes 2 sm' cmds+ ls <- liftIO $ listDirectory testDir+ liftIO $ removePathForcibly testDir+ case testing of+ Regular -> prettyNParallelCommands cmds ret+ Files -> printFiles ls `whenFailM` (ls === [])+ Eq bl -> do+ let (a, b) = case mkModel sm' . fst <$> ret of+ (x : y : _) -> (x,y)+ _ -> error "expected at least two histories"+ liftProperty $ printModels a b `whenFail`+ property (modelEquivalence bl a b)++printModels :: Show1 r => Model r -> Model r -> IO ()+printModels a b =+ putStrLn $ "Models are not equivalent: \n" ++ ppShow a ++ " \nand \n" ++ ppShow b++printFiles :: [String] -> IO ()+printFiles ls' =+ putStrLn $ "Cleanup was not complete. Found files " ++ show ls'++data Bug = NoBug+ | Exception+ | ExcAfter+ deriving stock (Eq, Show)++data DoubleCleanup = NoOp+ | ReDo+ deriving stock (Eq, Show)++data FinalTest = Regular+ | Files+ | Eq Bool+ deriving stock (Eq, Show)++-- | This is meant to be used, in order to test equality of two+-- Models, created by two different executions of the same program.+-- Note that we don't test reference equality. This is because+-- different executions in the parallel case, may create references+-- with different order, so the counter assigned by the semantics+-- can be different.+modelEquivalence :: Bool -> Model Concrete -> Model Concrete -> Bool+modelEquivalence bl a b =+ sameElements (Map.elems $ files a) (Map.elems $ files b)+ && counter a == counter b+ && (not bl || value a == value b)++makePath :: String -> String -> String+makePath tstDir file = tstDir ++ "/" ++ file++mkFileName :: Int -> String+mkFileName n = "file" ++ show n++testDirectoryBase :: String+testDirectoryBase = "cleanup-test-folder"
test/CrudWebserverDb.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -14,6 +15,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- NOTE: Make sure NOT to use DeriveAnyClass, or persistent-template -- will do the wrong thing.@@ -25,7 +28,7 @@ -- (C) 2017-2018, Stevan Andjelkovic -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -62,9 +65,7 @@ import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) import Control.Exception- (IOException, bracket)-import Control.Exception- (catch)+ (IOException, bracket, catch, onException) import Control.Monad.Logger (NoLoggingT, runNoLoggingT) import Control.Monad.Reader@@ -81,7 +82,6 @@ import Data.List (dropWhileEnd) import Data.Monoid- ((<>)) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions@@ -90,11 +90,11 @@ (Text) import qualified Data.Text as T import Data.TreeDiff- (Expr(App), ToExpr, toExpr)+ (Expr(App))+import Database.Persist.Class import Database.Persist.Postgresql- (ConnectionPool, ConnectionString, Key, SqlBackend,- delete, get, getJust, insert, liftSqlPersistMPool,- replace, runMigration, runSqlPool, update,+ (ConnectionPool, ConnectionString, SqlBackend,+ liftSqlPersistMPool, runMigrationQuiet, runSqlPool, withPostgresqlPool, (+=.)) import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share,@@ -104,14 +104,12 @@ import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) import Network.Socket- (AddrInfoFlag(AI_NUMERICSERV, AI_NUMERICHOST),+ (AddrInfoFlag(AI_NUMERICHOST, AI_NUMERICSERV), Socket, SocketType(Stream), addrAddress, addrFamily, addrFlags, addrProtocol, addrSocketType, close, connect, defaultHints, getAddrInfo, socket) import qualified Network.Wai.Handler.Warp as Warp-import Prelude hiding- (elem)-import qualified Prelude+import Prelude import Servant ((:<|>)(..), (:>), Application, Capture, Delete, Get, JSON, Post, Put, ReqBody, Server, serve)@@ -241,7 +239,7 @@ | GetUser (Reference (Key User) r) | IncAgeUser (Reference (Key User) r) | DeleteUser (Reference (Key User) r)- deriving (Show, Generic1)+ deriving stock (Show, Generic1) instance Rank2.Functor Action where instance Rank2.Foldable Action where@@ -253,7 +251,7 @@ | GotUser (Maybe User) | IncedAgeUser | DeletedUser- deriving (Show, Generic1)+ deriving stock (Show, Generic1) instance Rank2.Foldable Response where @@ -262,7 +260,7 @@ newtype Model r = Model [(Reference (Key User) r, User)]- deriving (Generic, Show)+ deriving stock (Generic, Show) instance ToExpr (Model Concrete) where @@ -293,9 +291,9 @@ preconditions :: Model Symbolic -> Action Symbolic -> Logic preconditions _ (PostUser _) = Top-preconditions (Model m) (GetUser key) = key `elem` map fst m-preconditions (Model m) (IncAgeUser key) = key `elem` map fst m-preconditions (Model m) (DeleteUser key) = key `elem` map fst m+preconditions (Model m) (GetUser key) = key `member` map fst m+preconditions (Model m) (IncAgeUser key) = key `member` map fst m+preconditions (Model m) (DeleteUser key) = key `member` map fst m @@ -312,7 +310,8 @@ -- * How to generate and shrink programs. generator :: Model Symbolic -> Maybe (Gen (Action Symbolic))-generator (Model m) = Just $ frequency+generator (Model []) = Just $ PostUser <$> arbitrary+generator (Model m) = Just $ frequency [ (1, PostUser <$> arbitrary) , (3, GetUser <$> elements (map fst m)) , (4, IncAgeUser <$> elements (map fst m))@@ -351,7 +350,7 @@ sm :: StateMachine Model Action (ReaderT ClientEnv IO) Response sm = StateMachine initModel transitions preconditions postconditions- Nothing generator Nothing shrinker semantics mock+ Nothing generator shrinker semantics mock noCleanup ------------------------------------------------------------------------ -- * Sequential property@@ -387,7 +386,7 @@ prop_crudWebserverDbParallel :: Int -> Property prop_crudWebserverDbParallel port =- forAllParallelCommands sm $ \cmds -> monadic (ioProperty . runner port) $ do+ forAllParallelCommands sm Nothing $ \cmds -> monadic (ioProperty . runner port) $ prettyParallelCommands cmds =<< runParallelCommandsNTimes 30 sm cmds demoRace' :: Int -> IO ()@@ -405,7 +404,7 @@ mkApp :: Bug -> ConnectionString -> IO Application mkApp bug conn = runNoLoggingT $ withPostgresqlPool (cs conn) 10 $ \pool -> do- runSqlPool (runMigration migrateAll) pool+ _ <- runSqlPool (runMigrationQuiet migrateAll) pool return (app bug pool) runServer :: Bug -> ConnectionString -> Warp.Port -> IO () -> IO ()@@ -488,21 +487,21 @@ , "--format" , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'" ] ""- healthyDb ip+ healthyDb pid ip `onException` callProcess "docker" [ "rm", "-f", "-v", pid ] return (pid, ip) where trim :: String -> String trim = dropWhileEnd isGarbage . dropWhile isGarbage where- isGarbage = flip Prelude.elem ['\'', '\n']+ isGarbage = flip elem ['\'', '\n'] - healthyDb :: String -> IO ()- healthyDb ip = do+ healthyDb :: String -> String -> IO ()+ healthyDb pid ip = do sock <- go 10 close sock where go :: Int -> IO Socket- go 0 = error "healtyDb: db isn't healthy"+ go 0 = error "healthyDb: db isn't healthy" go n = do let hints = defaultHints { addrFlags = [AI_NUMERICHOST , AI_NUMERICSERV]@@ -510,7 +509,13 @@ } addr : _ <- getAddrInfo (Just hints) (Just ip) (Just "5432") sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)- (connect sock (addrAddress addr) >> return sock)+ (connect sock (addrAddress addr) >>+ readProcess "docker"+ [ "exec"+ , "-u", "postgres"+ , pid+ , "psql", "-U", "postgres", "-d", "postgres", "-c", "SELECT 1 + 1"+ ] "" >> return sock) `catch` (\(_ :: IOException) -> do threadDelay 1000000 go (n - 1))@@ -518,5 +523,5 @@ cleanup :: (String, Async ()) -> IO () cleanup (pid, aServer) = do- callProcess "docker" [ "rm", "-f", pid ]+ callProcess "docker" [ "rm", "-f", "-v", pid ] cancel aServer
test/DieHard.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -14,7 +13,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -33,8 +32,6 @@ import Data.Kind (Type)-import Data.TreeDiff- (ToExpr) import GHC.Generics (Generic, Generic1) import Prelude@@ -61,10 +58,12 @@ | SmallIntoBig -- Pour the contents of the 3-liter jug -- into 5-liter jug. | BigIntoSmall- deriving (Eq, Show, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)+ deriving stock (Eq, Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames) data Response (r :: Type -> Type) = Done- deriving (Show, Generic1, Rank2.Foldable)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable) ------------------------------------------------------------------------ @@ -74,9 +73,9 @@ data Model (r :: Type -> Type) = Model { bigJug :: Int , smallJug :: Int- } deriving (Show, Eq, Generic)+ } deriving stock (Show, Eq, Generic) -deriving instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr (Model Concrete) initModel :: Model r initModel = Model 0 0@@ -157,7 +156,7 @@ sm :: StateMachine Model Command IO Response sm = StateMachine initModel transitions preconditions postconditions- Nothing generator Nothing shrinker semantics mock+ Nothing generator shrinker semantics mock noCleanup prop_dieHard :: Property prop_dieHard = forAllCommands sm Nothing $ \cmds -> monadicIO $ do
test/Echo.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} @@ -12,7 +12,7 @@ -- Copyright : (C) 2018, Damian Nadales -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -21,14 +21,13 @@ module Echo ( mkEnv , prop_echoOK+ , prop_echoNParallelOK , prop_echoParallelOK ) where import Data.Kind (Type)-import Data.TreeDiff- (ToExpr) import GHC.Generics (Generic, Generic1) import Prelude@@ -37,7 +36,8 @@ import Test.QuickCheck.Monadic (monadicIO) import UnliftIO- (TVar, atomically, newTVarIO, readTVar, writeTVar)+ (TVar, atomically, liftIO, newTVarIO, readTVar,+ writeTVar) import Test.StateMachine import Test.StateMachine.Types@@ -74,19 +74,32 @@ -- | Spec for echo. -prop_echoOK :: Env -> Property-prop_echoOK env = forAllCommands echoSM' Nothing $ \cmds -> monadicIO $ do+prop_echoOK :: Property+prop_echoOK = forAllCommands smUnused Nothing $ \cmds -> monadicIO $ do+ env <- liftIO $ mkEnv+ let echoSM' = echoSM env (hist, _, res) <- runCommands echoSM' cmds prettyCommands echoSM' hist (res === Ok)- where echoSM' = echoSM env -prop_echoParallelOK :: Bool -> Env -> Property-prop_echoParallelOK problem env = forAllParallelCommands echoSM' $ \cmds -> monadicIO $ do+prop_echoParallelOK :: Bool -> Property+prop_echoParallelOK problem = forAllParallelCommands smUnused Nothing $ \cmds -> monadicIO $ do+ env <- liftIO $ mkEnv+ let echoSM' = echoSM env let n | problem = 2 | otherwise = 1 prettyParallelCommands cmds =<< runParallelCommandsNTimes n echoSM' cmds- where echoSM' = echoSM env +prop_echoNParallelOK :: Int -> Bool -> Property+prop_echoNParallelOK np problem = forAllNParallelCommands smUnused np $ \cmds -> monadicIO $ do+ env <- liftIO $ mkEnv+ let echoSM' = echoSM env+ let n | problem = 2+ | otherwise = 1+ prettyNParallelCommands cmds =<< runNParallelCommandsNTimes n echoSM' cmds++smUnused :: StateMachine Model Action IO Response+smUnused = echoSM $ error "used env during command generation"+ echoSM :: Env -> StateMachine Model Action IO Response echoSM env = StateMachine { initModel = Empty@@ -96,10 +109,10 @@ , postcondition = mPostconditions , generator = mGenerator , invariant = Nothing- , distribution = Nothing , shrinker = mShrinker , semantics = mSemantics , mock = mMock+ , cleanup = noCleanup } where mTransitions :: Model r -> Action r -> Response r -> Model r@@ -151,7 +164,7 @@ mMock Empty Echo = return ErrEmpty mMock (Buf str) Echo = return (Out str) -deriving instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr (Model Concrete) -- | The model contains the last string that was communicated in an input -- action.@@ -160,7 +173,7 @@ Empty | -- | Last input string (a buffer with size one). Buf String- deriving (Eq, Show, Generic)+ deriving stock (Eq, Show, Generic) -- | Actions supported by the system. data Action (r :: Type -> Type)@@ -168,7 +181,8 @@ In String -- | Request a string output. | Echo- deriving (Show, Generic1, Rank2.Foldable, Rank2.Traversable, Rank2.Functor, CommandNames)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable, Rank2.Traversable, Rank2.Functor, CommandNames) -- | The system gives a single type of output response, containing a string -- with the input previously received.@@ -182,4 +196,5 @@ | ErrFull -- | Output string. | Out String- deriving (Show, Generic1, Rank2.Foldable, Rank2.Traversable, Rank2.Functor)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable, Rank2.Traversable, Rank2.Functor)
test/ErrorEncountered.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} module ErrorEncountered ( prop_error_sequential+ , prop_error_nparallel , prop_error_parallel ) where@@ -14,12 +16,9 @@ (Eq1) import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.TreeDiff- (ToExpr) import GHC.Generics (Generic, Generic1)-import Prelude hiding- (elem)+import Prelude import Test.QuickCheck (Gen, Property, arbitrary, elements, frequency, shrink, (===))@@ -27,8 +26,6 @@ (monadicIO) import Test.StateMachine-import Test.StateMachine.Types- (Reference(..), Symbolic(..)) import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.StateMachine.Z @@ -48,25 +45,27 @@ = Create | Read (Reference (Opaque (IORef Int)) r) | Write (Reference (Opaque (IORef Int)) r) Int- deriving (Eq, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames) -deriving instance Show (Command Symbolic)-deriving instance Show (Command Concrete)+deriving stock instance Show (Command Symbolic)+deriving stock instance Show (Command Concrete) data Response r = Created (Reference (Opaque (IORef Int)) r) | ReadValue Int | Written | WriteFailed- deriving (Generic1, Rank2.Foldable)+ deriving stock (Generic1)+ deriving anyclass (Rank2.Foldable) -deriving instance Show (Response Symbolic)-deriving instance Show (Response Concrete)+deriving stock instance Show (Response Symbolic)+deriving stock instance Show (Response Concrete) data Model r = Model [(Reference (Opaque (IORef Int)) r, Int)] | ErrorEncountered- deriving (Generic, Show)+ deriving stock (Generic, Show) instance ToExpr (Model Symbolic) instance ToExpr (Model Concrete)@@ -90,8 +89,8 @@ precondition ErrorEncountered _ = Bot precondition (Model m) cmd = case cmd of Create -> Top- Read ref -> ref `elem` domain m- Write ref _ -> ref `elem` domain m+ Read ref -> ref `member` domain m+ Write ref _ -> ref `member` domain m postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic postcondition (Model m) cmd resp = case (cmd, resp) of@@ -127,6 +126,7 @@ | otherwise -> pure WriteFailed generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator (Model []) = Just $ pure Create generator (Model model) = Just $ frequency [ (1, pure Create) , (4, Read <$> elements (domain model))@@ -140,7 +140,7 @@ sm :: StateMachine Model Command IO Response sm = StateMachine initModel transition precondition postcondition- Nothing generator Nothing shrinker semantics mock+ Nothing generator shrinker semantics mock noCleanup prop_error_sequential :: Property prop_error_sequential = forAllCommands sm Nothing $ \cmds -> monadicIO $ do@@ -148,5 +148,9 @@ prettyCommands sm hist (checkCommandNames cmds (res === Ok)) prop_error_parallel :: Property-prop_error_parallel = forAllParallelCommands sm $ \cmds -> monadicIO $ do+prop_error_parallel = forAllParallelCommands sm Nothing $ \cmds -> monadicIO $ prettyParallelCommands cmds =<< runParallelCommands sm cmds++prop_error_nparallel :: Int -> Property+prop_error_nparallel np = forAllNParallelCommands sm np $ \cmds -> monadicIO $+ prettyNParallelCommands cmds =<< runNParallelCommands sm cmds
+ test/Hanoi.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}++------------------------------------------------------------------------+-- |+-- Module : Hanoi+-- Copyright : (C) 2019, Adam Boniecki+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Adam Boniecki <adambonie@gmail.com>+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Solution to the famous Tower of Hanoi puzzle using tools for state+-- machine property-based testing.+--+-- The puzzle is to move N discs of different sizes from one peg to+-- another, with one auxiliary peg and a restriction that no disc may ever+-- be placed on top of a smaller disc. Only one disc can be moved at a time.++------------------------------------------------------------------------++module Hanoi+ ( prop_hanoi+ ) where++import Data.Array+import Data.Kind+ (Type)+import Data.Maybe+import Data.TreeDiff.Expr+ ()+import GHC.Generics+ (Generic, Generic1)+import Prelude+import Test.QuickCheck+ (Arbitrary(arbitrary), Gen, Property, choose,+ suchThat, (===))+import Test.QuickCheck.Monadic+ (monadicIO)++import Test.StateMachine+import qualified Test.StateMachine.Types.Rank2 as Rank2++------------------------------------------------------------------------++-- The model keeps track of which disc is on which peg++newtype Model (r :: Type -> Type) = Model (Array Int [Int])+ deriving stock (Show, Eq, Generic)++-- There are 3 pegs, so the bounds are (0, 2)++pegsBounds :: (Int,Int)+pegsBounds = (0, 2)++instance ToExpr (Model r) where+ toExpr (Model a) = toExpr $ elems a++initModel :: Int -> Model r+initModel discs = Model $ listArray pegsBounds [[1..discs], [], []]++-- Allowed action is to move one disc from the top of one peg to the top of another++data Command (r :: Type -> Type) = Move (Int,Int)+ deriving stock (Eq, Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++instance Arbitrary (Command r) where+ arbitrary = do+ x <- choose pegsBounds+ y <- choose pegsBounds `suchThat` (/= x)+ return $ Move (x,y)++data Response (r :: Type -> Type) = Done+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable)++------------------------------------------------------------------------++transitions :: Model r -> Command r -> Response r -> Model r+transitions (Model pegs) (Move (from_, to_)) _ = case pegs ! from_ of+ (x : xs) -> Model $ pegs // [(from_, xs), (to_, x : pegs ! to_)]+ _ -> error "transition: impossible, due to preconditon"++preconditions :: Model Symbolic -> Command Symbolic -> Logic+preconditions (Model pegs) (Move (from_, to_)) = Boolean (isJust x) .&& x .<= y+ where+ x = listToMaybe (pegs ! from_)+ -- Any disc can be placed on empty peg, so no disc counts as largest disc.+ y = listToMaybe (pegs ! to_ ++ [maxBound])++-- Check if all discs are at the last peg. The invariant states that this is not+-- the case, so when it is not satisfied, we have a counter example that is a+-- solution to our puzzle.++postconditions :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postconditions m c r = length lst ./= sum (fmap length pegs)+ where+ lst = pegs ! (snd $ bounds pegs)+ Model pegs = transitions m c r++------------------------------------------------------------------------++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator _ = Just $ arbitrary++shrinker :: Model r -> Command r -> [Command r]+shrinker _ _ = []++------------------------------------------------------------------------++semantics :: Command Concrete -> IO (Response Concrete)+semantics _ = return Done++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock _ _ = return Done++------------------------------------------------------------------------++sm :: Int -> StateMachine Model Command IO Response+sm discs = StateMachine (initModel discs) transitions preconditions postconditions+ Nothing generator shrinker semantics mock noCleanup++-- A sequential property for Tower of Hanoi with n discs.++-- Note that optimal solution requires 2^n-1 moves and this is not guaranteeed+-- to find an optimal one (or any at all).++prop_hanoi :: Int -> Property+prop_hanoi n = forAllCommands (sm n) Nothing $ \cmds -> monadicIO $ do+ (hist, _model, res) <- runCommands (sm n) cmds+ prettyCommands (sm n) hist (checkCommandNames cmds (res === Ok))
+ test/IORefs.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module IORefs (prop_IORefs_sequential) where++import Control.Concurrent+import Data.Coerce+ (coerce)+import Data.Foldable+ (toList)+import Data.IORef+import Data.Map.Strict+ (Map)+import GHC.Generics+ (Generic)+import Prelude+import Test.QuickCheck+import Test.StateMachine++import qualified Data.Map.Strict as Map++import Test.StateMachine.Lockstep.Simple++{-------------------------------------------------------------------------------+ Instantiate the simple API+-------------------------------------------------------------------------------}++data T a++data instance Cmd (T _) h = New | Read h | Update h+ deriving stock (Show, Functor, Foldable, Traversable)++data instance Resp (T a) h = Var h | Val a | Unit ()+ deriving stock (Show, Eq, Functor, Foldable, Traversable)++data instance MockHandle (T _) = MV Int+ deriving stock (Show, Eq, Ord, Generic)++newtype instance RealHandle (T a) = RealVar (Opaque (IORef a))+ deriving stock (Eq, Show, Generic)++type instance MockState (T a) = Map (MockHandle (T a)) a++instance ToExpr (MockHandle (T a))+instance ToExpr (RealHandle (T a))++{-------------------------------------------------------------------------------+ Interpreters+-------------------------------------------------------------------------------}++runMock :: a+ -> (a -> a)+ -> Cmd (T a) (MockHandle (T a))+ -> MockState (T a) -> (Resp (T a) (MockHandle (T a)), MockState (T a))+runMock e f cmd m =+ case cmd of+ New -> let v = MV (Map.size m) in (Var v, Map.insert v e m)+ Read v -> (Val (m Map.! v), m)+ Update v -> (Unit (), Map.adjust f v m)++runReal :: a+ -> (a -> a)+ -> Cmd (T a) (RealHandle (T a))+ -> IO (Resp (T a) (RealHandle (T a)))+runReal e f cmd =+ case cmd of+ New -> Var <$> coerce <$> newIORef e+ Read r -> Val <$> readIORef (coerce r)+ Update r -> Unit <$> slowModify (coerce r) f++slowModify :: IORef a -> (a -> a) -> IO ()+slowModify r f = readIORef r >>= \a -> threadDelay 1000 >> writeIORef r (f a)++{-------------------------------------------------------------------------------+ Generator+-------------------------------------------------------------------------------}++generator :: forall a.+ Model (T a) Symbolic+ -> Maybe (Gen (Cmd (T a) :@ Symbolic))+generator (Model _ hs) = Just $ oneof $ concat [+ withoutHandle+ , if null hs then [] else withHandle+ ]+ where+ withoutHandle :: [Gen (Cmd (T a) :@ Symbolic)]+ withoutHandle = [return $ At New]++ withHandle :: [Gen (Cmd (T a) :@ Symbolic)]+ withHandle = [+ fmap At $ Update <$> genHandle+ , fmap At $ Read <$> genHandle+ ]++ genHandle :: Gen (Reference (RealHandle (T a)) Symbolic)+ genHandle = elements (map fst hs)++{-------------------------------------------------------------------------------+ Wrapping it all up++ NOTE: The parallel property will fail (intentional race condition).+-------------------------------------------------------------------------------}++ioRefTest :: StateMachineTest (T Int)+ioRefTest = StateMachineTest {+ initMock = Map.empty+ , generator = IORefs.generator+ , shrinker = \_ _ -> []+ , newHandles = toList+ , runMock = IORefs.runMock 0 (+1)+ , runReal = IORefs.runReal 0 (+1)+ , cleanup = \_ -> return ()+ }++prop_IORefs_sequential :: Property+prop_IORefs_sequential = prop_sequential ioRefTest Nothing
test/MemoryReference.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,9 +12,16 @@ module MemoryReference ( prop_sequential+ , prop_runSavedCommands , prop_parallel+ , prop_parallel'+ , prop_nparallel , prop_precondition+ , prop_existsCommands , Bug(..)+ , prop_pairs_shrink_parallel_equivalence+ , prop_pairs_shrinkAndValidate_equivalence+ , prop_pairs_shrink_parallel ) where @@ -24,15 +32,11 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.TreeDiff- (ToExpr) import GHC.Generics (Generic, Generic1)-import Prelude hiding- (elem)-import qualified Prelude+import Prelude import System.Random- (randomRIO)+ (randomIO, randomRIO) import Test.QuickCheck (Gen, Property, arbitrary, elements, frequency, once, shrink, (===))@@ -40,10 +44,20 @@ (monadicIO) import Test.StateMachine+import Test.StateMachine.Parallel+ (shrinkAndValidateNParallel,+ shrinkAndValidateParallel, shrinkCommands',+ shrinkNParallelCommands, shrinkParallelCommands)+import Test.StateMachine.Sequential+ (ShouldShrink(..)) import Test.StateMachine.Types- (Commands(..), Reference(..), Symbolic(..), Var(..))+ (Commands(Commands), Reference(..), Symbolic(..),+ Var(Var)) import qualified Test.StateMachine.Types as Types import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.Utils+ (Shrunk(..), shrinkListS, shrinkListS'',+ shrinkPairS, shrinkPairS') import Test.StateMachine.Z ------------------------------------------------------------------------@@ -53,23 +67,27 @@ | Read (Reference (Opaque (IORef Int)) r) | Write (Reference (Opaque (IORef Int)) r) Int | Increment (Reference (Opaque (IORef Int)) r)- deriving (Eq, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames) -deriving instance Show (Command Symbolic)-deriving instance Show (Command Concrete)+deriving stock instance Show (Command Symbolic)+deriving stock instance Read (Command Symbolic)+deriving stock instance Show (Command Concrete) data Response r = Created (Reference (Opaque (IORef Int)) r) | ReadValue Int | Written | Incremented- deriving (Generic1, Rank2.Foldable)+ deriving stock (Eq, Generic1)+ deriving anyclass Rank2.Foldable -deriving instance Show (Response Symbolic)-deriving instance Show (Response Concrete)+deriving stock instance Show (Response Symbolic)+deriving stock instance Read (Response Symbolic)+deriving stock instance Show (Response Concrete) newtype Model r = Model [(Reference (Opaque (IORef Int)) r, Int)]- deriving (Generic, Show)+ deriving stock (Generic, Show) instance ToExpr (Model Symbolic) instance ToExpr (Model Concrete)@@ -93,9 +111,9 @@ precondition :: Model Symbolic -> Command Symbolic -> Logic precondition (Model m) cmd = case cmd of Create -> Top- Read ref -> ref `elem` domain m- Write ref _ -> ref `elem` domain m- Increment ref -> ref `elem` domain m+ Read ref -> ref `member` domain m+ Write ref _ -> ref `member` domain m+ Increment ref -> ref `member` domain m postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic postcondition (Model m) cmd resp = case (cmd, resp) of@@ -111,20 +129,38 @@ = None | Logic | Race- deriving Eq+ | Crash+ | CrashAndLogic+ deriving stock Eq semantics :: Bug -> Command Concrete -> IO (Response Concrete) semantics bug cmd = case cmd of Create -> Created <$> (reference . Opaque <$> newIORef 0) Read ref -> ReadValue <$> readIORef (opaque ref)- Write ref i -> Written <$ writeIORef (opaque ref) i'- where- -- One of the problems is a bug that writes a wrong value to the- -- reference.- i' | i `Prelude.elem` [5..10] = if bug == Logic then i + 1 else i- | otherwise = i+ Write ref i ->+ case bug of++ -- One of the problems is a bug that writes a wrong value to the+ -- reference.+ Logic | i `elem` [5..10] -> Written <$ writeIORef (opaque ref) (i + 1)++ -- There's also the possibility that the program gets killed or crashes.+ Crash -> do+ bool <- randomIO+ if bool+ then+ error "Crash before writing!"+ -- Written <$ writeIORef (opaque ref) i+ else do+ writeIORef (opaque ref) i+ error "Crash after writing!"+ CrashAndLogic -> do+ writeIORef (opaque ref) (i + 1)+ error "Crash after writing!"++ _otherwise -> Written <$ writeIORef (opaque ref) i Increment ref -> do- -- The other problem is that we introduce a possible race condition+ -- Another problem is that we introduce a possible race condition -- when incrementing. if bug == Race then do@@ -143,40 +179,122 @@ Increment _ -> pure Incremented generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))-generator (Model model) = Just $ frequency- [ (1, pure Create)- , (4, Read <$> elements (domain model))- , (4, Write <$> elements (domain model) <*> arbitrary)- , (4, Increment <$> elements (domain model))+generator m@(Model []) = Just (genCreate m)+generator m = Just $ frequency+ [ (1, genCreate m)+ , (4, genWrite m)+ , (4, genRead m)+ , (4, genIncr m) ] +genCreate, genRead, genWrite, genIncr :: Model Symbolic -> Gen (Command Symbolic)+genCreate _model = return Create+genRead (Model model) = Read <$> elements (domain model)+genWrite (Model model) = Write <$> elements (domain model) <*> arbitrary+genIncr (Model model) = Increment <$> elements (domain model)+ shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic] shrinker _ (Write ref i) = [ Write ref i' | i' <- shrink i ] shrinker _ _ = [] sm :: Bug -> StateMachine Model Command IO Response sm bug = StateMachine initModel transition precondition postcondition- Nothing generator Nothing shrinker (semantics bug) mock+ Nothing generator shrinker (semantics bug) mock noCleanup prop_sequential :: Bug -> Property prop_sequential bug = forAllCommands sm' Nothing $ \cmds -> monadicIO $ do (hist, _model, res) <- runCommands sm' cmds- prettyCommands sm' hist (checkCommandNames cmds (res === Ok))+ prettyCommands sm' hist (saveCommands "/tmp" cmds+ (coverCommandNames cmds $ checkCommandNames cmds (res === Ok))) where sm' = sm bug +prop_runSavedCommands :: Bug -> FilePath -> Property+prop_runSavedCommands bug fp = monadicIO $ do+ (_cmds, hist, _model, res) <- runSavedCommands (sm bug) fp+ prettyCommands (sm bug) hist (res === Ok)+ prop_parallel :: Bug -> Property-prop_parallel bug = forAllParallelCommands sm' $ \cmds -> monadicIO $ do+prop_parallel bug = forAllParallelCommands sm' Nothing $+ \cmds -> checkCommandNamesParallel cmds $ monadicIO $ prettyParallelCommands cmds =<< runParallelCommands sm' cmds where sm' = sm bug +prop_parallel' :: Bug -> Property+prop_parallel' bug = forAllParallelCommands sm' Nothing $ \cmds -> monadicIO $ do+ prettyParallelCommands cmds =<< runParallelCommands' sm' complete cmds+ where+ sm' = sm bug+ complete :: Command Concrete -> Response Concrete+ complete Create = Created (error "This reference will never be used.")++ complete Read {} = ReadValue 0 -- Doesn't matter what value we read.+ complete Write {} = Written+ complete Increment {} = Incremented++prop_nparallel :: Bug -> Int -> Property+prop_nparallel bug np = forAllNParallelCommands sm' np $ \cmds ->+ checkCommandNamesParallel cmds $ coverCommandNamesParallel cmds $ monadicIO $ do+ prettyNParallelCommands cmds =<< runNParallelCommands sm' cmds+ where+ sm' = sm bug+ prop_precondition :: Property prop_precondition = once $ monadicIO $ do (hist, _model, res) <- runCommands sm' cmds prettyCommands sm' hist- (res === PreconditionFailed "PredicateC (NotElem (Reference (Symbolic (Var 0))) [])")+ (res === PreconditionFailed "PredicateC (NotMember (Reference (Symbolic (Var 0))) [])") where sm' = sm None cmds = Commands [ Types.Command (Read (Reference (Symbolic (Var 0)))) (ReadValue 0) [] ]++prop_existsCommands :: Property+prop_existsCommands = existsCommands sm' gens $ \cmds -> monadicIO $ do+ (hist, _model, res) <- runCommands sm' cmds+ prettyCommands sm' hist (checkCommandNames cmds (res === Ok))+ where+ sm' = sm None+ gens =+ [ genCreate+ , genWrite+ , genIncr+ , genRead+ ]++{-------------------------------------------------------------------------------+ Meta properties which test the testing framework.+-------------------------------------------------------------------------------}++prop_pairs_shrink_parallel_equivalence :: Property+prop_pairs_shrink_parallel_equivalence =+ forAllParallelCommands (sm None) Nothing $ \pairCmds ->+ let pairShrunk = shrinkParallelCommands (sm None) pairCmds+ listCmds = Types.fromPair' pairCmds+ listShrunk = shrinkNParallelCommands (sm None) listCmds+ listShrunkPair = Types.toPairUnsafe' <$> listShrunk+ in listShrunkPair === pairShrunk++prop_pairs_shrinkAndValidate_equivalence :: Property+prop_pairs_shrinkAndValidate_equivalence =+ forAllParallelCommands (sm None) Nothing $ \pairCmds ->+ let pairShrunk' = shrinkAndValidateParallel (sm None) DontShrink pairCmds+ listCmds = Types.fromPair' pairCmds+ listShrunk' = shrinkAndValidateNParallel (sm None) DontShrink listCmds+ listShrunkPair' = Types.toPairUnsafe' <$> listShrunk'+ in listShrunkPair' === pairShrunk'++prop_pairs_shrink_parallel :: Property+prop_pairs_shrink_parallel =+ forAllParallelCommands (sm None) Nothing $ \cmds@(Types.ParallelCommands prefix suffixes) ->+ let pair =+ [ Shrunk s (Types.ParallelCommands prefix' (map Types.toPair suffixes'))+ | Shrunk s (prefix', suffixes') <- shrinkPairS shrinkCommands' (shrinkListS (shrinkPairS' shrinkCommands'))+ (prefix, map Types.fromPair suffixes)]+ (Types.ParallelCommands _ listSuffixes) = Types.fromPair' cmds+ list =+ [ Shrunk s $ Types.toPairUnsafe' (Types.ParallelCommands prefix' suffixes')+ | Shrunk s (prefix', suffixes') <- shrinkPairS shrinkCommands' (shrinkListS (shrinkListS'' shrinkCommands'))+ (prefix, listSuffixes)]+ in list == pair
+ test/Mock.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Mock+ ( prop_sequential_mock+ , prop_parallel_mock+ , prop_nparallel_mock+ )+ where++import Control.Concurrent+import Control.Monad.IO.Class+ (liftIO)+import GHC.Generics+ (Generic, Generic1)+import Prelude+import Test.QuickCheck+import Test.QuickCheck.Monadic+ (monadicIO)+import Test.StateMachine+import Test.StateMachine.DotDrawing+import qualified Test.StateMachine.Types.Rank2 as Rank2++------------------------------------------------------------------------++data Command r+ = Create+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++deriving stock instance Show (Command Symbolic)+deriving stock instance Read (Command Symbolic)+deriving stock instance Show (Command Concrete)++data Response r+ = Created (Reference Int r)+ | NotCreated+ deriving stock (Eq, Generic1)+ deriving anyclass Rank2.Foldable++deriving stock instance Show (Response Symbolic)+deriving stock instance Read (Response Symbolic)+deriving stock instance Show (Response Concrete)++data Model r = Model {+ refs :: [Reference Int r]+ , c :: Int+ }+ deriving stock (Generic, Show)++instance ToExpr (Model Symbolic)+instance ToExpr (Model Concrete)++initModel :: Model r+initModel = Model [] 0++transition :: Model r -> Command r -> Response r -> Model r+transition m@Model{..} cmd resp = case (cmd, resp, c) of+ (Create, Created ref, 0) -> Model (ref : refs) 1+ (Create, _, _) -> m++precondition :: Model Symbolic -> Command Symbolic -> Logic+precondition _ cmd = case cmd of+ Create -> Top++postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postcondition _ _ _ = Top++semantics :: MVar Int -> Command Concrete -> IO (Response Concrete)+semantics counter cmd = case cmd of+ Create -> do+ c <- modifyMVar counter (\x -> return (x + 1, x))+ case c of+ 0 -> return $ Created $ reference c+ _ -> return NotCreated++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock Model{..} cmd = case (cmd, c) of+ (Create, 0) -> Created <$> genSym+ (Create, _) -> return NotCreated++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator _ = Just $ frequency+ [(1, return Create)]++shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic]+shrinker _ _ = []++sm :: MVar Int -> StateMachine Model Command IO Response+sm counter = StateMachine initModel transition precondition postcondition+ Nothing generator shrinker (semantics counter) mock noCleanup++smUnused :: StateMachine Model Command IO Response+smUnused = sm undefined++prop_sequential_mock :: Property+prop_sequential_mock = forAllCommands smUnused Nothing $ \cmds -> monadicIO $ do+ counter <- liftIO $ newMVar 0+ (hist, _model, res) <- runCommands (sm counter) cmds+ prettyCommands smUnused hist (res === Ok)++prop_parallel_mock :: Property+prop_parallel_mock = forAllParallelCommands smUnused Nothing $ \cmds -> monadicIO $ do+ counter <- liftIO $ newMVar 0+ ret <- runParallelCommandsNTimes 1 (sm counter) cmds+ prettyParallelCommandsWithOpts cmds opts ret+ where opts = Just $ GraphOptions "mock-test-output.png" Png++prop_nparallel_mock :: Property+prop_nparallel_mock = forAllNParallelCommands smUnused 3 $ \cmds -> monadicIO $ do+ counter <- liftIO $ newMVar 0+ ret <- runNParallelCommandsNTimes 1 (sm counter) cmds+ prettyNParallelCommandsWithOpts cmds opts ret+ where opts = Just $ GraphOptions "mock-np-test-output.png" Png
+ test/Overflow.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+++module Overflow+ ( prop_sequential_overflow+ , prop_parallel_overflow+ , prop_nparallel_overflow+ ) where++import Control.Concurrent+ (threadDelay)+import Control.Concurrent.MVar+import Control.Monad+import Data.Int+import GHC.Generics+ (Generic, Generic1)+import Prelude+import System.Random+ (randomRIO)+import Test.QuickCheck+import Test.QuickCheck.Monadic+ (monadicIO)+import Test.StateMachine+import Test.StateMachine.DotDrawing+import qualified Test.StateMachine.Types.Rank2 as Rank2++------------------------------------------------------------------------++-- The Model is a set of references of Int8. Command BackAndForth picks a random reference and adds a+-- constant number (in an atomic way) and then substract the same number (in an atomic way).+-- If there are enough threads (4 in this case) the result can overflow.++data Command r+ = Create+ | Check (Reference (Opaque (MVar Int8)) r)+ | BackAndForth Int (Reference (Opaque (MVar Int8)) r)+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++deriving stock instance Show (Command Symbolic)+deriving stock instance Read (Command Symbolic)+deriving stock instance Show (Command Concrete)++data Response r+ = Created (Reference (Opaque (MVar Int8)) r)+ | IsNegative Bool+ | Unit+ deriving stock (Eq, Generic1)+ deriving anyclass (Rank2.Foldable)++deriving stock instance Show (Response Symbolic)+deriving stock instance Read (Response Symbolic)+deriving stock instance Show (Response Concrete)++newtype Model r = Model [(Reference (Opaque (MVar Int8)) r, Int8)]+ deriving stock (Generic, Show)++getVars :: Model r -> [Reference (Opaque (MVar Int8)) r]+getVars (Model ls) = fst <$> ls++instance ToExpr (Model Symbolic)+instance ToExpr (Model Concrete)++initModel :: Model r+initModel = Model []++transition :: Model r -> Command r -> Response r -> Model r+transition m@(Model model) cmd resp = case (cmd, resp) of+ (Create, Created var) -> Model ((var, 0) : model)+ (Check _, IsNegative _) -> m+ (BackAndForth _ _, Unit) -> m+ _ -> error "impossible to transition!"++precondition :: Model Symbolic -> Command Symbolic -> Logic+precondition m cmd = case cmd of+ Create -> Top+ Check var -> var `member` getVars m+ BackAndForth _ var -> var `member` getVars m++postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postcondition _ cmd resp = case (cmd, resp) of+ (Create, Created _) -> Top+ (Check _, IsNegative bl) -> bl .== False+ (BackAndForth _ _, Unit) -> Top+ _ -> Bot++semantics :: Command Concrete -> IO (Response Concrete)+semantics cmd = case cmd of+ Create -> Created <$> (reference . Opaque <$> newMVar 0)+ Check var -> do+ val <- readMVar (opaque var)+ return $ IsNegative $ val < 0+ BackAndForth n var -> do+ modifyMVar_ (opaque var) $ \x -> return $ x + fromIntegral n+ threadDelay =<< randomRIO (0, 5000)+ modifyMVar_ (opaque var) $ \x -> return $ x - fromIntegral n+ return Unit++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock _ cmd = case cmd of+ Create -> Created <$> genSym+ Check _var -> return $ IsNegative False+ BackAndForth _ _ -> return $ Unit++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator (Model []) = Just (return Create)+generator m = Just $ frequency+ [ (1, return Create)+ , (3, genBackAndForth m)+ , (3, genCheck m)+ ]++genCheck :: Model Symbolic -> Gen (Command Symbolic)+genCheck m =+ Check <$> elements (getVars m)++genBackAndForth :: Model Symbolic -> Gen (Command Symbolic)+genBackAndForth m = do+ -- The upper limit here must have the property 2 * n < 128 <= 3 * n, so that+ -- there is a counter example for >= 4 threads.+ -- The lower limit only affects how fast a counterexample will be found.+ n <- choose (30,60)+ BackAndForth n <$> elements (getVars m)++shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic]+shrinker _ (BackAndForth n var) = [ BackAndForth n' var | n' <- shrink n ]+shrinker _ _ = []++sm :: StateMachine Model Command IO Response+sm = StateMachine initModel transition precondition postcondition+ Nothing generator shrinker semantics mock noCleanup++prop_sequential_overflow :: Property+prop_sequential_overflow = forAllCommands sm Nothing $ \cmds -> monadicIO $ do+ (hist, _model, res) <- runCommands sm cmds+ prettyCommands sm hist (res === Ok)++prop_parallel_overflow :: Property+prop_parallel_overflow = forAllParallelCommands sm Nothing $ \cmds -> monadicIO $+ prettyParallelCommandsWithOpts cmds opts =<< runParallelCommands sm cmds+ where opts = Just $ GraphOptions "overflow-test-output.png" Png++prop_nparallel_overflow :: Int -> Property+prop_nparallel_overflow np = forAllNParallelCommands sm np $ \cmds -> monadicIO $+ prettyNParallelCommandsWithOpts cmds opts =<< runNParallelCommands sm cmds+ where opts = Just $ GraphOptions ("overflow-" ++ show np ++ "-test-output.png") Png
+ test/ProcessRegistry.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : ProcessRegistry+-- Copyright : (C) 2017, Jacob Stanley; 2018, Stevan Andjelkovic+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- This module contains the process registry example that is commonly+-- used in the papers on Erlang QuickCheck, e.g. "Finding Race+-- Conditions in Erlang with QuickCheck and PULSE". Parts of the code+-- are stolen from an example in Hedgehog.+--+-----------------------------------------------------------------------------++module ProcessRegistry+ ( prop_processRegistry+ , printLabelledExamples+ )+ where++import Control.Exception+ (catch)+import Control.Monad+ (when)+import Control.Monad.IO.Class+ (MonadIO(..))+import Data.Foldable+ (traverse_)+import Data.Functor.Classes+ (Ord1)+import Data.Hashable+ (Hashable)+import qualified Data.HashTable.IO as HashTable+import Data.IORef+ (IORef)+import qualified Data.IORef as IORef+import Data.Kind+ (Type)+import Data.List+ ((\\))+import Data.Map+ (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+ (isJust, isNothing)+import Data.Set+ (Set)+import qualified Data.Set as Set+import Data.Tuple+ (swap)+import GHC.Generics+ (Generic, Generic1)+import Prelude+import System.IO.Error+ (ioeGetErrorString)+import System.IO.Unsafe+ (unsafePerformIO)+import System.Random+ (randomRIO)+import Test.QuickCheck+ (Arbitrary, Gen, Property, arbitrary, elements,+ tabulate, (.&&.), (===))+import Test.QuickCheck.Monadic+ (monadicIO)++import Test.StateMachine+import Test.StateMachine.Labelling+import qualified Test.StateMachine.Types.Rank2 as Rank2+++------------------------------------------------------------------------+-- Implementation+--+-- The following code is stolen from an Hedgehog example:+--+-- Fake Process Registry+--+-- /These are global to simulate some kind of external system we're+-- testing./+--++newtype Name = Name String+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (ToExpr)++newtype Pid = Pid Int+ deriving newtype (Num)+ deriving stock (Eq, Ord, Generic, Show)+ deriving anyclass (ToExpr)++type ProcessTable = HashTable.CuckooHashTable String Int++pidRef :: IORef Pid+pidRef =+ unsafePerformIO $ IORef.newIORef 0+{-# NOINLINE pidRef #-}++procTable :: ProcessTable+procTable =+ unsafePerformIO $ HashTable.new+{-# NOINLINE procTable #-}++killedPidsRef :: IORef [Pid]+killedPidsRef =+ unsafePerformIO $ IORef.newIORef []+{-# NOINLINE killedPidsRef #-}++ioReset :: IO ()+ioReset = do+ IORef.writeIORef pidRef 0+ ks <- fmap fst <$> HashTable.toList procTable+ traverse_ (HashTable.delete procTable) ks+ IORef.writeIORef killedPidsRef []++ioSpawn :: IO Pid+ioSpawn = do+ pid <- IORef.readIORef pidRef+ IORef.writeIORef pidRef (pid + 1)++ die <- randomRIO (1, 6) :: IO Int+ if die == -1+ then error "ioSpawn"+ else pure pid++ioKill :: Pid -> IO ()+ioKill pid =+ IORef.modifyIORef killedPidsRef (pid :)++reverseLookup :: (Eq k, Eq v, Hashable k, Hashable v)+ => HashTable.CuckooHashTable k v -> v -> IO (Maybe k)+reverseLookup tbl val = do+ lbt <- swapTable tbl+ HashTable.lookup lbt val+ where+ -- Swap the keys and values in a hashtable.+ swapTable :: (Eq k, Eq v, Hashable k, Hashable v)+ => HashTable.CuckooHashTable k v -> IO (HashTable.CuckooHashTable v k)+ swapTable t = HashTable.fromList =<< fmap (map swap) (HashTable.toList t)++ioRegister :: Name -> Pid -> IO ()+ioRegister (Name name) pid'@(Pid pid) = do++ mpid <- HashTable.lookup procTable name+ when (isJust mpid) $+ fail "ioRegister: name already registered"++ mname <- reverseLookup procTable pid+ when (isJust mname) $+ fail "ioRegister: pid already registered"++ killedPids <- IORef.readIORef killedPidsRef++ when (pid' `elem` killedPids) $+ fail "ioRegister: pid is dead"++ HashTable.insert procTable name pid++ioUnregister :: Name -> IO ()+ioUnregister (Name name) = do+ m <- HashTable.lookup procTable name++ when (isNothing m) $+ fail "ioUnregister: not registered"++ HashTable.delete procTable name++-- Here we extend the Hedgehog example with a looking up names in the+-- registry.+ioWhereIs :: Name -> IO Pid+ioWhereIs (Name name) = do+ mpid <- HashTable.lookup procTable name++ case mpid of+ Nothing -> fail "ioWhereIs: not registered"+ Just pid -> return (Pid pid)++------------------------------------------------------------------------+-- Specification++data Action (r :: Type -> Type)+ = Spawn+ | Kill (Reference Pid r)+ | Register Name (Reference Pid r)+ | BadRegister Name (Reference Pid r)+ | Unregister Name+ | BadUnregister Name+ | WhereIs Name+ | Exit+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++data Action_+ = Spawn_+ | Kill_+ | Register_+ | BadRegister_+ | Unregister_+ | BadUnregister_+ | WhereIs_+ | Exit_+ deriving stock (Show, Eq, Ord, Generic)++constructor :: Action r -> Action_+constructor act = case act of+ Spawn {} -> Spawn_+ Kill {} -> Kill_+ Register {} -> Register_+ BadRegister {} -> BadRegister_+ Unregister {} -> Unregister_+ BadUnregister {} -> BadUnregister_+ WhereIs {} -> WhereIs_+ Exit {} -> Exit_++newtype Response (r :: Type -> Type) = Response+ { _getResponse :: Either Error (Success r) }+ deriving stock (Show, Generic1)+ deriving anyclass Rank2.Foldable++data Success (r :: Type -> Type)+ = Spawned (Reference Pid r)+ | Killed+ | Registered+ | Unregistered+ | HereIs (Reference Pid r)+ | Exited+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Foldable)++data Error+ = NameAlreadyRegisteredError+ | PidAlreadyRegisteredError+ | PidDeadRegisterError+ | NameNotRegisteredError+ | UnknownError+ deriving stock Show++success :: Success r -> Response r+success = Response . Right++failure :: Error -> Response r+failure = Response . Left++data Model (r :: Type -> Type) = Model+ { pids :: [Reference Pid r]+ , registry :: Map Name (Reference Pid r)+ , killed :: [Reference Pid r]+ , stop :: Bool+ }+ deriving stock (Show, Generic)++instance ToExpr (Model Concrete)++initModel :: Model r+initModel = Model [] Map.empty [] False++transition :: Model r -> Action r -> Response r -> Model r+transition m act (Response (Left _err)) = case act of+ BadRegister {} -> m+ BadUnregister {} -> m+ _otherwise -> error "transition: good command throws error"+transition Model {..} act (Response (Right resp)) = case (act, resp) of++ (Spawn, Spawned pid) ->+ Model { pids = pids ++ [pid], .. }++ (Kill pid, Killed) ->+ Model { killed = killed ++ [pid], .. }++ (Register name pid, Registered) ->+ Model { registry = Map.insert name pid registry, .. }++ (BadRegister _name _pid, _) -> error "transition: BadRegister"++ (Unregister name, Unregistered) ->+ Model { registry = Map.delete name registry, .. }++ (BadUnregister _name, _) -> error "transition: BadUnregister"++ (WhereIs _name, HereIs _pid) ->+ Model {..}++ (Exit, Exited) ->+ Model { stop = True, .. }++ (_, _) -> error "transition"++precondition :: Model Symbolic -> Action Symbolic -> Logic+precondition Model {..} act = case act of+ Spawn -> Top+ Kill pid -> pid `member` pids+ Register name pid -> pid `member` pids+ .&& name `notMember` Map.keys registry+ .&& pid `notMember` Map.elems registry+ BadRegister name pid -> pid `member` killed+ .|| name `member` Map.keys registry+ .|| pid `member` Map.elems registry+ Unregister name -> name `member` Map.keys registry+ BadUnregister name -> name `notMember` Map.keys registry+ WhereIs name -> name `member` Map.keys registry+ Exit -> Top++postcondition :: Model Concrete -> Action Concrete -> Response Concrete -> Logic+postcondition Model {..} act (Response (Left err)) = case act of+ BadRegister _name _pid -> Top+ BadUnregister _name -> Top+ _ -> Bot .// show err+postcondition Model {..} act (Response (Right resp)) = case (act, resp) of+ (Spawn, Spawned _pid) -> Top+ (Kill _pid, Killed) -> Top+ (Register _name _pid, Registered) -> Top+ (Unregister _name, Unregistered) -> Top+ (WhereIs name, HereIs pid) -> registry Map.! name .== pid+ (Exit, Exited) -> Top+ (_, _) -> Bot++semantics' :: Action Concrete -> IO (Success Concrete)+semantics' Spawn = Spawned . reference <$> ioSpawn+semantics' (Kill pid) = Killed <$ ioKill (concrete pid)+semantics' (Register name pid) = Registered <$ ioRegister name (concrete pid)+semantics' (BadRegister name pid) = Registered <$ ioRegister name (concrete pid)+semantics' (Unregister name) = Unregistered <$ ioUnregister name+semantics' (BadUnregister name) = Unregistered <$ ioUnregister name+semantics' (WhereIs name) = HereIs . reference <$> ioWhereIs name+semantics' Exit = return Exited++semantics :: Action Concrete -> IO (Response Concrete)+semantics act = fmap success (semantics' act)+ `catch`+ (return . failure . handler)+ where+ handler :: IOError -> Error+ handler err = case ioeGetErrorString err of+ "ioRegister: name already registered" -> NameAlreadyRegisteredError+ "ioRegister: pid already registered" -> PidAlreadyRegisteredError+ "ioRegister: pid is dead" -> PidDeadRegisterError+ "ioUnregister: not registered" -> NameNotRegisteredError+ _ -> UnknownError++data Fin2+ = Zero+ | One+ | Two+ deriving stock (Enum, Bounded, Show, Eq, Read, Ord)++data State = Fin2 :*: Fin2 | Stop+ deriving stock (Show, Eq, Ord, Generic)++partition :: Model r -> State+partition Model {..}+ | stop = Stop+ | otherwise = ( toEnum (length pids - length killed)+ :*: toEnum (length (Map.keys registry))+ )++sinkState :: State -> Bool+sinkState = (== Stop)++_initState :: State+_initState = Zero :*: Zero++allNames :: [Name]+allNames = map Name ["A", "B", "C"]++instance Arbitrary Name where+ arbitrary = elements allNames++genSpawn, genKill, genRegister, genBadRegister, genUnregister, genBadUnregister,+ genWhereIs, genExit :: Model Symbolic -> Gen (Action Symbolic)++genSpawn _model = return Spawn+genKill model = Kill <$> elements (pids model)+genRegister model = Register <$> arbitrary <*> elements (pids model \\ killed model)+genBadRegister model = BadRegister <$> arbitrary <*> elements (pids model ++ killed model)+genUnregister model = Unregister <$> elements (Map.keys (registry model))+genBadUnregister model = BadUnregister <$> elements (allNames \\ Map.keys (registry model))+genWhereIs model = WhereIs <$> elements (Map.keys (registry model))+genExit _model = return Exit++gens :: Map Action_ (Model Symbolic -> Gen (Action Symbolic))+gens = Map.fromList+ [ (Spawn_, genSpawn)+ , (Kill_, genKill)+ , (Register_, genRegister)+ , (BadRegister_, genBadRegister)+ , (Unregister_, genUnregister)+ , (BadUnregister_, genBadUnregister)+ , (WhereIs_, genWhereIs)+ , (Exit_, genExit)+ ]++generator :: Model Symbolic -> Maybe (Gen (Action Symbolic))+generator = markovGenerator markov gens partition sinkState++shrinker :: Model Symbolic -> Action Symbolic -> [Action Symbolic]+shrinker _model _act = []++mock :: Model Symbolic -> Action Symbolic -> GenSym (Response Symbolic)+mock m act = case act of+ Spawn -> success . Spawned <$> genSym+ Kill _pid -> pure (success Killed)+ Register _name _pid -> pure (success Registered)+ BadRegister name pid+ | name `elem` Map.keys (registry m) -> pure (failure NameAlreadyRegisteredError)+ | pid `elem` Map.elems (registry m) -> pure (failure PidAlreadyRegisteredError)+ | pid `elem` killed m -> pure (failure PidDeadRegisterError)+ | otherwise -> error "mock: BadRegister"+ Unregister _name -> pure (success Unregistered)+ BadUnregister _name -> pure (failure NameNotRegisteredError)+ WhereIs _name -> success . HereIs <$> genSym+ Exit -> pure (success Exited)++sm :: StateMachine Model Action IO Response+sm = StateMachine initModel transition precondition postcondition+ Nothing generator shrinker semantics mock noCleanup++markov :: Markov State Action_ Double+markov = makeMarkov+ [ Zero :*: Zero -< [ Spawn_ /- One :*: Zero ]++ , One :*: Zero -< [ Spawn_ /- Two :*: Zero+ , Register_ /- One :*: One+ , (BadRegister_, 10) >- One :*: Zero+ , (Kill_, 20) >- Zero :*: Zero+ ]++ , One :*: One -< [ (Spawn_, 40) >- Two :*: One+ , BadRegister_ /- One :*: One+ , (Unregister_, 20) >- One :*: Zero+ , BadUnregister_ /- One :*: One+ , (WhereIs_, 20) >- One :*: One+ ]++ , Two :*: Zero -< [ (Register_, 80) >- Two :*: One+ , (Kill_, 20) >- One :*: Zero+ ]++ , Two :*: One -< [ (Register_, 30) >- Two :*: Two+ , (Kill_, 10) >- One :*: One+ , (Unregister_, 20) >- Two :*: Zero+ , (BadUnregister_, 10) >- Two :*: One+ , (WhereIs_, 20) >- Two :*: One+ , (Exit_, 10) >- Stop+ ]++ , Two :*: Two -< [ (Exit_, 30) >- Stop+ , (Unregister_, 20) >- Two :*: One+ , (WhereIs_, 50) >- Two :*: Two+ ]+ ]++------------------------------------------------------------------------++-- Requirements from the paper "How well are your requirements tested?"+-- (2016) by Arts and Hughes.+data Req+ = RegisterNewNameAndPid_REG001+ | RegisterExistingName_REG002+ | RegisterExistingPid_REG003+ | RegisterDeadPid_REG004+ | UnregisterRegisteredName_UNR001+ | UnregisterNotRegisteredName_UNR002+ | WHE001+ | WHE002+ | DIE001+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (ToExpr)++type EventPred r = Predicate (Event Model Action Response r) Req++-- Convenience combinator for creating classifiers for successful commands.+successful :: (Event Model Action Response r -> Success r -> Either Req (EventPred r))+ -> EventPred r+successful f = predicate $ \ev ->+ case eventResp ev of+ Response (Left _ ) -> Right $ successful f+ Response (Right ok) -> f ev ok++tag :: forall r. Ord1 r => [Event Model Action Response r] -> [Req]+tag = classify+ [ tagRegisterNewNameAndPid+ , tagRegisterExistingName Set.empty+ , tagRegisterExistingPid Set.empty+ , tagRegisterDeadPid Set.empty+ , tagUnregisterRegisteredName Set.empty+ , tagUnregisterNotRegisteredName Set.empty+ ]+ where+ tagRegisterNewNameAndPid :: EventPred r+ tagRegisterNewNameAndPid = successful $ \ev _ -> case eventCmd ev of+ Register _ _ -> Left RegisterNewNameAndPid_REG001+ _otherwise -> Right tagRegisterNewNameAndPid++ tagRegisterExistingName :: Set Name -> EventPred r+ tagRegisterExistingName existingNames = predicate $ \ev ->+ case (eventCmd ev, eventResp ev) of+ (Register name _pid, Response (Right Registered)) ->+ Right (tagRegisterExistingName (Set.insert name existingNames))+ (BadRegister name _pid, Response (Left NameAlreadyRegisteredError))+ | name `Set.member` existingNames -> Left RegisterExistingName_REG002+ _otherwise+ -> Right (tagRegisterExistingName existingNames)++ tagRegisterExistingPid :: Set (Reference Pid r) -> EventPred r+ tagRegisterExistingPid existingPids = predicate $ \ev ->+ case (eventCmd ev, eventResp ev) of+ (Register _name pid, Response (Right Registered)) ->+ Right (tagRegisterExistingPid (Set.insert pid existingPids))+ (BadRegister _name pid, Response (Left PidAlreadyRegisteredError))+ | pid `Set.member` existingPids -> Left RegisterExistingPid_REG003+ _otherwise+ -> Right (tagRegisterExistingPid existingPids)++ tagRegisterDeadPid :: Set (Reference Pid r) -> EventPred r+ tagRegisterDeadPid killedPids = predicate $ \ev ->+ case (eventCmd ev, eventResp ev) of+ (Kill pid, Response (Right Killed)) ->+ Right (tagRegisterDeadPid (Set.insert pid killedPids))+ (BadRegister _name pid, Response (Left PidDeadRegisterError))+ | pid `Set.member` killedPids -> Left RegisterDeadPid_REG004+ _otherwise+ -> Right (tagRegisterDeadPid killedPids)++ tagUnregisterRegisteredName :: Set Name -> EventPred r+ tagUnregisterRegisteredName registeredNames = successful $ \ev resp ->+ case (eventCmd ev, resp) of+ (Register name _pid, Registered) ->+ Right (tagUnregisterRegisteredName (Set.insert name registeredNames))+ (Unregister name, Unregistered)+ | name `Set.member` registeredNames -> Left UnregisterRegisteredName_UNR001+ _otherwise+ -> Right (tagUnregisterRegisteredName registeredNames)++ tagUnregisterNotRegisteredName :: Set Name -> EventPred r+ tagUnregisterNotRegisteredName registeredNames = predicate $ \ev ->+ case (eventCmd ev, eventResp ev) of+ (Register name _pid, Response (Right Registered)) ->+ Right (tagUnregisterNotRegisteredName (Set.insert name registeredNames))+ (BadUnregister name, Response (Left NameNotRegisteredError))+ | name `Set.notMember` registeredNames -> Left UnregisterNotRegisteredName_UNR002+ _otherwise+ -> Right (tagUnregisterNotRegisteredName registeredNames)++printLabelledExamples :: IO ()+printLabelledExamples = showLabelledExamples sm tag++------------------------------------------------------------------------++prop_processRegistry :: StatsDb IO -> Property+prop_processRegistry sdb = forAllCommands sm (Just 100000) $ \cmds -> monadicIO $ do+ liftIO ioReset+ (hist, _model, res) <- runCommands sm cmds++ let observed = historyObservations sm markov partition constructor hist+ reqs = tag (execCmds sm cmds)++ persistStats sdb observed++ prettyCommands' sm tag cmds hist+ $ tabulate "_Requirements" (map show reqs)+ $ coverMarkov markov+ $ tabulateMarkov sm partition constructor cmds+ $ printReliability sdb (transitionMatrix markov) observed+ $ res === Ok .&&. reqs === tag (execHistory sm hist)
+ test/RQlite.hs view
@@ -0,0 +1,771 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module RQlite (+ Level (..)+ , prop_sequential_rqlite+ , prop_parallel_rqlite+ , prop_nparallel_rqlite+ , runCmds+ ) where++import Control.Concurrent+ (threadDelay)+import Control.Concurrent.MVar+import Control.Exception+ (bracketOnError, try)+import Control.Monad+ (void, when)+import Control.Monad.IO.Class+ (liftIO)+import Data.Aeson hiding+ (Result)+import Data.Foldable+import Data.Functor.Classes+import Data.Kind+import Data.List+import Data.Map+ (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.TreeDiff+import GHC.Generics+import Prelude+import "hs-rqlite" Rqlite+import "hs-rqlite" Rqlite.Status+import System.Directory+import System.IO+import System.Process+import System.Random+import Test.QuickCheck hiding+ (Result)+import Test.QuickCheck.Monadic+import Test.StateMachine+import Test.StateMachine.DotDrawing+import Test.StateMachine.Types+ (History(..), ParallelCommandsF(..), interleavings)+import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.Types.References++------------------------------------------------------------------------++newtype At t r = At { unAt :: t (NodeRef r) }+ deriving stock (Generic)++instance Show (t (NodeRef r)) => Show (At t r) where+ show = show . unAt++data Person = Person+ { name :: String+ , age :: Int+ }+ deriving stock (Show, Read, Eq, Generic)++-- HTTP requests utilities++instance FromJSON Person where+ parseJSON j = do+ (n, a) <- parseJSON j+ return $ Person n a++createQ :: String+createQ = "CREATE TABLE Person (name text, age Int)"++insertQuery :: String -> Person -> IO PostResult+insertQuery host Person{..} =+ postQuery True host $ "INSERT INTO Person(name, age) VALUES('" ++ name ++ "', " ++ show age ++ ")"++selectQuery :: Maybe Level -> String -> IO (GetResult Person)+selectQuery lvl host = do+ putStrLnM $ "querying " ++ host+ getQuery lvl host True "SELECT * FROM Person"++createQuery :: String -> IO PostResult+createQuery host = postQuery True host createQ++------------------------++-- Docker utilities++data Container = Container {+ counter :: Int+ , cn :: Int+ , nodeName :: String+ , cport :: Int+} deriving stock (Generic)++instance Eq Container where+ n1 == n2 = counter n1 == counter n2++instance Show Container where+ show Container{..} = "Node@" ++ show cport++instance ToExpr Container where+ toExpr Container{..} = App ("Node@" ++ show cport) []++ignoreIOError :: IO a -> IO ()+ignoreIOError action = do+ (_ :: Either IOError a) <- try action+ return ()++stopContainer :: String -> IO ()+stopContainer ndName = do+ stdErr <- openFile "/dev/null" AppendMode+ -- stopping or removing a non-existing container should be a no-op+ ignoreIOError $ readCreateProcess (proc "docker"+ [ "stop"+ , ndName+ ]) {std_err = UseHandle stdErr}+ ""+ ignoreIOError $ readCreateProcess (proc "docker"+ [ "rm"+ , ndName+ ]) {std_err = UseHandle stdErr}+ ""++mkNodeTime :: Int -> Int -> Timeout -> Timeout -> Maybe Int -> IO Container+mkNodeTime c n timeout elTimeout mjoin = do+ (ndName, p) <- setupNode n timeout elTimeout mjoin+ return $ Container c n ndName p++stopNode :: Container -> IO ()+stopNode Container {..} = stopContainer nodeName++setupNode :: Int -> Timeout -> Timeout -> Maybe Int -> IO (String, Int)+setupNode n timeout elTimeout mjoin = do+ r :: Word <- randomIO+ let p = leaderPort + 2 * n+ p' = 4002 + 2 * n+ ip = "172.19.0." ++ show (10 + n) -- http+ ip' = "172.18.0." ++ show (10 + n)+ mjoin' = fmap (\j -> "http://" ++ httpHost j) mjoin+ ndName = mkNodeName r+ jls = case mjoin' of+ Nothing -> []+ Just join -> ["-join", join]+ stopContainer ndName++ void $ readProcess "docker"+ ([ "create"+ , "--net"+ , "rqlite-http"+ , "--ip"+ , ip+ , "-p"+ , show p ++ ":" ++ show p+ , "--name"+ , ndName+ , "rqlite/rqlite:4.5.0"+ , "-http-addr"+ , ip ++ ":" ++ show p+ , "-raft-addr"+ , ip' ++ ":" ++ show p'+ , "-raft-timeout"+ , show timeout+ , "-raft-election-timeout"+ , show elTimeout+ ] ++ jls) ""++ -- connect the container to the rqlite network.+ void $ readProcess "docker"+ [ "network"+ , "connect"+ , "--ip"+ , ip'+ , "rqlite-network"+ , ndName+ ] ""++ stdOut' <- openFile (testPath ++ "/out-" ++ show n) AppendMode+ stdErr' <- openFile (testPath ++ "/err-" ++ show n) AppendMode+ stdIn' <- openFile "/dev/null" ReadMode+ -- we don't use readProcess here, because we don't want to block.+ void $ createProcess (proc "docker"+ [ "start"+ , "-a" -- this attaches the stdout and stderr to the one we specify.+ , ndName+ ]) {std_in = UseHandle stdIn', std_out = UseHandle stdOut', std_err = UseHandle stdErr'}++ putStrLnM "RAN"+ return (ndName, p)+++pauseNode :: Container -> IO ()+pauseNode Container{..} =+ void $ readProcess "docker"+ [ "pause"+ , nodeName+ ] ""++unPauseNode :: Container -> IO ()+unPauseNode Container{..} =+ void $ readProcess "docker"+ [ "unpause"+ , nodeName+ ] ""++mkNodeName :: Word -> String+mkNodeName n = "rqlite-node-" ++ show n++disconnectNode :: String -> IO ()+disconnectNode ndName =+ void $ readProcess "docker"+ [ "network"+ , "disconnect"+ , "rqlite-network"+ , ndName+ ] ""++connectNode :: Container -> IO ()+connectNode Container {..} =+ void $ readProcess "docker"+ [ "network"+ , "connect"+ , "--ip"+ , "172.18.0." ++ show (10 + cn)+ , "rqlite-network"+ , nodeName+ ] ""++createRQNetworks :: IO ()+createRQNetworks = do+ -- this way we don't "polute" test output with messages (i.e. network+ -- may already be present).+ stdErr <- openFile "/dev/null" AppendMode+ void $ ignoreIOError $ readCreateProcess (proc "docker"+ [ "network"+ , "create"+ , "--subnet"+ , "172.19.0.0/16"+ , "rqlite-http"]) {std_err = UseHandle stdErr}+ ""+ void $ ignoreIOError $ readCreateProcess (proc "docker"+ [ "network"+ , "create"+ , "--subnet"+ , "172.18.0.0/16"+ , "rqlite-network"]) {std_err = UseHandle stdErr}+ ""++-- retryUntilElections :: IO a -> IO a+-- retryUntilElections action = go 20+-- where+-- go n = do+-- res <- try action+-- let retry e = if n > 0 then do+-- putStrLnM "LeadershipLost. Retrying"+-- threadDelay 500000+-- go (n-1)+-- else throwIO e+-- case res of+-- Right a -> return a+-- Left e@(LeadershipLost _) -> retry e+-- Left e@NotLeader -> retry e+-- Left e -> throwIO e+++------------------------++sameElements :: Eq a => [a] -> [a] -> Bool+sameElements x y = null (x \\ y) && null (y \\ x)++type NodeRef = Reference Container++data Model r = Model {+ dbModel :: DBModel+ , nodes :: [(NodeRef r, Int)]+ } deriving stock (Generic, Show)++data DBModel = DBModel {+ persons :: [Person]+ , nodeState :: Map Int NodeState+ , cutLines :: [(Int, Int)]+ , cWhere :: Int+ , cRef :: Int+ } deriving stock (Generic, Show)++type Join = Maybe Int++data Timeout =+ Ms Int+ | Sec Int++instance Show Timeout where+ show (Ms n) = show n ++ "ms"+ show (Sec n) = show n ++ "s"++data Cmd node =+ Spawn Int Timeout Timeout Join+ | ReSpawn Int Int Timeout Timeout Join+ | Disconnect node+ | Connect node+ | Stop node+ | Insert node Person+ | Get node (Maybe Level)+ | Pause node+ | UnPause node+ | Delay Int+ deriving stock (Generic, Show, Functor, Foldable, Traversable)++newtype Resp node = Resp (Either SomeError (Success node))+ deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic)++newtype SomeError = SomeError String+ deriving stock (Show, Eq)++data Success node =+ Unit+ | Spawned node+ | Got [Person]+ deriving stock (Show, Functor, Foldable, Traversable, Generic)++deriving stock instance Generic1 (At Cmd)+deriving anyclass instance Rank2.Functor (At Cmd)+deriving anyclass instance Rank2.Foldable (At Cmd)+deriving anyclass instance Rank2.Traversable (At Cmd)++deriving anyclass instance ToExpr DBModel+deriving anyclass instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr Person++deriving stock instance Generic1 (At Resp)+deriving anyclass instance Rank2.Functor (At Resp)+deriving anyclass instance Rank2.Foldable (At Resp)+deriving anyclass instance Rank2.Traversable (At Resp)++instance Eq node => Eq (Success node) where+ Unit == Unit = True+ (Got ps) == (Got ps') = sameElements ps ps'+ Spawned n == Spawned n' = n == n'+ _ == _ = False++instance CommandNames (At Cmd) where+ cmdName (At Spawn {}) = "Spawn"+ cmdName (At ReSpawn {}) = "ReSpawn"+ cmdName (At Connect {}) = "Connect"+ cmdName (At Disconnect {}) = "Disconnect"+ cmdName (At Stop {}) = "Stop"+ cmdName (At Insert {}) = "Insert"+ cmdName (At Get {}) = "Get"+ cmdName (At Pause {}) = "Pause"+ cmdName (At UnPause {}) = "UnPause"+ cmdName (At Delay {}) = "Delay"++unitResp :: Resp node+unitResp = Resp (Right Unit)++data Event (r :: Type -> Type) = Event+ { eventBefore :: Model r+ , eventCmd :: At Cmd r+ , eventAfter :: Model r+ , eventMockResp :: Resp Int+ }++lockstep :: forall (r :: Type -> Type).+ (Eq1 r, Show1 r)+ => Model r+ -> At Cmd r+ -> At Resp r+ -> Event r+lockstep model@Model {..} cmd (At resp) = Event+ { eventBefore = model+ , eventCmd = cmd+ , eventAfter = model'+ , eventMockResp = mockResp+ }+ where+ (mockResp, dbModel') = step model cmd+ newNodes = zip (toList resp) (toList mockResp)+ model' = Model {+ dbModel = dbModel'+ , nodes = nodes `union'` newNodes+ }++union' :: forall k v. (Eq k, Eq v, Show k, Show v)+ => [(k, v)] -- Mapping known to have duplicate keys+ -> [(k, v)] -- With potential duplicates+ -> [(k, v)]+union' acc [] = acc+union' acc ((k, v) : kvs) =+ case lookup k acc of+ Just v' | v /= v' -> error $ renderError v'+ _otherwise -> union' ((k, v) : acc) kvs+ where+ renderError :: v -> String+ renderError v' = unwords [+ "Key"+ , show k+ , "with two different values"+ , show v+ , "and"+ , show v'+ ]++(!) :: Eq1 r => [(NodeRef r, v)] -> NodeRef r -> v+env ! r = case lookup r env of+ Just a -> a+ Nothing -> error "(!): key not found"++step :: Eq1 r => Model r -> At Cmd r -> (Resp Int, DBModel)+step (Model m@DBModel{..} nodes) (At cmd) = case cmd of+ Insert _ p -> (unitResp, m {persons = p : persons})+ Get _ _ -> (Resp $ Right $ Got $ persons, m)+ Spawn wh _ _ _ -> ( Resp $ Right $ Spawned cRef, m {+ nodeState = M.insert cRef (Running wh) nodeState+ , cWhere = wh + 1 -- while shrinking, node locations may not be consecutive.+ , cRef = cRef + 1+ })+ ReSpawn pRef wh _ _ _ ->+ ( Resp $ Right $ Spawned cRef, m {+ nodeState = M.union (M.fromList [(cRef, Running wh), (pRef, Done)]) nodeState+ , cRef = cRef + 1+ })+ Connect ref -> (unitResp, m {+ nodeState = M.update connectST (nodes ! ref) nodeState+ })+ Disconnect ref -> (unitResp, m {+ nodeState = M.update disconnectST (nodes ! ref) nodeState+ })+ Stop ref -> (unitResp, m {+ nodeState = M.update stopST (nodes ! ref) nodeState+ })+ Pause ref -> (unitResp, m {+ nodeState = M.update pauseST (nodes ! ref) nodeState+ })+ UnPause ref -> (unitResp, m {+ nodeState = M.update unPauseST (nodes ! ref) nodeState+ })+ Delay _ -> (unitResp, m)++data NodeState+ = Running Int+ | Disconnected Int+ | Stopped Int+ | Paused Int+ | Done+ deriving stock (Show, Generic)+ deriving anyclass ToExpr++connectST :: NodeState -> Maybe NodeState+connectST (Disconnected wh) = Just $ Running wh+connectST st = error $ "is not dicsonnected but " ++ show st++disconnectST :: NodeState -> Maybe NodeState+disconnectST (Running wh) = Just $ Disconnected wh+disconnectST st = error $ "is not running but " ++ show st++stopST :: NodeState -> Maybe NodeState+stopST (Running wh) = Just $ Stopped wh+stopST st = error $ "is not running but " ++ show st++pauseST :: NodeState -> Maybe NodeState+pauseST (Running wh) = Just $ Paused wh+pauseST st = error $ "is not running but " ++ show st++unPauseST :: NodeState -> Maybe NodeState+unPauseST (Paused wh) = Just $ Running wh+unPauseST st = error $ "is not paused but " ++ show st++runsMp :: Int -> Map Int NodeState -> Bool+runsMp n mp = case M.lookup n mp of+ Just (Running _) -> True+ _ -> False++pausedMP :: Int -> Map Int NodeState -> Bool+pausedMP n mp = case M.lookup n mp of+ Just (Paused _) -> True+ _ -> False++disconnectedMP :: Int -> Map Int NodeState -> Bool+disconnectedMP n mp = case M.lookup n mp of+ Just (Disconnected _) -> True+ _ -> False++stoppedMp :: Int -> Map Int NodeState -> Bool+stoppedMp n mp = case M.lookup n mp of+ Just (Stopped _) -> True+ _ -> False++getRunning :: Map Int NodeState -> [(Int, Int)]+getRunning = mapMaybe f . M.toList+ where+ f (a, Running wh) = Just (a, wh)+ f _ = Nothing++getNotRunning :: Map Int NodeState -> [Int]+getNotRunning = mapMaybe f . M.toList+ where+ f (a, Stopped _) = Just a+ f (a, Done) = Just a+ f (a, Disconnected _) = Just a+ f (a, Paused _) = Just a+ f _ = Nothing++isStopped :: NodeState -> Bool+isStopped (Stopped _) = True+isStopped _ = False++isDisconnected :: NodeState -> Bool+isDisconnected (Disconnected _) = True+isDisconnected _ = False++initModel :: Model r+initModel = Model (DBModel [] M.empty [] 0 0) []++transition :: forall r. (Eq1 r, Show1 r) => Model r -> At Cmd r -> At Resp r -> Model r+transition model cmd = eventAfter . lockstep model cmd++precondition :: Model Symbolic -> At Cmd Symbolic -> Logic+precondition (Model DBModel{..} nodes) (At cmd) = case cmd of+ Spawn n _ _ j+ -> Boolean $ length (getRunning nodeState) <= 2+ && (not (null (getRunning nodeState)) || n == 0)+ && joinsRunning j nodeState+ && n < 3+ ReSpawn prevRef _ _ _ j+ -> Boolean $ elem prevRef (snd <$> nodes)+ && stoppedMp prevRef nodeState+ && length (getRunning nodeState) <= 2+ && joinsRunning j nodeState+ Stop n -> Boolean $ elem n (fst <$> nodes)+ && runsMp (nodes ! n) nodeState+ && nodes ! n /= 0+ && null (getNotRunning nodeState)+ && length (getRunning nodeState) == 3+ Disconnect n+ -> Boolean $ elem n (fst <$> nodes)+ && runsMp (nodes ! n) nodeState+ && null (getNotRunning nodeState)+ && nodes ! n /= 0+ && length (getRunning nodeState) == 3+ Connect n -> Boolean $ elem n (fst <$> nodes)+ && disconnectedMP (nodes ! n) nodeState+ Insert n _ -> Boolean $ elem n (fst <$> nodes)+ && runsMp (nodes ! n) nodeState+ Get n _ -> Boolean $ elem n (fst <$> nodes)+ && runsMp (nodes ! n) nodeState+ Pause n -> Boolean $ elem n (fst <$> nodes)+ && runsMp (nodes ! n) nodeState+ UnPause n -> Boolean $ elem n (fst <$> nodes)+ && pausedMP (nodes ! n) nodeState+ Delay _ -> Top++postcondition :: Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic+postcondition m@Model{..} cmd resp =+ toMock (eventAfter ev) resp .== eventMockResp ev+ where+ ev = lockstep m cmd resp++toMock :: Eq1 r => Model r -> At Resp r -> Resp Int+toMock Model{..} (At r) = fmap+ (\n -> fromMaybe (error "could not find person ref") $ Prelude.lookup n nodes) r++shrinker :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]+shrinker _ _ = []++semantics :: MVar Int -> At Cmd Concrete -> IO (At Resp Concrete)+semantics counter (At cmd) = At . Resp <$> case cmd of+ Insert node p -> do+ _ <- insertQuery (httpHost $ cn $ concrete node) p+ return $ Right Unit+ Get node lvl -> do+ res <- selectQuery lvl $ httpHost $ cn $ concrete node+ return $ case res of+ GetResult p -> Right $ Got p+ GetError e -> Left $ SomeError $ show e+ Spawn n t elt join -> do+ putStrLnM $ "Starting at " ++ show n ++ " joining " ++ show join+ c <- modifyMVar counter $ \m -> return (m + 1, m)+ bracketOnError (mkNodeTime c n t elt join)+ stopNode+ $ \rqNode -> do+ threadDelay 500000+ _ <- retryUntilAlive $ httpHost n+ _ <- createQuery $ httpHost n+ return $ Right $ Spawned $ reference rqNode+ ReSpawn n _ t elt join -> do+ putStrLnM $ "Restarting at " ++ show n ++ " joining " ++ show join+ c <- modifyMVar counter $ \m -> return (m + 1, m)+ bracketOnError (mkNodeTime c n t elt join)+ stopNode+ $ \rqNode -> do+ threadDelay 500000+ _ <- retryUntilAlive $ httpHost n+ return $ Right $ Spawned $ reference rqNode+ Stop node -> do+ putStrLnM $ "Stopping at " ++ show (cport $ concrete node)+ stopNode $ concrete node+ return $ Right Unit+ Disconnect node -> do+ disconnectNode $ nodeName $ concrete node+ return $ Right Unit+ Connect node -> do+ connectNode $ concrete node+ _ <- retryUntilAlive $ httpHost $ cn $ concrete node+ return $ Right Unit+ Pause node -> do+ pauseNode $ concrete node+ return $ Right Unit+ UnPause node -> do+ unPauseNode $ concrete node+ return $ Right Unit+ Delay n -> do+ threadDelay n+ return $ Right Unit++httpHost :: Int -> String+httpHost n = "172.19.0." ++ show (10 + n) ++ ":" ++ show (leaderPort + 2 * n)++mock :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)+mock (Model DBModel{..} _) (At cmd) = At <$> case cmd of+ Spawn {} -> Resp . Right . Spawned <$> genSym+ ReSpawn {} -> Resp . Right . Spawned <$> genSym+ Stop {} -> return unitResp+ Disconnect {} -> return unitResp+ Connect {} -> return unitResp+ Insert {} -> return unitResp+ Get {} -> return $ Resp $ Right $ Got persons+ Pause {} -> return unitResp+ UnPause {} -> return unitResp+ Delay {} -> return unitResp++sm :: MVar Int -> Maybe Level -> StateMachine Model (At Cmd) IO (At Resp)+sm counter lvl = StateMachine initModel transition precondition postcondition+ Nothing (generatorImpl lvl) shrinker (semantics counter) mock garbageCollect++prop_sequential_rqlite :: Maybe Level -> Property+prop_sequential_rqlite lvl =+ forAllCommands (sm undefined lvl) (Just 7) $ \cmds -> checkCommandNames cmds $ monadicIO $ do+ liftIO $ do+ createRQNetworks+ removePathForcibly testPath+ createDirectory testPath+ threadDelay 10000+ c <- liftIO $ newMVar 0+ (hist, _, res) <- runCommands (sm c lvl) cmds+ prettyCommands (sm undefined lvl) hist $ res === Ok++prop_parallel_rqlite :: Maybe Level -> Property+prop_parallel_rqlite lvl =+ forAllParallelCommands (sm undefined lvl) (Just 7) $ \cmds -> checkCommandNamesParallel cmds $ monadicIO $ do+ liftIO $ do+ createRQNetworks+ removePathForcibly testPath+ createDirectory testPath+ threadDelay 10000+ c <- liftIO $ newMVar 0+ prettyParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png)+ =<< runParallelCommandsNTimes 2 (sm c lvl) cmds++prop_nparallel_rqlite :: Int -> Maybe Level -> Property+prop_nparallel_rqlite np lvl =+ forAllNParallelCommands (sm undefined lvl) np $ \cmds ->+ monadicIO $ do+ liftIO $ do+ removePathForcibly testPath+ createDirectory testPath+ threadDelay 10000+ c <- liftIO $ newMVar 0+ prettyNParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png)+ =<< runNParallelCommandsNTimes 1 (sm c lvl) cmds+++runCmds :: ParallelCommandsF [] (At Cmd) (At Resp) -> Property+runCmds cmds = withMaxSuccess 1 $ noShrinking $ monadicIO $ do+ liftIO $ do+ removePathForcibly testPath+ createDirectory testPath+ c <- liftIO $ newMVar 0+ ls <- runNParallelCommandsNTimes 1 (sm c $ Just Weak) cmds+ prettyNParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png) ls+ liftIO $ print $ fst $ head ls+ liftIO $ print $ interleavings $ unHistory $ fst $ head ls++garbageCollect :: Model Concrete -> IO ()+garbageCollect (Model _ nodes) =+ forM_ nodes $ \(Reference (Concrete node), p) -> do+ putStrLnM $ "stopping " ++ show p+ stopNode node++generatorImpl :: Maybe Level -> Model Symbolic -> Maybe (Gen (At Cmd Symbolic))+generatorImpl _ (Model _ []) = Just $ return $ At initCmd+generatorImpl lvl (Model DBModel{..} nodes) = Just $ At <$> do+ node <- fst <$> elements nodes+ let+ reconnect :: (Int, Gen (Cmd (NodeRef Symbolic)))+ reconnect = case find (isDisconnected . snd) (M.toList nodeState) of+ (Just (_, Disconnected _)) ->+ (100, return $ Connect node)+ _ -> (0, undefined)+ frequency+ [ (5, Insert node <$> arbitrary)+ , (5, return $ Get node lvl)+ , (if cWhere <= 3 then 20 else 0, return $ mkSpawn Nothing cWhere $ joinNode False nodeState)+ , (if cWhere == 3 then 20 else 0, return $ Stop node)+ , (if cWhere == 3 then 20 else 0, return $ Disconnect node)+ , respawn+ , reconnect]+ where++ respawn :: (Int, Gen (Cmd (NodeRef Symbolic)))+ respawn = case find (isStopped . snd) (M.toList nodeState) of+ (Just (ref, Stopped n)) ->+ -- Sometimes, when a node respawns the rqlite files are not found+ -- and the test fails. I'm not sure why this happens.+ -- Until this is properly fixed, we disable this command.+ (0, return $ mkSpawn (Just ref) n $ joinNode True nodeState)+ _ -> (0, undefined)++joinNode :: Bool -> Map Int NodeState -> Maybe Int+joinNode avoid0 ndState =+ case snd <$> getRunning ndState of+ [] -> Nothing+ rs -> Just $ case (elem 0 rs, delete 0 rs, avoid0) of+ (False, _, _) -> head rs+ (True, _, False) -> 0+ (True, rs', True) -> head rs'++joinsRunning :: Maybe Int -> Map Int NodeState -> Bool+joinsRunning Nothing _ = True+joinsRunning (Just n) mp = elem n $ snd <$> getRunning mp++initCmd :: Cmd node+initCmd = Spawn 0 (Sec 1) (Sec 1) Nothing++mkSpawn :: Maybe Int -> Int -> Maybe Int -> Cmd node+mkSpawn respawm n =+ (case respawm of+ Nothing -> Spawn+ Just ref -> ReSpawn ref) n (Sec 1) (Sec 1)++testPath :: String+testPath = "rqlite-test-output"++names :: [String]+names = ["John", "Stevan", "Kostas", "Curry", "Robert"]++leaderPort :: Int+leaderPort = 4001++instance Arbitrary Person where+ arbitrary = do+ n <- elements names+ a <- choose (0, 100)+ return $ Person n a++putStrLnM :: String -> IO ()+putStrLnM str = when isDebugging $ putStrLn str++isDebugging :: Bool+isDebugging = False
+ test/SQLite.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-identities #-}++module SQLite+ ( prop_sequential_sqlite+ , prop_parallel_sqlite+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad.IO.Unlift+ (MonadUnliftIO, withRunInIO)+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Bifoldable+import Data.Bifunctor+import qualified Data.Bifunctor.TH as TH+import Data.Bitraversable+import Data.Functor.Classes+import Data.Kind+ (Type)+import Data.List hiding+ (insert)+import Data.Maybe+ (fromMaybe)+import Data.Pool+import Data.Text+ (Text)+import Data.TreeDiff.Expr+import Database.Persist+import Database.Persist.Sqlite+import Database.Sqlite hiding+ (step)+import GHC.Generics+ (Generic, Generic1)+import Prelude+import System.Directory+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.StateMachine+import Test.StateMachine.DotDrawing+import Test.StateMachine.Types+import qualified Test.StateMachine.Types.Rank2 as Rank2++import Schema++------------------------------------------------------------------------++newtype At t r = At {unAt :: t (PRef r) (CRef r)}+ deriving stock (Generic)++type PRef = Reference (Key Person)+type CRef = Reference (Key Car)++deriving stock instance Show1 r => Show (At Resp r)+deriving stock instance Show1 r => Show (At Cmd r)+deriving stock instance Eq1 r => Eq (At Resp r)++data TableEntity+ = TPerson Person+ | TCar Car+ deriving stock (Eq, Show, Ord)++data Tag = SPerson | SCar+ deriving stock (Eq, Show)++data Cmd kp kh =+ Insert TableEntity+ | SelectList Tag+ deriving stock (Show, Generic1)++data Model (r :: Type -> Type) = Model+ { dbModel :: DBModel+ , knownPerson :: [(PRef r, Int)]+ , knownCars :: [(CRef r, Int)]+ } deriving stock (Generic, Show)++data DBModel = DBModel {+ persons :: [(Int, Person)]+ , nextPerson :: Int+ , cars :: [(Int, Car)]+ , nextCar :: Int+ } deriving stock (Generic, Show)++initModelImpl :: Model r+initModelImpl = Model (DBModel [] 0 [] 0) [] []++newtype Resp kp kc = Resp (Either SqliteException (Success kp kc))+ deriving stock (Show, Generic1)++instance (Eq kp, Eq kc) => Eq (Resp kp kc) where+ (Resp (Left e1)) == (Resp (Left e2)) = seError e1 == seError e2+ (Resp (Right r1)) == (Resp (Right r2)) = r1 == r2+ _ == _ = False++getPers :: Resp kp kc -> [kp]+getPers (Resp (Right (InsertedPerson kp))) = [kp]+getPers _ = []++getCars :: Resp kp kc -> [kc]+getCars (Resp (Right (InsertedCar kc))) = [kc]+getCars _ = []++data Success kp kc =+ Unit ()+ | InsertedPerson kp+ | InsertedCar kc+ | List [TableEntity]+ deriving stock (Show, Eq, Generic1)++data Event r = Event+ { eventBefore :: Model r+ , eventCmd :: At Cmd r+ , eventAfter :: Model r+ , eventMockResp :: Resp Int Int+ }++lockstep :: forall r. (Show1 r, Ord1 r)+ => Model r+ -> At Cmd r+ -> At Resp r+ -> Event r+lockstep model@Model {..} cmd resp = Event+ { eventBefore = model+ , eventCmd = cmd+ , eventAfter = Model {+ dbModel = dbModel'+ , knownPerson = union' knownPerson newPerson+ , knownCars = union' knownCars newCars+ }+ , eventMockResp = mockResp+ }+ where+ (mockResp, dbModel') = step model cmd+ newPerson = zip (getPers $ unAt resp) (getPers mockResp)+ newCars = zip (getCars $ unAt resp) (getCars mockResp)++union' :: forall k v. (Eq k, Eq v, Show k, Show v)+ => [(k, v)] -- Mapping known to have duplicate keys+ -> [(k, v)] -- With potential duplicates+ -> [(k, v)]+union' acc [] = acc+union' acc ((k, v) : kvs) =+ case lookup k acc of+ Just v' | v /= v' -> error $ renderError v'+ _otherwise -> union' ((k, v) : acc) kvs+ where+ renderError :: v -> String+ renderError v' = unwords [+ "Key"+ , show k+ , "with two different values"+ , show v+ , "and"+ , show v'+ ]++toMock :: Eq1 r => Model r -> At Resp r -> Resp Int Int+toMock Model{..} (At r) =+ bimap (\p -> fromMaybe (error "could not find person ref") $ lookup p knownPerson)+ (\c -> fromMaybe (error "could not find car ref") $ lookup c knownCars) r++canInsertP :: Person -> [Person] -> Bool+canInsertP p ps = personName p `notElem` (personName <$> ps)++canInsertC :: Car -> [Car] -> Bool+canInsertC c cs = carCid c `notElem` (carCid <$> cs)++step :: Model r+ -> At Cmd r+ -> (Resp Int Int, DBModel)+step Model{..} = runPure dbModel++runPure :: DBModel -> At Cmd r -> (Resp Int Int, DBModel)+runPure dbModel@DBModel{..} cmd = case unAt cmd of+ Insert (TPerson person) ->+ if canInsertP person $ snd <$> persons+ then (Resp $ Right $ InsertedPerson nextPerson, dbModel{persons = (nextPerson, person) : persons, nextPerson = nextPerson + 1})+ else (Resp $ Left $ SqliteException ErrorConstraint "" "constraint error Primary Key", dbModel)+ Insert (TCar car) -> if canInsertC car $ snd <$> cars+ then if carOwner car `elem` (PersonKey . personName . snd <$> persons)+ then (Resp $ Right $ InsertedCar nextCar, dbModel{cars = (nextCar, car) : cars, nextCar = nextCar + 1})+ else (Resp $ Left $ SqliteException ErrorConstraint "" "constraint error Foreign Key", dbModel)+ else (Resp $ Left $ SqliteException ErrorConstraint "" "constraint error Primary Key", dbModel)+ SelectList SPerson ->+ (Resp $ Right $ List $ TPerson . snd <$> persons, dbModel)+ SelectList SCar ->+ (Resp $ Right $ List $ TCar . snd <$> cars, dbModel)++mockImpl :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)+mockImpl model cmdErr = At <$> bitraverse (const genSym) (const genSym) mockResp+ where+ (mockResp, _model') = step model cmdErr++shrinkerImpl :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]+shrinkerImpl _ _ = []++semanticsImpl :: MonadIO m => AsyncWithPool SqlBackend -> MVar () -> At Cmd Concrete -> m (At Resp Concrete)+semanticsImpl poolBackend _lock cmd = At . Resp <$>+ case unAt cmd of+ Insert (TPerson person) -> do+ ret <- liftIO $ try $ runNoLoggingT $ flip runSqlAsyncWrite poolBackend $+ insert person+ case ret of+ Right key -> return $ Right $ InsertedPerson $ reference key+ Left (e :: SqliteException) ->+ return $ Left e+ Insert (TCar car) -> do+ ret <- liftIO $ try $ runNoLoggingT $ flip runSqlAsyncWrite poolBackend $+ insert car+ case ret of+ Right key -> return $ Right $ InsertedCar $ reference key+ Left (e :: SqliteException) ->+ return $ Left e+ SelectList ts -> do+ ret <- liftIO $ try $ runNoLoggingT $ flip runSqlAsyncRead poolBackend $+ case ts of+ SPerson -> do+ (pers :: [Entity Person]) <- selectList [] []+ return $ TPerson . entityVal <$> pers+ SCar -> do+ (pers :: [Entity Car]) <- selectList [] []+ return $ TCar . entityVal <$> pers+ case ret of+ Right ls -> return $ Right $ List ls+ Left (e :: SqliteException) ->+ return $ Left e++preconditionImpl :: Model Symbolic -> At Cmd Symbolic -> Logic+preconditionImpl Model{..} cmd = case unAt cmd of+ Insert (TPerson p) -> Boolean $ canInsertP p (snd <$> persons dbModel)+ Insert (TCar c) -> Boolean $ canInsertC c (snd <$> cars dbModel)+ && let PersonKey p = carOwner c+ in (p `elem` (personName . snd <$> persons dbModel))+ _ -> Top++equalResp' :: (Eq kp, Eq kc, Show kp, Show kc) => Resp kp kc -> Resp kp kc -> Logic+equalResp' (Resp (Right _)) (Resp (Right _)) = Top+equalResp' r1 r2 = r1 .== r2++postconditionImpl :: Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic+postconditionImpl model cmd resp =+ equalResp' (toMock (eventAfter ev) resp) (eventMockResp ev)+ where+ ev = lockstep model cmd resp++transitionImpl :: (Show1 r, Ord1 r) => Model r -> At Cmd r -> At Resp r -> Model r+transitionImpl model cmd = eventAfter . lockstep model cmd++deriving anyclass instance ToExpr DBModel+deriving anyclass instance ToExpr (Model Concrete)++sm :: MonadIO m => String -> AsyncWithPool SqlBackend -> MVar () -> StateMachine Model (At Cmd) m (At Resp)+sm folder poolBackend lock = StateMachine {+ initModel = initModelImpl+ , transition = transitionImpl+ , precondition = preconditionImpl+ , postcondition = postconditionImpl+ , invariant = Nothing+ , generator = generatorImpl+ , shrinker = shrinkerImpl+ , semantics = semanticsImpl poolBackend lock+ , mock = mockImpl+ , cleanup = clean folder+ }++smUnused :: StateMachine Model (At Cmd) IO (At Resp)+smUnused = sm undefined undefined undefined++generatorImpl :: Model Symbolic -> Maybe (Gen (At Cmd Symbolic))+generatorImpl Model {..} = Just $ At <$>+ frequency [ (3, Insert <$> arbitrary)+ , (3, SelectList <$> arbitrary)+ ]++instance Arbitrary TableEntity where+ arbitrary = frequency [+ (1, TPerson <$> arbitrary)+ , (1, TCar <$> arbitrary)+ ]++instance Arbitrary Tag where+ arbitrary = frequency+ [(1, return SPerson), (1, return SCar)]++deriving anyclass instance ToExpr Person+deriving anyclass instance ToExpr (Key Person)+deriving stock instance Generic (Key Person)+deriving anyclass instance ToExpr Car+deriving stock instance Generic Person+deriving stock instance Generic Car+deriving stock instance Generic (Key Car)++instance ToExpr (Key Car) where+ toExpr key = App (show key) []++clean :: MonadIO m => String -> Model Concrete -> m ()+clean folder _ = liftIO $ removePathForcibly folder++prop_sequential_sqlite :: Property+prop_sequential_sqlite =+ forAllCommands smUnused Nothing $ \cmds -> monadicIO $ do+ liftIO $ do+ removePathForcibly "sqlite-seq"+ createDirectory "sqlite-seq"+ db <- liftIO $ runNoLoggingT $ createSqliteAsyncPool "sqlite-seq/persons.db" 5+ _ <- liftIO $ flip runSqlAsyncWrite db $ do+ _ <- runMigrationQuiet $ migrate entityDefs $ entityDef (Nothing :: Maybe Person)+ runMigrationQuiet $ migrate entityDefs $ entityDef (Nothing :: Maybe Car)+ lock <- liftIO $ newMVar ()+ (hist, _model, res) <- runCommands (sm "sqlite-seq" db lock) cmds+ prettyCommands smUnused hist $ res === Ok++prop_parallel_sqlite :: Property+prop_parallel_sqlite =+ forAllParallelCommands smUnused Nothing $ \cmds -> monadicIO $ do+ liftIO $ do+ removePathForcibly "sqlite-par"+ createDirectory "sqlite-par"+ qBackend <- liftIO $ runNoLoggingT $ createSqliteAsyncPool "sqlite-par/persons.db" 5+ _ <- liftIO $ flip runSqlAsyncWrite qBackend $ do+ _ <- runMigrationQuiet $ migrate entityDefs $ entityDef (Nothing :: Maybe Person)+ runMigrationQuiet $ migrate entityDefs $ entityDef (Nothing :: Maybe Car)+ lock <- liftIO $ newMVar ()+ ret <- runParallelCommandsNTimes 1 (sm "sqlite-par" qBackend lock) cmds+ prettyParallelCommandsWithOpts cmds (Just $ GraphOptions "sqlite.jpeg" Jpeg) ret+ liftIO $ closeSqlAsyncPool qBackend++instance Bifoldable t => Rank2.Foldable (At t) where+ foldMap = \f (At x) -> bifoldMap (app f) (app f) x+ where+ app :: (r x -> m) -> Reference x r -> m+ app f (Reference x) = f x++instance Bifunctor t => Rank2.Functor (At t) where+ fmap = \f (At x) -> At (bimap (app f) (app f) x)+ where+ app :: (r x -> r' x) -> Reference x r -> Reference x r'+ app f (Reference x) = Reference (f x)++instance Bitraversable t => Rank2.Traversable (At t) where+ traverse = \f (At x) -> At <$> bitraverse (app f) (app f) x+ where+ app :: Functor f+ => (r x -> f (r' x)) -> Reference x r -> f (Reference x r')+ app f (Reference x) = Reference <$> f x++{-------------------------------------------------------------------------------------------+ Async+-------------------------------------------------------------------------------------------}++data AsyncQueue r = AsyncQueue+ { asyncThreadId :: !ThreadId+ -- ^ Returns the 'ThreadId' of the thread running++ , _asyncQueue :: TBQueue (AsyncAction r)+ -- ^ A queue which can be used to send actions+ -- to the thread.++ , _serves :: TVar Bool++ , _resource :: r+ -- ^ the resource. We may not want to give AsyncQueue+ -- access to the resource and allow only the forked thread+ -- to have access.+ }++instance Eq (AsyncQueue a) where+ a == b = asyncThreadId a == asyncThreadId b++data AsyncAction r = forall a. AsyncAction (r -> IO a) (TMVar (Either SomeException a))++asyncQueueBound :: Int -> IO r -> IO (AsyncQueue r)+asyncQueueBound = asyncQueueUsing forkOS++asyncQueueUsing :: (IO () -> IO ThreadId) -> Int+ -> IO r -> IO (AsyncQueue r)+asyncQueueUsing doFork queueSize createResource = do+ resVar :: TMVar (Either SomeException r) <- newEmptyTMVarIO+ servesVar <- newTVarIO True+ queue <- newTBQueueIO $ fromIntegral queueSize+ t <- doFork $+ handle (atomically . putTMVar resVar . Left) $ do+ r <- createResource+ atomically $ putTMVar resVar $ Right r+ serve queue servesVar r+ res <- atomically $ takeTMVar resVar+ case res of+ Left e -> throwIO e+ Right r -> return $ AsyncQueue t queue servesVar r++serve :: TBQueue (AsyncAction r) -> TVar Bool -> r -> IO ()+serve queue serves resource = go+ where+ go = do+ AsyncAction action mvar <- atomically $ readTBQueue queue+ ret <- try $ action resource+ atomically $ putTMVar mvar ret+ servesNow <- readTVarIO serves+ when servesNow go++waitQueue :: AsyncQueue r -> (r -> IO a) -> IO a+waitQueue async action = do+ resp <- newEmptyTMVarIO+ atomically $ do+ serves <- readTVar $ _serves async+ if serves then writeTBQueue (_asyncQueue async) $ AsyncAction action resp+ else throwSTM $ userError "Doesn't serve"+ ret <- atomically $ takeTMVar resp+ case ret of+ Left e -> throwIO e+ Right a -> return a++data AsyncWithPool r = AsyncWithPool {+ queue :: AsyncQueue r+ , pool :: Pool r+ }++mkAsyncWithPool :: AsyncQueue r -> Pool r -> AsyncWithPool r+mkAsyncWithPool = AsyncWithPool++createSqliteAsyncQueue :: (MonadLogger m, MonadUnliftIO m)+ => Text -> m (AsyncQueue SqlBackend)+createSqliteAsyncQueue str = do+ logFunc <- askLogFunc+ liftIO $ asyncQueueBound 1000 $ open' str logFunc++createSqliteAsyncPool :: (MonadLogger m, MonadUnliftIO m)+ => Text -> Int -> m (AsyncWithPool SqlBackend)+createSqliteAsyncPool str n = do+ q <- createSqliteAsyncQueue str+ p <- createSqlitePool str n+ return $ mkAsyncWithPool q p++open' :: Text -> LogFunc -> IO SqlBackend+open' str logFunc = do+ conn <- open str+ wrapConnection conn logFunc `onException` close conn++runSqlAsyncWrite :: MonadUnliftIO m => ReaderT SqlBackend m a -> AsyncWithPool SqlBackend -> m a+runSqlAsyncWrite r a = runSqlAsyncQueue r (queue a)++runSqlAsyncRead :: MonadUnliftIO m => ReaderT SqlBackend m a -> AsyncWithPool SqlBackend -> m a+runSqlAsyncRead r a = runSqlPool r $ pool a++closeSqlAsyncPool :: AsyncWithPool SqlBackend -> IO ()+closeSqlAsyncPool (AsyncWithPool q p) = do+ closeSqlAsyncQueue q+ destroyAllResources p++runSqlAsyncQueue :: MonadUnliftIO m => ReaderT SqlBackend m a -> AsyncQueue SqlBackend -> m a+runSqlAsyncQueue r q = withRunInIO $ \run' ->+ waitQueue q $ run' . runSqlConn r++closeSqlAsyncQueue :: AsyncQueue SqlBackend -> IO ()+closeSqlAsyncQueue q = waitQueue q close'++TH.deriveBifunctor ''Success+TH.deriveBifoldable ''Success+TH.deriveBitraversable ''Success++TH.deriveBifunctor ''Resp+TH.deriveBitraversable ''Resp+TH.deriveBifoldable ''Resp++TH.deriveBifunctor ''Cmd+TH.deriveBifoldable ''Cmd+TH.deriveBitraversable ''Cmd
+ test/Schema.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema+ ( Person (..)+ , Car (..)+ , Key (..)+ , CarId+ , entityDefs+ ) where++import Database.Persist.Class+import Database.Persist.Sqlite+import Database.Persist.TH+import Prelude+import Test.QuickCheck++share [mkPersist sqlSettings, mkSave "entityDefs"] [persistLowerCase|+Person+ name String+ age Int+ Primary name+ deriving Show+ deriving Eq+ deriving Ord++Car+ cid Int+ color String Maybe+ owner PersonId+ deriving Show+ deriving Eq+ deriving Ord+|]++instance Arbitrary Person where+ arbitrary = Person <$> elements names+ <*> suchThat arbitrary (>0)++instance Arbitrary Car where+ arbitrary = Car <$> arbitrary+ <*> genColor+ <*> (PersonKey <$> elements names)++names :: [String]+names = ["John", "Stevan", "Kostas", "Curry", "Robert"]++colors :: [String]+colors = ["black", "blue", "red", "yellow"]++genColor :: Gen (Maybe String)+genColor = elements $ Nothing : (Just <$> colors)
test/ShrinkingProps.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImplicitParams #-}@@ -21,11 +22,10 @@ , ShrinkParFailure(..) ) where -import Prelude hiding- (elem)+import Prelude import Control.Monad- (replicateM)+ (forM_, replicateM) import Control.Monad.Except (Except, runExcept, throwError) import Control.Monad.State@@ -36,17 +36,17 @@ (toList) import Data.Functor.Classes (Eq1, Show1)+import Data.List.Split+ (chunksOf) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Monoid- ((<>)) import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.TreeDiff- (ToExpr(..), defaultExprViaShow)+ (defaultExprViaShow) import Data.Typeable (Typeable) import GHC.Generics@@ -60,9 +60,9 @@ (monadicIO) import Test.Tasty import Test.Tasty.QuickCheck- (Arbitrary(..), Gen, Property, conjoin,- counterexample, elements, getNonNegative, getSmall,- oneof, property, testProperty, (===))+ (Gen, Property, choose, conjoin, counterexample,+ elements, forAllShrinkShow, oneof, property,+ testProperty, (===)) import Test.StateMachine import qualified Test.StateMachine.Parallel as QSM@@ -70,17 +70,27 @@ import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.StateMachine.Utils- (forAllShrinkShow)+ (Shrunk(..), shrinkListS', shrinkListS',+ shrinkListS'', shrinkPairS') +------------------------------------------------------------------------+ tests :: TestTree tests = testGroup "Shrinking properties" [- testProperty "Sanity check: standard sequential test" prop_sequential- , testProperty "Sanity check: standard parallel test" prop_parallel- , testProperty "Correct references after sequential shrinking" prop_sequential_subprog- , testProperty "Correct references after parallel shrinking" prop_parallel_subprog- , testProperty "Correct references after parallel shrinking (buggyShrinkCmds)" (prop_parallel_subprog' buggyShrinkCmds)- , testProperty "Sequential shrinker provides correct model" prop_sequential_model- , testProperty "Parallel shrinker provides correct model" prop_parallel_model+ testProperty "Sanity check: standard sequential test" prop_sequential+ , testProperty "Sanity check: standard parallel test" prop_parallel+ , testProperty "Sanity check: standard 3-parallel test" prop_3parallel+ , testProperty "Correct references after sequential shrinking" prop_sequential_subprog+ , testProperty "Correct references after parallel shrinking" prop_parallel_subprog+ , testProperty "Correct references after 3-parallel shrinking" prop_nparallel_subprog+ , testProperty "Correct references after parallel shrinking (buggyShrinkCmds)" (prop_parallel_subprog' buggyShrinkCmds)+ , testProperty "Sequential shrinker provides correct model" prop_sequential_model+ , testProperty "Parallel shrinker provides correct model" prop_parallel_model+ , testProperty "2-Parallel shrinker provides correct model" $ prop_nparallel_model 2+ , testProperty "3-Parallel shrinker provides correct model" $ prop_nparallel_model 3+ , testProperty "1-Parallel is equivalent to sequential" prop_one_thread+ , testProperty "2 Threads equivalence" prop_pairs_round_trip+ , testProperty "shrink round trips" prop_shrink_round_trip ] {-------------------------------------------------------------------------------@@ -95,7 +105,7 @@ -- -- This is used when testing whether shrinking messes up references (see below) newtype CmdID = CmdID Int- deriving (Show, Eq, Ord, Generic)+ deriving stock (Show, Eq, Ord, Generic) -- | Commands --@@ -115,13 +125,14 @@ -- | Get the value of the specified variables | Read CmdID (Maybe (Model Symbolic)) [var]- deriving (Show, Eq, Functor, Foldable, Traversable, Generic1, CommandNames)+ deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic1)+ deriving anyclass CommandNames data Resp var = Refs [var] | Unit () | Vals [Int]- deriving (Show, Eq, Functor, Foldable, Traversable)+ deriving stock (Show, Eq, Functor, Foldable, Traversable) cmdID :: Cmd var -> CmdID cmdID (CreateRef cid _ _) = cid@@ -139,11 +150,11 @@ -- | Mock variable newtype MockVar = MockVar Int- deriving (Show, Eq, Ord, Generic)+ deriving stock (Show, Eq, Ord, Generic) -- | Mock system state newtype MockState = MockState (Map MockVar Int)- deriving (Show, Eq, Ord, Generic)+ deriving stock (Show, Eq, Ord, Generic) newVar :: State MockState MockVar newVar = state $ \(MockState m) ->@@ -175,7 +186,7 @@ -------------------------------------------------------------------------------} data IOVar = IOVar String (TVar Int)- deriving (Eq)+ deriving stock Eq instance Show IOVar where show (IOVar l _) = "<" ++ l ++ ">"@@ -199,7 +210,8 @@ -------------------------------------------------------------------------------} newtype At f r = At (f (Reference IOVar r))- deriving (Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable)+ deriving stock Generic1+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable) type (:@) f r = At f r @@ -221,7 +233,7 @@ -- -- We include the CmdID so that we can reference it in the generator data Model r = Model MockState (KnownRefs r) CmdID- deriving (Generic, Eq)+ deriving stock (Generic, Eq) initModel :: Model r initModel = Model (MockState Map.empty) [] (CmdID 0)@@ -273,6 +285,8 @@ -------------------------------------------------------------------------------} generator :: Model Symbolic -> Maybe (Gen (Cmd :@ Symbolic))+generator (Model _ [] cid) = Just $+ At . CreateRef cid Nothing <$> small generator (Model _ knownRefs cid) = Just $ oneof [ At . CreateRef cid Nothing <$> small , small >>= \n -> At . Incr cid Nothing <$> replicateM n pickRef@@ -282,8 +296,8 @@ pickRef :: Gen (Reference IOVar Symbolic) pickRef = elements (map fst knownRefs) - small :: Gen Int- small = getSmall . getNonNegative <$> arbitrary+small :: Gen Int+small = choose (0,30) -- | Shrinker --@@ -306,7 +320,7 @@ precondition :: Model Symbolic -> Cmd :@ Symbolic -> Logic precondition (Model _ knownRefs _) (At cmd) =- forall (toList cmd) (`elem` map fst knownRefs)+ forall (toList cmd) (`member` map fst knownRefs) postcondition :: HasCallStack => Model Concrete -> Cmd :@ Concrete -> Resp :@ Concrete -> Logic@@ -333,25 +347,28 @@ , semantics = semantics , mock = mock , invariant = Nothing- , distribution = Nothing+ , cleanup = noCleanup } {------------------------------------------------------------------------------- The type class instances required by QSM -------------------------------------------------------------------------------} -deriving instance Show1 r => Show (Cmd :@ r)-deriving instance Show1 r => Show (Resp :@ r)-deriving instance Show1 r => Show (Model r)+deriving stock instance Eq1 r => Eq (Cmd :@ r)+deriving stock instance Eq1 r => Eq (Resp :@ r) +deriving stock instance Show1 r => Show (Cmd :@ r)+deriving stock instance Show1 r => Show (Resp :@ r)+deriving stock instance Show1 r => Show (Model r)+ instance CommandNames (At Cmd) where cmdName (At cmd) = cmdName cmd cmdNames _ = cmdNames (Proxy @(Cmd ())) -deriving instance ToExpr (Model Concrete)-deriving instance ToExpr MockState-deriving instance ToExpr MockVar-deriving instance ToExpr CmdID+deriving anyclass instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr MockState+deriving anyclass instance ToExpr MockVar+deriving anyclass instance ToExpr CmdID instance ToExpr IOVar where toExpr = defaultExprViaShow@@ -366,9 +383,13 @@ prettyCommands sm hist (checkCommandNames cmds (res === Ok)) prop_parallel :: Property-prop_parallel = forAllParallelCommands sm $ \cmds -> monadicIO $+prop_parallel = forAllParallelCommands sm Nothing $ \cmds -> monadicIO $ prettyParallelCommands cmds =<< runParallelCommands sm cmds +prop_3parallel :: Property+prop_3parallel = forAllNParallelCommands sm 3 $ \cmds -> monadicIO $+ prettyNParallelCommands cmds =<< runNParallelCommands sm cmds+ {------------------------------------------------------------------------------- Test that shrinking does not mess up references @@ -379,7 +400,7 @@ -------------------------------------------------------------------------------} data ExplicitRef = ExplicitRef CmdID Int- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) type RefGraph = Map CmdID (Set ExplicitRef) @@ -436,7 +457,7 @@ , ssfGrOrig :: RefGraph , ssfGrShrunk :: RefGraph }- deriving (Show)+ deriving stock Show -- | Test that sequential shrinking results in a program whose reference -- graph is a subgraph of the reference graph of the original program@@ -458,14 +479,16 @@ walk over all commands in 'ParallelCommands' -------------------------------------------------------------------------------} -data ShrinkParFailure = SPF {- spfOrig :: QSM.ParallelCommands (At Cmd) (At Resp)- , spfShrunk :: QSM.ParallelCommands (At Cmd) (At Resp)+data ShrinkParFailure t = SPF {+ spfOrig :: QSM.ParallelCommandsF t (At Cmd) (At Resp)+ , spfShrunk :: QSM.ParallelCommandsF t (At Cmd) (At Resp) , spfTrOrig :: RefGraph , spfTrShrunk :: RefGraph }- deriving (Show) +deriving stock instance Show (ShrinkParFailure QSM.Pair)+deriving stock instance Show (ShrinkParFailure [])+ -- | Compute reference graph for a parallel program -- -- We do this by constructing the refernce graph of the sequential program@@ -475,9 +498,13 @@ refGraph' (QSM.ParallelCommands prefix suffixes) = refGraph (prefix <> mconcat (map (\(QSM.Pair l r) -> l `mappend` r) suffixes)) +refGraph'' :: HasCallStack => QSM.NParallelCommands (At Cmd) (At Resp) -> RefGraph+refGraph'' (QSM.ParallelCommands prefix suffixes) =+ refGraph (prefix <> mconcat (mconcat suffixes))+ prop_parallel_subprog :: Property prop_parallel_subprog =- forAllShrinkShow (QSM.generateParallelCommands sm) (const []) ppShow $+ forAllShrinkShow (QSM.generateParallelCommands sm Nothing) (const []) ppShow $ prop_parallel_subprog' where -- TODO add as a test (?)@@ -493,6 +520,41 @@ where cmds' = refGraph' cmds +prop_shrink_round_trip :: ([Int], [Int]) -> Property+prop_shrink_round_trip (ls1, ls2) =+ let+ ex = shrinkPairS' shrinkListS' (ls1, ls2)+ f (Shrunk wasShrunk [x,y]) = Shrunk wasShrunk (x,y)+ f (Shrunk _ _) = error "invariant violated! shrunk list should have length 2"+ val = f <$> shrinkListS'' shrinkListS' [ls1, ls2]+ in+ val === ex++prop_pairs_round_trip :: Property+prop_pairs_round_trip = forAllParallelCommands sm Nothing $ \pairCmds ->+ let+ pairShrunk = QSM.shrinkParallelCommands sm pairCmds+ listCmds = QSM.fromPair' pairCmds+ listShrunk = QSM.shrinkNParallelCommands sm listCmds+ listShrunkPair = QSM.toPairUnsafe' <$> listShrunk+ in+ listShrunkPair === pairShrunk++prop_nparallel_subprog :: Property+prop_nparallel_subprog =+ forAllShrinkShow (QSM.generateNParallelCommands sm 3) (const []) ppShow $+ prop_nparallel_subprog'++prop_nparallel_subprog' :: QSM.NParallelCommands (At Cmd) (At Resp) -> Property+prop_nparallel_subprog' cmds =+ conjoin [ let shrunk' = refGraph'' shrunk in+ counterexample (ppShow (SPF cmds shrunk cmds' shrunk')) $+ shrunk' `isSubGraphOf` cmds'+ | shrunk <- QSM.shrinkNParallelCommands sm cmds+ ]+ where+ cmds' = refGraph'' cmds+ -- A set of valid commands to resulted in an invalid shrink buggyShrinkCmds :: QSM.ParallelCommands (At Cmd) (At Resp) buggyShrinkCmds = QSM.ParallelCommands (QSM.Commands [])@@ -569,6 +631,33 @@ suffix separately -------------------------------------------------------------------------------} +checkCorrectModelNParallel :: QSM.NParallelCommands (At Cmd) (At Resp) -> Property+checkCorrectModelNParallel = \(QSM.ParallelCommands prefix suffixes) ->+ case runExcept (go prefix suffixes) of+ Left err -> counterexample err $ property False+ Right () -> property True+ where+ go :: QSM.Commands (At Cmd) (At Resp)+ -> [[QSM.Commands (At Cmd) (At Resp)]]+ -> Except String ()+ go prefix suffixes = do+ modelAfterPrefix <- checkCorrectModel' initModel prefix+ go' modelAfterPrefix suffixes++ go' :: Model Symbolic+ -> [[QSM.Commands (At Cmd) (At Resp)]]+ -> Except String ()+ go' _ [] = return ()+ go' m ([] : suffixes) =+ go' m suffixes+ go' m ((headThread : suffix) : suffixes) = do+ modelAfterHead <- checkCorrectModel' m headThread+ -- The starting model for the right part is the /initial/ model:+ -- it should not be affected by the left part+ forM_ suffix $ checkCorrectModel' m+ -- But when we check the /next/ suffix, /both/ parts have been executed+ go' (foldl (\m' r -> QSM.advanceModel sm m' r) modelAfterHead suffix) suffixes+ checkCorrectModelParallel :: QSM.ParallelCommands (At Cmd) (At Resp) -> Property checkCorrectModelParallel = \(QSM.ParallelCommands prefix suffixes) -> case runExcept (go prefix suffixes) of@@ -596,7 +685,71 @@ prop_parallel_model :: Property prop_parallel_model =- forAllShrinkShow (QSM.generateParallelCommands sm) (const []) ppShow $ \cmds ->+ forAllShrinkShow (QSM.generateParallelCommands sm Nothing) (const []) ppShow $ \cmds -> conjoin [ checkCorrectModelParallel shrunk | shrunk <- QSM.shrinkParallelCommands sm cmds ]++prop_nparallel_model :: Int -> Property+prop_nparallel_model n =+ forAllShrinkShow (QSM.generateNParallelCommands sm n) (const []) ppShow $ \cmds ->+ conjoin [ checkCorrectModelNParallel shrunk+ | shrunk <- QSM.shrinkNParallelCommands sm cmds+ ]++prop_one_thread :: Int -> Property+prop_one_thread n = forAllCommands sm Nothing $ \cmds -> monadicIO $ do+ let n' = 1 + (n `mod` 10)+ (hist, _model, _res) <- runCommands sm cmds+ let cmdsList = QSM.unCommands cmds+ (px, sx) = splitAt (div (length cmdsList) 3) cmdsList+ cmdsChucks = chunksOf n' sx+ sfxs = (\c -> [c]) . QSM.Commands <$> cmdsChucks+ nParallelCmd = QSM.ParallelCommands {prefix = QSM.Commands px, suffixes = sfxs}+ res <- runNParallelCommandsNTimes 1 sm nParallelCmd+ let (hist', _ret) = unzip res+ let events = snd <$> (QSM.unHistory hist)+ events' = snd <$> (concat (QSM.unHistory <$> hist'))+ return $ cmpList equalH events' events++{-------------------------------------------------------------------------------+ Testing equality between histories of different executions has to be+ different from the default equality check. This is because different+ executions will create different references, so we have to check them+ only by value.+-------------------------------------------------------------------------------}++type Hist = QSM.HistoryEvent (At Cmd) (At Resp)++equalH :: Hist -> Hist -> Bool+equalH (QSM.Invocation c sv) (QSM.Invocation c' sv') = equalCmd c c' && sv == sv'+equalH (QSM.Response r) (QSM.Response r') = equalResp r r'+equalH (QSM.Exception s) (QSM.Exception s') = s == s'+equalH _ _ = False++equalCmd :: Cmd :@ Concrete -> Cmd :@ Concrete -> Bool+equalCmd (At (CreateRef c m n)) (At (CreateRef c' m' n'))+ = c == c' && m == m' && n == n'+equalCmd (At (Incr c m vs)) (At (Incr c' m' vs'))+ = c == c' && m == m' && eqVars vs vs'+equalCmd (At (Read c m vs)) (At (Read c' m' vs'))+ = c == c' && m == m' && eqVars vs vs'+equalCmd _ _ = False++equalResp :: Resp :@ Concrete -> Resp :@ Concrete -> Bool+equalResp (At (Refs vs)) (At (Refs vs')) = eqVars vs vs'+equalResp (At (Unit ())) (At (Unit ())) = True+equalResp (At (Vals ns)) (At (Vals ns')) = ns == ns'+equalResp _ _ = False++cmpList :: (a -> a -> Bool) -> [a] -> [a] -> Bool+cmpList _cmp [] [] = True+cmpList cmp (a : as) (b : bs) =+ cmp a b && cmpList cmp as bs+cmpList _ _ _ = False++eqVars :: [Reference IOVar Concrete] -> [Reference IOVar Concrete] -> Bool+eqVars vs vs' = cmpList equalVar (concrete <$> vs) (concrete <$> vs')++equalVar :: IOVar -> IOVar -> Bool+equalVar (IOVar s _) (IOVar s' _) = s == s'
test/Spec.hs view
@@ -17,78 +17,213 @@ import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck- (expectFailure, ioProperty, testProperty,- withMaxSuccess)+ (expectFailure, testProperty, withMaxSuccess) +import Bookstore as Store import CircularBuffer-import qualified CrudWebserverDb as WS+import Cleanup+import qualified CrudWebserverDb as WS import DieHard import Echo import ErrorEncountered+import Hanoi+import IORefs import MemoryReference+import Mock+import Overflow+import ProcessRegistry+import RQlite import qualified ShrinkingProps+import SQLite+import Test.StateMachine.Markov+ (PropertyName, StatsDb, fileStatsDb) import TicketDispenser+import qualified UnionFind ------------------------------------------------------------------------ tests :: Bool -> TestTree tests docker0 = testGroup "Tests"- [ testCase "Doctest Z module" (doctest ["src/Test/StateMachine/Z.hs"])+ [ testCase "Doctest"+ (doctest [ "src/Test/StateMachine/Z.hs"+ , "src/Test/StateMachine/Logic.hs"+ ]) , ShrinkingProps.tests- , testProperty "Die Hard"+ , testProperty "TowersOfHanoi"+ (expectFailure (prop_hanoi 3))+ , testProperty "DieHard" (expectFailure (withMaxSuccess 2000 prop_dieHard))- , testGroup "Memory reference"- [ testProperty "No bug" (prop_sequential None)- , testProperty "Logic bug" (expectFailure (prop_sequential Logic))- , testProperty "Race bug sequential" (prop_sequential Race)- , testProperty "Race bug parallel" (expectFailure (prop_parallel Race))- , testProperty "Precondition failed" prop_precondition+ , testGroup "MemoryReference"+ [testProperty "NoBugSeq" (prop_sequential MemoryReference.None)+ , testProperty "LogicBug" (expectFailure (prop_sequential Logic))+ , testProperty "RaceBugSequential" (prop_sequential Race)+ , testProperty "NoBugParallel" (prop_parallel MemoryReference.None)+ , testProperty "RaceBugParallel" (expectFailure (prop_parallel Race))+ , testProperty "CrashBugParallel" (prop_parallel' Crash)+ , testProperty "CrashAndLogicBugParallel"+ (expectFailure (withMaxSuccess 10000 (prop_parallel' CrashAndLogic)))+ , testProperty "PreconditionFailed" prop_precondition+ , testProperty "ExistsCommands" prop_existsCommands+ , testProperty "NoBug 1 thread" (prop_nparallel MemoryReference.None 1)+ , testProperty "NoBug 2 threads" (prop_nparallel MemoryReference.None 2)+ , testProperty "NoBug 3 threads" (withMaxSuccess 80 $ prop_nparallel MemoryReference.None 3)+ , testProperty "NoBug 4 threads" (withMaxSuccess 40 $ prop_nparallel MemoryReference.None 4)+ , testProperty "RaceBugParalleel 1 thread" (prop_nparallel Race 1)+ , testProperty "RaceBugParalleel 2 threads" (expectFailure (prop_nparallel Race 2))+ , testProperty "RaceBugParalleel 3 threads" (expectFailure (prop_nparallel Race 3))+ , testProperty "RaceBugParalleel 4 threads" (expectFailure (prop_nparallel Race 4))+ , testProperty "ShrinkParallelEquivalence" prop_pairs_shrink_parallel_equivalence+ , testProperty "ShrinkAndValidateParallelEquivalence" prop_pairs_shrinkAndValidate_equivalence+ , testProperty "ShrinkPairsEquialence" prop_pairs_shrink_parallel ]+ , testGroup "Overflow"+ [ testProperty "2-threads" prop_parallel_overflow+ , testProperty "3-threads" $ prop_nparallel_overflow 3+ , testProperty "4-threads" $ expectFailure+ $ withMaxSuccess 500+ $ prop_nparallel_overflow 4+ ]+ , testGroup "Cleanup"+ [ testProperty "seqRegularNoOp" $ prop_sequential_clean Regular Cleanup.NoBug NoOp+ , testProperty "seqRegular" $ prop_sequential_clean Regular Cleanup.NoBug ReDo+ , testProperty "seqRegularExcNoOp"+ $ expectFailure $ prop_sequential_clean Regular Cleanup.Exception NoOp+ , testProperty "seqRegularExc"+ $ expectFailure $ prop_sequential_clean Regular Cleanup.Exception ReDo+ , testProperty "seqFilesNoOp" $ prop_sequential_clean Files Cleanup.NoBug NoOp+ , testProperty "seqFiles" $ prop_sequential_clean Files Cleanup.NoBug ReDo+ , testProperty "seqFilesExcNoOp" $ prop_sequential_clean Files Cleanup.Exception NoOp+ , testProperty "seqFilesExc" $ prop_sequential_clean Files Cleanup.Exception ReDo+ , testProperty "seqFilesExcAfterNoOp" $ prop_sequential_clean Files Cleanup.ExcAfter NoOp+ , testProperty "seqFilesExcAfterReDo" $ prop_sequential_clean Files Cleanup.ExcAfter ReDo+ , testProperty "seqEquivNoOp" $ prop_sequential_clean (Eq False) Cleanup.NoBug NoOp++ , testProperty "2-threadsRegularExc"+ $ expectFailure $ prop_parallel_clean Regular Cleanup.Exception NoOp+ , testProperty "2-threadsRegularExc"+ $ expectFailure $ prop_parallel_clean Regular Cleanup.Exception ReDo+ , testProperty "2-threadsFilesExc"+ $ expectFailure $ withMaxSuccess 1000 $ prop_parallel_clean Files Cleanup.Exception ReDo+ , testProperty "2-threadsEquivFailingNoOp"+ $ expectFailure $ withMaxSuccess 1000 $ prop_parallel_clean (Eq True) Cleanup.NoBug NoOp++ , testProperty "3-threadsRegularNoOp" $ prop_nparallel_clean 3 Regular Cleanup.NoBug NoOp+ , testProperty "3-threadsRegular" $ prop_nparallel_clean 3 Regular Cleanup.NoBug ReDo+ , testProperty "3-threadsRegularExc" $ expectFailure+ $ prop_nparallel_clean 3 Regular Cleanup.Exception NoOp+ , testProperty "3-threadsRegularExc"+ $ expectFailure $ prop_nparallel_clean 3 Regular Cleanup.Exception ReDo+ , testProperty "3-threadsFilesNoOp" $ prop_nparallel_clean 3 Files Cleanup.NoBug NoOp+ , testProperty "3-threadsFiles" $ prop_nparallel_clean 3 Files Cleanup.NoBug ReDo+ , testProperty "3-threadsFilesExcNoOp" $ prop_nparallel_clean 3 Files Cleanup.Exception NoOp+ , testProperty "3-threadsFilesExc"+ $ expectFailure $ withMaxSuccess 1000 $ prop_nparallel_clean 3 Files Cleanup.Exception ReDo+ , testProperty "3-threadsFilesExcAfter" $ prop_nparallel_clean 3 Files Cleanup.ExcAfter NoOp+ , testProperty "3-threadsEquivNoOp" $ prop_nparallel_clean 3 (Eq False) Cleanup.NoBug NoOp+ , testProperty "3-threadsEquivFailingNoOp"+ $ expectFailure $ withMaxSuccess 1000 $ prop_nparallel_clean 3 (Eq True) Cleanup.NoBug NoOp+ ]+ , testGroup "SQLite"+ [ testProperty "Parallel" prop_parallel_sqlite+ ]+ , testGroup "Rqlite"+ [ whenDocker docker0 "rqlite" $ testProperty "parallel" $ withMaxSuccess 10 $ prop_parallel_rqlite (Just Weak)+ -- we currently don't add other properties, because they interfere (Tasty runs tests on parallel)+ -- , testProperty "sequential" $ withMaxSuccess 10 $ prop_sequential_rqlite (Just Weak)+ -- , testProperty "sequential-stale" $ expectFailure $ prop_sequential_rqlite (Just RQlite.None)+ ] , testGroup "ErrorEncountered"- [ testProperty "sequential" prop_error_sequential- , testProperty "parallel" prop_error_parallel+ [ testProperty "Sequential" prop_error_sequential+ , testProperty "Parallel" prop_error_parallel+ , testProperty "2-Parallel" $ prop_error_nparallel 2+ , testProperty "3-Parallel" $ prop_error_nparallel 3+ , testProperty "4-Parallel" $ prop_error_nparallel 4 ]- , testGroup "Crud webserver"- [ webServer docker0 WS.None 8800 "No bug" WS.prop_crudWebserverDb- , webServer docker0 WS.Logic 8801 "Logic bug" (expectFailure . WS.prop_crudWebserverDb)- , webServer docker0 WS.Race 8802 "No race bug" WS.prop_crudWebserverDb- , webServer docker0 WS.Race 8803 "Race bug" (expectFailure . WS.prop_crudWebserverDbParallel)+ , testGroup "CrudWebserver"+ [ webServer docker0 WS.None 8800 "NoBug" WS.prop_crudWebserverDb+ , webServer docker0 WS.Logic 8801 "LogicBug" (expectFailure . WS.prop_crudWebserverDb)+ , webServer docker0 WS.Race 8802 "NoRaceBug" WS.prop_crudWebserverDb+ , webServer docker0 WS.Race 8803 "RaceBug" (expectFailure . WS.prop_crudWebserverDbParallel) ]- , testGroup "Ticket dispenser"- [ ticketDispenser "sequential" prop_ticketDispenser- , ticketDispenser "parallel with exclusive lock" (withMaxSuccess 30 .+ , testGroup "Bookstore"+ [ dataBase docker0 "NoBug" (Store.prop_bookstore Store.NoBug)+ , dataBase docker0 "SqlStatementBug"+ $ expectFailure+ . withMaxSuccess 500+ . Store.prop_bookstore Bug+ , dataBase docker0 "InputValidationBug"+ $ expectFailure+ . withMaxSuccess 500+ . Store.prop_bookstore Injection+ ]+ , testGroup "TicketDispenser"+ [ testProperty "Sequential" prop_ticketDispenser+ , testProperty "ParallelWithExclusiveLock" (withMaxSuccess 30 prop_ticketDispenserParallelOK)- , ticketDispenser "parallel with shared lock" (expectFailure .+ , testProperty "ParallelWithSharedLock" (expectFailure prop_ticketDispenserParallelBad)+ , testProperty "2-ParallelWithExclusiveLock" (prop_ticketDispenserNParallelOK 2)+ , testProperty "3-ParallelWithExclusiveLock" (prop_ticketDispenserNParallelOK 3)+ , testProperty "4-ParallelWithExclusiveLock" (prop_ticketDispenserNParallelOK 4)+ , testProperty "3-ParallelWithSharedLock" (expectFailure $+ prop_ticketDispenserNParallelBad 3) ]- , testGroup "Circular buffer"- [ testProperty "`unpropNoSizeCheck`: the first bug is found"- (expectFailure unpropNoSizeCheck)- , testProperty "`unpropFullIsEmpty`: the second bug is found"- (expectFailure unpropFullIsEmpty)- , testProperty "`unpropBadRem`: the third bug is found"+ , testGroup "Mock"+ [ testProperty "sequential" prop_sequential_mock+ , testProperty "parallel" prop_parallel_mock+ , testProperty "nparallel" prop_nparallel_mock+ ]+ , testGroup "CircularBuffer"+ [ testProperty "unpropNoSizeCheck"+ (expectFailure (withMaxSuccess 1000 unpropNoSizeCheck))+ , testProperty "unpropFullIsEmpty"+ (expectFailure (withMaxSuccess 1000 unpropFullIsEmpty))+ , testProperty "unpropBadRem" (expectFailure (withMaxSuccess 1000 unpropBadRem))- , testProperty "`unpropStillBadRem`: the fourth bug is found"- (expectFailure unpropStillBadRem)- , testProperty "`prop_circularBuffer`: the fixed version is correct"+ , testProperty "unpropStillBadRem"+ (expectFailure (withMaxSuccess 1000 unpropStillBadRem))+ , testProperty "prop_circularBuffer" prop_circularBuffer ] , testGroup "Echo"- [ testProperty "sequential" (ioProperty (prop_echoOK <$> mkEnv))- , testProperty "parallel ok" (ioProperty (prop_echoParallelOK False <$> mkEnv))- , testProperty "parallel bad, see issue #218"- (expectFailure (ioProperty (prop_echoParallelOK True <$> mkEnv)))+ [ testProperty "Sequential" prop_echoOK+ , testProperty "ParallelOk" (prop_echoParallelOK False)+ , testProperty "ParallelBad" -- See issue #218.+ (expectFailure (prop_echoParallelOK True))+ , testProperty "2-Parallel" (prop_echoNParallelOK 2 False)+ , testProperty "3-Parallel" (prop_echoNParallelOK 3 False)+ , testProperty "Parallel bad, 2 threads, see issue #218"+ (expectFailure (prop_echoNParallelOK 2 True))+ , testProperty "Parallel bad, 3 threads, see issue #218"+ (expectFailure (prop_echoNParallelOK 3 True)) ]+ , testGroup "ProcessRegistry"+ [ testProperty "Sequential" (prop_processRegistry (statsDb "processRegistry"))+ ]+ , testGroup "UnionFind"+ [ testProperty "Sequential" UnionFind.prop_unionFindSequential ]+ , testGroup "Lockstep"+ [ testProperty "IORefs_Sequential" prop_IORefs_sequential+ ] ] where+ statsDb :: PropertyName -> StatsDb IO+ statsDb = fileStatsDb "/tmp/stats-db"+ webServer docker bug port test prop | docker = withResource (WS.setup bug WS.connectionString port) WS.cleanup (const (testProperty test (prop port)))+ | otherwise = testCase ("No docker or running on CI, skipping: " ++ test) (return ())++ dataBase docker test prop+ | docker = withResource Store.setup+ Store.cleanup+ (\io -> testProperty test (prop (snd <$> io))) | otherwise = testCase ("No docker, skipping: " ++ test) (return ()) - ticketDispenser test prop =- withResource setupLock cleanupLock- (\ioLock -> testProperty test (ioProperty (prop <$> ioLock)))+ whenDocker docker test prop+ | docker = prop+ | otherwise = testCase ("No docker, skipping: " ++ test) (return ()) ------------------------------------------------------------------------
test/TicketDispenser.hs view
@@ -1,14 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -16,7 +14,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) ----- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@here.com>+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk> -- Stability : provisional -- Portability : non-portable (GHC extensions) --@@ -27,7 +25,9 @@ module TicketDispenser ( prop_ticketDispenser , prop_ticketDispenserParallel+ , prop_ticketDispenserNParallelOK , prop_ticketDispenserParallelOK+ , prop_ticketDispenserNParallelBad , prop_ticketDispenserParallelBad , withDbLock , setupLock@@ -37,10 +37,10 @@ import Control.Exception (IOException, catch)+import Control.Monad.IO.Class+ (liftIO) import Data.Kind (Type)-import Data.TreeDiff- (ToExpr) import GHC.Generics (Generic, Generic1) import Prelude hiding@@ -59,7 +59,7 @@ import Test.QuickCheck (Gen, Property, frequency, (===)) import Test.QuickCheck.Monadic- (monadicIO)+ (PropertyM, monadicIO) import Test.StateMachine import qualified Test.StateMachine.Types.Rank2 as Rank2@@ -71,12 +71,14 @@ data Action (r :: Type -> Type) = TakeTicket | Reset- deriving (Show, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)+ deriving stock (Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames) data Response (r :: Type -> Type) = GotTicket Int | ResetOk- deriving (Show, Generic1, Rank2.Foldable)+ deriving stock (Show, Generic1)+ deriving anyclass Rank2.Foldable -- Which correspond to taking a ticket and getting the next number, and -- resetting the number counter of the dispenser.@@ -86,9 +88,9 @@ -- The dispenser has to be reset before use, hence the maybe integer. newtype Model (r :: Type -> Type) = Model (Maybe Int)- deriving (Eq, Show, Generic)+ deriving stock (Eq, Show, Generic) -deriving instance ToExpr (Model Concrete)+deriving anyclass instance ToExpr (Model Concrete) initModel :: Model r initModel = Model Nothing@@ -186,39 +188,56 @@ removeFile tdb removeFile tlock -withDbLock :: (DbLock -> IO ()) -> IO ()+withDbLock :: (DbLock -> PropertyM IO ()) -> PropertyM IO () withDbLock run = do- lock <- setupLock+ lock <- liftIO setupLock run lock- cleanupLock lock+ liftIO $ cleanupLock lock sm :: SharedExclusive -> DbLock -> StateMachine Model Action IO Response sm se files = StateMachine initModel transitions preconditions postconditions- Nothing generator Nothing shrinker (semantics se files) mock+ Nothing generator shrinker (semantics se files) mock noCleanup +smUnused :: SharedExclusive -> StateMachine Model Action IO Response+smUnused se = sm se (error "dblock used during command creation")+ -- Sequentially the model is consistent (even though the lock is -- shared). -prop_ticketDispenser :: DbLock -> Property-prop_ticketDispenser files = forAllCommands sm' Nothing $ \cmds -> monadicIO $ do- (hist, _, res) <- runCommands sm' cmds- prettyCommands sm' hist $- checkCommandNames cmds (res === Ok)- where- sm' = sm Shared files+prop_ticketDispenser :: Property+prop_ticketDispenser =+ forAllCommands (smUnused Shared) Nothing $ \cmds -> monadicIO $+ withDbLock $ \ioLock -> do+ let sm' = sm Shared ioLock+ (hist, _, res) <- runCommands sm' cmds+ prettyCommands sm' hist $+ checkCommandNames cmds (res === Ok) -prop_ticketDispenserParallel :: SharedExclusive -> DbLock -> Property-prop_ticketDispenserParallel se files =- forAllParallelCommands sm' $ \cmds -> monadicIO $- prettyParallelCommands cmds =<< runParallelCommandsNTimes 100 sm' cmds- where- sm' = sm se files+prop_ticketDispenserParallel :: SharedExclusive -> Property+prop_ticketDispenserParallel se =+ forAllParallelCommands (smUnused se) Nothing $ \cmds -> monadicIO $+ withDbLock $ \ioLock -> do+ let sm' = sm se ioLock+ prettyParallelCommands cmds =<< runParallelCommandsNTimes 100 sm' cmds +prop_ticketDispenserNParallel :: SharedExclusive -> Int -> Property+prop_ticketDispenserNParallel se np =+ forAllNParallelCommands (smUnused se) np $ \cmds -> monadicIO $+ withDbLock $ \ioLock -> do+ let sm' = sm se ioLock+ prettyNParallelCommands cmds =<< runNParallelCommands sm' cmds+ -- So long as the file locks are exclusive, i.e. not shared, the -- parallel property passes.-prop_ticketDispenserParallelOK :: DbLock -> Property+prop_ticketDispenserParallelOK :: Property prop_ticketDispenserParallelOK = prop_ticketDispenserParallel Exclusive -prop_ticketDispenserParallelBad :: DbLock -> Property+prop_ticketDispenserParallelBad :: Property prop_ticketDispenserParallelBad = prop_ticketDispenserParallel Shared++prop_ticketDispenserNParallelOK :: Int -> Property+prop_ticketDispenserNParallelOK = prop_ticketDispenserNParallel Exclusive++prop_ticketDispenserNParallelBad :: Int -> Property+prop_ticketDispenserNParallelBad = prop_ticketDispenserNParallel Shared
+ test/UnionFind.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : UnionFind+-- Copyright : (C) 2017-2019, ATS Advanced Telematic Systems GmbH+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>,+-- Momoko Hattori <momohatt10@gmail.com>+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- This module contains a specification for an imperative-style union/find+-- algorithm.+--+-----------------------------------------------------------------------------++module UnionFind+ ( prop_unionFindSequential+ )+ where++import Data.Functor.Classes+ (Eq1(..))+import Data.IORef+ (IORef, newIORef, readIORef, writeIORef)+import GHC.Generics+ (Generic, Generic1)+import Prelude+import Test.QuickCheck+ (Gen, Property, arbitrary, elements, frequency,+ shrink, (===))+import Test.QuickCheck.Monadic+ (monadicIO)++import Test.StateMachine+import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.Types.References+import Test.StateMachine.Z+ (domain, empty)++------------------------------------------------------------------------++-- The union/find algorithm is basically an efficient way of+-- implementing an equivalence relation.+--+-- This example is borrowed from the paper+-- <http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps *Testing+-- monadic code with QuickCheck*> by Koen Claessen and John Hughes+-- (2002).+--+-- Let's start with the implementation of the algorithm, which we have+-- taken from the paper.++-- Our implementation is slightly different in that we use @IORef@s+-- instead of @STRef@s (see issue #84).+data Element = Element Int (IORef Link)++data Link+ = Weight Int+ | Next Element++instance Eq Element where+ Element _ ref1 == Element _ ref2 = ref1 == ref2++instance Show Element where+ show (Element x _) = "Element " ++ show x++type Ref r = Reference (Opaque Element) r++-- We represent actions in the same way as they do in section 11 of the+-- paper.+data Command r+ = New Int+ | Find (Ref r)+ | Union (Ref r) (Ref r)+ deriving stock (Eq, Show, Generic1)+ deriving anyclass (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)++data Response r+ = -- | New element was created.+ Created (Ref r)+ -- | Command 'Find' was successful with a return value.+ | Found (Ref r)+ -- | Command 'Union' was successful.+ | United+ deriving stock Generic1+ deriving anyclass Rank2.Foldable++deriving stock instance Show (Response Symbolic)+deriving stock instance Show (Response Concrete)++------------------------------------------------------------------------++-- The model corresponds closely to the *relational specification* given+-- in section 12 of the paper.++newtype Model r = Model [(Ref r, Ref r)]+ deriving stock (Generic, Eq, Show)++instance ToExpr (Model Symbolic)+instance ToExpr (Model Concrete)++initModel :: Model r+initModel = Model empty++-- Find representative of 'ref'+(!) :: Eq1 r => Model r -> Ref r -> Ref r+Model m ! ref = case lookup ref m of+ Just ref' | ref == ref' -> ref+ | otherwise -> Model m ! ref'+ Nothing -> error "(!): couldn't find key"++extend :: Eq1 r => Model r -> (Ref r, Ref r) -> Model r+extend (Model m) p@(ref1, ref2) =+ case lookup ref1 m of+ Just z -> -- case of 'Union' command+ let w = Model m ! ref2 in+ Model $ map (\(x, y) -> if y == z then (x, w) else (x, y)) m+ Nothing -> -- case of 'New' command+ Model $ p : m++------------------------------------------------------------------------++precondition :: Model Symbolic -> Command Symbolic -> Logic+precondition m@(Model model) cmd = case cmd of+ New _ -> Top+ Find ref -> ref `member` map fst model+ Union ref1 ref2 -> (ref1 `member` map fst model) .&&+ (ref2 `member` map fst model) .&&+ (m ! ref1 ./= m ! ref2)++transition :: Eq1 r => Model r -> Command r -> Response r -> Model r+transition m cmd resp = case (cmd, resp) of+ (New _, Created ref) -> m `extend` (ref, ref)+ (Find _, Found _) ->+ -- The equivalence relation should be the same after 'find' command.+ m+ (Union ref1 ref2, United) ->+ -- Update the model with a new equivalence relation between ref1 and ref2.+ -- It doesn't matter whether ref1's root is pointed to ref2's root or vice versa.+ m `extend` (ref1, ref2)+ _ -> error "transition: impossible."++postcondition :: Model Concrete -> Command Concrete -> Response Concrete -> Logic+postcondition m cmd resp = case (cmd, resp) of+ (New _, Created ref) -> m' ! ref .== ref+ (Find _, Found _) -> m .== m'+ (Union ref1 ref2, United) ->+ let z = m' ! ref1+ in (z .== m ! ref1 .|| z .== m ! ref2) .&& m' ! ref1 .== m' ! ref2+ _ -> Bot+ where+ m' = transition m cmd resp++------------------------------------------------------------------------++newElement :: Int -> IO Element+newElement x = do+ ref <- newIORef (Weight 1)+ return (Element x ref)++findElement :: Element -> IO Element+findElement (Element x ref) = do+ e <- readIORef ref+ case e of+ Weight _ -> return (Element x ref)+ Next next -> do+ last' <- findElement next+ writeIORef ref (Next last')+ return last'++unionElements :: Element -> Element -> IO ()+unionElements e1 e2 = do+ Element x1 ref1 <- findElement e1+ Element x2 ref2 <- findElement e2+ if ref1 == ref2+ then error "equivalent elements"+ else do+ Weight w1 <- readIORef ref1+ Weight w2 <- readIORef ref2++ if w1 <= w2+ then do+ writeIORef ref1 (Next (Element x2 ref2))+ writeIORef ref2 (Weight (w1 + w2))+ else do+ writeIORef ref2 (Next (Element x1 ref1))+ writeIORef ref1 (Weight (w1 + w2))++semantics :: Command Concrete -> IO (Response Concrete)+semantics (New x) = Created . Reference . Concrete . Opaque <$> newElement x+semantics (Find ref) = Found . Reference . Concrete . Opaque <$> findElement (opaque ref)+semantics (Union ref1 ref2) = United <$ unionElements (opaque ref1) (opaque ref2)++mock :: Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic)+mock _ cmd = case cmd of+ New _ -> Created <$> genSym+ Find _ -> Found <$> genSym+ Union _ _ -> pure United++generator :: Model Symbolic -> Maybe (Gen (Command Symbolic))+generator (Model m)+ | null m = Just $ New <$> arbitrary+ | otherwise = Just $ frequency+ [ (1, New <$> arbitrary)+ , (8, Find <$> elements (domain m))+ , (8, Union <$> elements (domain m) <*> elements (domain m))+ ]++shrinker :: Model Symbolic -> Command Symbolic -> [Command Symbolic]+shrinker _ (New n) = [ New n' | n' <- shrink n ]+shrinker _ _ = []++sm :: StateMachine Model Command IO Response+sm = StateMachine initModel transition precondition postcondition+ Nothing generator shrinker semantics mock noCleanup++prop_unionFindSequential :: Property+prop_unionFindSequential =+ forAllCommands sm Nothing $ \cmds -> monadicIO $ do+ (hist, _model, res) <- runCommands sm cmds+ prettyCommands sm hist (checkCommandNames cmds (res === Ok))