diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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, diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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* diff --git a/quickcheck-state-machine.cabal b/quickcheck-state-machine.cabal --- a/quickcheck-state-machine.cabal +++ b/quickcheck-state-machine.cabal @@ -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 + 2018-2019, HERE Europe B.V.; + 2019-2020, Stevan Andjelkovic. +maintainer: Stevan Andjelkovic 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 diff --git a/src/Test/StateMachine.hs b/src/Test/StateMachine.hs --- a/src/Test/StateMachine.hs +++ b/src/Test/StateMachine.hs @@ -4,7 +4,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) -- --- Maintainer : Stevan Andjelkovic +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/src/Test/StateMachine/BoxDrawer.hs b/src/Test/StateMachine/BoxDrawer.hs --- a/src/Test/StateMachine/BoxDrawer.hs +++ b/src/Test/StateMachine/BoxDrawer.hs @@ -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 diff --git a/src/Test/StateMachine/DotDrawing.hs b/src/Test/StateMachine/DotDrawing.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/DotDrawing.hs @@ -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) diff --git a/src/Test/StateMachine/Labelling.hs b/src/Test/StateMachine/Labelling.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/Labelling.hs @@ -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 +-- 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 diff --git a/src/Test/StateMachine/Lockstep/Auxiliary.hs b/src/Test/StateMachine/Lockstep/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/Lockstep/Auxiliary.hs @@ -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 diff --git a/src/Test/StateMachine/Lockstep/NAry.hs b/src/Test/StateMachine/Lockstep/NAry.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/Lockstep/NAry.hs @@ -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 diff --git a/src/Test/StateMachine/Lockstep/Simple.hs b/src/Test/StateMachine/Lockstep/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/Lockstep/Simple.hs @@ -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 diff --git a/src/Test/StateMachine/Logic.hs b/src/Test/StateMachine/Logic.hs --- a/src/Test/StateMachine/Logic.hs +++ b/src/Test/StateMachine/Logic.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/src/Test/StateMachine/Markov.hs b/src/Test/StateMachine/Markov.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/Markov.hs @@ -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 +-- 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=<(" ++ show (lookupStates from to successes) ++ "" + ++ ", " ++ show (lookupStates from to failures) ++ ")>]\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) diff --git a/src/Test/StateMachine/Parallel.hs b/src/Test/StateMachine/Parallel.hs --- a/src/Test/StateMachine/Parallel.hs +++ b/src/Test/StateMachine/Parallel.hs @@ -9,7 +9,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) -- --- Maintainer : Stevan Andjelkovic +-- Maintainer : Stevan Andjelkovic -- 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)) diff --git a/src/Test/StateMachine/Sequential.hs b/src/Test/StateMachine/Sequential.hs --- a/src/Test/StateMachine/Sequential.hs +++ b/src/Test/StateMachine/Sequential.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 "" (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) diff --git a/src/Test/StateMachine/Types.hs b/src/Test/StateMachine/Types.hs --- a/src/Test/StateMachine/Types.hs +++ b/src/Test/StateMachine/Types.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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." diff --git a/src/Test/StateMachine/Types/Environment.hs b/src/Test/StateMachine/Types/Environment.hs --- a/src/Test/StateMachine/Types/Environment.hs +++ b/src/Test/StateMachine/Types/Environment.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/src/Test/StateMachine/Types/GenSym.hs b/src/Test/StateMachine/Types/GenSym.hs --- a/src/Test/StateMachine/Types/GenSym.hs +++ b/src/Test/StateMachine/Types/GenSym.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/src/Test/StateMachine/Types/History.hs b/src/Test/StateMachine/Types/History.hs --- a/src/Test/StateMachine/Types/History.hs +++ b/src/Test/StateMachine/Types/History.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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' + ] diff --git a/src/Test/StateMachine/Types/References.hs b/src/Test/StateMachine/Types/References.hs --- a/src/Test/StateMachine/Types/References.hs +++ b/src/Test/StateMachine/Types/References.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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" diff --git a/src/Test/StateMachine/Utils.hs b/src/Test/StateMachine/Utils.hs --- a/src/Test/StateMachine/Utils.hs +++ b/src/Test/StateMachine/Utils.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/src/Test/StateMachine/Z.hs b/src/Test/StateMachine/Z.hs --- a/src/Test/StateMachine/Z.hs +++ b/src/Test/StateMachine/Z.hs @@ -6,7 +6,7 @@ -- Copyright : (C) 2017, ATS Advanced Telematic Systems GmbH -- License : BSD-style (see the file LICENSE) -- --- Maintainer : Stevan Andjelkovic +-- Maintainer : Stevan Andjelkovic -- Stability : provisional -- Portability : portable -- diff --git a/test/Bookstore.hs b/test/Bookstore.hs new file mode 100644 --- /dev/null +++ b/test/Bookstore.hs @@ -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 ] diff --git a/test/CircularBuffer.hs b/test/CircularBuffer.hs --- a/test/CircularBuffer.hs +++ b/test/CircularBuffer.hs @@ -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 diff --git a/test/Cleanup.hs b/test/Cleanup.hs new file mode 100644 --- /dev/null +++ b/test/Cleanup.hs @@ -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" diff --git a/test/CrudWebserverDb.hs b/test/CrudWebserverDb.hs --- a/test/CrudWebserverDb.hs +++ b/test/CrudWebserverDb.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/test/DieHard.hs b/test/DieHard.hs --- a/test/DieHard.hs +++ b/test/DieHard.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/test/Echo.hs b/test/Echo.hs --- a/test/Echo.hs +++ b/test/Echo.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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) diff --git a/test/ErrorEncountered.hs b/test/ErrorEncountered.hs --- a/test/ErrorEncountered.hs +++ b/test/ErrorEncountered.hs @@ -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 diff --git a/test/Hanoi.hs b/test/Hanoi.hs new file mode 100644 --- /dev/null +++ b/test/Hanoi.hs @@ -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 +-- 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)) diff --git a/test/IORefs.hs b/test/IORefs.hs new file mode 100644 --- /dev/null +++ b/test/IORefs.hs @@ -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 diff --git a/test/MemoryReference.hs b/test/MemoryReference.hs --- a/test/MemoryReference.hs +++ b/test/MemoryReference.hs @@ -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 diff --git a/test/Mock.hs b/test/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Mock.hs @@ -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 diff --git a/test/Overflow.hs b/test/Overflow.hs new file mode 100644 --- /dev/null +++ b/test/Overflow.hs @@ -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 diff --git a/test/ProcessRegistry.hs b/test/ProcessRegistry.hs new file mode 100644 --- /dev/null +++ b/test/ProcessRegistry.hs @@ -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 +-- 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) diff --git a/test/RQlite.hs b/test/RQlite.hs new file mode 100644 --- /dev/null +++ b/test/RQlite.hs @@ -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 diff --git a/test/SQLite.hs b/test/SQLite.hs new file mode 100644 --- /dev/null +++ b/test/SQLite.hs @@ -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 diff --git a/test/Schema.hs b/test/Schema.hs new file mode 100644 --- /dev/null +++ b/test/Schema.hs @@ -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) diff --git a/test/ShrinkingProps.hs b/test/ShrinkingProps.hs --- a/test/ShrinkingProps.hs +++ b/test/ShrinkingProps.hs @@ -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' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 ()) ------------------------------------------------------------------------ diff --git a/test/TicketDispenser.hs b/test/TicketDispenser.hs --- a/test/TicketDispenser.hs +++ b/test/TicketDispenser.hs @@ -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 +-- Maintainer : Stevan Andjelkovic -- 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 diff --git a/test/UnionFind.hs b/test/UnionFind.hs new file mode 100644 --- /dev/null +++ b/test/UnionFind.hs @@ -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 , +-- Momoko Hattori +-- 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 +-- 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))