diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,37 @@ +0.15.0 +====== + + - change text of error messages to include module names + ([#116](https://github.com/acid-state/acid-state/pull/116)) + - depend on filelock library to avoid locking bug + ([#91](https://github.com/acid-state/acid-state/pull/91)) + - permit events that are polymorphic in the base monad, with a MonadReader/MonadState constraint + ([#94](https://github.com/acid-state/acid-state/pull/94)) + - fix a minor memory leak + ([#104](https://github.com/acid-state/acid-state/pull/104)) + - add a test suite and extend examples + ([#98](https://github.com/acid-state/acid-state/pull/98)) + - improve benchmarks + ([#113](https://github.com/acid-state/acid-state/pull/113)) + - expose internal modules (subject to change in the future) + +0.14.3 +====== + + - support building on GHC 8.2 + - update links from seize.it to github.com + 0.14.2 ====== - - createCheckpoint now cuts a new events file (bug #74) + - createCheckpoint now cuts a new events file + ([#74](https://github.com/acid-state/acid-state/pull/74)) 0.14.1 ====== - - fix bug in archiveLog that resulted in logs being moved prematurely (bug #22) + - fix bug in archiveLog that resulted in logs being moved prematurely + ([#22](https://github.com/acid-state/acid-state/issues/22)) - tweaks for GHC 8.0.x, template-haskell 2.11.x - fix compilation of benchmarks @@ -22,4 +47,4 @@ which are compiled against safecopy 0.8 / cereal 0.4. - additional fixes for TH and kinded type variables - [https://github.com/acid-state/acid-state/pull/56](https://github.com/acid-state/acid-state/pull/56) + ([#56](https://github.com/acid-state/acid-state/pull/56)) diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -1,5 +1,5 @@ Name: acid-state -Version: 0.14.3 +Version: 0.15.0 Synopsis: Add ACID guarantees to any serializable Haskell data structure. Description: Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage: https://github.com/acid-state/acid-state @@ -10,43 +10,53 @@ Category: Database Build-type: Simple Cabal-version: >=1.10 -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.3 Extra-source-files: CHANGELOG.md - examples/*.hs - examples/errors/*.hs - src-win32/*.hs - src-unix/*.hs + test-state/OldStateTest1/*.log + test-state/OldStateTest1/*.version + test-state/OldStateTest2/*.log + test-state/OldStateTest2/*.version + test-state/OldStateTest3/*.log + test-state/OldStateTest3/*.version Source-repository head type: git location: https://github.com/acid-state/acid-state +flag skip-state-machine-test + description: If enabled, do not build/run the state-machine test + default: False + manual: True + Library Exposed-Modules: Data.Acid, + Data.Acid.Archive, + Data.Acid.Common, Data.Acid.Local, Data.Acid.Memory, Data.Acid.Memory.Pure, Data.Acid.Remote, Data.Acid.Advanced, Data.Acid.Log, Data.Acid.CRC, - Data.Acid.Abstract, Data.Acid.Core + Data.Acid.Abstract, Data.Acid.Core, + Data.Acid.TemplateHaskell - Other-modules: Data.Acid.Archive, - Paths_acid_state, - Data.Acid.TemplateHaskell, Data.Acid.Common, FileIO + Other-modules: Paths_acid_state, + FileIO Build-depends: array, - base >= 4 && < 5, + base >= 4.5.1.0 && < 5, bytestring >= 0.10.2, cereal >= 0.4.1.0, containers, - extensible-exceptions, safecopy >= 0.6, stm >= 2.4, directory, + filelock, filepath, mtl, - network, - template-haskell + network < 2.9, + template-haskell, + th-expand-syns if os(windows) Build-depends: Win32 @@ -63,8 +73,81 @@ default-language: Haskell2010 GHC-Options: -fwarn-unused-imports -fwarn-unused-binds +test-suite specs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , acid-state + , deepseq + , hspec + , hspec-discover + , mtl + , safecopy + , template-haskell + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -threaded -rtsopts -with-rtsopts=-N + other-modules: Data.Acid.TemplateHaskellSpec + default-language: Haskell2010 +test-suite state-machine + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: StateMachine.hs + build-depends: base + , acid-state + , containers + , deepseq >= 1.4.0.0 + , directory + , hedgehog + , mtl + , safecopy + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + other-modules: Data.Acid.KeyValueStateMachine + Data.Acid.StateMachineTest + default-language: Haskell2010 + if flag(skip-state-machine-test) + buildable: False + +test-suite examples + type: exitcode-stdio-1.0 + hs-source-dirs: examples + examples/errors + main-is: Examples.hs + build-depends: base + , acid-state + , cereal + , containers + , directory + , mtl + , network + , safecopy + , text + , time + ghc-options: -threaded -rtsopts -with-rtsopts=-N + other-modules: ChangeState + ChangeVersion + CheckpointCutsEvent + Exceptions + HelloDatabase + HelloWorld + HelloWorldNoTH + KeyValue + KeyValueNoTH + MonadStateConstraint + ParameterisedState + RemoteClient + RemoteCommon + RemoteServer + RemoveEvent + SlowCheckpoint + StressTest + StressTestNoTH + if !os(windows) + other-modules: Proxy + default-language: Haskell2010 + benchmark loading-benchmark type: exitcode-stdio-1.0 @@ -81,7 +164,7 @@ directory, system-fileio == 0.3.*, system-filepath, - criterion >= 0.8 && < 1.2, + criterion >= 1.0.0.0 && < 1.6, mtl, base, acid-state diff --git a/benchmarks/loading/Benchmark.hs b/benchmarks/loading/Benchmark.hs --- a/benchmarks/loading/Benchmark.hs +++ b/benchmarks/loading/Benchmark.hs @@ -1,78 +1,175 @@ +{-# LANGUAGE RecordWildCards #-} import Benchmark.Prelude import Criterion.Main import qualified Data.Acid as Acid +import qualified Data.Acid.Memory as Memory import qualified Benchmark.FileSystem as FS import qualified Benchmark.Model as Model; import Benchmark.Model (Model) import qualified System.Random as Random - main :: IO () -main = do +main = defaultMain [benchmark defaultBenchmarkInterfaces [100,200,300,400]] - workingPath <- do - workingPath <- FS.getTemporaryDirectory - rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z') - return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr +benchmark :: [BenchmarkInterface] -> [Int] -> Benchmark +benchmark bis sizes = env setupWorkingPath $ \ workingPath -> + bgroup "" $ map (benchmarksGroup bis workingPath) sizes + +-- | An acid-state interface to be benchmarked. +data BenchmarkInterface = forall m . + BenchmarkInterface + { benchName :: String + -- ^ Name of the interface, for use in constructing benchmarks. + , benchPersist :: Bool + -- ^ Does this interface actually persist data to disk? If + -- it doesn't, some benchmarks are not applicable. + , benchOpen :: FS.FilePath -> IO (Acid.AcidState m) + -- ^ Open an acid-state component with the given path. Note + -- that the type of the state is encapsulated within + -- 'BenchmarkInterface'. + , benchUpdate :: Acid.AcidState m -> [[Int]] -> IO () + -- ^ Execute an 'insert' update against the acid-state. + , benchQuery :: Acid.AcidState m -> IO Int + -- ^ Execute a 'sumUp' query against the state. + } + +memoryBenchmarkInterface :: BenchmarkInterface +memoryBenchmarkInterface = + BenchmarkInterface { benchName = "Memory" + , benchPersist = False + , benchOpen = const $ Memory.openMemoryState mempty + , benchUpdate = \ inst v -> Acid.update inst (Model.Insert v) + , benchQuery = \ inst -> Acid.query inst Model.SumUp + } + +localBenchmarkInterface :: BenchmarkInterface +localBenchmarkInterface = + BenchmarkInterface { benchName = "Local" + , benchPersist = True + , benchOpen = \ p -> Acid.openLocalStateFrom (FS.encodeString p) mempty + , benchUpdate = \ inst v -> Acid.update inst (Model.Insert v) + , benchQuery = \ inst -> Acid.query inst Model.SumUp + } + +defaultBenchmarkInterfaces :: [BenchmarkInterface] +defaultBenchmarkInterfaces = [memoryBenchmarkInterface, localBenchmarkInterface] + + +setupWorkingPath :: IO FS.FilePath +setupWorkingPath = do + workingPath <- do workingPath <- FS.getTemporaryDirectory + rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z') + return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr putStrLn $ "Working under the following temporary directory: " ++ FS.encodeString workingPath FS.removeTreeIfExists workingPath FS.createTree workingPath + return workingPath - defaultMain =<< sequence - [ - prepareBenchmarksGroup workingPath $ 100, - prepareBenchmarksGroup workingPath $ 200, - prepareBenchmarksGroup workingPath $ 300, - prepareBenchmarksGroup workingPath $ 400 - ] +benchmarksGroup :: [BenchmarkInterface] -> FS.FilePath -> Int -> Benchmark +benchmarksGroup bis workingPath size = + bgroup (show size) + [ bgroup (benchName bi) $ + initializeBenchmarksGroup bi workingPath' size + : if benchPersist bi then [openCloseBenchmarksGroup bi workingPath' size] else [] + | bi <- bis + ] + where + workingPath' = workingPath <> FS.decodeString (show size) -prepareBenchmarksGroup :: FS.FilePath -> Int -> IO Benchmark -prepareBenchmarksGroup workingPath size = do +-- | The Initialize benchmarks measure how long it takes to open an +-- empty 'AcidState' component, call 'initialize' to populate it with +-- data, and optionally checkpoint before closing. +initializeBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark +initializeBenchmarksGroup bi workingPath size = + bgroup "Initialize" + [ bench "Without checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ -> + initializeClose bi workingPath size + , bench "With checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ -> + initializeCheckpointClose bi workingPath size + ] + +prepareInitialize :: BenchmarkInterface -> FS.FilePath -> IO () +prepareInitialize bi workingPath = + when (benchPersist bi) $ do FS.removeTreeIfExists workingPath + FS.createTree workingPath + + +-- | The OpenClose benchmarks measure how long it takes to open an +-- existing on-disk 'AcidState' component (either from a checkpoint or +-- from a transaction log), optionally execute a query over the entire +-- state, then close. These benchmarks are not applicable if the +-- interface being benchmarked does not persist data. +openCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark +openCloseBenchmarksGroup bi workingPath size = + env (prepareOpenCloseBenchmarksGroup bi workingPath size) $ \ ~(logsInstancePath, checkpointInstancePath) -> bgroup "OpenClose" + [ + bench "From Logs" $ nfIO $ + openClose bi logsInstancePath + , bench "From Checkpoint" $ nfIO $ + openClose bi checkpointInstancePath + , bench "From Logs (with query)" $ nfIO $ + openQueryClose bi logsInstancePath + , bench "From Checkpoint (with query)" $ nfIO $ + openQueryClose bi checkpointInstancePath + ] + +-- | Set up data on disk for the open/close benchmarks. This +-- initializes an instance, creates a copy of it (for restoring from +-- transaction logs), then checkpoints. +prepareOpenCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> IO (FS.FilePath, FS.FilePath) +prepareOpenCloseBenchmarksGroup bi workingPath size = do putStrLn $ "Preparing instances for size " ++ show size let - workingPath' = workingPath <> (FS.decodeString $ show size) - logsInstancePath = workingPath' <> "logs-instance" - checkpointInstancePath = workingPath' <> "checkpoint-instance" + logsInstancePath = workingPath <> "logs-instance" + checkpointInstancePath = workingPath <> "checkpoint-instance" FS.createTree logsInstancePath FS.createTree checkpointInstancePath putStrLn "Initializing" - inst <- initialize checkpointInstancePath size + initialize bi checkpointInstancePath size $ \inst -> do - putStrLn "Copying" - FS.copy checkpointInstancePath logsInstancePath - FS.removeFile $ logsInstancePath <> "open.lock" + putStrLn "Copying" + FS.copy checkpointInstancePath logsInstancePath + FS.removeFile $ logsInstancePath <> "open.lock" - putStrLn "Checkpointing" - Acid.createCheckpoint inst + putStrLn "Checkpointing" + Acid.createCheckpoint inst - putStrLn "Closing" - Acid.closeAcidState inst + putStrLn "Closing" + Acid.closeAcidState inst - return $ bgroup (show size) - [ - bench "From Logs" $ nfIO $ - load logsInstancePath >>= Acid.closeAcidState, - bench "From Checkpoint" $ nfIO $ - load checkpointInstancePath >>= Acid.closeAcidState - ] + return (logsInstancePath, checkpointInstancePath) +initialize :: BenchmarkInterface -> FS.FilePath -> Int -> (forall m . Acid.AcidState m -> IO r) -> IO r +initialize BenchmarkInterface{..} p size k = do + inst <- benchOpen p + let values = replicate size $ replicate 100 $ replicate 100 1 + mapM_ (benchUpdate inst) values + k inst -load :: FS.FilePath -> IO (Acid.AcidState Model) -load path = Acid.openLocalStateFrom (FS.encodeString path) mempty +initializeClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO () +initializeClose bi p size = initialize bi p size Acid.closeAcidState -initialize :: FS.FilePath -> Int -> IO (Acid.AcidState Model) -initialize path size = do - inst <- Acid.openLocalStateFrom (FS.encodeString path) mempty - let values = replicate size $ replicate 100 $ replicate 100 1 - mapM_ (Acid.update inst . Model.Insert) values - return inst +initializeCheckpointClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO () +initializeCheckpointClose bi p size = + initialize bi p size $ \ inst -> do + Acid.createCheckpoint inst + Acid.closeAcidState inst +openClose :: BenchmarkInterface -> FS.FilePath -> IO () +openClose BenchmarkInterface{..} p = benchOpen p >>= Acid.closeAcidState + +openQueryClose :: BenchmarkInterface -> FS.FilePath -> IO Int +openQueryClose BenchmarkInterface{..} p = do + inst <- benchOpen p + n <- benchQuery inst + Acid.closeAcidState inst + return n diff --git a/benchmarks/loading/Benchmark/Model.hs b/benchmarks/loading/Benchmark/Model.hs --- a/benchmarks/loading/Benchmark/Model.hs +++ b/benchmarks/loading/Benchmark/Model.hs @@ -10,4 +10,7 @@ insert :: [[Int]] -> Acid.Update Model () insert = modify . (:) -Acid.makeAcidic ''Model ['insert] +sumUp :: Acid.Query Model Int +sumUp = sum . map (sum . map sum) <$> ask + +Acid.makeAcidic ''Model ['insert, 'sumUp] diff --git a/examples/CheckpointCutsEvent.hs b/examples/CheckpointCutsEvent.hs --- a/examples/CheckpointCutsEvent.hs +++ b/examples/CheckpointCutsEvent.hs @@ -18,14 +18,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Main (main) where +module CheckpointCutsEvent (main) where -- import Control.Concurrent +import Control.Applicative import Control.Monad.Reader import Control.Monad.State import Data.Acid +import Data.List import Data.SafeCopy import Data.Typeable +import System.Directory import System.Environment ------------------------------------------------------ @@ -47,10 +50,38 @@ main :: IO () -main = - do acid <- openLocalState (Counter 0) +main = do + putStrLn "CheckpointCutsEvent test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + acid <- openLocalStateFrom fp (Counter 0) replicateM_ 10 $ do is <- replicateM 10 (update acid IncCounter) print is createCheckpoint acid createArchive acid closeAcidState acid + checkDirectoryContents fp expected_state + checkDirectoryContents (fp ++ "/Archive") expected_archive + s <- readFile (fp ++ "/events-0000000100.log") + unless (s == "") $ error "non-empty events file" + putStrLn "CheckpointCutsEvent done" + where + fp = "state/CheckpointCutsEvent" + + expected_state = [".","..","Archive","checkpoints-0000000009.log","checkpoints-0000000010.log" + ,"checkpoints.version","events-0000000100.log","events.version","open.lock"] + expected_archive = [".","..","checkpoints-0000000000.log","checkpoints-0000000001.log" + ,"checkpoints-0000000002.log","checkpoints-0000000003.log","checkpoints-0000000004.log" + ,"checkpoints-0000000005.log","checkpoints-0000000006.log","checkpoints-0000000007.log" + ,"checkpoints-0000000008.log","events-0000000000.log","events-0000000010.log" + ,"events-0000000020.log","events-0000000030.log","events-0000000040.log" + ,"events-0000000050.log","events-0000000060.log","events-0000000070.log" + ,"events-0000000080.log","events-0000000090.log"] + + +checkDirectoryContents :: FilePath -> [FilePath] -> IO () +checkDirectoryContents fp expected_fs = do + putStrLn $ "Checking contents of " ++ fp + fs <- sort <$> getDirectoryContents fp + unless (fs == expected_fs) $ error $ "bad contents of " ++ fp ++ ": expected " + ++ show expected_fs ++ " but got " ++ show fs diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import qualified ChangeState +import qualified ChangeVersion +import qualified CheckpointCutsEvent +import qualified Exceptions +import qualified RemoveEvent +import qualified SlowCheckpoint + +main :: IO () +main = do + ChangeState.test + ChangeVersion.test + CheckpointCutsEvent.main + Exceptions.test + RemoveEvent.test + SlowCheckpoint.main diff --git a/examples/HelloDatabase.hs b/examples/HelloDatabase.hs --- a/examples/HelloDatabase.hs +++ b/examples/HelloDatabase.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module HelloDatabase (main) where import Data.Acid diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module HelloWorld (main) where import Control.Monad.Reader import Control.Monad.State diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module HelloWorldNoTH (main) where import Data.Acid import Data.Acid.Advanced diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module KeyValue (main) where import Data.Acid import Data.Acid.Remote diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module KeyValueNoTH (main) where import Data.Acid import Data.Acid.Advanced diff --git a/examples/MonadStateConstraint.hs b/examples/MonadStateConstraint.hs new file mode 100644 --- /dev/null +++ b/examples/MonadStateConstraint.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module MonadStateConstraint (main) where + +import Control.Monad.Reader +import Control.Monad.State +import Data.Acid +import Data.SafeCopy +import Data.Typeable +import System.Environment + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data HelloWorldState = HelloWorldState String + deriving (Show, Typeable) + +$(deriveSafeCopy 0 'base ''HelloWorldState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +writeState :: MonadState HelloWorldState m => String -> m () +writeState newValue + = put (HelloWorldState newValue) + +queryState :: MonadReader HelloWorldState m => m String +queryState = do HelloWorldState string <- ask + return string + +$(makeAcidic ''HelloWorldState ['writeState, 'queryState]) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do acid <- openLocalState (HelloWorldState "Hello world") + args <- getArgs + if null args + then do string <- query acid QueryState + putStrLn $ "The state is: " ++ string + else do update acid (WriteState (unwords args)) + putStrLn "The state has been modified!" diff --git a/examples/ParameterisedState.hs b/examples/ParameterisedState.hs new file mode 100644 --- /dev/null +++ b/examples/ParameterisedState.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module ParameterisedState (main) where + +import Control.Monad.State.Strict + +import Data.Acid +import qualified Data.Map as Map +import Data.SafeCopy (SafeCopy(..), deriveSafeCopy, base) +import Data.Serialize +import Data.Typeable +import GHC.Generics + +data Entry k = Entry + { key :: !k + , val :: !Int + } + deriving (Eq, Ord, Generic) + +instance Serialize k => Serialize (Entry k) + +$(deriveSafeCopy 0 'base ''Entry) + +newtype Store k = Store { store :: Map.Map k (Entry k) } + deriving (Eq, Generic) + +#if __GLASGOW_HASKELL__ <= 708 +deriving instance Typeable1 Store +#endif + +instance (Ord k, Serialize k) => SafeCopy (Store k) +instance (Ord k, Serialize k) => Serialize (Store k) + +insertStore + :: (Ord k, Serialize k) + => Entry k + -> Update (Store k) k +insertStore item = do + modify $ \(Store s) -> Store $ Map.insert (key item) item s + return (key item) + +makeAcidic ''Store [ 'insertStore ] + + +main :: IO () +main = do st <- openLocalState (Store Map.empty :: Store String) + k <- update st (InsertStore (Entry "A" 42)) + putStrLn k diff --git a/examples/Proxy.hs b/examples/Proxy.hs --- a/examples/Proxy.hs +++ b/examples/Proxy.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module Proxy (main) where import Data.Acid import Data.Acid.Advanced (scheduleUpdate) diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs --- a/examples/RemoteClient.hs +++ b/examples/RemoteClient.hs @@ -1,4 +1,4 @@ -module Main (main) where +module RemoteClient (main) where import Control.Monad.Reader import Data.Acid diff --git a/examples/RemoteServer.hs b/examples/RemoteServer.hs --- a/examples/RemoteServer.hs +++ b/examples/RemoteServer.hs @@ -1,4 +1,4 @@ -module Main where +module RemoteServer where import Control.Exception (bracket) import Data.Acid (closeAcidState, openLocalState) diff --git a/examples/SlowCheckpoint.hs b/examples/SlowCheckpoint.hs --- a/examples/SlowCheckpoint.hs +++ b/examples/SlowCheckpoint.hs @@ -2,14 +2,19 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +-- With optimizations enabled, serializing the checkpoint can happen too quickly +{-# OPTIONS_GHC -O0 #-} +module SlowCheckpoint (main) where + import Data.Acid import Control.Concurrent +import Control.Monad.Reader import Control.Monad.State import Data.SafeCopy import Data.Time +import System.Directory import System.IO ------------------------------------------------------ @@ -36,13 +41,20 @@ put $ SlowCheckpoint slow (tick+1) return tick -$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick]) +askTick :: Query SlowCheckpoint Int +askTick = do SlowCheckpoint _ tick <- ask + return tick +$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick, 'askTick]) + ------------------------------------------------------ -- This is how AcidState is used: main :: IO () -main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) +main = do putStrLn "SlowCheckpoint test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + acid <- openLocalStateFrom fp (SlowCheckpoint 0 0) putStrLn "This example illustrates that the state is still accessible while" putStrLn "a checkpoint is being serialized. This is an important property when" putStrLn "the size of a checkpoint reaches several hundred megabytes." @@ -51,12 +63,20 @@ putStrLn "" doTick acid update acid SetComputationallyHeavyData - forkIO $ do putStrLn "Seriazing checkpoint..." + forkIO $ do putStrLn "Serializing checkpoint..." t <- timeIt $ createCheckpoint acid - putStrLn $ "Checkpoint created in: " ++ show t + n <- query acid AskTick + putStrLn $ "Checkpoint created in: " ++ show t ++ " (saw " ++ show n ++ " ticks)" + when (n < threshold) $ error $ "Not enough ticks! Expected at least " ++ show threshold replicateM_ 20 $ do doTick acid threadDelay (10^5) + putStrLn "SlowCheckpoint done" + where + fp = "state/SlowCheckpoint" + + -- We must see at least this many ticks for the test to be considered a success + threshold = 5 doTick acid = do tick <- update acid Tick diff --git a/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module StressTest (main) where import Data.Acid import Data.Acid.Advanced (groupUpdates) diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module StressTestNoTH (main) where import Data.Acid import Data.Acid.Advanced diff --git a/examples/errors/ChangeState.hs b/examples/errors/ChangeState.hs --- a/examples/errors/ChangeState.hs +++ b/examples/errors/ChangeState.hs @@ -1,19 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module ChangeState (main, test) where import Data.Acid +import Control.Exception import Control.Monad.State import Data.SafeCopy +import System.Directory import System.Environment - -import Data.Typeable - -import Control.Exception -import Prelude hiding (catch) +import Data.List (isSuffixOf) import qualified Data.Text as Text @@ -43,9 +40,24 @@ putStrLn "without telling AcidState how to migrate from the old version to the new." putStrLn "Hopefully this program will fail with a readable error message." putStrLn "" - firstAcid <- openLocalStateFrom "state/ChangeState" (FirstState "first state") + firstAcid <- openLocalStateFrom fp (FirstState "first state") createCheckpoint firstAcid closeAcidState firstAcid - secondAcid <- openLocalStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used")) + secondAcid <- openLocalStateFrom fp (SecondState (Text.pack "This initial value shouldn't be used")) closeAcidState secondAcid - putStrLn "If you see this message then something has gone wrong!" + error "If you see this message then something has gone wrong!" + +test :: IO () +test = do + putStrLn "ChangeState test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + handle hdl main + putStrLn "ChangeState done" + where + hdl (ErrorCall msg) + | "Could not parse saved checkpoint due to the following error: too few bytes\nFrom:\tChangeState.SecondState:\n\tdemandInput\n\n" `isSuffixOf` msg + = putStrLn $ "Caught error: " ++ msg + hdl e = throwIO e + +fp = "state/ChangeState" diff --git a/examples/errors/ChangeVersion.hs b/examples/errors/ChangeVersion.hs new file mode 100644 --- /dev/null +++ b/examples/errors/ChangeVersion.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module ChangeVersion (main, test) where + +import Data.Acid + +import Control.Exception +import Control.Monad.State +import Data.SafeCopy +import System.Directory +import System.Environment + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data FirstState = FirstState String + deriving (Show) + +data SecondState = SecondState Int + deriving (Show) + +$(deriveSafeCopy 0 'base ''FirstState) +$(deriveSafeCopy 1 'base ''SecondState) +-- The version number difference is important here, as safecopy has no +-- way to reliably notice if we change a type and fail to update its +-- migration history. In some cases the serialised data will fail to +-- parse (see the "ChangeState" example), but it depends on the types +-- involved, and this will not always be the case. + +------------------------------------------------------ +-- The transaction we will execute over the state. + +$(makeAcidic ''FirstState []) +$(makeAcidic ''SecondState []) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do putStrLn "This example simulates what happens when you modify your safecopy" + putStrLn "version without specifying how to migrate from the old version to the new." + putStrLn "Hopefully this program will fail with a readable error message." + putStrLn "" + firstAcid <- openLocalStateFrom fp (FirstState "first state") + createCheckpoint firstAcid + closeAcidState firstAcid + secondAcid <- openLocalStateFrom fp (SecondState 42) + closeAcidState secondAcid + error "If you see this message then something has gone wrong!" + +test :: IO () +test = do + putStrLn "ChangeVersion test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + handle hdl main + putStrLn "ChangeVersion done" + where + hdl (ErrorCall msg) + | msg == "Could not parse saved checkpoint due to the following error: Failed reading: safecopy: ChangeVersion.SecondState: Cannot find getter associated with this version number: Version {unVersion = 0}\nEmpty call stack\n" + = putStrLn $ "Caught error: " ++ msg + hdl e = throwIO e + +fp = "state/ChangeVersion" diff --git a/examples/errors/Exceptions.hs b/examples/errors/Exceptions.hs --- a/examples/errors/Exceptions.hs +++ b/examples/errors/Exceptions.hs @@ -2,13 +2,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module Exceptions (main, test) where import Data.Acid import Data.Acid.Local (createCheckpointAndClose) import Control.Monad.State import Data.SafeCopy +import System.Directory import System.Environment import Data.Typeable @@ -70,7 +71,40 @@ ["6"] -> update acid (StateNestedError2 (error "nested state error (2)")) _ -> do putStrLn "Call with [123456] to test error scenarios." putStrLn "If the tick doesn't get stuck, everything is fine." - n <- update acid Tick - putStrLn $ "Tick: " ++ show n + do_tick acid `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException) createCheckpointAndClose acid + +do_tick :: AcidState MyState -> IO () +do_tick acid = do n <- update acid Tick + putStrLn $ "Tick: " ++ show n + +test :: IO () +test = do putStrLn "Exceptions test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + acid <- openLocalStateFrom fp (MyState 0) + do_tick acid + handle hdl $ update acid (undefined :: FailEvent) + do_tick acid + handle hdl $ update acid FailEvent + do_tick acid + handle hdl $ update acid ErrorEvent + do_tick acid + handle hdl $ update acid StateError + do_tick acid + -- We can't currently cope with an error being thrown during serialization of the state (see #38) + -- handle hdl $ update acid StateNestedError1 + do_tick acid + handle hdl $ update acid (StateNestedError2 (error "nested state error (2)")) + do_tick acid + n <- update acid Tick + unless (n == expected_n) $ error $ "Wrong tick value, expected " ++ show expected_n + createCheckpointAndClose acid + putStrLn "Exceptions done" + where + fp = "state/Exceptions" + + hdl e = putStrLn $ "Caught exception: " ++ show (e:: SomeException) + + expected_n = 7 diff --git a/examples/errors/RemoveEvent.hs b/examples/errors/RemoveEvent.hs --- a/examples/errors/RemoveEvent.hs +++ b/examples/errors/RemoveEvent.hs @@ -2,13 +2,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module RemoveEvent (main, test) where import Data.Acid import Control.Monad.State import Data.SafeCopy +import System.Directory import System.Environment +import Data.List (isSuffixOf) import Data.Typeable @@ -44,10 +46,25 @@ putStrLn "that is required to replay the journal." putStrLn "Hopefully this program will fail with a readable error message." putStrLn "" - firstAcid <- openLocalStateFrom "state/RemoveEvent" FirstState + firstAcid <- openLocalStateFrom fp FirstState update firstAcid FirstEvent closeAcidState firstAcid - secondAcid <- openLocalStateFrom "state/RemoveEvent" SecondState + secondAcid <- openLocalStateFrom fp SecondState closeAcidState secondAcid - putStrLn "If you see this message then something has gone wrong!" + error "If you see this message then something has gone wrong!" + +test :: IO () +test = do + putStrLn "RemoveEvent test" + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp + handle hdl main + putStrLn "RemoveEvent done" + where + hdl (ErrorCall msg) + | "This method is required but not available: \"RemoveEvent.FirstEvent\". Did you perhaps remove it before creating a checkpoint?" `isSuffixOf` msg + = putStrLn $ "Caught error: " ++ msg + hdl e = throwIO e + +fp = "state/RemoveEvent" diff --git a/src-unix/FileIO.hs b/src-unix/FileIO.hs --- a/src-unix/FileIO.hs +++ b/src-unix/FileIO.hs @@ -1,31 +1,17 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where +module FileIO(FHandle,open,write,flush,close) where import System.Posix(Fd(Fd), openFd, fdWriteBuf, - fdToHandle, closeFd, - OpenMode(WriteOnly,ReadWrite), - exclusive, trunc, + OpenMode(WriteOnly), defaultFileFlags, stdFileMode ) import Data.Word(Word8,Word32) import Foreign(Ptr) import Foreign.C(CInt(..)) -import System.IO -import Data.Maybe (listToMaybe) -import qualified System.IO.Error as SE -import System.Posix.Process (getProcessID) -import System.Posix.Signals (nullSignal, signalProcess) -import System.Posix.Types (ProcessID) -import Control.Exception.Extensible as E -import System.Directory ( createDirectoryIfMissing, removeFile) -import System.FilePath - -newtype PrefixLock = PrefixLock FilePath - data FHandle = FHandle Fd -- should handle opening flags correctly @@ -43,111 +29,3 @@ close :: FHandle -> IO () close (FHandle fd) = closeFd fd - --- Unix needs to use a special open call to open files for exclusive writing ---openExclusively :: FilePath -> IO Handle ---openExclusively fp = --- fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags --- where flags = defaultFileFlags {exclusive = True, trunc = True} - - - - -obtainPrefixLock :: FilePath -> IO PrefixLock -obtainPrefixLock prefix = do - checkLock fp >> takeLock fp - where fp = prefix ++ ".lock" - --- |Read the lock and break it if the process is dead. -checkLock :: FilePath -> IO () -checkLock fp = readLock fp >>= maybeBreakLock fp - --- |Read the lock and return the process id if possible. -readLock :: FilePath -> IO (Maybe ProcessID) -readLock fp = try (readFile fp) >>= - return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines) - --- |Is this a permission error? If so we don't have permission to --- remove the lock file, abort. -checkReadFileError :: [Char] -> IOError -> Maybe ProcessID -checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp)) - | SE.isDoesNotExistError e = Nothing - | True = throw e - -maybeBreakLock :: FilePath -> Maybe ProcessID -> IO () -maybeBreakLock fp Nothing = - -- The lock file exists, but there's no PID in it. At this point, - -- we will break the lock, because the other process either died - -- or will give up when it failed to read its pid back from this - -- file. - breakLock fp -maybeBreakLock fp (Just pid) = do - -- The lock file exists and there is a PID in it. We can break the - -- lock if that process has died. - -- getProcessStatus only works on the children of the calling process. - -- exists <- try (getProcessStatus False True pid) >>= either checkException (return . isJust) - exists <- doesProcessExist pid - case exists of - True -> throw (lockedBy fp pid) - False -> breakLock fp - -doesProcessExist :: ProcessID -> IO Bool -doesProcessExist pid = - -- Implementation 1 - -- doesDirectoryExist ("/proc/" ++ show pid) - -- Implementation 2 - try (signalProcess nullSignal pid) >>= return . either checkException (const True) - where checkException e | SE.isDoesNotExistError e = False - | True = throw e - --- |We have determined the locking process is gone, try to remove the --- lock. -breakLock :: FilePath -> IO () -breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ())) - --- |An exception when we tried to break a lock, if it says the lock --- file has already disappeared we are still good to go. -checkBreakError :: IOError -> IO () -checkBreakError e | SE.isDoesNotExistError e = return () - | True = throw e - --- |Try to create lock by opening the file with the O_EXCL flag and --- writing our PID into it. Verify by reading the pid back out and --- matching, maybe some other process slipped in before we were done --- and broke our lock. -takeLock :: FilePath -> IO PrefixLock -takeLock fp = do - createDirectoryIfMissing True (takeDirectory fp) - h <- openFd fp ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= fdToHandle - pid <- getProcessID - hPutStrLn h (show pid) >> hClose h - -- Read back our own lock and make sure its still ours - readLock fp >>= maybe (throw (cantLock fp pid)) - (\ pid' -> if pid /= pid' - then throw (stolenLock fp pid pid') - else return (PrefixLock fp)) - --- |An exception saying the data is locked by another process. -lockedBy :: (Show a) => FilePath -> a -> SomeException -lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp)) - --- |An exception saying we don't have permission to create lock. -cantLock :: FilePath -> ProcessID -> SomeException -cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp)) - --- |An exception saying another process broke our lock before we --- finished creating it. -stolenLock :: FilePath -> ProcessID -> ProcessID -> SomeException -stolenLock fp pid pid' = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ "'s lock was stolen by process " ++ show pid') Nothing (Just fp)) - --- |Relinquish the lock by removing it and then verifying the removal. -releasePrefixLock :: PrefixLock -> IO () -releasePrefixLock (PrefixLock fp) = - dropLock >>= either checkDrop return - where - dropLock = try (removeFile fp) - checkDrop e | SE.isDoesNotExistError e = return () - | True = throw e - - - diff --git a/src-win32/FileIO.hs b/src-win32/FileIO.hs --- a/src-win32/FileIO.hs +++ b/src-win32/FileIO.hs @@ -1,4 +1,4 @@ -module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where +module FileIO(FHandle,open,write,flush,close) where import System.Win32(HANDLE, createFile, gENERIC_WRITE, @@ -11,21 +11,9 @@ import Data.Word(Word8,Word32) import Foreign(Ptr) import System.IO -import System.Directory(createDirectoryIfMissing,removeFile) -import Control.Exception.Extensible(try,throw) -import Control.Exception(SomeException,IOException) -import qualified Control.Exception as E -type PrefixLock = (FilePath, Handle) - data FHandle = FHandle HANDLE -tryE :: IO a -> IO (Either SomeException a) -tryE = try - -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = E.catch - open :: FilePath -> IO FHandle open filename = fmap FHandle $ createFile filename gENERIC_WRITE fILE_SHARE_NONE Nothing cREATE_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing @@ -38,27 +26,3 @@ close :: FHandle -> IO () close (FHandle handle) = closeHandle handle - --- Windows opens files for exclusive writing by default -openExclusively :: FilePath -> IO Handle -openExclusively fp = openFile fp ReadWriteMode - -obtainPrefixLock :: FilePath -> IO PrefixLock -obtainPrefixLock prefix = do - createDirectoryIfMissing True prefix - -- catchIO obtainLock onError - catchIO obtainLock onError - where fp = prefix ++ ".lock" - obtainLock = do - h <- openExclusively fp - return (fp, h) - onError e = do - putStrLn "There may already be an instance of this application running, which could result in a loss of data." - putStrLn ("Please make sure there is no other application attempting to access '" ++ prefix ++ "'") - throw e - -releasePrefixLock :: PrefixLock -> IO () -releasePrefixLock (fp, h) = do - tryE $ hClose h - tryE $ removeFile fp - return () diff --git a/src/Data/Acid/Abstract.hs b/src/Data/Acid/Abstract.hs --- a/src/Data/Acid/Abstract.hs +++ b/src/Data/Acid/Abstract.hs @@ -132,7 +132,7 @@ Just (Just x) -> x _ -> error $ - "Data.Acid: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r) + "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r) #else downcast :: Typeable1 sub => AcidState st -> sub st downcast AcidState{acidSubState = AnyState sub} @@ -142,5 +142,5 @@ Just (Just x) -> x _ -> error $ - "Data.Acid: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) + "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) #endif diff --git a/src/Data/Acid/Archive.hs b/src/Data/Acid/Archive.hs --- a/src/Data/Acid/Archive.hs +++ b/src/Data/Acid/Archive.hs @@ -30,7 +30,7 @@ entriesToList :: Entries -> [Entry] entriesToList Done = [] entriesToList (Next entry next) = entry : entriesToList next -entriesToList (Fail msg) = error msg +entriesToList (Fail msg) = error $ "Data.Acid.Archive: " <> msg entriesToListNoFail :: Entries -> [Entry] entriesToListNoFail Done = [] diff --git a/src/Data/Acid/Core.hs b/src/Data/Acid/Core.hs --- a/src/Data/Acid/Core.hs +++ b/src/Data/Acid/Core.hs @@ -40,6 +40,7 @@ import Control.Monad ( liftM ) import Control.Monad.State ( State, runState ) import qualified Data.Map as Map +import Data.Monoid ((<>)) import Data.ByteString.Lazy as Lazy ( ByteString ) import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) @@ -117,7 +118,7 @@ = modifyMVar_ (coreState core) $ \st -> do action st return errorMsg - where errorMsg = error "Access failure: Core closed." + where errorMsg = error "Data.Acid.Core: Access failure: Core closed." -- | Modify the state component. The resulting state is ensured to be in -- WHNF. @@ -160,12 +161,12 @@ lazyDecode :: SafeCopy a => Lazy.ByteString -> a lazyDecode inp = case runGetLazy safeGet inp of - Left msg -> error msg + Left msg -> error $ "Data.Acid.Core: " <> msg Right val -> val missingMethod :: Tag -> a missingMethod tag - = error msg + = error $ "Data.Acid.Core: " <> msg where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) ++ ". Did you perhaps remove it before creating a checkpoint?" diff --git a/src/Data/Acid/Local.hs b/src/Data/Acid/Local.hs --- a/src/Data/Acid/Local.hs +++ b/src/Data/Acid/Local.hs @@ -30,22 +30,21 @@ import Data.Acid.Abstract import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) -import Control.Exception ( onException, evaluate ) +import Control.Exception ( onException, evaluate, Exception, throwIO ) import Control.Monad.State ( runState ) import Control.Monad ( join ) import Control.Applicative ( (<$>), (<*>) ) import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString.Lazy as Lazy ( length ) - import Data.Serialize ( runPutLazy, runGetLazy ) import Data.SafeCopy ( SafeCopy(..), safeGet, safePut , primitive, contain ) import Data.Typeable ( Typeable, typeOf ) import Data.IORef -import System.FilePath ( () ) - -import FileIO ( obtainPrefixLock, releasePrefixLock, PrefixLock ) +import System.FilePath ( (), takeDirectory ) +import System.FileLock +import System.Directory ( createDirectoryIfMissing ) {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) @@ -66,10 +65,13 @@ , localCopy :: IORef st , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog Checkpoint - , localLock :: PrefixLock + , localLock :: FileLock } deriving (Typeable) +newtype StateIsLocked = StateIsLocked FilePath deriving (Show, Typeable) +instance Exception StateIsLocked + -- | Issue an Update event and return immediately. The event is not durable -- before the MVar has been filled but the order of events is honored. -- The behavior in case of exceptions is exactly the same as for 'update'. @@ -201,7 +203,7 @@ takeMVar mvar closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) - releasePrefixLock (localLock acidState) + unlockFile (localLock acidState) where acidState = downcast abstract_state @@ -278,15 +280,15 @@ True -> do (n, st) <- loadCheckpoint return $ do - lock <- obtainPrefixLock lockFile + lock <- maybeLockFile lockFile replayEvents lock n st False -> do - lock <- obtainPrefixLock lockFile - (n, st) <- loadCheckpoint `onException` releasePrefixLock lock + lock <- maybeLockFile lockFile + (n, st) <- loadCheckpoint `onException` unlockFile lock return $ do replayEvents lock n st where - lockFile = directory "open" + lockFile = directory "open.lock" eventsLogKey = LogKey { logDirectory = directory , logPrefix = "events" } checkpointsLogKey = LogKey { logDirectory = directory @@ -317,10 +319,16 @@ , localCheckpoints = checkpointsLog , localLock = lock } + maybeLockFile path = do + createDirectoryIfMissing True (takeDirectory path) + maybe (throwIO (StateIsLocked path)) + return =<< tryLockFile path Exclusive + checkpointRestoreError msg = error $ "Could not parse saved checkpoint due to the following error: " ++ msg + -- | Close an AcidState and associated logs. -- Any subsequent usage of the AcidState will throw an exception. closeLocalState :: LocalState st -> IO () @@ -328,7 +336,7 @@ = do closeCore (localCore acidState) closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) - releasePrefixLock (localLock acidState) + unlockFile (localLock acidState) createLocalArchive :: LocalState st -> IO () createLocalArchive state @@ -361,4 +369,3 @@ , closeAcidState = closeLocalState local , acidSubState = mkAnyState local } - diff --git a/src/Data/Acid/Log.hs b/src/Data/Acid/Log.hs --- a/src/Data/Acid/Log.hs +++ b/src/Data/Acid/Log.hs @@ -35,6 +35,7 @@ import qualified Data.ByteString.Unsafe as Strict import Data.List import Data.Maybe +import Data.Monoid ((<>)) import qualified Data.Serialize.Get as Get import qualified Data.Serialize.Put as Put import Data.SafeCopy ( safePut, safeGet, SafeCopy ) @@ -148,7 +149,7 @@ modifyMVar_ (logCurrent fLog) $ \handle -> do close handle _ <- forkIO $ forM_ (logThreads fLog) killThread - return $ error "FileLog has been closed" + return $ error "Data.Acid.Log: FileLog has been closed" readEntities :: FilePath -> IO [Lazy.ByteString] readEntities path = do @@ -157,7 +158,7 @@ where worker Done = [] worker (Next entry next) = entry : worker next - worker (Fail msg) = error msg + worker (Fail msg) = error $ "Data.Acid.Log: " <> msg ensureLeastEntryId :: FileLog object -> EntryId -> IO () ensureLeastEntryId fLog youngestEntry = do @@ -310,9 +311,9 @@ case Archive.readEntries archive of Done -> worker logFiles Next entry next -> return $ Just (decode' (lastEntry entry next)) - Fail msg -> error msg + Fail msg -> error $ "Data.Acid.Log: " <> msg lastEntry entry Done = entry - lastEntry entry (Fail msg) = error msg + lastEntry entry (Fail msg) = error $ "Data.Acid.Log: " <> msg lastEntry _ (Next entry next) = lastEntry entry next -- Schedule a new log entry. This call does not block @@ -321,7 +322,7 @@ pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO () pushEntry fLog object finally = atomically $ do tid <- readTVar (logNextEntryId fLog) - writeTVar (logNextEntryId fLog) (tid+1) + writeTVar (logNextEntryId fLog) $! tid+1 (entries, actions) <- readTVar (logQueue fLog) writeTVar (logQueue fLog) ( encoded : entries, finally : actions ) where @@ -342,5 +343,5 @@ decode' :: SafeCopy object => Lazy.ByteString -> object decode' inp = case Get.runGetLazy safeGet inp of - Left msg -> error msg + Left msg -> error $ "Data.Acid.Log: " <> msg Right val -> val diff --git a/src/Data/Acid/Remote.hs b/src/Data/Acid/Remote.hs --- a/src/Data/Acid/Remote.hs +++ b/src/Data/Acid/Remote.hs @@ -108,6 +108,7 @@ import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common +import Data.Monoid ((<>)) import qualified Data.ByteString as Strict import Data.ByteString.Char8 ( pack ) import qualified Data.ByteString.Lazy as Lazy @@ -291,7 +292,7 @@ 1 -> liftM RunUpdate get 2 -> return CreateCheckpoint 3 -> return CreateArchive - _ -> error $ "Serialize.get for Command, invalid tag: " ++ show tag + _ -> error $ "Data.Acid.Remote: Serialize.get for Command, invalid tag: " ++ show tag data Response = Result Lazy.ByteString | Acknowledgement | ConnectionError @@ -305,7 +306,7 @@ 0 -> liftM Result get 1 -> return Acknowledgement 2 -> return ConnectionError - _ -> error $ "Serialize.get for Response, invalid tag: " ++ show tag + _ -> error $ "Data.Acid.Remote: Serialize.get for Response, invalid tag: " ++ show tag {- | Server inner-loop @@ -429,7 +430,7 @@ getResponse leftover = do debugStrLn $ "listener: listening for Response." let go inp = case inp of - Fail msg _ -> error msg + Fail msg _ -> error $ "Data.Acid.Remote: " <> msg Partial cont -> do debugStrLn $ "listener: ccGetSome" bs <- ccGetSome cc 1024 go (cont bs) @@ -487,7 +488,7 @@ = do let encoded = runPutLazy (safePut event) resp <- remoteQueryCold acidState (methodTag event, encoded) return (case runGetLazyFix safeGet resp of - Left msg -> error msg + Left msg -> error $ "Data.Acid.Remote: " <> msg Right result -> result) remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString @@ -497,7 +498,7 @@ (Result result) -> return result ConnectionError -> do debugStrLn "retrying query event." remoteQueryCold rs event - Acknowledgement -> error "remoteQueryCold got Acknowledgement. That should never happen." + Acknowledgement -> error "Data.Acid.Remote: remoteQueryCold got Acknowledgement. That should never happen." scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleRemoteUpdate (RemoteState fn _shutdown) event @@ -506,7 +507,7 @@ respRef <- fn (RunUpdate (methodTag event, encoded)) forkIO $ do Result resp <- takeMVar respRef putMVar parsed (case runGetLazyFix safeGet resp of - Left msg -> error msg + Left msg -> error $ "Data.Acid.Remote: " <> msg Right result -> result) return parsed diff --git a/src/Data/Acid/TemplateHaskell.hs b/src/Data/Acid/TemplateHaskell.hs --- a/src/Data/Acid/TemplateHaskell.hs +++ b/src/Data/Acid/TemplateHaskell.hs @@ -1,22 +1,25 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE TemplateHaskell, CPP, NamedFieldPuns #-} + {- Holy crap this code is messy. -} -module Data.Acid.TemplateHaskell - ( makeAcidic - ) where +module Data.Acid.TemplateHaskell where import Language.Haskell.TH import Language.Haskell.TH.Ppr +import Language.Haskell.TH.ExpandSyns import Data.Acid.Core import Data.Acid.Common -import Data.List ((\\), nub) +import Data.List ((\\), nub, delete) import Data.Maybe (mapMaybe) import Data.SafeCopy import Data.Typeable import Data.Char +import Data.Monoid ((<>)) import Control.Applicative import Control.Monad +import Control.Monad.State (MonadState) +import Control.Monad.Reader (MonadReader) {-| Create the control structures required for acid states using Template Haskell. @@ -62,8 +65,8 @@ -> makeAcidic' eventNames stateName tyvars [constructor] TySynD _name tyvars _ty -> makeAcidic' eventNames stateName tyvars [] - _ -> error "Unsupported state type. Only 'data', 'newtype' and 'type' are supported." - _ -> error "Given state is not a type." + _ -> error "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported." + _ -> error "Data.Acid.TemplateHaskell: Given state is not a type." makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] makeAcidic' eventNames stateName tyvars constructors @@ -89,8 +92,8 @@ #else VarI _name eventType _decl _fixity #endif - -> return eventType - _ -> error $ "Events must be functions: " ++ show eventName + -> expandSyns eventType + _ -> error $ "Data.Acid.TemplateHaskell: Events must be functions: " ++ show eventName --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where -- acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] @@ -140,17 +143,29 @@ -- need to rename the variables in the context to match. -- -- The contexts returned by this function will have the variables renamed. -eventCxts :: Type -- ^ State type (used for error messages) +-- +-- Additionally, if the event uses MonadReader or MonadState it might look +-- like this: +-- +-- > setState :: (MonadState x m, IsFoo x) => m () +-- +-- In this case we have to rename 'x' to the actual state we're going to +-- use. This is done by 'renameState'. +eventCxts :: Type -- ^ State type -> [TyVarBndr] -- ^ type variables that will be used for the State type in the IsAcidic instance -> Name -- ^ 'Name' of the event -> Type -- ^ 'Type' of the event -> [Pred] -- ^ extra context to add to 'IsAcidic' instance eventCxts targetStateType targetTyVars eventName eventType = - let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate) + let TypeAnalysis { context = cxt, stateType } = analyseType eventName eventType - eventTyVars = findTyVars stateType -- find the type variable names that this event is using for the State type - table = zip eventTyVars (map tyVarBndrName targetTyVars) -- create a lookup table - in map (unify table) cxt -- rename the type variables + -- find the type variable names that this event is using + -- for the State type + eventTyVars = findTyVars stateType + -- create a lookup table + table = zip eventTyVars (map tyVarBndrName targetTyVars) + in map (unify table) -- rename the type variables + (renameState stateType targetStateType cxt) where -- | rename the type variables in a Pred unify :: [(Name, Name)] -> Pred -> Pred @@ -177,8 +192,10 @@ renameName :: Pred -> [(Name, Name)] -> Name -> Name renameName pred table n = case lookup n table of - Nothing -> error $ unlines [ show $ ppr_sig eventName eventType + Nothing -> error $ unlines [ "Data.Acid.TemplateHaskell: " , "" + , show $ ppr_sig eventName eventType + , "" , "can not be used as an UpdateEvent because the class context: " , "" , pprint pred @@ -191,6 +208,21 @@ ] (Just n') -> n' +-- | See the end of comment for 'eventCxts'. +renameState :: Type -> Type -> Cxt -> Cxt +renameState tfrom tto cxt = map renamePred cxt + where +#if MIN_VERSION_template_haskell(2,10,0) + renamePred p = renameType p -- in 2.10.0: type Pred = Type +#else + renamePred (ClassP n tys) = ClassP n (map renameType tys) + renamePred (EqualP a b) = EqualP (renameType a) (renameType b) +#endif + renameType n | n == tfrom = tto + renameType (AppT a b) = AppT (renameType a) (renameType b) + renameType (SigT a k) = SigT (renameType a) k + renameType typ = typ + -- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) makeEventHandler :: Name -> Type -> ExpQ makeEventHandler eventName eventType @@ -199,7 +231,7 @@ let lamClause = conP eventStructName [varP var | var <- vars ] conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars)) where constr = if isUpdate then 'UpdateEvent else 'QueryEvent - (tyvars, _cxt, args, stateType, _resultType, isUpdate) = analyseType eventName eventType + TypeAnalysis { tyvars, argumentTypes = args, stateType, isUpdate } = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -208,7 +240,7 @@ assertTyVarsOk = case tyVarNames \\ stateTypeTyVars of [] -> return () - ns -> error $ unlines + ns -> error $ "Data.Acid.TemplateHaskell: " <> unlines [show $ ppr_sig eventName eventType , "" , "can not be used as an UpdateEvent because it contains the type variables: " @@ -220,10 +252,9 @@ , pprint stateType ] - - --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 -- deriving (Typeable) +makeEventDataType :: Name -> Type -> DecQ makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] #if MIN_VERSION_template_haskell(2,12,0) @@ -241,7 +272,7 @@ [_] -> newtypeD (return []) eventStructName tyvars con cxt _ -> dataD (return []) eventStructName tyvars [con] cxt #endif - where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType + where TypeAnalysis { tyvars, argumentTypes = args } = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -267,7 +298,7 @@ [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []] , valD (varP 'getCopy) (normalB (contained getArgs)) [] ] - where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType + where TypeAnalysis { tyvars, context, argumentTypes = args } = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -282,27 +313,39 @@ type MethodResult (MyUpdateEvent key val) = Return type MethodState (MyUpdateEvent key val) = State key val -} -makeMethodInstance eventName eventType - = do let preds = [ ''SafeCopy, ''Typeable ] - ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) - structType = foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars)) - instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context) - (return ty) +makeMethodInstance eventName eventType = do + let preds = + [ ''SafeCopy, ''Typeable ] + ty = + AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) + structType = + foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars)) + instanceContext = + cxt $ + [ classP classPred [varT tyvar] + | tyvar <- allTyVarBndrNames tyvars + , classPred <- preds + ] + ++ map return context + instanceD + instanceContext + (return ty) #if __GLASGOW_HASKELL__ >= 707 - [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType)) - , tySynInstD ''MethodState (tySynEqn [structType] (return stateType)) + [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType)) + , tySynInstD ''MethodState (tySynEqn [structType] (return stateType)) #else - [ tySynInstD ''MethodResult [structType] (return resultType) - , tySynInstD ''MethodState [structType] (return stateType) + [ tySynInstD ''MethodResult [structType] (return resultType) + , tySynInstD ''MethodState [structType] (return stateType) #endif - ] - where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType + ] + where TypeAnalysis { tyvars, context, stateType, resultType } = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs --instance (SafeCopy key, Typeable key -- ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val) +makeEventInstance :: Name -> Type -> DecQ makeEventInstance eventName eventType = do let preds = [ ''SafeCopy, ''Typeable ] eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent @@ -310,34 +353,90 @@ instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context) (return ty) [] - where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType + where TypeAnalysis { tyvars, context, isUpdate } = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs +data TypeAnalysis = TypeAnalysis + { tyvars :: [TyVarBndr] + , context :: Cxt + , argumentTypes :: [Type] + , stateType :: Type + , resultType :: Type + , isUpdate :: Bool + } deriving (Eq, Show) --- (tyvars, cxt, args, state type, result type, is update) -analyseType :: Name -> Type -> ([TyVarBndr], Cxt, [Type], Type, Type, Bool) -analyseType eventName t - = let (tyvars, cxt, t') = case t of - ForallT binds [] t' -> - (binds, [], t') - ForallT binds cxt t' -> - (binds, cxt, t') - _ -> ([], [], t) - args = getArgs t' - (stateType, resultType, isUpdate) = findMonad t' - in (tyvars, cxt, args, stateType, resultType, isUpdate) - where getArgs ForallT{} = error $ "Event has an invalid type signature: Nested forall: " ++ show eventName - getArgs (AppT (AppT ArrowT a) b) = a : getArgs b - getArgs _ = [] +analyseType :: Name -> Type -> TypeAnalysis +analyseType eventName t = go [] [] [] t + where +#if MIN_VERSION_template_haskell(2,10,0) + getMonadReader :: Cxt -> Name -> [(Type, Type)] + getMonadReader cxt m = do + constraint@(AppT (AppT (ConT c) x) m') <- cxt + guard (c == ''MonadReader && m' == VarT m) + return (constraint, x) - findMonad (AppT (AppT ArrowT a) b) - = findMonad b - findMonad (AppT (AppT (ConT con) state) result) - | con == ''Update = (state, result, True) - | con == ''Query = (state, result, False) - findMonad _ = error $ "Event has an invalid type signature: Not an Update or a Query: " ++ show eventName + getMonadState :: Cxt -> Name -> [(Type, Type)] + getMonadState cxt m = do + constraint@(AppT (AppT (ConT c) x) m') <- cxt + guard (c == ''MonadState && m' == VarT m) + return (constraint, x) +#else + getMonadReader :: Cxt -> Name -> [(Pred, Type)] + getMonadReader cxt m = do + constraint@(ClassP c [x, m']) <- cxt + guard (c == ''MonadReader && m' == VarT m) + return (constraint, x) + + getMonadState :: Cxt -> Name -> [(Pred, Type)] + getMonadState cxt m = do + constraint@(ClassP c [x, m']) <- cxt + guard (c == ''MonadState && m' == VarT m) + return (constraint, x) +#endif + + -- a -> b + go tyvars cxt args (AppT (AppT ArrowT a) b) + = go tyvars cxt (args ++ [a]) b + -- Update st res + -- Query st res + go tyvars context argumentTypes (AppT (AppT (ConT con) stateType) resultType) + | con == ''Update = + TypeAnalysis + { tyvars, context, argumentTypes, stateType, resultType + , isUpdate = True + } + | con == ''Query = + TypeAnalysis + { tyvars, context, argumentTypes, stateType, resultType + , isUpdate = False + } + -- (...) => a + go tyvars cxt args (ForallT tyvars2 cxt2 a) + = go (tyvars ++ tyvars2) (cxt ++ cxt2) args a + -- (MonadState state m) => ... -> m result + -- (MonadReader state m) => ... -> m result + go tyvars' cxt argumentTypes (AppT (VarT m) resultType) + | [] <- queries, [(cx, stateType)] <- updates + = TypeAnalysis + { tyvars, argumentTypes , stateType, resultType + , isUpdate = True + , context = delete cx cxt + } + + | [(cx, stateType)] <- queries, [] <- updates + = TypeAnalysis + { tyvars, argumentTypes , stateType, resultType + , isUpdate = False + , context = delete cx cxt + } + where + queries = getMonadReader cxt m + updates = getMonadState cxt m + tyvars = filter ((/= m) . tyVarBndrName) tyvars' + -- otherwise, fail + go _ _ _ _ = error $ "Data.Acid.TemplateHaskell: Event has an invalid type signature: Not an Update, Query, MonadState, or MonadReader: " ++ show eventName -- | find the type variables -- | e.g. State a b ==> [a,b] diff --git a/test-state/OldStateTest1/checkpoints-0000000000.log b/test-state/OldStateTest1/checkpoints-0000000000.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest1/checkpoints-0000000000.log diff --git a/test-state/OldStateTest1/checkpoints.version b/test-state/OldStateTest1/checkpoints.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest1/checkpoints.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test-state/OldStateTest1/events-0000000000.log b/test-state/OldStateTest1/events-0000000000.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest1/events-0000000000.log differ diff --git a/test-state/OldStateTest1/events-0000000681.log b/test-state/OldStateTest1/events-0000000681.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest1/events-0000000681.log diff --git a/test-state/OldStateTest1/events.version b/test-state/OldStateTest1/events.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest1/events.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test-state/OldStateTest2/checkpoints-0000000000.log b/test-state/OldStateTest2/checkpoints-0000000000.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest2/checkpoints-0000000000.log diff --git a/test-state/OldStateTest2/checkpoints.version b/test-state/OldStateTest2/checkpoints.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest2/checkpoints.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test-state/OldStateTest2/events-0000000000.log b/test-state/OldStateTest2/events-0000000000.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000000.log differ diff --git a/test-state/OldStateTest2/events-0000000003.log b/test-state/OldStateTest2/events-0000000003.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000003.log differ diff --git a/test-state/OldStateTest2/events-0000000007.log b/test-state/OldStateTest2/events-0000000007.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000007.log differ diff --git a/test-state/OldStateTest2/events-0000000012.log b/test-state/OldStateTest2/events-0000000012.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000012.log differ diff --git a/test-state/OldStateTest2/events-0000000014.log b/test-state/OldStateTest2/events-0000000014.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000014.log differ diff --git a/test-state/OldStateTest2/events-0000000017.log b/test-state/OldStateTest2/events-0000000017.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000017.log differ diff --git a/test-state/OldStateTest2/events-0000000019.log b/test-state/OldStateTest2/events-0000000019.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000019.log differ diff --git a/test-state/OldStateTest2/events-0000000031.log b/test-state/OldStateTest2/events-0000000031.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000031.log differ diff --git a/test-state/OldStateTest2/events-0000000042.log b/test-state/OldStateTest2/events-0000000042.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000042.log differ diff --git a/test-state/OldStateTest2/events-0000000044.log b/test-state/OldStateTest2/events-0000000044.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000044.log differ diff --git a/test-state/OldStateTest2/events-0000000046.log b/test-state/OldStateTest2/events-0000000046.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000046.log differ diff --git a/test-state/OldStateTest2/events-0000000057.log b/test-state/OldStateTest2/events-0000000057.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000057.log differ diff --git a/test-state/OldStateTest2/events-0000000059.log b/test-state/OldStateTest2/events-0000000059.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000059.log differ diff --git a/test-state/OldStateTest2/events-0000000060.log b/test-state/OldStateTest2/events-0000000060.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000060.log differ diff --git a/test-state/OldStateTest2/events-0000000069.log b/test-state/OldStateTest2/events-0000000069.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000069.log differ diff --git a/test-state/OldStateTest2/events-0000000078.log b/test-state/OldStateTest2/events-0000000078.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000078.log differ diff --git a/test-state/OldStateTest2/events-0000000079.log b/test-state/OldStateTest2/events-0000000079.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000079.log differ diff --git a/test-state/OldStateTest2/events-0000000082.log b/test-state/OldStateTest2/events-0000000082.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000082.log differ diff --git a/test-state/OldStateTest2/events-0000000098.log b/test-state/OldStateTest2/events-0000000098.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000098.log differ diff --git a/test-state/OldStateTest2/events-0000000100.log b/test-state/OldStateTest2/events-0000000100.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000100.log differ diff --git a/test-state/OldStateTest2/events-0000000102.log b/test-state/OldStateTest2/events-0000000102.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000102.log differ diff --git a/test-state/OldStateTest2/events-0000000104.log b/test-state/OldStateTest2/events-0000000104.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000104.log differ diff --git a/test-state/OldStateTest2/events-0000000112.log b/test-state/OldStateTest2/events-0000000112.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000112.log differ diff --git a/test-state/OldStateTest2/events-0000000117.log b/test-state/OldStateTest2/events-0000000117.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000117.log differ diff --git a/test-state/OldStateTest2/events-0000000122.log b/test-state/OldStateTest2/events-0000000122.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000122.log differ diff --git a/test-state/OldStateTest2/events-0000000126.log b/test-state/OldStateTest2/events-0000000126.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000126.log differ diff --git a/test-state/OldStateTest2/events-0000000127.log b/test-state/OldStateTest2/events-0000000127.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000127.log differ diff --git a/test-state/OldStateTest2/events-0000000131.log b/test-state/OldStateTest2/events-0000000131.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000131.log differ diff --git a/test-state/OldStateTest2/events-0000000141.log b/test-state/OldStateTest2/events-0000000141.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000141.log differ diff --git a/test-state/OldStateTest2/events-0000000143.log b/test-state/OldStateTest2/events-0000000143.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest2/events-0000000143.log differ diff --git a/test-state/OldStateTest2/events-0000000149.log b/test-state/OldStateTest2/events-0000000149.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest2/events-0000000149.log diff --git a/test-state/OldStateTest2/events.version b/test-state/OldStateTest2/events.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest2/events.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test-state/OldStateTest3/checkpoints-0000000000.log b/test-state/OldStateTest3/checkpoints-0000000000.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000000.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000001.log b/test-state/OldStateTest3/checkpoints-0000000001.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000001.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000003.log b/test-state/OldStateTest3/checkpoints-0000000003.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000003.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000004.log b/test-state/OldStateTest3/checkpoints-0000000004.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000004.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000005.log b/test-state/OldStateTest3/checkpoints-0000000005.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000005.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000006.log b/test-state/OldStateTest3/checkpoints-0000000006.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000006.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000007.log b/test-state/OldStateTest3/checkpoints-0000000007.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000007.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000008.log b/test-state/OldStateTest3/checkpoints-0000000008.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000008.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000009.log b/test-state/OldStateTest3/checkpoints-0000000009.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000009.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000010.log b/test-state/OldStateTest3/checkpoints-0000000010.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000010.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000011.log b/test-state/OldStateTest3/checkpoints-0000000011.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000011.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000012.log b/test-state/OldStateTest3/checkpoints-0000000012.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000012.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000014.log b/test-state/OldStateTest3/checkpoints-0000000014.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000014.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000016.log b/test-state/OldStateTest3/checkpoints-0000000016.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000016.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000017.log b/test-state/OldStateTest3/checkpoints-0000000017.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000017.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000019.log b/test-state/OldStateTest3/checkpoints-0000000019.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000019.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000020.log b/test-state/OldStateTest3/checkpoints-0000000020.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000020.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000022.log b/test-state/OldStateTest3/checkpoints-0000000022.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000022.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000023.log b/test-state/OldStateTest3/checkpoints-0000000023.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000023.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000024.log b/test-state/OldStateTest3/checkpoints-0000000024.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000024.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000025.log b/test-state/OldStateTest3/checkpoints-0000000025.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000025.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000028.log b/test-state/OldStateTest3/checkpoints-0000000028.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000028.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000029.log b/test-state/OldStateTest3/checkpoints-0000000029.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000029.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000031.log b/test-state/OldStateTest3/checkpoints-0000000031.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000031.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000032.log b/test-state/OldStateTest3/checkpoints-0000000032.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000032.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000033.log b/test-state/OldStateTest3/checkpoints-0000000033.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000033.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000034.log b/test-state/OldStateTest3/checkpoints-0000000034.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000034.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000037.log b/test-state/OldStateTest3/checkpoints-0000000037.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000037.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000040.log b/test-state/OldStateTest3/checkpoints-0000000040.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000040.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000041.log b/test-state/OldStateTest3/checkpoints-0000000041.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000041.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000043.log b/test-state/OldStateTest3/checkpoints-0000000043.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000043.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000044.log b/test-state/OldStateTest3/checkpoints-0000000044.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000044.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000045.log b/test-state/OldStateTest3/checkpoints-0000000045.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000045.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000046.log b/test-state/OldStateTest3/checkpoints-0000000046.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/checkpoints-0000000046.log differ diff --git a/test-state/OldStateTest3/checkpoints-0000000047.log b/test-state/OldStateTest3/checkpoints-0000000047.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest3/checkpoints-0000000047.log diff --git a/test-state/OldStateTest3/checkpoints.version b/test-state/OldStateTest3/checkpoints.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest3/checkpoints.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test-state/OldStateTest3/events-0000000000.log b/test-state/OldStateTest3/events-0000000000.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000000.log differ diff --git a/test-state/OldStateTest3/events-0000000001.log b/test-state/OldStateTest3/events-0000000001.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000001.log differ diff --git a/test-state/OldStateTest3/events-0000000002.log b/test-state/OldStateTest3/events-0000000002.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000002.log differ diff --git a/test-state/OldStateTest3/events-0000000003.log b/test-state/OldStateTest3/events-0000000003.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000003.log differ diff --git a/test-state/OldStateTest3/events-0000000006.log b/test-state/OldStateTest3/events-0000000006.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000006.log differ diff --git a/test-state/OldStateTest3/events-0000000016.log b/test-state/OldStateTest3/events-0000000016.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000016.log differ diff --git a/test-state/OldStateTest3/events-0000000018.log b/test-state/OldStateTest3/events-0000000018.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000018.log differ diff --git a/test-state/OldStateTest3/events-0000000023.log b/test-state/OldStateTest3/events-0000000023.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000023.log differ diff --git a/test-state/OldStateTest3/events-0000000027.log b/test-state/OldStateTest3/events-0000000027.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000027.log differ diff --git a/test-state/OldStateTest3/events-0000000029.log b/test-state/OldStateTest3/events-0000000029.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000029.log differ diff --git a/test-state/OldStateTest3/events-0000000030.log b/test-state/OldStateTest3/events-0000000030.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000030.log differ diff --git a/test-state/OldStateTest3/events-0000000031.log b/test-state/OldStateTest3/events-0000000031.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000031.log differ diff --git a/test-state/OldStateTest3/events-0000000033.log b/test-state/OldStateTest3/events-0000000033.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000033.log differ diff --git a/test-state/OldStateTest3/events-0000000034.log b/test-state/OldStateTest3/events-0000000034.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000034.log differ diff --git a/test-state/OldStateTest3/events-0000000036.log b/test-state/OldStateTest3/events-0000000036.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000036.log differ diff --git a/test-state/OldStateTest3/events-0000000037.log b/test-state/OldStateTest3/events-0000000037.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000037.log differ diff --git a/test-state/OldStateTest3/events-0000000038.log b/test-state/OldStateTest3/events-0000000038.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000038.log differ diff --git a/test-state/OldStateTest3/events-0000000041.log b/test-state/OldStateTest3/events-0000000041.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000041.log differ diff --git a/test-state/OldStateTest3/events-0000000044.log b/test-state/OldStateTest3/events-0000000044.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000044.log differ diff --git a/test-state/OldStateTest3/events-0000000051.log b/test-state/OldStateTest3/events-0000000051.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000051.log differ diff --git a/test-state/OldStateTest3/events-0000000054.log b/test-state/OldStateTest3/events-0000000054.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000054.log differ diff --git a/test-state/OldStateTest3/events-0000000055.log b/test-state/OldStateTest3/events-0000000055.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000055.log differ diff --git a/test-state/OldStateTest3/events-0000000058.log b/test-state/OldStateTest3/events-0000000058.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000058.log differ diff --git a/test-state/OldStateTest3/events-0000000059.log b/test-state/OldStateTest3/events-0000000059.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000059.log differ diff --git a/test-state/OldStateTest3/events-0000000060.log b/test-state/OldStateTest3/events-0000000060.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000060.log differ diff --git a/test-state/OldStateTest3/events-0000000061.log b/test-state/OldStateTest3/events-0000000061.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000061.log differ diff --git a/test-state/OldStateTest3/events-0000000062.log b/test-state/OldStateTest3/events-0000000062.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000062.log differ diff --git a/test-state/OldStateTest3/events-0000000064.log b/test-state/OldStateTest3/events-0000000064.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000064.log differ diff --git a/test-state/OldStateTest3/events-0000000065.log b/test-state/OldStateTest3/events-0000000065.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000065.log differ diff --git a/test-state/OldStateTest3/events-0000000066.log b/test-state/OldStateTest3/events-0000000066.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000066.log differ diff --git a/test-state/OldStateTest3/events-0000000067.log b/test-state/OldStateTest3/events-0000000067.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000067.log differ diff --git a/test-state/OldStateTest3/events-0000000068.log b/test-state/OldStateTest3/events-0000000068.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000068.log differ diff --git a/test-state/OldStateTest3/events-0000000070.log b/test-state/OldStateTest3/events-0000000070.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000070.log differ diff --git a/test-state/OldStateTest3/events-0000000075.log b/test-state/OldStateTest3/events-0000000075.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000075.log differ diff --git a/test-state/OldStateTest3/events-0000000076.log b/test-state/OldStateTest3/events-0000000076.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000076.log differ diff --git a/test-state/OldStateTest3/events-0000000077.log b/test-state/OldStateTest3/events-0000000077.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000077.log differ diff --git a/test-state/OldStateTest3/events-0000000078.log b/test-state/OldStateTest3/events-0000000078.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000078.log differ diff --git a/test-state/OldStateTest3/events-0000000079.log b/test-state/OldStateTest3/events-0000000079.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000079.log differ diff --git a/test-state/OldStateTest3/events-0000000081.log b/test-state/OldStateTest3/events-0000000081.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000081.log differ diff --git a/test-state/OldStateTest3/events-0000000083.log b/test-state/OldStateTest3/events-0000000083.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000083.log differ diff --git a/test-state/OldStateTest3/events-0000000088.log b/test-state/OldStateTest3/events-0000000088.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000088.log differ diff --git a/test-state/OldStateTest3/events-0000000089.log b/test-state/OldStateTest3/events-0000000089.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000089.log differ diff --git a/test-state/OldStateTest3/events-0000000092.log b/test-state/OldStateTest3/events-0000000092.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000092.log differ diff --git a/test-state/OldStateTest3/events-0000000094.log b/test-state/OldStateTest3/events-0000000094.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000094.log differ diff --git a/test-state/OldStateTest3/events-0000000097.log b/test-state/OldStateTest3/events-0000000097.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000097.log differ diff --git a/test-state/OldStateTest3/events-0000000099.log b/test-state/OldStateTest3/events-0000000099.log new file mode 100644 Binary files /dev/null and b/test-state/OldStateTest3/events-0000000099.log differ diff --git a/test-state/OldStateTest3/events-0000000100.log b/test-state/OldStateTest3/events-0000000100.log new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest3/events-0000000100.log diff --git a/test-state/OldStateTest3/events.version b/test-state/OldStateTest3/events.version new file mode 100644 --- /dev/null +++ b/test-state/OldStateTest3/events.version @@ -0,0 +1,1 @@ +0.15.0 diff --git a/test/Data/Acid/KeyValueStateMachine.hs b/test/Data/Acid/KeyValueStateMachine.hs new file mode 100644 --- /dev/null +++ b/test/Data/Acid/KeyValueStateMachine.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module instantiates the general framework in +-- 'Data.Acid.StateMachineTest' with an acid-state component that +-- implements a simple key-value store. +module Data.Acid.KeyValueStateMachine (tests) where + +import Control.DeepSeq +import Control.Exception +import Control.Monad.Reader +import Control.Monad.State +import Data.Acid +import Data.Acid.StateMachineTest +import Data.SafeCopy +import qualified Data.Map as Map +import Data.Typeable +import GHC.Generics +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +type Key = Int +type Value = String + +data KeyValue = KeyValue !(Map.Map Key Value) + deriving (Eq, Show, Typeable) + +$(deriveSafeCopy 0 'base ''KeyValue) + +-- | Insert a key into the key-value store. +insertKey :: Key -> Value -> Update KeyValue () +insertKey key value + = do KeyValue m <- get + put (KeyValue (Map.insert key value m)) + +-- | A slightly more complicated update transaction: reverse the value +-- at the given key, and return the resulting state. Crucially, this +-- is non-idempotent, unlike 'insertKey'. +reverseKey :: Key -> Update KeyValue KeyValue +reverseKey key + = do KeyValue m <- get + let r = KeyValue (Map.adjust reverse key m) + put r + return r + +-- | An update that may fail: reverse the value at the given key, or +-- fail if it is missing. +reverseKeyOrFail :: Key -> Bomb -> Update KeyValue () +reverseKeyOrFail key _ + = do KeyValue m <- get + case Map.lookup key m of + Nothing -> failUpdate "key not in map" + Just val -> put (KeyValue (Map.insert key (reverse val) m)) + +-- | An update that attempts to put an undefined state. This transaction should +-- simply fail and not modify the state. +breakState :: Update KeyValue () +breakState = put (throw (TransactionError "broken state")) + +-- | An update that puts a partially-defined state. Unfortunately +-- acid-state does not handle this case gracefully, and will fail with +-- 'BlockedIndefinitelyOnMVar' (see #38). Thus this update is not +-- included in 'keyValueCommands' below. +breakState2 :: Update KeyValue () +breakState2 = put (KeyValue (Map.singleton 1 (throw (TransactionError "broken state")))) + +-- | Look up a key from the store. +lookupKey :: Key -> Query KeyValue (Maybe Value) +lookupKey key + = do KeyValue m <- ask + return (Map.lookup key m) + +-- | Look up a key from the store, or fail if it is missing. +lookupKeyOrFail :: Key -> Bomb -> Query KeyValue Value +lookupKeyOrFail key _ + = do KeyValue m <- ask + maybe (failQuery "key not in map") return (Map.lookup key m) + +-- | Query the current value of the state. This is not used in the +-- generated commands, but is used for checking the state we get back +-- in 'prop_restore_old_state_1' etc. +askState :: Query KeyValue KeyValue +askState = ask + +$(makeAcidic ''KeyValue ['insertKey, 'reverseKey, 'reverseKeyOrFail, 'breakState, 'breakState2, 'lookupKey, 'lookupKeyOrFail, 'askState]) + +deriving instance Generic InsertKey +deriving instance Generic ReverseKey +deriving instance Generic ReverseKeyOrFail +deriving instance Generic BreakState +deriving instance Generic LookupKey +deriving instance Generic LookupKeyOrFail + +deriving instance Show InsertKey +deriving instance Show ReverseKey +deriving instance Show ReverseKeyOrFail +deriving instance Show BreakState +deriving instance Show LookupKey +deriving instance Show LookupKeyOrFail + +instance NFData InsertKey +instance NFData ReverseKey +instance NFData ReverseKeyOrFail +instance NFData BreakState +instance NFData LookupKey +instance NFData LookupKeyOrFail + +genKey :: Gen Key +genKey = Gen.int (Range.constant 1 10) + +genValue :: Gen Value +genValue = Gen.string (Range.constant 0 10) Gen.alphaNum + +keyValueCommands :: MonadIO m => [Command Gen m (Model KeyValue)] +keyValueCommands = [ acidUpdate (InsertKey <$> genKey <*> genValue) + , acidUpdate (ReverseKey <$> genKey) + , acidUpdateMayFail (ReverseKeyOrFail <$> genKey <*> genBomb) + , acidUpdateMayFail (pure BreakState) + , acidQuery (LookupKey <$> genKey) + , acidQueryMayFail (LookupKeyOrFail <$> genKey <*> genBomb) + ] + +-- | Possible initial states; because of #20 we can currently only use +-- one of these when testing the properties. +initialStates :: [KeyValue] +initialStates = [ KeyValue Map.empty + , KeyValue (Map.singleton 1 "foo") + ] + +prop_sequential :: Property +prop_sequential = acidStateSequentialProperty (acidStateInterface fp) (pure (head initialStates)) (Range.linear 1 10) keyValueCommands + where + fp = "state/KeyValueSequentialTest" + +prop_parallel :: Property +prop_parallel = acidStateParallelProperty (acidStateInterface fp) (pure (head initialStates)) (Range.linear 1 10) (Range.linear 1 10) keyValueCommands + where + fp = "state/KeyValueParallelTest" + +prop_restore_old_state_1 :: Property +prop_restore_old_state_1 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r + where + fp = "test-state/OldStateTest1" + r = KeyValue (Map.fromList [(1,""),(2,""),(3,"y5Pl"),(4,""),(5,"Zc"),(6,"8aENKK") + ,(7,"FDzyGCz"),(8,""),(9,"xq"),(10,"1Ra1obuINa")]) + +prop_restore_old_state_2 :: Property +prop_restore_old_state_2 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r + where + fp = "test-state/OldStateTest2" + r = KeyValue (Map.fromList [(1,"PLwR1S6F"),(2,"0yrcVQM0c"),(3,"zAA"),(4,"prAocOc") + ,(5,"HM"),(6,"ENdfLrrW"),(7,"sESXGsI"),(8,"AFa69uu5") + ,(9,"XBvIQHX"),(10,"A2CzkvW")]) + +prop_restore_old_state_3 :: Property +prop_restore_old_state_3 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r + where + fp = "test-state/OldStateTest3" + r = KeyValue (Map.fromList [(1,"4"),(2,"RQ1xEc5"),(3,"aT0Hqk"),(4,"Duf") + ,(5,"tssCng7e0d"),(6,"uQW0hCVze"),(7,"FSCZPMGL") + ,(8,"q1WI9He"),(9,"IYHbWmO"),(10,"lCErPJC3")]) + + +tests :: IO Bool +tests = checkParallel $$(discover) diff --git a/test/Data/Acid/StateMachineTest.hs b/test/Data/Acid/StateMachineTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Acid/StateMachineTest.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module provides a general framework for state-machine testing of +-- acid-state components. It needs to be instantiated with a +-- particular acid-state component to get a concrete test. +module Data.Acid.StateMachineTest + ( acidUpdate + , acidUpdateMayFail + , acidUpdateCheckFail + , acidQuery + , acidQueryMayFail + , acidQueryCheckFail + , acidStateSequentialProperty + , acidStateParallelProperty + , restoreOldStateProperty + , acidStateInterface + , AcidStateInterface(..) + + , Model(..) + , open + , close + , checkpoint + , checkpointClose + , kill + + -- * Testing exceptions + , TransactionError(..) + , failQuery + , failUpdate + , Bomb(..) + , explodeWHNF + , explodeNF + , genBomb + ) where + +import Control.DeepSeq +import Control.Exception (Exception, IOException, throw, catch, try, evaluate) +import Control.Monad.Reader +import Control.Monad.State +import qualified Data.Acid as Acid +import qualified Data.Acid.Common as Common +import qualified Data.Acid.Core as Core +import qualified Data.Acid.Local as Local +import Data.Maybe +import qualified Data.SafeCopy as SafeCopy +import Data.Typeable +import Hedgehog +import qualified Hedgehog.Gen as Gen +import System.Directory (removeDirectoryRecursive, removeFile) +import System.IO.Unsafe (unsafePerformIO) + +-- | Exception to be thrown when a query or update fails. +-- +-- At the moment the only way to implement failing transactions is by +-- throwing an exception from pure code. The state machine tests +-- assume that all failures use 'failQuery' or 'failUpdate', which +-- throw this exception. Thus we can catch this exception in cases +-- where transaction failures are accepted. +-- +-- Even if acid-state provided a pure way to throw and catch errors in +-- the 'Update' and 'Query' monads, we would still need to test that +-- it correctly handles exceptions thrown during transactions. +data TransactionError = TransactionError String + deriving Show +instance Exception TransactionError + +-- | Cause a 'Query' to fail in a (possibly) expected manner. See +-- 'acidQueryMayFail' and 'acidQueryCheckFail'. +failQuery :: String -> Acid.Query s a +failQuery s = throw (TransactionError s) + +-- | Cause an 'Update' to fail in a (possibly) expected manner. See +-- 'acidUpdateMayFail' and 'acidUpdateCheckFail'. +failUpdate :: String -> Acid.Update s a +failUpdate s = throw (TransactionError s) + +-- | Container for exceptions thrown from pure code. This is +-- intended for use as an argument to transactions, for testing +-- transactions that cannot be serialised. +data Bomb = Bomb { unBomb :: Int } + +instance NFData Bomb where + rnf (Bomb n) = rnf n + +-- | Slightly hacky 'Show' instance that will attempt to show +-- something sensible even if evaluating the 'Bomb' throws an +-- exception. +instance Show Bomb where + show b = "(Bomb " ++ s ++ ")" + where + s = unsafePerformIO $ evaluate (show (unBomb b)) `catch` \ TransactionError{} -> return "(exploded)" + +-- | Throw an exception when evaluated to WHNF. +explodeWHNF :: Bomb +explodeWHNF = throw (TransactionError "boom!") + +-- | Throw an exception when evaluated to NF (but not when +-- evaluated to WHNF). +explodeNF :: Bomb +explodeNF = Bomb (throw (TransactionError "boom!")) + +-- | Generate a bomb that may or may not explode (throw an exception) +-- when evaluated. +genBomb :: Gen Bomb +genBomb = Gen.element [Bomb 0, Bomb 1, Bomb 2, Bomb 3, explodeWHNF, explodeNF] + +$(SafeCopy.deriveSafeCopy 0 'SafeCopy.base ''Bomb) + + +-- | Model of an acid-state component, for state machine property +-- testing. We start in 'StateAbsent' and can transition to +-- 'StateOpen' by opening the state for the first time. Thereafter we +-- can transition between 'StateOpen' and 'StateClosed' by opening and +-- closing the state. Both of the latter keep track of the current +-- value of the state. +data Model s (v :: * -> *) + = StateAbsent -- ^ State is not present on disk + | StateClosed s -- ^ State is present on disk, but not in memory + | StateOpen s (Var (Opaque (Acid.AcidState s)) v) -- ^ State is open in memory + +-- | Return the handle to the acid-state component if it is open, or +-- return 'Nothing' if it is closed or absent. +modelHandle :: Model s v -> Maybe (Var (Opaque (Acid.AcidState s)) v) +modelHandle (StateOpen _ hdl) = Just hdl +modelHandle _ = Nothing + +-- | Is the state currently open? +isOpen :: Model s v -> Bool +isOpen = isJust . modelHandle + +-- | Return the current value of the state, if it is present. +modelValue :: Model s v -> Maybe s +modelValue (StateClosed s) = Just s +modelValue (StateOpen s _) = Just s +modelValue StateAbsent = Nothing + + +-- | Description of the interface for performing +-- meta-operations on an acid-state, such as opening, closing and +-- checkpointing it. The testing code is abstracted over this +-- interface so that we can substitute alternate serialisation +-- backends. +data AcidStateInterface s = + (Typeable s, Acid.IsAcidic s, Show s) + => AcidStateInterface + { openState :: s -> IO (Acid.AcidState s) + , closeState :: Acid.AcidState s -> IO () + , checkpointState :: Acid.AcidState s -> IO () + , checkpointCloseState :: Acid.AcidState s -> IO () + , resetState :: IO () + , statePath :: FilePath + } + +-- | Standard implementation of the acid-state interface, using +-- 'SafeCopy'-based serialisation. +-- +-- This takes the path to the state directory as an argument. +-- Warning: this path will be deleted/overwritten! +acidStateInterface :: (Acid.IsAcidic s, SafeCopy.SafeCopy s, Typeable s, Show s) + => FilePath -> AcidStateInterface s +acidStateInterface fp = + AcidStateInterface { openState = Acid.openLocalStateFrom fp + , closeState = Acid.closeAcidState + , checkpointState = Acid.createCheckpoint + , checkpointCloseState = Local.createCheckpointAndClose + , resetState = removeDirectoryRecursive fp + `catch` (\ (_ :: IOException) -> return ()) + , statePath = fp + } + + +data Open s (v :: * -> *) = Open s + deriving Show + +instance HTraversable (Open s) where + htraverse _ (Open s) = pure (Open s) + +-- | Command to open the state, given the interface to use and a +-- generator for possible initial state values. +open :: MonadIO m => AcidStateInterface s -> Gen s -> Command Gen m (Model s) +open AcidStateInterface{..} gen_initial_state = + Command gen execute [ Require require, Update update ] + where + require model _ = not (isOpen model) + + gen StateAbsent = Just (Open <$> gen_initial_state) + gen StateClosed{} = Just (Open <$> gen_initial_state) + gen StateOpen{} = Nothing + + execute (Open initial_state) = liftIO (Opaque <$> openState initial_state) + + update StateAbsent (Open s) hdl = StateOpen s hdl + update (StateClosed s) (Open _) hdl = StateOpen s hdl + update StateOpen{} _ _ = error "open: state already open!" + + +data WithState s (v :: * -> *) = WithState String (Var (Opaque (Acid.AcidState s)) v) + deriving (Show) + +instance HTraversable (WithState s) where + htraverse k (WithState l v) = WithState l <$> htraverse k v + +genWithState :: Applicative g => String -> Model s v -> Maybe (g (WithState s v)) +genWithState l model = pure . WithState l <$> modelHandle model + +-- | Command to close the state. +close :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s) +close AcidStateInterface{..} = + Command (genWithState "Close") execute [ Require require, Update update ] + where + require model _ = isOpen model + + execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (closeState st) + update (StateOpen s _) _ _ = StateClosed s + update _ _ _ = error "close: not open" + +-- | Command to take a checkpoint of the state. +checkpoint :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s) +checkpoint AcidStateInterface{..} = + Command (genWithState "checkpoint") execute [ Require require ] + where + require model _ = isOpen model + execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (checkpointState st) + +-- | Command to take a checkpoint and close the state, as a single atomic action. +checkpointClose :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s) +checkpointClose AcidStateInterface{..} = + Command (genWithState "checkpointClose") execute [ Require require, Update update ] + where + require model _ = isOpen model + execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (checkpointCloseState st) + update (StateOpen s _) _ _ = StateClosed s + update _ _ _ = error "checkpointClose: not open" + +-- | Command to simulate killing the process without closing the +-- state. This does not actually stop the old thread, though. +-- +-- The lock file is removed so that the state can be reopened +-- (otherwise further commands would immediately fail). +kill :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s) +kill AcidStateInterface{..} = + Command (genWithState "kill") execute [ Require require, Update update ] + where + require model _ = isOpen model + execute WithState{} = liftIO $ removeFile (statePath ++ "/open.lock") + update (StateOpen s _) _ _ = StateClosed s + update _ _ _ = error "kill: not open" + + + +data AcidCommand s e (v :: * -> *) = AcidCommand e (Var (Opaque (Acid.AcidState s)) v) + deriving (Show) + +instance HTraversable (AcidCommand s e) where + htraverse k (AcidCommand e s) = AcidCommand e <$> htraverse k s + +-- | Translate an acid-state update into a command that executes the +-- update, given a generator of inputs. If the update fails, the +-- property as a whole fails. +acidUpdate :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.UpdateEvent e + , Show e + , NFData e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + ) + => Gen e -> Command Gen m (Model s) +acidUpdate = acidUpdateCheckFail (\ _ _ _ _ -> failure) + +-- | Translate an acid-state update into a command that executes the +-- update, given a generator of inputs. If the update fails, the +-- property as a whole succeeds. +acidUpdateMayFail :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.UpdateEvent e + , Show e + , NFData e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + ) + => Gen e -> Command Gen m (Model s) +acidUpdateMayFail = acidUpdateCheckFail (\ _ _ _ _ -> return ()) + +-- | Translate an acid-state update into a command that executes the +-- update, given a generator of inputs. If the update fails, the +-- given predicate is tested on the old and new states, the event and +-- the 'TransactionError' exception. +acidUpdateCheckFail :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.UpdateEvent e + , Show e + , NFData e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + ) + => (s -> s -> e -> TransactionError -> Test ()) + -> Gen e -> Command Gen m (Model s) +acidUpdateCheckFail allow_failure gen_event = + Command gen execute [ Require require, Update update, Ensure ensure ] + where + -- Generate updates only when state is open + gen :: Model s Symbolic -> Maybe (Gen (AcidCommand s e Symbolic)) + gen model = case modelHandle model of + Just st -> Just (AcidCommand <$> gen_event <*> pure st) + Nothing -> Nothing + + -- Execute a concrete update directly using acid-state + execute :: AcidCommand s e Concrete -> m (Either TransactionError (Acid.EventResult e)) + execute (AcidCommand e (Var (Concrete (Opaque st)))) = liftIO (try (Acid.update st e)) + + -- Shrinking updates requires the state to be open + require :: Model s Symbolic -> AcidCommand s e Symbolic -> Bool + require model _ = isOpen model + + -- Updates cause the model state to be updated. This needs + -- 'unsafePerformIO' because the update function must be pure, but + -- we need to deal with the possibility of the transaction + -- throwing a 'TransactionError' exception, in which case the + -- state of the model should not change. We need to deepseq the + -- update event itself, in case it contains a nested error that + -- will show up during serialisation but is not forced by + -- executing the transaction. + update :: Model s v + -> AcidCommand s e v + -> Var (Either TransactionError (Acid.EventResult e)) v + -> Model s v + update (StateOpen s hdl) (AcidCommand c _) _ = + unsafePerformIO $ do + s' <- evaluate (c `deepseq` execState (lookupMethod c) s) + `catch` \ (_ :: TransactionError) -> return s + return (StateOpen s' hdl) + update _ _ _ = error "acidUpdate: state not open" + + -- Evaluating the update directly on the model value of the old + -- state should give the same result + ensure :: Model s Concrete + -> Model s Concrete + -> AcidCommand s e Concrete + -> Either TransactionError (Acid.EventResult e) + -> Test () + ensure model0 model1 (AcidCommand c _) (Left e) = case (modelValue model0, modelValue model1) of + (Just v0, Just v1) -> allow_failure v0 v1 c e + _ -> failure + ensure model _ (AcidCommand c _) (Right o) = case modelValue model of + Just v -> evalState (lookupMethod c) v === o + Nothing -> failure + +-- | Translate an acid-state query into a command that executes the +-- query, given a generator of inputs. If the query fails, the +-- property as a whole fails. +acidQuery :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.QueryEvent e + , Show e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + , Eq s + , Show s + ) + => Gen e -> Command Gen m (Model s) +acidQuery = acidQueryCheckFail (\ _ _ _ -> failure) + +-- | Translate an acid-state query into a command that executes the +-- query, given a generator of inputs. If the query fails, the +-- property as a whole succeeds. +acidQueryMayFail :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.QueryEvent e + , Show e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + , Eq s + , Show s + ) + => Gen e -> Command Gen m (Model s) +acidQueryMayFail = acidQueryCheckFail (\ _ _ _ -> return ()) + +-- | Translate an acid-state query into a command that executes the +-- query, given a generator of inputs. If the query fails, the given +-- predicate is tested on the state, the event and the +-- 'TransactionError' exception. +acidQueryCheckFail :: forall s e m . + ( Acid.IsAcidic s + , Acid.EventState e ~ s + , Acid.QueryEvent e + , Show e + , Eq (Acid.EventResult e) + , Show (Acid.EventResult e) + , Typeable (Acid.EventResult e) + , MonadIO m + , Eq s + , Show s + ) + => (s -> e -> TransactionError -> Test ()) -> Gen e -> Command Gen m (Model s) +acidQueryCheckFail allow_failure gen_event = Command gen execute + [ Require require + , Ensure unchanged_model + , Ensure correct_output + ] + where + -- Generate queries only when state is open + gen model = case modelHandle model of + Just st -> Just (AcidCommand <$> gen_event <*> pure st) + Nothing -> Nothing + + -- Execute a concrete query directly using acid-state + execute (AcidCommand e (Var (Concrete (Opaque st)))) = + liftIO (try (evaluate =<< Acid.query st e)) + + -- Shrinking queries requires the state to be open + require model _ = isOpen model + + -- Queries should not change the value in the model + unchanged_model model0 model1 _ _ = modelValue model0 === modelValue model1 + + -- Evaluating the query directly on the model value of the old + -- state should give the same result + correct_output model _ (AcidCommand c _) r = case modelValue model of + Just v -> case r of + Right o -> evalState (lookupMethod c) v === o + Left e -> allow_failure v c e + Nothing -> failure + +-- | Extract the underlying method implementation in the pure 'State' +-- monad for an acid-state query or update. +lookupMethod :: (Core.Method m, Acid.IsAcidic (Core.MethodState m)) + => m -> State (Core.MethodState m) (Core.MethodResult m) +lookupMethod m = Core.lookupHotMethod mmap m + where + mmap = Core.mkMethodMap (Common.eventsToMethods Common.acidEvents) + + +-- | Test the sequential property (agreement between model and +-- implementation) for an acid-state component, given the interface, a +-- generator for initial values of the state, and a list of commands +-- built from 'acidQuery' and 'acidUpdate'. Additional commands will +-- be added to open and close the state. +-- +-- Note that if the generator for initial values can return more than +-- one result, this will fail due to #20. +acidStateSequentialProperty :: AcidStateInterface s -> Gen s -> Range Int -> [Command Gen (TestT IO) (Model s)] -> Property +acidStateSequentialProperty i gen_initial_state range commands = property $ do + actions <- forAll $ Gen.sequential range StateAbsent $ + [ open i gen_initial_state + , close i + , checkpoint i + , checkpointClose i + , kill i + ] ++ commands ++ commands + test $ do liftIO $ resetState i + executeSequential StateAbsent actions + +-- | Test the parallel property (absence of race conditions) for an +-- acid-state component, given the interface, a generator for initial +-- values of the state, and a list of commands built from 'acidQuery' +-- and 'acidUpdate'. Additional commands will be added to open and +-- close the state. +-- +-- Note that if the generator for initial values can return more than +-- one result, this will fail due to #20. +-- +-- The state cannot be opened twice in parallel, so the length of the +-- sequential prefix must be at least 1, so that the open command +-- happens exactly once. +acidStateParallelProperty :: AcidStateInterface s -> Gen s -> Range Int -> Range Int -> [Command Gen (TestT IO) (Model s)] -> Property +acidStateParallelProperty i gen_initial_state prefix_range parallel_range commands = property $ do + actions <- forAll $ Gen.parallel prefix_range parallel_range StateAbsent $ + [ open i gen_initial_state + , checkpoint i + ] ++ commands ++ commands + test $ do liftIO $ resetState i + executeParallel StateAbsent actions + +-- | Test that restoring an acid-state component (with the given initial +-- value), then executing the given query, results in the given +-- expected value. This is mostly useful to test that restoring from +-- files created by an older version of acid-state can still be read. +restoreOldStateProperty :: (Acid.EventState e ~ s, Acid.EventResult e ~ r, Acid.QueryEvent e, Eq r, Show r) + => AcidStateInterface s -> s -> e -> r -> Property +restoreOldStateProperty i initial_state q expected_result = withTests 1 $ property $ test $ do + liftIO $ removeFile (statePath i ++ "/open.lock") `catch` (\ (_ :: IOException) -> return ()) + st <- liftIO $ openState i initial_state + r <- liftIO $ Acid.query st q + r === expected_result diff --git a/test/Data/Acid/TemplateHaskellSpec.hs b/test/Data/Acid/TemplateHaskellSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Acid/TemplateHaskellSpec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Acid.TemplateHaskellSpec where + +import Test.Hspec hiding (context) + +import Data.SafeCopy (SafeCopy) +import Data.Typeable (Typeable) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Control.Monad.Reader +import Control.Monad.State + +import Data.Acid +import Data.Acid.TemplateHaskell + +spec :: Spec +spec = do + let name = mkName "foo" + nameT = ConT name + upperName = mkName "Foo" + upperNameT = ConT upperName + + describe "makeEventInstance" $ do + it "works with monomorphic types" $ do + eventType <- runQ [t| Int -> Query Char () |] + makeEventInstance name eventType + `quoteShouldBe` + [d| instance QueryEvent $(return upperNameT) |] + + it "requires instances on polymorphic types" $ do + let a = VarT (mkName "a") + a' = return a + eventType <- runQ [t| (Ord $(a')) => $(a') -> Update Char $(a') |] + + makeEventInstance name eventType + `quoteShouldBe` + [d| instance (Ord $(a')) => UpdateEvent $(return upperNameT) + |] + + + describe "analyseType" $ do + it "can work with the Query type" $ do + typ <- runQ [t| Int -> Query String Char |] + + analyseType name typ + `shouldBe` TypeAnalysis + { tyvars = [] + , context = [] + , argumentTypes = [ConT ''Int] + , stateType = ConT ''String + , resultType = ConT ''Char + , isUpdate = False + } + + it "can work with the Update type" $ do + typ <- runQ [t| Int -> Update String Char |] + + analyseType name typ + `shouldBe` TypeAnalysis + { tyvars = [] + , context = [] + , argumentTypes = [ConT ''Int] + , stateType = ConT ''String + , resultType = ConT ''Char + , isUpdate = True + } + + it "can work with MonadReader" $ do + typ <- runQ [t| forall m. (MonadReader Int m) => Int -> m () |] + analyseType name typ + `shouldBe` TypeAnalysis + { tyvars = [] + , context = [] + , argumentTypes = [ConT ''Int] + , stateType = ConT ''Int + , resultType = TupleT 0 + , isUpdate = False + } + + it "can work with MonadState" $ do + typ <- runQ [t| forall m. (MonadState Int m) => Int -> m () |] + analyseType name typ + `shouldBe` TypeAnalysis + { tyvars = [] + , context = [] + , argumentTypes = [ConT ''Int] + , stateType = ConT ''Int + , resultType = TupleT 0 + , isUpdate = True + } + + it "can work with many type variables (note that eventCxts later rejects this)" $ do + let m = mkName "m" + typ <- runQ [t| (MonadReader Int $(varT m)) => Int -> Query Int ($(varT m) ()) |] + analyseType name typ + `shouldBe` TypeAnalysis + { tyvars = [] + , context = +#if MIN_VERSION_template_haskell(2,10,0) + [ ConT ''MonadReader + `AppT` ConT ''Int + `AppT` VarT m + ] +#else + [ ClassP ''MonadReader [ConT ''Int, VarT m] + ] +#endif + , argumentTypes = [ConT ''Int] + , stateType = ConT ''Int + , resultType = VarT m `AppT` TupleT 0 + , isUpdate = False + } + + describe "eventCxts" $ do + let binders = [] + stateType = ConT ''Char + it "rejects types with constrainted type variables unknown to state" $ do + let predicate eventType = + evaluate + . force + . map show + $ eventCxts stateType binders name eventType + eventType <- runQ [t| forall a. (Ord a) => Int -> Query Char a |] + + predicate eventType + `shouldThrow` + anyErrorCall + + it "accepts types with unconstrained type variables" $ do + eventType <- runQ [t| forall a. Int -> Query Char a |] + + eventCxts stateType binders name eventType + `shouldBe` + [] + let x = mkName "x" + + it "accepts constrained type variables in the state" $ do + let binders = [PlainTV (mkName "x")] + stateType = ConT ''Maybe `AppT` VarT x + eventType <- runQ [t| forall a. (Ord a) => Int -> Query (Maybe a) Int|] + + eventCxts stateType binders name eventType + `shouldBe` +#if MIN_VERSION_template_haskell(2,10,0) + [ConT ''Ord `AppT` VarT x] +#else + [ClassP ''Ord [VarT x]] +#endif + + it "can rename a polymorphic state" $ do + eventType <- runQ [t| forall r m. (MonadReader r m, Ord r) => Int -> m Char |] + eventCxts stateType binders name eventType + `shouldBe` +#if MIN_VERSION_template_haskell(2,10,0) + [ConT ''Ord `AppT` ConT ''Char] +#else + [ClassP ''Ord [ConT ''Char]] +#endif + + +quoteShouldBe :: (Eq a, Show a) => Q a -> Q [a] -> Expectation +quoteShouldBe qa qb = do + actual <- runQ qa + [expected] <- runQ qb + actual `shouldBe` expected diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/StateMachine.hs b/test/StateMachine.hs new file mode 100644 --- /dev/null +++ b/test/StateMachine.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Control.Monad (unless) +import Data.Acid.KeyValueStateMachine +import System.Exit (exitFailure) + +main :: IO () +main = do ok <- tests + unless ok exitFailure