diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,117 @@ +0.16.1.4 +========= + +_Andreas Abel, 2025-08-27_ + +- Drop support for GHC 7 +- Tested with GHC 8.2 - 9.14.1-alpha1 + +0.16.1.3 +======== + +_Andreas Abel, 2023-08-03_ + +- Support template-haskell-2.21 + ([#162](https://github.com/acid-state/acid-state/pull/162)) +- Tested with GHC 7.8 - 9.8.1-alpha1 + +0.16.1.2 +======== + +_Andreas Abel, 2023-04-06_ + +- Support unix-2.8 +- Tested with GHC 7.8 - 9.6.1 + +0.16.1.1 +======== + +_Andreas Abel, 2022-06-01_ + +- Adapt to changes in hedgehog-1.1 related to barbies +- Support mtl-2.3 +- Tested with GHC 7.8 - 9.2.3 + +0.16.1 +====== + +_David Fox, 2022-02-18_ + + - Support GHC-9.0.2, template-haskell 2.18 + +0.16.0.1 +======== + +_Jeremy Shaw, 2020-05-19_ + +0.16.0 +====== + +_Jeremy Shaw, 2019-11-14_ + + - support network-3.x and ghc-8.8.1 + - Fix tests + ([#131](https://github.com/acid-state/acid-state/pull/131)) + - Haddock documentation fixes + - Update build dependency constraints + +0.15.2 +====== + + - adds acid-state-repair recovery tool + ([#126](https://github.com/acid-state/acid-state/pull/16)) + - parameterize the underlying serialization library + ([#96](https://github.com/acid-state/acid-state/pull/96)) + - support safecopy-0.10, which supports GHC.Generics + ([#128](https://github.com/acid-state/acid-state/pull/128)) + +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 + ([#74](https://github.com/acid-state/acid-state/pull/74)) + +0.14.1 +====== + + - 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 + +0.14.0 +====== + + - fixes for cereal 0.5 while maintaining cereal 0.4 + compatibility. IMPORTANT: cereal 0.5 / safecopy 0.9 change the + serialization format of Float/Double. Migration should be performed + automatically on old data. However, you should be aware that once + you upgrade to safecopy 0.9 / cereal 0.5, your data will be + migrated and not readable by older versions of your application + which are compiled against safecopy 0.8 / cereal 0.4. + + - additional fixes for TH and kinded type variables + ([#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,54 +1,89 @@ +Cabal-version: 1.18 Name: acid-state -Version: 0.12.4 +Version: 0.16.1.4 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: http://acid-state.seize.it/ +Homepage: https://github.com/acid-state/acid-state License: PublicDomain Author: David Himmelstrup Maintainer: Lemmih -- Copyright: Category: Database Build-type: Simple -Cabal-version: >=1.10 + +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + -- cabal-3.12 cannot install dependency system-filepath any more in the GHC 8.0 environment + -- https://github.com/haskell/cabal/issues/10379 + -- GHC == 8.0.2 + +Extra-doc-files: + CHANGELOG.md Extra-source-files: - 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: False + Library - Exposed-Modules: Data.Acid, - Data.Acid.Local, Data.Acid.Memory, - Data.Acid.Memory.Pure, Data.Acid.Remote, + 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.TemplateHaskell + Data.Acid.Repair - Other-modules: Data.Acid.Log, Data.Acid.Archive, - Data.Acid.CRC, Paths_acid_state, - Data.Acid.TemplateHaskell, Data.Acid.Common, FileIO, - Data.Acid.Abstract, Data.Acid.Core + Other-modules: Paths_acid_state + FileIO - Build-depends: array, - base >= 4 && < 5, - bytestring >= 0.10, - cereal >= 0.4.1.0, - containers, - extensible-exceptions, - safecopy >= 0.6, - stm >= 2.4, - directory, - filepath, - mtl, - network, - template-haskell + -- Lower bounds taken from GHC 8.0 / LTS 7.0 + Build-depends: array >= 0.5.1.1 + , base >= 4.9 && < 5 + , bytestring >= 0.10.8.0 + , cereal >= 0.5.3.0 + , containers >= 0.5.7.1 + , safecopy >= 0.6 && < 0.11 + , stm >= 2.4 + , directory >= 1.2.6.2 + , filelock >= 0.1.0.1 + , filepath >= 1.4.1.0 + , mtl >= 2.2.1 + , network >= 2.6.3.1 && < 3.3 + , network-bsd + , template-haskell >= 2.11.0.0 && < 2.25 + , th-expand-syns >= 0.4.0.0 if os(windows) - Build-depends: Win32 + Build-depends: Win32 >= 2.3.1.1 else - Build-depends: unix + Build-depends: unix >= 2.7.2.0 Hs-Source-Dirs: src/ @@ -58,10 +93,98 @@ Hs-Source-Dirs: src-unix/ default-language: Haskell2010 - GHC-Options: -fwarn-unused-imports -fwarn-unused-binds + GHC-Options: -Wall + -Wcompat + -Wno-dodgy-imports + -Wno-missing-signatures + -Wno-name-shadowing + -Wno-unused-do-bind + -Wno-unused-matches +executable acid-state-repair + hs-source-dirs: repair + build-depends: acid-state + , base + , directory + main-is: Main.hs + default-language: Haskell2010 +test-suite specs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , acid-state + , deepseq + , hspec + , 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 + default-extensions: TypeOperators + + 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 @@ -69,37 +192,43 @@ benchmarks/loading main-is: Benchmark.hs + other-modules: + Benchmark.FileSystem + Benchmark.Model + Benchmark.Prelude build-depends: random, directory, system-fileio == 0.3.*, system-filepath, - criterion >= 0.8 && < 1.1, + -- perRunEnv was added in criterion-1.2.0.0 + criterion >= 1.2.0.0 && < 1.7, mtl, base, acid-state default-language: Haskell2010 default-extensions: - PatternGuards + -- keep this list alphabetically sorted! + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances GADTs - StandaloneDeriving MultiParamTypeClasses - ScopedTypeVariables - FlexibleInstances - TypeFamilies - TypeOperators - FlexibleContexts NoImplicitPrelude - EmptyDataDecls - DataKinds NoMonomorphismRestriction + OverloadedStrings + PatternGuards RankNTypes - ConstraintKinds - DefaultSignatures - TupleSections + ScopedTypeVariables + StandaloneDeriving TemplateHaskell - OverloadedStrings - DeriveDataTypeable + TupleSections + TypeFamilies + TypeOperators ghc-options: -O2 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/FileSystem.hs b/benchmarks/loading/Benchmark/FileSystem.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/FileSystem.hs @@ -0,0 +1,57 @@ +module Benchmark.FileSystem + ( + copy, + removeTreeIfExists, + exists, + getTemporaryDirectory, + module Filesystem, + module Filesystem.Path.CurrentOS + ) + where + +import Benchmark.Prelude hiding (stripPrefix, last) +import Filesystem.Path.CurrentOS +import Filesystem +import qualified System.Directory as Directory +import Debug.Trace +import qualified Data.List as List + + + +removeTreeIfExists :: FilePath -> IO () +removeTreeIfExists path = removeTree path `catch` \e -> case e of + _ | isDoesNotExistError e -> return () + | otherwise -> throwIO e + +exists :: FilePath -> IO Bool +exists path = do + isDir <- isDirectory path + isFile <- isFile path + return $ isDir || isFile + +getTemporaryDirectory :: IO FilePath +getTemporaryDirectory = + Directory.getTemporaryDirectory >>= return . decodeString + +copy :: FilePath -> FilePath -> IO () +copy from to = do + isDir <- isDirectory from + if isDir + then copyDirectory from to + else copyFile from to + +copyDirectory :: FilePath -> FilePath -> IO () +copyDirectory path path' = do + members <- listDirectory path + let members' = do + member <- members + let relative = + fromMaybe (error "Unexpectedly empty member path") $ + last member + return $ path' <> relative + sequence_ $ zipWith copy members members' + +last :: FilePath -> Maybe FilePath +last p = case splitDirectories p of + [] -> Nothing + l -> Just $ List.last l diff --git a/benchmarks/loading/Benchmark/Model.hs b/benchmarks/loading/Benchmark/Model.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/Model.hs @@ -0,0 +1,16 @@ +module Benchmark.Model where + +import Benchmark.Prelude hiding (insert) +import qualified Data.Acid as Acid + + + +type Model = [[[Int]]] + +insert :: [[Int]] -> Acid.Update Model () +insert = modify . (:) + +sumUp :: Acid.Query Model Int +sumUp = sum . map (sum . map sum) <$> ask + +Acid.makeAcidic ''Model ['insert, 'sumUp] diff --git a/benchmarks/loading/Benchmark/Prelude.hs b/benchmarks/loading/Benchmark/Prelude.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/Prelude.hs @@ -0,0 +1,42 @@ +module Benchmark.Prelude + ( + module Prelude, + module Control.Monad, + module Control.Applicative, + module Control.Arrow, + module Data.Monoid, + module Data.Foldable, + module Data.Traversable, + module Data.Maybe, + module Data.List, + module Data.Data, + + -- mtl + module Control.Monad.State, + module Control.Monad.Reader, + + -- exceptions + module Control.Exception, + module System.IO.Error, + ) + where + +import Prelude hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath) +import Control.Monad hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Applicative +import Control.Arrow +import Data.Monoid +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Data.List hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Data + +-- mtl +import Control.Monad.State hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.Reader hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) + +-- exceptions +import Control.Exception +import System.IO.Error + diff --git a/examples/CheckpointCutsEvent.hs b/examples/CheckpointCutsEvent.hs new file mode 100644 --- /dev/null +++ b/examples/CheckpointCutsEvent.hs @@ -0,0 +1,85 @@ +{- +This example is mostly just to test that this bug is fixed: + +https://github.com/acid-state/acid-state/issues/73 + +At the end of a run, the checkpoint file should contain a single +checkpoint and the event file should be empty. The old checkpoints and +events should be in the Archive directory. + +In the Acrhive directory, each checkpoint file should contain one +checkpoint, and each event file should contain 10 events. + +If you comment out the 'createArchive' line below, then the checkpoint +files should contain 10 checkpoints each. + +-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module CheckpointCutsEvent (main) where + +-- import Control.Concurrent +import Control.Applicative +import Control.Monad +import Control.Monad.State ( get, put ) +import Data.Acid +import Data.List ( sort ) +import Data.SafeCopy +import System.Directory +import System.Environment + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +newtype Counter = Counter { unCounter :: Integer } + deriving (Show) + +$(deriveSafeCopy 0 'base ''Counter) + +incCounter :: Update Counter Integer +incCounter = + do (Counter c) <- get + let c' = succ c + put (Counter c') + return c' + +$(makeAcidic ''Counter ['incCounter]) + + +main :: IO () +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 @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# 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 @@ -1,21 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module HelloWorld (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) + deriving (Show) $(deriveSafeCopy 0 'base ''HelloWorldState) diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -1,24 +1,22 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module HelloWorldNoTH (main) where import Data.Acid import Data.Acid.Advanced -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad +import Control.Monad.Reader (ask) +import Control.Monad.State (put) import Data.SafeCopy import System.Environment -import Data.Typeable - ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data HelloWorldState = HelloWorldState String - deriving (Show, Typeable) + deriving (Show) instance SafeCopy HelloWorldState where putCopy (HelloWorldState state) = contain $ safePut state @@ -56,8 +54,6 @@ data WriteState = WriteState String data QueryState = QueryState - -deriving instance Typeable WriteState instance SafeCopy WriteState where putCopy (WriteState st) = contain $ safePut st getCopy = contain $ liftM WriteState safeGet @@ -66,7 +62,6 @@ type MethodState WriteState = HelloWorldState instance UpdateEvent WriteState -deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState @@ -77,6 +72,6 @@ instance IsAcidic HelloWorldState where - acidEvents = [ UpdateEvent (\(WriteState newState) -> writeState newState) - , QueryEvent (\QueryState -> queryState) + acidEvents = [ UpdateEvent (\(WriteState newState) -> writeState newState) safeCopyMethodSerialiser + , QueryEvent (\QueryState -> queryState) safeCopyMethodSerialiser ] diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module KeyValue (main) where import Data.Acid import Data.Acid.Remote @@ -11,13 +10,10 @@ import Control.Monad.Reader import Control.Monad.State import Data.SafeCopy -import Network import System.Environment import System.Exit import System.IO -import Data.Typeable - import qualified Data.Map as Map ------------------------------------------------------ @@ -27,7 +23,6 @@ type Value = String data KeyValue = KeyValue !(Map.Map Key Value) - deriving (Typeable) $(deriveSafeCopy 0 'base ''KeyValue) diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -1,21 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module KeyValueNoTH (main) where import Data.Acid import Data.Acid.Advanced import Control.Applicative -import Control.Monad.Reader +import Control.Monad +import Control.Monad.Reader (ask) import qualified Control.Monad.State as State import Data.SafeCopy import System.Environment import System.IO -import Data.Typeable - import qualified Data.Map as Map ------------------------------------------------------ @@ -25,7 +23,6 @@ type Value = String data KeyValue = KeyValue !(Map.Map Key Value) - deriving (Typeable) instance SafeCopy KeyValue where putCopy (KeyValue state) = contain $ safePut state @@ -73,8 +70,6 @@ data InsertKey = InsertKey Key Value data LookupKey = LookupKey Key - -deriving instance Typeable InsertKey instance SafeCopy InsertKey where putCopy (InsertKey key value) = contain $ safePut key >> safePut value getCopy = contain $ InsertKey <$> safeGet <*> safeGet @@ -83,7 +78,6 @@ type MethodState InsertKey = KeyValue instance UpdateEvent InsertKey -deriving instance Typeable LookupKey instance SafeCopy LookupKey where putCopy (LookupKey key) = contain $ safePut key getCopy = contain $ LookupKey <$> safeGet @@ -93,6 +87,6 @@ instance QueryEvent LookupKey instance IsAcidic KeyValue where - acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value) - , QueryEvent (\(LookupKey key) -> lookupKey key) + acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value) safeCopyMethodSerialiser + , QueryEvent (\(LookupKey key) -> lookupKey key) safeCopyMethodSerialiser ] diff --git a/examples/MonadStateConstraint.hs b/examples/MonadStateConstraint.hs new file mode 100644 --- /dev/null +++ b/examples/MonadStateConstraint.hs @@ -0,0 +1,44 @@ +{-# 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 System.Environment + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data HelloWorldState = HelloWorldState String + deriving (Show) + +$(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,48 @@ +{-# LANGUAGE CPP #-} +{-# 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) + +instance (Ord k, Serialize k, SafeCopy k, Typeable 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 @@ -1,27 +1,23 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module Proxy (main) where import Data.Acid import Data.Acid.Advanced (scheduleUpdate) import Data.Acid.Remote -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) import Data.SafeCopy -import Network import System.Environment import System.IO -import Data.Typeable - ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data ProxyStressState = StressState !Int - deriving (Typeable) $(deriveSafeCopy 0 'base ''ProxyStressState) @@ -45,17 +41,19 @@ openLocal = openLocalState (StressState 0) openRemote :: String -> IO (AcidState ProxyStressState) -openRemote socket = openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket) +openRemote socket = openRemoteState skipAuthenticationPerform "localhost" port +port = 6303 + main :: IO () main = do args <- getArgs case args of ["server", socket] -> do acid <- openLocal - acidServer skipAuthenticationCheck (UnixSocket socket) acid + acidServer skipAuthenticationCheck port acid ["proxy", from, to] -> do acid <- openRemote from - acidServer skipAuthenticationCheck (UnixSocket to) acid + acidServer skipAuthenticationCheck port acid ["query", socket] -> do acid <- openRemote socket n <- query acid QueryState diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs --- a/examples/RemoteClient.hs +++ b/examples/RemoteClient.hs @@ -1,10 +1,10 @@ -module Main (main) where +module RemoteClient (main) where -import Control.Monad.Reader +import Control.Monad import Data.Acid import Data.Acid.Advanced import Data.Acid.Remote -import Network +import Network.Socket (SockAddr(..)) import RemoteCommon import System.Environment import System.IO @@ -13,7 +13,9 @@ -- This is how AcidState is used: open :: IO (AcidState StressState) -open = openRemoteState skipAuthenticationPerform "localhost" (PortNumber 8080) +open = openRemoteState skipAuthenticationPerform "localhost" 8080 +-- on Unixy systems we could use a Unix Domain Socket +-- open = openRemoteStateSockAddr skipAuthenticationPerform (SockAddrUnix "remote.socket") main :: IO () main = do args <- getArgs diff --git a/examples/RemoteCommon.hs b/examples/RemoteCommon.hs --- a/examples/RemoteCommon.hs +++ b/examples/RemoteCommon.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,12 +7,11 @@ import Control.Monad.State import Data.Acid import Data.SafeCopy -import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate -data StressState = StressState !Int deriving (Typeable) +data StressState = StressState !Int $(deriveSafeCopy 0 'base ''StressState) diff --git a/examples/RemoteServer.hs b/examples/RemoteServer.hs --- a/examples/RemoteServer.hs +++ b/examples/RemoteServer.hs @@ -1,11 +1,13 @@ -module Main where +module RemoteServer where import Control.Exception (bracket) import Data.Acid (closeAcidState, openLocalState) -import Data.Acid.Remote (acidServer, skipAuthenticationCheck) -import Network (PortID (..)) +import Data.Acid.Remote (acidServer, acidServerSockAddr, skipAuthenticationCheck) import RemoteCommon (StressState (..)) +import Network.Socket (SockAddr(..)) main :: IO () main = bracket (openLocalState $ StressState 0) - closeAcidState $ acidServer skipAuthenticationCheck (PortNumber 8080) + closeAcidState $ acidServer skipAuthenticationCheck 8080 +-- on Unixy systems we could use a Unix Domain Socket +-- closeAcidState $ acidServerSockAddr skipAuthenticationCheck (SockAddrUnix "remote.socket") diff --git a/examples/SlowCheckpoint.hs b/examples/SlowCheckpoint.hs --- a/examples/SlowCheckpoint.hs +++ b/examples/SlowCheckpoint.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# 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.State +import Control.Monad +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) 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 @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module StressTest (main) where import Data.Acid import Data.Acid.Advanced (groupUpdates) @@ -13,13 +12,10 @@ import System.Environment import System.IO -import Data.Typeable - ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int - deriving (Typeable) $(deriveSafeCopy 0 'base ''StressState) diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -1,25 +1,22 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module StressTestNoTH (main) where import Data.Acid import Data.Acid.Advanced -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) import Data.SafeCopy import System.Environment import System.IO -import Data.Typeable - ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int - deriving (Typeable) instance SafeCopy StressState where putCopy (StressState state) = contain $ safePut state @@ -65,7 +62,6 @@ data PokeState = PokeState data QueryState = QueryState -deriving instance Typeable PokeState instance SafeCopy PokeState where putCopy PokeState = contain $ return () getCopy = contain $ return PokeState @@ -74,7 +70,6 @@ type MethodState PokeState = StressState instance UpdateEvent PokeState -deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState @@ -84,6 +79,6 @@ instance QueryEvent QueryState instance IsAcidic StressState where - acidEvents = [ UpdateEvent (\PokeState -> pokeState) - , QueryEvent (\QueryState -> queryState) + acidEvents = [ UpdateEvent (\PokeState -> pokeState) safeCopyMethodSerialiser + , QueryEvent (\QueryState -> queryState) safeCopyMethodSerialiser ] 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.Monad.State +import Control.Exception +import Control.Monad 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 +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 @@ -1,18 +1,18 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} {-# 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 Control.Monad +import Control.Monad.State ( get, put ) import Data.SafeCopy +import System.Directory import System.Environment -import Data.Typeable - import Control.Exception import Prelude hiding (catch) @@ -20,7 +20,7 @@ -- The Haskell structure that we want to encapsulate data MyState = MyState Integer - deriving (Show, Typeable) + deriving (Show) $(deriveSafeCopy 0 'base ''MyState) @@ -28,7 +28,7 @@ -- The transaction we will execute over the state. failEvent :: Update MyState () -failEvent = fail "fail!" +failEvent = pure $ error "fail!" errorEvent :: Update MyState () errorEvent = error "error!" @@ -70,7 +70,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 @@ -1,16 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module RemoveEvent (main, test) where import Data.Acid -import Control.Monad.State +import Control.Monad import Data.SafeCopy +import System.Directory import System.Environment - -import Data.Typeable +import Data.List (isSuffixOf) import Control.Exception import Prelude hiding (catch) @@ -44,10 +43,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/repair/Main.hs b/repair/Main.hs new file mode 100644 --- /dev/null +++ b/repair/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Data.Acid.Repair +import System.Directory + +main :: IO () +main = do + directory <- getCurrentDirectory + repairEvents directory + repairCheckpoints directory diff --git a/src-unix/FileIO.hs b/src-unix/FileIO.hs --- a/src-unix/FileIO.hs +++ b/src-unix/FileIO.hs @@ -1,36 +1,30 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where -import System.Posix(Fd(Fd), - openFd, - fdWriteBuf, - fdToHandle, - closeFd, - OpenMode(WriteOnly,ReadWrite), - exclusive, trunc, - defaultFileFlags, - stdFileMode - ) + +module FileIO(FHandle,open,write,flush,close) where + +import System.Posix + ( Fd(Fd), openFd, fdWriteBuf, closeFd + , OpenMode(WriteOnly) +#if MIN_VERSION_unix(2,8,0) + , OpenFileFlags(creat) +#endif + , 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 open :: FilePath -> IO FHandle +#if !MIN_VERSION_unix(2,8,0) open filename = fmap FHandle $ openFd filename WriteOnly (Just stdFileMode) defaultFileFlags +#else +open filename = fmap FHandle $ openFd filename WriteOnly defaultFileFlags{ creat = Just stdFileMode } +#endif write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32 write (FHandle fd) data' length = fmap fromIntegral $ fdWriteBuf fd data' $ fromIntegral length @@ -43,111 +37,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.hs b/src/Data/Acid.hs --- a/src/Data/Acid.hs +++ b/src/Data/Acid.hs @@ -9,7 +9,7 @@ AcidState container using a transaction log on disk. To see how it all fits together, have a look at these example - . + . -} 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 @@ -18,38 +18,29 @@ import Data.ByteString.Lazy ( ByteString ) import Control.Monad ( void ) import Control.Monad.Trans ( MonadIO(liftIO) ) -#if __GLASGOW_HASKELL__ >= 707 import Data.Typeable ( Typeable, gcast, typeOf ) -#else -import Data.Typeable ( Typeable1, gcast1, typeOf1 ) -#endif data AnyState st where -#if __GLASGOW_HASKELL__ >= 707 AnyState :: Typeable sub_st => sub_st st -> AnyState st -#else - AnyState :: Typeable1 sub_st => sub_st st -> AnyState st -#endif -- Haddock doesn't get the types right on its own. {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) guarantees. - [@Atomicity@] State changes are all-or-nothing. This is what you'd expect of any state - variable in Haskell and AcidState doesn't change that. - + [@Atomicity@] State changes are all-or-nothing. This is what you'd expect + of any state variable in Haskell and AcidState doesn't + change that. [@Consistency@] No event or set of events will break your data invariants. - - [@Isolation@] Transactions cannot interfere with each other even when issued in parallel. - - [@Durability@] Successful transaction are guaranteed to survive unexpected system shutdowns - (both those caused by hardware and software). + [@Isolation@] Transactions cannot interfere with each other even when + issued in parallel. + [@Durability@] Successful transaction are guaranteed to survive unexpected + system shutdowns (both those caused by hardware and software). -} data AcidState st = AcidState { _scheduleUpdate :: forall event. (UpdateEvent event, EventState event ~ st) => event -> IO (MVar (EventResult event)) , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString) - , _query :: (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event) + , _query :: forall event. (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event) , queryCold :: Tagged ByteString -> IO ByteString , -- | Take a snapshot of the state and save it to disk. Creating checkpoints @@ -84,7 +75,7 @@ -- scheduleUpdate acid EventB -- @ scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event)) -scheduleUpdate = _scheduleUpdate -- Redirection to make Haddock happy. +scheduleUpdate acid = _scheduleUpdate acid -- Redirection to make Haddock happy. -- | Schedule multiple Update events and wait for them to be durable, but -- throw away their results. This is useful for importing existing @@ -111,20 +102,15 @@ -- | Issue a Query event and wait for its result. Events may be issued in parallel. query :: QueryEvent event => AcidState (EventState event) -> event -> IO (EventResult event) -query = _query -- Redirection to make Haddock happy. +query acid = _query acid -- Redirection to make Haddock happy. -- | Same as 'query' but lifted into any monad capable of doing IO. query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) query' acidState event = liftIO (query acidState event) -#if __GLASGOW_HASKELL__ >= 707 mkAnyState :: Typeable sub_st => sub_st st -> AnyState st -#else -mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st -#endif mkAnyState = AnyState -#if __GLASGOW_HASKELL__ >= 707 downcast :: (Typeable sub, Typeable st) => AcidState st -> sub st downcast AcidState{acidSubState = AnyState sub} = r @@ -133,15 +119,4 @@ Just (Just x) -> x _ -> error $ - "Data.Acid: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r) -#else -downcast :: Typeable1 sub => AcidState st -> sub st -downcast AcidState{acidSubState = AnyState sub} - = r - where - r = case gcast1 (Just sub) of - Just (Just x) -> x - _ -> - error $ - "Data.Acid: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) -#endif + "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r) diff --git a/src/Data/Acid/Advanced.hs b/src/Data/Acid/Advanced.hs --- a/src/Data/Acid/Advanced.hs +++ b/src/Data/Acid/Advanced.hs @@ -17,9 +17,14 @@ , Method(..) , IsAcidic(..) , Event(..) + + , safeCopySerialiser + , safeCopyMethodSerialiser + , defaultArchiver ) where import Data.Acid.Abstract +import Data.Acid.Archive import Data.Acid.Core import Data.Acid.Common 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 @@ -12,38 +12,86 @@ , readEntries , entriesToList , entriesToListNoFail + , Archiver(..) + , defaultArchiver ) where import Data.Acid.CRC import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy +import Data.ByteString.Builder import Data.Monoid -import Data.Serialize.Builder import Data.Serialize.Get hiding (Result (..)) import qualified Data.Serialize.Get as Serialize +-- | A bytestring that represents an entry in an archive. type Entry = Lazy.ByteString + +-- | Result of unpacking an archive. This is essentially a list of +-- 'Entry', but may terminate in 'Fail' if the archive format is +-- incorrect. data Entries = Done | Next Entry Entries | Fail String deriving (Show) +-- | Convert 'Entries' to a normal list, calling 'error' if there was +-- a failure in unpacking the archive. 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 +-- | Convert 'Entries' to a normal list, silently ignoring a failure +-- to unpack the archive and instead returning a truncated list. entriesToListNoFail :: Entries -> [Entry] entriesToListNoFail Done = [] entriesToListNoFail (Next entry next) = entry : entriesToListNoFail next entriesToListNoFail Fail{} = [] + +-- | Interface for the lowest level of the serialisation layer, which +-- handles packing lists of 'Entry' elements (essentially just +-- bytestrings) into a single bytestring, perhaps with error-checking. +-- +-- Any @'Archiver'{'archiveWrite', 'archiveRead'}@ must satisfy the +-- round-trip property: +-- +-- > forall xs . entriesToList (archiveRead (archiveWrite xs)) == xs +-- +-- Moreover, 'archiveWrite' must be a monoid homomorphism, so that +-- concatenating archives is equivalent to concatenating the lists of +-- entries that they represent: +-- +-- > archiveWrite [] == empty +-- > forall xs ys . archiveWrite xs <> archiveWrite ys == archiveWrite (xs ++ ys) +data Archiver + = Archiver + { archiveWrite :: [Entry] -> Lazy.ByteString + -- ^ Pack a list of entries into a bytestring. + + , archiveRead :: Lazy.ByteString -> Entries + -- ^ Unpack a bytestring as a list of 'Entries', including the + -- possibility of failure if the format is invalid. + } + +-- | Standard (and historically the only) implementation of the +-- 'Archiver' interface. This represents each entry in the following +-- format: +-- +-- > | entry length | crc16 | entry | +-- > | 8 bytes | 2 bytes | n bytes | +defaultArchiver :: Archiver +defaultArchiver = Archiver packEntries readEntries + + putEntry :: Entry -> Builder putEntry content - = putWord64le contentLength `mappend` - putWord16le contentHash `mappend` - fromLazyByteString content + = word64LE contentLength !<> + word16LE contentHash !<> + lazyByteString content where contentLength = fromIntegral $ Lazy.length content contentHash = crc16 content + a !<> b = let c = a <> b in c `seq` c putEntries :: [Entry] -> Builder putEntries = mconcat . map putEntry diff --git a/src/Data/Acid/Common.hs b/src/Data/Acid/Common.hs --- a/src/Data/Acid/Common.hs +++ b/src/Data/Acid/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} ----------------------------------------------------------------------------- -- | @@ -13,27 +14,15 @@ import Data.Acid.Core -import Control.Monad.State -import Control.Monad.Reader -import Data.ByteString.Lazy ( ByteString ) -import Data.SafeCopy -import Data.Serialize ( Get, runGet, runGetLazy ) -import Control.Applicative -import qualified Data.ByteString as Strict - --- Silly fix for bug in cereal-0.3.3.0's version of runGetLazy. -runGetLazyFix :: Get a - -> ByteString - -> Either String a -runGetLazyFix getter inp - = case runGet getter Strict.empty of - Left _msg -> runGetLazy getter inp - Right val -> Right val +import Control.Monad +import Control.Monad.State (MonadState, get, State) +import Control.Monad.Reader (MonadReader, Reader, runReader) -class (SafeCopy st) => IsAcidic st where +class IsAcidic st where acidEvents :: [Event st] -- ^ List of events capable of updating or querying the state. + -- | Context monad for Update events. newtype Update st a = Update { unUpdate :: State st a } deriving (Monad, Functor, MonadState st) @@ -72,9 +61,10 @@ -- QueryEvents are executed in a MonadReader context and obviously do not have -- to be serialized to disk. data Event st where - UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> Event (EventState ev) - QueryEvent :: QueryEvent ev => (ev -> Query (EventState ev) (EventResult ev)) -> Event (EventState ev) + UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev) + QueryEvent :: QueryEvent ev => (ev -> Query (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev) + -- | All UpdateEvents are also Methods. class Method ev => UpdateEvent ev -- | All QueryEvents are also Methods. @@ -84,8 +74,7 @@ eventsToMethods :: [Event st] -> [MethodContainer st] eventsToMethods = map worker where worker :: Event st -> MethodContainer st - worker (UpdateEvent fn) = Method (unUpdate . fn) - worker (QueryEvent fn) = Method (\ev -> do st <- get - return (runReader (unQuery $ fn ev) st) - ) - + worker (UpdateEvent fn ms) = Method (unUpdate . fn) ms + worker (QueryEvent fn ms) = Method (\ev -> do st <- get + return (runReader (unQuery $ fn ev) st) + ) ms 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 @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies, - FlexibleContexts, BangPatterns #-} +{-# LANGUAGE CPP, GADTs, TypeFamilies, + FlexibleContexts, BangPatterns, + DefaultSignatures, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Core @@ -28,11 +29,21 @@ , modifyCoreState_ , withCoreState , lookupHotMethod + , lookupHotMethodAndSerialiser , lookupColdMethod , runHotMethod , runColdMethod , MethodMap , mkMethodMap + + , Serialiser(..) + , safeCopySerialiser + , MethodSerialiser(..) + , safeCopyMethodSerialiser + , encodeMethod + , decodeMethod + , encodeResult + , decodeResult ) where import Control.Concurrent ( MVar, newMVar, withMVar @@ -40,19 +51,18 @@ import Control.Monad ( liftM ) import Control.Monad.State ( State, runState ) import qualified Data.Map as Map +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif import Data.ByteString.Lazy as Lazy ( ByteString ) import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) import Data.Serialize ( runPutLazy, runGetLazy ) import Data.SafeCopy ( SafeCopy, safeGet, safePut ) -import Data.Typeable ( Typeable, TypeRep, typeOf ) +import Data.Typeable ( Typeable, TypeRep, typeRepTyCon, typeOf, tyConModule ) import Unsafe.Coerce ( unsafeCoerce ) -#if MIN_VERSION_base(4,4,0) - -import Data.Typeable.Internal ( TypeRep (..), tyConModule ) - -- in base >= 4.4 the Show instance for TypeRep no longer provides a -- fully qualified name. But we have old data around that expects the -- FQN. So we will recreate the old naming system for newer versions @@ -60,30 +70,67 @@ -- end-of-life anyway. showQualifiedTypeRep :: TypeRep -> String showQualifiedTypeRep tr = tyConModule con ++ "." ++ show tr - where con = extractTypeRepCon tr -#if MIN_VERSION_base(4,8,0) - extractTypeRepCon (TypeRep _ c _ _) = c -#else - extractTypeRepCon (TypeRep _ c _) = c -#endif + where con = typeRepTyCon tr -#else +-- | Interface for (de)serialising values of type @a@. +-- +-- A @'Serialiser' { 'serialiserEncode', 'serialiserDecode' }@ must +-- satisfy the round-trip property: +-- +-- > forall x . serialiserDecode (serialiserEncode x) == Right x +data Serialiser a = + Serialiser + { serialiserEncode :: a -> Lazy.ByteString + -- ^ Serialise a value to a bytestring. + , serialiserDecode :: Lazy.ByteString -> Either String a + -- ^ Deserialise a value, generating a string error message + -- on failure. + } -showQualifiedTypeRep :: TypeRep -> String -showQualifiedTypeRep tr = show tr +-- | Default implementation of 'Serialiser' interface using 'SafeCopy'. +safeCopySerialiser :: SafeCopy a => Serialiser a +safeCopySerialiser = Serialiser (runPutLazy . safePut) (runGetLazy safeGet) -#endif +-- | Interface for (de)serialising a method, namely 'Serialiser's for +-- its arguments type and its result type. +data MethodSerialiser method = + MethodSerialiser + { methodSerialiser :: Serialiser method + , resultSerialiser :: Serialiser (MethodResult method) + } + +-- | Default implementation of 'MethodSerialiser' interface using 'SafeCopy'. +safeCopyMethodSerialiser :: (SafeCopy method, SafeCopy (MethodResult method)) => MethodSerialiser method +safeCopyMethodSerialiser = MethodSerialiser safeCopySerialiser safeCopySerialiser + +-- | Encode the arguments of a method using the given serialisation strategy. +encodeMethod :: MethodSerialiser method -> method -> ByteString +encodeMethod ms = serialiserEncode (methodSerialiser ms) + +-- | Decode the arguments of a method using the given serialisation strategy. +decodeMethod :: MethodSerialiser method -> ByteString -> Either String method +decodeMethod ms = serialiserDecode (methodSerialiser ms) + +-- | Encode the result of a method using the given serialisation strategy. +encodeResult :: MethodSerialiser method -> MethodResult method -> ByteString +encodeResult ms = serialiserEncode (resultSerialiser ms) + +-- | Decode the result of a method using the given serialisation strategy. +decodeResult :: MethodSerialiser method -> ByteString -> Either String (MethodResult method) +decodeResult ms = serialiserDecode (resultSerialiser ms) + + -- | The basic Method class. Each Method has an indexed result type -- and a unique tag. -class ( Typeable ev, SafeCopy ev - , Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => - Method ev where +class Method ev where type MethodResult ev type MethodState ev methodTag :: ev -> Tag + default methodTag :: Typeable ev => ev -> Tag methodTag ev = Lazy.pack (showQualifiedTypeRep (typeOf ev)) + -- | The control structure at the very center of acid-state. -- This module provides access to a mutable state through -- methods. No efforts towards durability, checkpointing or @@ -118,7 +165,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. @@ -155,18 +202,18 @@ lookupColdMethod core (storedMethodTag, methodContent) = case Map.lookup storedMethodTag (coreMethods core) of Nothing -> missingMethod storedMethodTag - Just (Method method) - -> liftM (runPutLazy . safePut) (method (lazyDecode methodContent)) + Just (Method method ms) + -> liftM (encodeResult ms) (method (lazyDecode ms methodContent)) -lazyDecode :: SafeCopy a => Lazy.ByteString -> a -lazyDecode inp - = case runGetLazy safeGet inp of - Left msg -> error msg +lazyDecode :: MethodSerialiser method -> Lazy.ByteString -> method +lazyDecode ms inp + = case decodeMethod ms inp of + 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?" @@ -180,21 +227,29 @@ -- | Find the state action that corresponds to an in-memory method. lookupHotMethod :: Method method => MethodMap (MethodState method) -> method -> State (MethodState method) (MethodResult method) -lookupHotMethod methodMap method +lookupHotMethod methodMap method = fst (lookupHotMethodAndSerialiser methodMap method) + +-- | Find the state action and serialiser that correspond to an +-- in-memory method. +lookupHotMethodAndSerialiser :: Method method => MethodMap (MethodState method) -> method + -> (State (MethodState method) (MethodResult method), MethodSerialiser method) +lookupHotMethodAndSerialiser methodMap method = case Map.lookup (methodTag method) methodMap of Nothing -> missingMethod (methodTag method) - Just (Method methodHandler) + Just (Method methodHandler ms) -> -- If the methodTag doesn't index the right methodHandler then we're in deep -- trouble. Luckly, it would take deliberate malevolence for that to happen. - unsafeCoerce methodHandler method + (unsafeCoerce methodHandler method, unsafeCoerce ms) -- | Method tags must be unique and are most commonly generated automatically. type Tag = Lazy.ByteString type Tagged a = (Tag, a) +type MethodBody method = method -> State (MethodState method) (MethodResult method) + -- | Method container structure that hides the exact type of the method. data MethodContainer st where - Method :: (Method method) => (method -> State (MethodState method) (MethodResult method)) -> MethodContainer (MethodState method) + Method :: (Method method) => MethodBody method -> MethodSerialiser method -> MethodContainer (MethodState method) -- | Collection of Methods indexed by a Tag. type MethodMap st = Map.Map Tag (MethodContainer st) @@ -206,8 +261,6 @@ where -- A little bit of ugliness is required to access the methodTags. methodType :: MethodContainer st -> Tag methodType m = case m of - Method fn -> let ev :: (ev -> State st res) -> ev - ev _ = undefined - in methodTag (ev fn) - - + Method fn _ -> let ev :: (ev -> State st res) -> ev + ev _ = undefined + in methodTag (ev fn) 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local @@ -15,33 +15,43 @@ module Data.Acid.Local ( openLocalState , openLocalStateFrom + , openLocalStateWithSerialiser , prepareLocalState , prepareLocalStateFrom + , prepareLocalStateWithSerialiser + , defaultStateDirectory + , scheduleLocalUpdate' + , scheduleLocalColdUpdate' , createCheckpointAndClose + , LocalState(..) + , Checkpoint(..) + , SerialisationLayer(..) + , defaultSerialisationLayer + , mkEventsLogKey + , mkCheckpointsLogKey ) where +import Data.Acid.Archive import Data.Acid.Log as Log import Data.Acid.Core import Data.Acid.Common 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) @@ -61,11 +71,14 @@ = LocalState { localCore :: Core st , localCopy :: IORef st , localEvents :: FileLog (Tagged ByteString) - , localCheckpoints :: FileLog Checkpoint - , localLock :: PrefixLock - } deriving (Typeable) + , localCheckpoints :: FileLog (Checkpoint st) + , localLock :: FileLock + } +newtype StateIsLocked = StateIsLocked FilePath deriving (Show) +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'. @@ -79,7 +92,7 @@ scheduleLocalUpdate :: UpdateEvent event => LocalState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleLocalUpdate acidState event = do mvar <- newEmptyMVar - let encoded = runPutLazy (safePut event) + let encoded = encodeMethod ms event -- It is important that we encode the event now so that we can catch -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs) @@ -93,8 +106,34 @@ putMVar mvar result return st' return mvar - where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event + where (hotMethod, ms) = lookupHotMethodAndSerialiser (coreMethods (localCore acidState)) event +-- | Same as scheduleLocalUpdate but does not immediately change the localCopy +-- and return the result mvar - returns an IO action to do this instead. Take +-- care to run actions of multiple Updates in the correct order as otherwise +-- Queries will operate on outdated state. +scheduleLocalUpdate' :: UpdateEvent event => LocalState (EventState event) -> event -> MVar (EventResult event) -> IO (IO ()) +scheduleLocalUpdate' acidState event mvar + = do + let encoded = encodeMethod ms event + + -- It is important that we encode the event now so that we can catch + -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs) + evaluate (Lazy.length encoded) + + act <- modifyCoreState (localCore acidState) $ \st -> + do let !(result, !st') = runState hotMethod st + -- Schedule the log entry. Very important that it happens when 'localCore' is locked + -- to ensure that events are logged in the same order that they are executed. + pushEntry (localEvents acidState) (methodTag event, encoded) $ return () + let action = do writeIORef (localCopy acidState) st' + putMVar mvar result + return (st', action) + -- this is the action to update state for queries and release the + -- result into the supplied mvar + return act + where (hotMethod, ms) = lookupHotMethodAndSerialiser (coreMethods (localCore acidState)) event + scheduleLocalColdUpdate :: LocalState st -> Tagged ByteString -> IO (MVar ByteString) scheduleLocalColdUpdate acidState event = do mvar <- newEmptyMVar @@ -108,6 +147,23 @@ return mvar where coldMethod = lookupColdMethod (localCore acidState) event +-- | Same as scheduleLocalColdUpdate but does not immediately change the +-- localCopy and return the result mvar - returns an IO action to do this +-- instead. Take care to run actions of multiple Updates in the correct order as +-- otherwise Queries will operate on outdated state. +scheduleLocalColdUpdate' :: LocalState st -> Tagged ByteString -> MVar ByteString -> IO (IO ()) +scheduleLocalColdUpdate' acidState event mvar + = do act <- modifyCoreState (localCore acidState) $ \st -> + do let !(result, !st') = runState coldMethod st + -- Schedule the log entry. Very important that it happens when 'localCore' is locked + -- to ensure that events are logged in the same order that they are executed. + pushEntry (localEvents acidState) event $ return () + let action = do writeIORef (localCopy acidState) st' + putMVar mvar result + return (st', action) + return act + where coldMethod = lookupColdMethod (localCore acidState) event + -- | Issue a Query event and wait for its result. Events may be issued in parallel. localQuery :: QueryEvent event => LocalState (EventState event) -> event -> IO (EventResult event) localQuery acidState event @@ -130,128 +186,218 @@ -- with this call. -- -- This call will not return until the operation has succeeded. -createLocalCheckpoint :: SafeCopy st => LocalState st -> IO () +createLocalCheckpoint :: IsAcidic st => LocalState st -> IO () createLocalCheckpoint acidState - = do mvar <- newEmptyMVar + = do cutFileLog (localEvents acidState) + mvar <- newEmptyMVar withCoreState (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) pushAction (localEvents acidState) $ - do let encoded = runPutLazy (safePut st) - pushEntry (localCheckpoints acidState) (Checkpoint eventId encoded) (putMVar mvar ()) + pushEntry (localCheckpoints acidState) (Checkpoint eventId st) (putMVar mvar ()) takeMVar mvar -- | Save a snapshot to disk and close the AcidState as a single atomic -- action. This is useful when you want to make sure that no events -- are saved to disk after a checkpoint. -createCheckpointAndClose :: (SafeCopy st, Typeable st) => AcidState st -> IO () +createCheckpointAndClose :: (IsAcidic st, Typeable st) => AcidState st -> IO () createCheckpointAndClose abstract_state = do mvar <- newEmptyMVar closeCore' (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) pushAction (localEvents acidState) $ - pushEntry (localCheckpoints acidState) (Checkpoint eventId (runPutLazy (safePut st))) (putMVar mvar ()) + pushEntry (localCheckpoints acidState) (Checkpoint eventId st) (putMVar mvar ()) takeMVar mvar closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) - releasePrefixLock (localLock acidState) + unlockFile (localLock acidState) where acidState = downcast abstract_state -data Checkpoint = Checkpoint EntryId ByteString +data Checkpoint s = Checkpoint EntryId s -instance SafeCopy Checkpoint where +-- | Previous versions of @acid-state@ had +-- +-- > data Checkpoint = Checkpoint EntryId ByteString +-- +-- where the 'ByteString' is the @safecopy@-serialization of the +-- original checkpoint data. Thus we give a 'SafeCopy' instance that +-- is backwards-compatible with this by making nested calls to +-- 'safePut' and 'safeGet'. +-- +-- Note that if the inner data cannot be deserialised, 'getCopy' will +-- not report an error immediately but will return a 'Checkpoint' +-- whose payload is an error thunk. This means consumers can skip +-- deserialising intermediate checkpoint data when they care only +-- about the last checkpoint in a file. However, they must be sure to +-- force the returned data promptly. +instance SafeCopy s => SafeCopy (Checkpoint s) where kind = primitive putCopy (Checkpoint eventEntryId content) = contain $ do safePut eventEntryId - safePut content - getCopy = contain $ Checkpoint <$> safeGet <*> safeGet + safePut (runPutLazy (safePut content)) + getCopy = contain $ Checkpoint <$> safeGet <*> (fromNested <$> safeGet) + where + fromNested b = case runGetLazy safeGet b of + Left msg -> checkpointRestoreError msg + Right v -> v + errorTypeName s = "Checkpoint " ++ errorTypeName s -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. -openLocalState :: (Typeable st, IsAcidic st) +openLocalState :: (Typeable st, IsAcidic st, SafeCopy st) => st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) openLocalState initialState = - openLocalStateFrom ("state" show (typeOf initialState)) initialState + openLocalStateFrom (defaultStateDirectory initialState) initialState -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. -- The most recent checkpoint will be loaded immediately but the AcidState will not be opened -- until the returned function is executed. -prepareLocalState :: (Typeable st, IsAcidic st) +prepareLocalState :: (Typeable st, IsAcidic st, SafeCopy st) => st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (IO (AcidState st)) prepareLocalState initialState = - prepareLocalStateFrom ("state" show (typeOf initialState)) initialState + prepareLocalStateFrom (defaultStateDirectory initialState) initialState +-- | Directory to load the state from unless otherwise specified, +-- namely \"state\/[typeOf state]\/\". +defaultStateDirectory :: Typeable st => st -> FilePath +defaultStateDirectory initialState = "state" show (typeOf initialState) -- | Create an AcidState given a log directory and an initial value. -- -- This will create or resume a log found in @directory@. -- Running two AcidState's from the same directory is an error -- but will not result in dataloss. -openLocalStateFrom :: (IsAcidic st) +openLocalStateFrom :: (IsAcidic st, SafeCopy st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) openLocalStateFrom directory initialState = - join $ resumeLocalStateFrom directory initialState False + openLocalStateWithSerialiser directory initialState defaultSerialisationLayer --- | Create an AcidState given an initial value. +-- | Create an AcidState given a log directory, an initial value and a serialisation layer. -- -- This will create or resume a log found in @directory@. +-- Running two AcidState's from the same directory is an error +-- but will not result in dataloss. +openLocalStateWithSerialiser :: (IsAcidic st) + => FilePath -- ^ Location of the checkpoint and transaction files. + -> st -- ^ Initial state value. This value is only used if no checkpoint is + -- found. + -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives. + -> IO (AcidState st) +openLocalStateWithSerialiser directory initialState serialisationLayer = + join $ resumeLocalStateFrom directory initialState False serialisationLayer + +-- | Create an AcidState given a log directory and an initial value. +-- +-- This will create or resume a log found in @directory@. -- The most recent checkpoint will be loaded immediately but the AcidState will not be opened -- until the returned function is executed. -prepareLocalStateFrom :: (IsAcidic st) +prepareLocalStateFrom :: (IsAcidic st, SafeCopy st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (IO (AcidState st)) prepareLocalStateFrom directory initialState = - resumeLocalStateFrom directory initialState True + prepareLocalStateWithSerialiser directory initialState defaultSerialisationLayer +-- | Create an AcidState given a log directory, an initial value and a serialisation layer. +-- +-- This will create or resume a log found in @directory@. +-- The most recent checkpoint will be loaded immediately but the AcidState will not be opened +-- until the returned function is executed. +prepareLocalStateWithSerialiser :: (IsAcidic st) + => FilePath -- ^ Location of the checkpoint and transaction files. + -> st -- ^ Initial state value. This value is only used if no checkpoint is + -- found. + -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives. + -> IO (IO (AcidState st)) +prepareLocalStateWithSerialiser directory initialState serialisationLayer = + resumeLocalStateFrom directory initialState True serialisationLayer +data SerialisationLayer st = + SerialisationLayer + { checkpointSerialiser :: Serialiser (Checkpoint st) + -- ^ Serialisation strategy for checkpoints. + -- + -- Use 'safeCopySerialiser' for the backwards-compatible + -- implementation using "Data.SafeCopy". + + , eventSerialiser :: Serialiser (Tagged ByteString) + -- ^ Serialisation strategy for events. + -- + -- Use 'safeCopySerialiser' for the backwards-compatible + -- implementation using "Data.SafeCopy". + + , archiver :: Archiver + -- ^ Serialisation strategy for archive log files. + -- + -- Use 'defaultArchiver' for the backwards-compatible + -- implementation using "Data.Serialize". + } + +-- | Standard (and historically the only) serialisation layer, using +-- 'safeCopySerialiser' and 'defaultArchiver'. +defaultSerialisationLayer :: SafeCopy st => SerialisationLayer st +defaultSerialisationLayer = SerialisationLayer safeCopySerialiser safeCopySerialiser defaultArchiver + +mkEventsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Tagged ByteString) +mkEventsLogKey directory serialisationLayer = + LogKey { logDirectory = directory + , logPrefix = "events" + , logSerialiser = eventSerialiser serialisationLayer + , logArchiver = archiver serialisationLayer } + +mkCheckpointsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Checkpoint object) +mkCheckpointsLogKey directory serialisationLayer = + LogKey { logDirectory = directory + , logPrefix = "checkpoints" + , logSerialiser = checkpointSerialiser serialisationLayer + , logArchiver = archiver serialisationLayer } + resumeLocalStateFrom :: (IsAcidic st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> Bool -- ^ True => load checkpoint before acquiring the lock. + -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives. -> IO (IO (AcidState st)) -resumeLocalStateFrom directory initialState delayLocking = +resumeLocalStateFrom directory initialState delayLocking serialisationLayer = case delayLocking of 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" - eventsLogKey = LogKey { logDirectory = directory - , logPrefix = "events" } - checkpointsLogKey = LogKey { logDirectory = directory - , logPrefix = "checkpoints" } + lockFile = directory "open.lock" + eventsLogKey = mkEventsLogKey directory serialisationLayer + checkpointsLogKey = mkCheckpointsLogKey directory serialisationLayer loadCheckpoint = do mbLastCheckpoint <- Log.newestEntry checkpointsLogKey case mbLastCheckpoint of Nothing -> return (0, initialState) - Just (Checkpoint eventCutOff content) -> do - case runGetLazy safeGet content of - Left msg -> checkpointRestoreError msg - Right val -> return (eventCutOff, val) + Just (Checkpoint eventCutOff !val) -> + -- N.B. We must be strict in val so that we force any + -- lurking deserialisation error immediately. + return (eventCutOff, val) replayEvents lock n st = do core <- mkCore (eventsToMethods acidEvents) st @@ -269,10 +415,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 () @@ -280,7 +432,7 @@ = do closeCore (localCore acidState) closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) - releasePrefixLock (localLock acidState) + unlockFile (localLock acidState) createLocalArchive :: LocalState st -> IO () createLocalArchive state @@ -313,4 +465,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 @@ -1,9 +1,10 @@ --- A log is a stack of entries that supports efficient pushing of --- new entries and fetching of old. It can be considered an --- extendible array of entries. +{-# LANGUAGE CPP #-} + +-- | A log is a stack of entries that supports efficient pushing of new entries +-- and fetching of old. It can be considered an extendible array of entries. -- module Data.Acid.Log - ( FileLog + ( FileLog(..) , LogKey(..) , EntryId , openFileLog @@ -18,9 +19,11 @@ , askCurrentEntryId , cutFileLog , archiveFileLog + , findLogFiles ) where -import Data.Acid.Archive as Archive +import Data.Acid.Archive (Archiver(..), Entries(..), entriesToList) +import Data.Acid.Core import System.Directory import System.FilePath import System.IO @@ -33,16 +36,16 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict import qualified Data.ByteString.Unsafe as Strict -import Data.List +import Data.List ( (\\), stripPrefix, sort ) import Data.Maybe -import qualified Data.Serialize.Get as Get -import qualified Data.Serialize.Put as Put -import Data.SafeCopy ( safePut, safeGet, SafeCopy ) - +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif import Text.Printf ( printf ) import Paths_acid_state ( version ) import Data.Version ( showVersion ) +import Control.Exception ( handle, IOException ) type EntryId = Int @@ -58,6 +61,8 @@ = LogKey { logDirectory :: FilePath , logPrefix :: String + , logSerialiser :: Serialiser object + , logArchiver :: Archiver } formatLogFile :: String -> EntryId -> String @@ -87,7 +92,8 @@ currentState <- newEmptyMVar queue <- newTVarIO ([], []) nextEntryRef <- newTVarIO 0 - tid2 <- forkIO $ fileWriter currentState queue + tid1 <- myThreadId + tid2 <- forkIO $ fileWriter (logArchiver identifier) currentState queue tid1 let fLog = FileLog { logIdentifier = identifier , logCurrent = currentState , logNextEntryId = nextEntryRef @@ -98,27 +104,29 @@ handle <- open (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) putMVar currentState handle else do let (lastFileEntryId, lastFilePath) = maximum logFiles - entries <- readEntities lastFilePath + entries <- readEntities (logArchiver identifier) lastFilePath let currentEntryId = lastFileEntryId + length entries atomically $ writeTVar nextEntryRef currentEntryId handle <- open (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) putMVar currentState handle return fLog -fileWriter :: MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> IO () -fileWriter currentState queue = forever $ do +fileWriter :: Archiver -> MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO () +fileWriter archiver currentState queue parentTid = forever $ do (entries, actions) <- atomically $ do (entries, actions) <- readTVar queue when (null entries && null actions) retry writeTVar queue ([], []) return (reverse entries, reverse actions) - withMVar currentState $ \fd -> do - let arch = Archive.packEntries entries - writeToDisk fd (repack arch) + handle (\e -> throwTo parentTid (e :: IOException)) $ + withMVar currentState $ \fd -> do + let arch = archiveWrite archiver entries + writeToDisk fd (repack arch) sequence_ actions yield --- Repack a lazy bytestring into larger blocks that can be efficiently written to disk. +-- | Repack a lazy bytestring into larger blocks that can be efficiently written +-- to disk. repack :: Lazy.ByteString -> [Strict.ByteString] repack = worker where @@ -145,16 +153,12 @@ 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 +readEntities :: Archiver -> FilePath -> IO [Lazy.ByteString] +readEntities archiver path = do archive <- Lazy.readFile path - return $ worker (Archive.readEntries archive) - where - worker Done = [] - worker (Next entry next) = entry : worker next - worker (Fail msg) = error msg + return $ entriesToList (archiveRead archiver archive) ensureLeastEntryId :: FileLog object -> EntryId -> IO () ensureLeastEntryId fLog youngestEntry = do @@ -164,10 +168,10 @@ cutFileLog fLog return () --- Read all durable entries younger than the given EntryId. --- Note that entries written during or after this call won't --- be included in the returned list. -readEntriesFrom :: SafeCopy object => FileLog object -> EntryId -> IO [object] +-- | Read all durable entries younger than the given 'EntryId'. Note that +-- entries written during or after this call won't be included in the returned +-- list. +readEntriesFrom :: FileLog object -> EntryId -> IO [object] readEntriesFrom fLog youngestEntry = do -- Cut the log so we can read written entries without interfering -- with the writing of new entries. @@ -183,15 +187,17 @@ -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back -- to lazy bytestrings once the bug has been fixed. archive <- liftM Lazy.fromChunks $ mapM (Strict.readFile . snd) relevant - let entries = entriesToList $ readEntries archive - return $ map decode' + let entries = entriesToList $ archiveRead (logArchiver identifier) archive + return $ map (decode' identifier) $ take (entryCap - youngestEntry) -- Take events under the eventCap. $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young. where rangeStart (firstEntryId, _path) = firstEntryId + identifier = logIdentifier fLog --- Obliterate log entries younger than or equal to the EventId. Very unsafe, can't be undone -rollbackTo :: SafeCopy object => LogKey object -> EntryId -> IO () +-- | Obliterate log entries younger than or equal to the 'EntryId'. Very unsafe, +-- can't be undone +rollbackTo :: LogKey object -> EntryId -> IO () rollbackTo identifier youngestEntry = do logFiles <- findLogFiles identifier let sorted = sort logFiles @@ -201,24 +207,26 @@ | otherwise = do archive <- Strict.readFile path pathHandle <- openFile path WriteMode - let entries = entriesToList $ readEntries (Lazy.fromChunks [archive]) + let entries = entriesToList $ archiveRead (logArchiver identifier) (Lazy.fromChunks [archive]) entriesToKeep = take (youngestEntry - rangeStart + 1) entries - lengthToKeep = Lazy.length (packEntries entriesToKeep) + lengthToKeep = Lazy.length (archiveWrite (logArchiver identifier) entriesToKeep) hSetFileSize pathHandle (fromIntegral lengthToKeep) hClose pathHandle loop (reverse sorted) --- Obliterate log entries as long as the filterFn returns True. -rollbackWhile :: SafeCopy object => LogKey object -> (object -> Bool) -> IO () +-- | Obliterate log entries as long as the filter function returns @True@. +rollbackWhile :: LogKey object + -> (object -> Bool) -- ^ the filter function + -> IO () rollbackWhile identifier filterFn = do logFiles <- findLogFiles identifier let sorted = sort logFiles loop [] = return () loop ((_rangeStart, path) : xs) = do archive <- Strict.readFile path - let entries = entriesToList $ readEntries (Lazy.fromChunks [archive]) - entriesToSkip = takeWhile (filterFn . decode') $ reverse entries - skip_size = Lazy.length (packEntries entriesToSkip) + let entries = entriesToList $ archiveRead (logArchiver identifier) (Lazy.fromChunks [archive]) + entriesToSkip = takeWhile (filterFn . decode' identifier) $ reverse entries + skip_size = Lazy.length (archiveWrite (logArchiver identifier) entriesToSkip) orig_size = fromIntegral $ Strict.length archive new_size = orig_size - skip_size if new_size == 0 @@ -228,9 +236,15 @@ hClose pathHandle loop (reverse sorted) --- Filter out log files that are outside the min_entry/max_entry range. --- minEntryId <= x < maxEntryId -filterLogFiles :: Maybe EntryId -> Maybe EntryId -> [(EntryId, FilePath)] -> [(EntryId, FilePath)] +-- | Filter out log files that are outside the min_entry/max_entry range. +-- +-- minEntryId <= x < maxEntryId +filterLogFiles + :: Maybe EntryId + -- ^ minEntryId + -> Maybe EntryId + -- ^ maxEntryId + -> [(EntryId, FilePath)] -> [(EntryId, FilePath)] filterLogFiles minEntryIdMb maxEntryIdMb logFiles = worker logFiles where worker [] = [] @@ -252,14 +266,14 @@ Just maxEntryId -> (< maxEntryId) rangeStart (firstEntryId, _path) = firstEntryId --- Move all log files that do not contain entries equal or higher than the given entryId --- into an Archive/ directory. +-- | Move all log files that do not contain entries equal or higher than the +-- given entryId into an @Archive/@ directory. archiveFileLog :: FileLog object -> EntryId -> IO () archiveFileLog fLog entryId = do logFiles <- findLogFiles (logIdentifier fLog) let sorted = sort logFiles - relevant = filterLogFiles Nothing (Just entryId) sorted \\ - filterLogFiles (Just (entryId+1)) (Just entryId) sorted + relevant = filterLogFiles Nothing (Just entryId) sorted + \\ filterLogFiles (Just entryId) (Just (entryId+1)) sorted createDirectoryIfMissing True archiveDir forM_ relevant $ \(_startEntry, logFilePath) -> @@ -286,12 +300,15 @@ where key = logIdentifier fLog --- Finds the newest entry in the log. Doesn't work on open logs. --- Do not use after the log has been opened. --- Implementation: Search the newest log files first. Once a file --- containing at least one valid entry is found, --- return the last entry in that file. -newestEntry :: SafeCopy object => LogKey object -> IO (Maybe object) +-- | Finds the newest entry in the log. Doesn't work on open logs. Do not use +-- after the log has been opened. +-- +-- Implementation: +-- +-- - Search the newest log files first. +-- - Once a file containing at least one valid entry is found, return the last +-- entry in that file. +newestEntry :: LogKey object -> IO (Maybe object) newestEntry identifier = do logFiles <- findLogFiles identifier let sorted = reverse $ sort logFiles @@ -304,27 +321,28 @@ -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back -- to lazy bytestrings once the bug has been fixed. archive <- fmap Lazy.fromStrict $ Strict.readFile logFile - case Archive.readEntries archive of + case archiveRead (logArchiver identifier) archive of Done -> worker logFiles - Next entry next -> return $ Just (decode' (lastEntry entry next)) - Fail msg -> error msg + Next entry next -> return $ Just (decode' identifier (lastEntry entry next)) + 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 --- The given IO action runs once the object is durable. The IO action --- blocks the serialization of events so it should be swift. -pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO () +-- | Schedule a new log entry. This call does not block. The given IO action +-- runs once the object is durable. The IO action blocks the serialization of +-- events so it should be swift. +pushEntry :: 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 - encoded = Lazy.fromChunks [ Strict.copy $ Put.runPut (safePut object) ] + encoded = Lazy.fromChunks [ Strict.copy $ Lazy.toStrict $ + serialiserEncode (logSerialiser (logIdentifier fLog)) object ] --- The given IO action is executed once all previous entries are durable. +-- | The given IO action is executed once all previous entries are durable. pushAction :: FileLog object -> IO () -> IO () pushAction fLog finally = atomically $ do (entries, actions) <- readTVar (logQueue fLog) @@ -336,8 +354,8 @@ -- FIXME: Check for unused input. -decode' :: SafeCopy object => Lazy.ByteString -> object -decode' inp = - case Get.runGetLazy safeGet inp of - Left msg -> error msg +decode' :: LogKey object -> Lazy.ByteString -> object +decode' s inp = + case serialiserDecode (logSerialiser s) inp of + Left msg -> error $ "Data.Acid.Log: " <> msg Right val -> val diff --git a/src/Data/Acid/Memory.hs b/src/Data/Acid/Memory.hs --- a/src/Data/Acid/Memory.hs +++ b/src/Data/Acid/Memory.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory @@ -8,6 +8,7 @@ -- Portability : non-portable (uses GHC extensions) -- -- AcidState container without a transaction log. Mostly used for testing. +-- Supports Atomicity, Consistency and Isolation, but not Durability. -- module Data.Acid.Memory @@ -21,12 +22,9 @@ import Control.Concurrent ( newEmptyMVar, putMVar, MVar ) import Control.Monad.State ( runState ) import Data.ByteString.Lazy ( ByteString ) -import Data.Typeable ( Typeable ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Data.SafeCopy ( SafeCopy(..) ) - {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) guarantees. @@ -43,9 +41,10 @@ data MemoryState st = MemoryState { localCore :: Core st , localCopy :: IORef st - } deriving (Typeable) + } --- | Create an AcidState given an initial value. +-- | Create an 'AcidState' given an initial value. The state is kept only in +-- memory, so it is not durable. openMemoryState :: (IsAcidic st) => st -- ^ Initial state value. -> IO (AcidState st) @@ -55,8 +54,7 @@ return $ toAcidState MemoryState { localCore = core, localCopy = ref } --- | 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. +-- | Issue an Update event and return immediately. The order of events is honored. -- The behavior in case of exceptions is exactly the same as for 'update'. -- -- If EventA is scheduled before EventB, EventA /will/ be executed before EventB: @@ -103,12 +101,12 @@ where coldMethod = lookupColdMethod (localCore acidState) event -- | This is a nop with the memory backend. -createMemoryCheckpoint :: SafeCopy st => MemoryState st -> IO () +createMemoryCheckpoint :: MemoryState st -> IO () createMemoryCheckpoint acidState = return () -- | This is a nop with the memory backend. -createMemoryArchive :: SafeCopy st => MemoryState st -> IO () +createMemoryArchive :: MemoryState st -> IO () createMemoryArchive acidState = return () diff --git a/src/Data/Acid/Memory/Pure.hs b/src/Data/Acid/Memory/Pure.hs --- a/src/Data/Acid/Memory/Pure.hs +++ b/src/Data/Acid/Memory/Pure.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory.Pure @@ -7,8 +7,13 @@ -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- --- AcidState container without a transaction log. Mostly used for testing. +-- AcidState container without a transaction log. Mostly used for testing. -- +-- This module consists of internal implementation details for +-- "Data.Acid.Memory". You should not normally need to import it. Call +-- 'Data.Acid.Memory.openMemoryState' and thereafter use the API from +-- "Data.Acid" instead. +-- module Data.Acid.Memory.Pure ( IsAcidic(..) @@ -35,18 +40,8 @@ import Control.Monad.State import Control.Monad.Reader -{-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) - guarantees. - - [@Atomicity@] State changes are all-or-nothing. This is what you'd expect of any state - variable in Haskell and AcidState doesn't change that. - - [@Consistency@] No event or set of events will break your data invariants. - - [@Isolation@] Transactions cannot interfere with each other even when issued in parallel. - - [@Durability@] Successful transaction are guaranteed to survive system failure (both - hardware and software). +{-| Pure state value used internally. This is not the same as + 'Data.Acid.AcidState' from "Data.Acid". -} data AcidState st = AcidState { localMethods :: MethodMap st @@ -80,10 +75,10 @@ -- | Create an AcidState given an initial value. openAcidState :: IsAcidic st - => st -- ^ Initial state value. + => st -- ^ Initial state value. -> AcidState st openAcidState initialState - = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) + = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) , localState = initialState } -- | Execute the 'Update' monad in a pure environment. 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE CPP, RankNTypes, RecordWildCards, ScopedTypeVariables #-} ----------------------------------------------------------------------------- {- | Module : Data.Acid.Remote @@ -25,7 +25,7 @@ 'openRemoteState' and 'acidServer' communicate over an unencrypted socket. If you need an encrypted connection, see @acid-state-tls@. -On Unix®-like systems you can use 'UnixSocket' to create a socket file for +On Unix®-like systems you can use 'SockAddrUnix' to create a socket file for local communication between the client and server. Access can be controlled by setting the permissions of the parent directory containing the socket file. @@ -33,7 +33,7 @@ It is also possible to perform some simple authentication using 'sharedSecretCheck' and 'sharedSecretPerform'. Keep in mind that secrets will be sent in plain-text if you do not use -@acid-state-tls@. If you are using a 'UnixSocket' additional +@acid-state-tls@. If you are using a 'SockAddrUnix' additional authentication may not be required, so you can use 'skipAuthenticationCheck' and 'skipAuthenticationPerform'. @@ -78,8 +78,10 @@ ( -- * Server/Client acidServer + , acidServerSockAddr , acidServer' , openRemoteState + , openRemoteStateSockAddr -- * Authentication , skipAuthenticationCheck , skipAuthenticationPerform @@ -99,7 +101,7 @@ import Control.Concurrent.STM.TQueue import Control.Exception ( AsyncException(ThreadKilled) , Exception(fromException), IOException, Handler(..) - , SomeException, catch, catches, throw ) + , SomeException, catch, catches, throw, bracketOnError ) import Control.Exception ( throwIO, finally ) import Control.Monad ( forever, liftM, join, when ) import Control.Concurrent ( ThreadId, forkIO, threadDelay, killThread, myThreadId ) @@ -108,20 +110,21 @@ import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif import qualified Data.ByteString as Strict import Data.ByteString.Char8 ( pack ) import qualified Data.ByteString.Lazy as Lazy import Data.IORef ( newIORef, readIORef, writeIORef ) import Data.Serialize -import Data.SafeCopy ( SafeCopy, safeGet, safePut ) import Data.Set ( Set, member ) -import Data.Typeable ( Typeable ) import GHC.IO.Exception ( IOErrorType(..) ) -import Network ( HostName, PortID(..), connectTo, listenOn, withSocketsDo ) -import Network.Socket ( Socket, accept, sClose ) -import Network.Socket.ByteString ( recv, sendAll ) +import Network.BSD ( PortNumber, getProtocolNumber, getHostByName, hostAddress ) +import Network.Socket +import Network.Socket.ByteString as NSB ( recv, sendAll ) import System.Directory ( removeFile ) -import System.IO ( Handle, hPrint, hFlush, hClose, stderr ) +import System.IO ( Handle, hPrint, hFlush, hClose, stderr, IOMode(..) ) import System.IO.Error ( ioeGetErrorType, isFullError, isDoesNotExistError ) debugStrLn :: String -> IO () @@ -143,7 +146,7 @@ | AcidStateClosed | SerializeError String | AuthenticationError String - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception AcidRemoteException -- | create a 'CommChannel' from a 'Handle'. The 'Handle' should be @@ -163,8 +166,8 @@ socketToCommChannel :: Socket -> CommChannel socketToCommChannel socket = CommChannel { ccPut = sendAll socket - , ccGetSome = recv socket - , ccClose = sClose socket + , ccGetSome = NSB.recv socket + , ccClose = close socket } {- | skip server-side authentication checking entirely. -} @@ -207,40 +210,73 @@ then return () else throwIO (AuthenticationError "shared secret authentication failed.") -{- | Accept connections on @port@ and handle requests using the given 'AcidState'. +{- | Accept connections on @sockAddr@ and handle requests using the given 'AcidState'. This call doesn't return. - On Unix®-like systems you can use 'UnixSocket' to communicate - using a socket file. To control access, you can set the permissions of - the parent directory which contains the socket file. - - see also: 'openRemoteState' and 'sharedSecretCheck'. + see also: 'acidServer', 'openRemoteState' and 'sharedSecretCheck'. -} -acidServer :: SafeCopy st => - (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' - -> PortID -- ^ Port to listen on +acidServerSockAddr :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' + -> SockAddr -- ^ SockAddr to listen on -> AcidState st -- ^ state to serve -> IO () -acidServer checkAuth port acidState - = withSocketsDo $ - do listenSocket <- listenOn port +acidServerSockAddr checkAuth sockAddr acidState + = do listenSocket <- listenOn sockAddr (acidServer' checkAuth listenSocket acidState) `finally` (cleanup listenSocket) where cleanup socket = - do sClose socket - case port of + do close socket #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) - UnixSocket path -> removeFile path + case sockAddr of + (SockAddrUnix path) -> removeFile path + _ -> pure () #endif - _ -> return () + +{- | Accept connections on @port@ and handle requests using the given 'AcidState'. + This call doesn't return. + + see also: 'acidServerSockAddr', 'openRemoteState' and 'sharedSecretCheck'. + -} +acidServer :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' + -> PortNumber -- ^ Port to listen on + -> AcidState st -- ^ state to serve + -> IO () +acidServer checkAuth port acidState + = acidServerSockAddr checkAuth (SockAddrInet port 0) acidState + +listenOn :: SockAddr -> IO Socket +listenOn sockAddr = do +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + proto <- case sockAddr of + (SockAddrUnix {}) -> pure 0 + _ -> getProtocolNumber "tcp" +#else + proto <- getProtocolNumber "tcp" +#endif + bracketOnError + (socket af Stream proto) + close + (\sock -> do + setSocketOption sock ReuseAddr 1 + bind sock sockAddr + listen sock maxListenQueue + return sock + ) + + where + af = case sockAddr of + (SockAddrInet {}) -> AF_INET + (SockAddrInet6 {}) -> AF_INET6 +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + (SockAddrUnix {}) -> AF_UNIX +#endif + {- | Works the same way as 'acidServer', but uses pre-binded socket @listenSocket@. Can be useful when fine-tuning of socket binding parameters is needed (for example, listening on a particular network interface, IPv4/IPv6 options). -} -acidServer' :: SafeCopy st => - (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' +acidServer' :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' -> Socket -- ^ binded socket to accept connections from -> AcidState st -- ^ state to serve -> IO () @@ -291,7 +327,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,14 +341,13 @@ 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 This function is generally only needed if you are adding a new communication channel. -} -process :: SafeCopy st => - CommChannel -- ^ a connected, authenticated communication channel +process :: CommChannel -- ^ a connected, authenticated communication channel -> AcidState st -- ^ state to share -> IO () process CommChannel{..} acidState @@ -341,23 +376,53 @@ writeChan chan (return Acknowledgement) data RemoteState st = RemoteState (Command -> IO (MVar Response)) (IO ()) - deriving (Typeable) {- | Connect to an acid-state server which is sharing an 'AcidState'. -} openRemoteState :: IsAcidic st => (CommChannel -> IO ()) -- ^ authentication function, see 'sharedSecretPerform' - -> HostName -- ^ remote host to connect to (ignored when 'PortID' is 'UnixSocket') - -> PortID -- ^ remote port to connect to + -> HostName -- ^ remote host to connect to + -> PortNumber -- ^ remote port to connect to -> IO (AcidState st) -openRemoteState performAuthorization host port +openRemoteState performAuthorization host port = + do he <- getHostByName host + openRemoteStateSockAddr performAuthorization (SockAddrInet port (hostAddress he)) + +{- | Connect to an acid-state server which is sharing an 'AcidState'. -} +openRemoteStateSockAddr :: IsAcidic st => + (CommChannel -> IO ()) -- ^ authentication function, see 'sharedSecretPerform' + -> SockAddr -- ^ remote SockAddr to connect to + -> IO (AcidState st) +openRemoteStateSockAddr performAuthorization sockAddr = withSocketsDo $ do processRemoteState reconnect where + af :: Family + af = case sockAddr of + (SockAddrInet {}) -> AF_INET + (SockAddrInet6 {}) -> AF_INET6 +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + (SockAddrUnix {}) -> AF_UNIX +#endif + -- | reconnect reconnect :: IO CommChannel reconnect = (do debugStrLn "Reconnecting." - handle <- connectTo host port +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + proto <- case sockAddr of + (SockAddrUnix {}) -> pure 0 + _ -> getProtocolNumber "tcp" +#else + proto <- getProtocolNumber "tcp" +#endif + handle <- bracketOnError + (socket af Stream proto) + close -- only done if there's an error + (\sock -> do + connect sock sockAddr + socketToHandle sock ReadWriteMode + ) + let cc = handleToCommChannel handle performAuthorization cc debugStrLn "Reconnected." @@ -429,7 +494,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) @@ -482,13 +547,15 @@ return (toAcidState $ RemoteState actor (shutdown actorTID)) -remoteQuery :: QueryEvent event => RemoteState (EventState event) -> event -> IO (EventResult event) -remoteQuery acidState event - = do let encoded = runPutLazy (safePut event) +remoteQuery :: QueryEvent event => RemoteState (EventState event) -> MethodMap (EventState event) -> event -> IO (EventResult event) +remoteQuery acidState mmap event + = do let encoded = encodeMethod ms event resp <- remoteQueryCold acidState (methodTag event, encoded) - return (case runGetLazyFix safeGet resp of - Left msg -> error msg + return (case decodeResult ms resp of + Left msg -> error $ "Data.Acid.Remote: " <> msg Right result -> result) + where + (_, ms) = lookupHotMethodAndSerialiser mmap event remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString remoteQueryCold rs@(RemoteState fn _shutdown) event @@ -497,18 +564,20 @@ (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 - = do let encoded = runPutLazy (safePut event) +scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> MethodMap (EventState event) -> event -> IO (MVar (EventResult event)) +scheduleRemoteUpdate (RemoteState fn _shutdown) mmap event + = do let encoded = encodeMethod ms event parsed <- newEmptyMVar respRef <- fn (RunUpdate (methodTag event, encoded)) forkIO $ do Result resp <- takeMVar respRef - putMVar parsed (case runGetLazyFix safeGet resp of - Left msg -> error msg + putMVar parsed (case decodeResult ms resp of + Left msg -> error $ "Data.Acid.Remote: " <> msg Right result -> result) return parsed + where + (_, ms) = lookupHotMethodAndSerialiser mmap event scheduleRemoteColdUpdate :: RemoteState st -> Tagged Lazy.ByteString -> IO (MVar Lazy.ByteString) scheduleRemoteColdUpdate (RemoteState fn _shutdown) event @@ -531,15 +600,17 @@ = do Acknowledgement <- takeMVar =<< fn CreateArchive return () -toAcidState :: IsAcidic st => RemoteState st -> AcidState st +toAcidState :: forall st . IsAcidic st => RemoteState st -> AcidState st toAcidState remote - = AcidState { _scheduleUpdate = scheduleRemoteUpdate remote + = AcidState { _scheduleUpdate = scheduleRemoteUpdate remote mmap , scheduleColdUpdate = scheduleRemoteColdUpdate remote - , _query = remoteQuery remote + , _query = remoteQuery remote mmap , queryCold = remoteQueryCold remote , createCheckpoint = createRemoteCheckpoint remote , createArchive = createRemoteArchive remote , closeAcidState = closeRemoteState remote , acidSubState = mkAnyState remote } - + where + mmap :: MethodMap st + mmap = mkMethodMap (eventsToMethods acidEvents) diff --git a/src/Data/Acid/Repair.hs b/src/Data/Acid/Repair.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Repair.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE LambdaCase #-} + +module Data.Acid.Repair + ( repairFile + , repairEvents + , repairCheckpoints + ) where + +import qualified Data.Acid.Archive as Archive +import Data.Acid.Local (mkEventsLogKey, mkCheckpointsLogKey) +import Data.Acid.Log (LogKey) +import qualified Data.Acid.Log as Log +import qualified Data.ByteString.Lazy as Lazy +import Data.List (sort) +import System.Directory +import System.FilePath.Posix +import System.IO (hClose, openTempFile) + +repairEntries :: Lazy.ByteString -> Lazy.ByteString +repairEntries = + Archive.packEntries . Archive.entriesToListNoFail . Archive.readEntries + +-- | @'repairFile' path@ will truncate the entries in @file@ until there are +-- only valid entries (if a corrupted entry is found, then the rest of the file +-- is truncated). +-- +-- The old file will be copied to @path.bak@ (or @path.bak.1@, etc… if the file +-- already exists). +-- +-- 'repairFile' tries very hard to avoid leaving files in an inconsistent state: +-- the truncated file is written in a temporary file, which is then moved into +-- place, similarly copies are performed with moves instead. Still this is not +-- fully atomic: there are two consecutive moves, so 'repairFile' may, in case +-- of crash, yield a state where the @path.bak@ file is there but no @path@ is +-- there anymore, this would require manual intervention. +repairFile :: FilePath -> IO () +repairFile fp = do + broken <- Lazy.readFile fp + let repaired = repairEntries broken + (tmp, temph) <- openTempFile (takeDirectory fp) (takeFileName fp) + -- We use `openTempFile`, here, rather than `findNext` because we want to + -- make extra-sure that we are not overriding an important file. + hClose temph + -- Closing immediately to benefit from the bracket guarantees of + -- `writeFile`. A more elegant solution would be to use a `withTempFile` + -- function, such as that from package `temporary`. + Lazy.writeFile tmp repaired + dropFile fp + renameFile tmp fp + +-- Repairs the files corresponding to the given 'LogKey'. It implements the +-- logic described in 'repairEvents'. +repairLogs :: LogKey object -> IO () +repairLogs identifier = do + logFiles <- Log.findLogFiles identifier + let sorted = sort logFiles + (_eventIds, files) = unzip sorted + broken_files <- mapM needsRepair files + -- We're doing a second deserialisation of the files here (see + -- 'needsRepair'). It would be better, computation-time-wise to make as + -- single pass and let `repairEntries`, for instance, return whether a fix + -- is needed. But it's a lot of complication and requires loading the + -- entire base in memory, rather than streaming files one-by-one. So it's + -- better to just do the second pass. + repair $ map snd $ dropWhile (\(b,_) -> not b) $ zip broken_files files + where + repair [] = return () + repair (file:rest) = do + mapM_ dropFile (reverse rest) + repairFile file + +-- Moves (atomically) a file `path` to `path.bak` (or `path.bak.1`, etc… if the +-- file already exists). +dropFile :: FilePath -> IO () +dropFile fp = do + bak <- findNext (fp ++ ".bak") + -- We're using `findNext` rather than `openTempFile`, here, because we + -- want predictable names + renameFile fp bak + +-- | Repairs the WAL files with the following strategy: +-- +-- * Let `f` be the oldest corrupted file. +-- * All files older than `f` is left untouched +-- * `f` is repaired with `repairFile` +-- * Old files younger than `f` is dropped (and saved to `path.bak`, or +-- `path.bak.1`, etc…) +-- +-- In other words, all the log entries after the first corrupted entry is +-- dropped. The reasoning is that newer entries are likely not to make sense +-- after some entries have been removed from the log. This strategy guarantees a +-- consistent state, albeit a potentially old one. +repairEvents + :: FilePath -- ^ Directory in which the events files can be found. + -> IO () +repairEvents directory = + repairLogs (mkEventsLogKey directory noserialisation) + where + noserialisation = + error "Repair.repairEvents: the serialisation layer shouldn't be forced" + +-- | Repairs the checkpoints file using the following strategy: +-- +-- * Every checkpoints file is repaired with `repairFile` +-- +-- Checkpoints are mostly independent. Contrary to 'repairEvents', dropping a +-- checkpoint doesn't affect the consistency of later checkpoints. +repairCheckpoints + :: FilePath -- ^ Directory in which the checkpoints files can be found. + -> IO () +repairCheckpoints directory = do + let checkpointLogKey = mkCheckpointsLogKey directory noserialisation + checkpointFiles <- Log.findLogFiles checkpointLogKey + let (_eventIds, files) = unzip checkpointFiles + mapM_ repairFile files + where + noserialisation = + error "Repair.repairCheckpoints: the serialisation layer shouldn't be forced" + +needsRepair :: FilePath -> IO Bool +needsRepair fp = do + contents <- Lazy.readFile fp + let entries = Archive.readEntries contents + return $ entriesNeedRepair entries + where + entriesNeedRepair Archive.Fail{} = True + entriesNeedRepair Archive.Done = False + entriesNeedRepair (Archive.Next _ rest) = entriesNeedRepair rest + +findNext :: FilePath -> IO (FilePath) +findNext fp = go 0 + where + go n = + let next = fileWithSuffix fp n in + doesFileExist next >>= \case + False -> return next + True -> go (n+1) + +fileWithSuffix :: FilePath -> Int -> FilePath +fileWithSuffix fp i = + if i == 0 then fp + else fp ++ "." ++ show i 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,30 @@ -{-# 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.SafeCopy import Data.Typeable import Data.Char -import Control.Applicative +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif import Control.Monad +import Control.Monad.State (MonadState) +import Control.Monad.Reader (MonadReader) +#if !MIN_VERSION_template_haskell(2,17,0) +type TyVarBndrUnit = TyVarBndr +#endif + {-| Create the control structures required for acid states using Template Haskell. @@ -42,56 +50,119 @@ -} makeAcidic :: Name -> [Name] -> Q [Dec] -makeAcidic stateName eventNames +makeAcidic = makeAcidicWithSerialiser safeCopySerialiserSpec + + +-- | Specifies how to customise the 'IsAcidic' instance and event data +-- type serialisation instances for a particular serialisation layer. +data SerialiserSpec = + SerialiserSpec + { serialisationClassName :: Name + -- ^ Class for serialisable types, e.g. @''Safecopy@. + , methodSerialiserName :: Name + -- ^ Name of the 'MethodSerialiser' to use in the list of + -- events in the 'IsAcidic' instance. + , makeEventSerialiser :: Name -> Type -> DecQ + -- ^ Function to generate an instance of the class named by + -- 'serialisationClassName', given the event name and its type. + } + +-- | Default implementation of 'SerialiserSpec' that uses 'SafeCopy' +-- for serialising events. +safeCopySerialiserSpec :: SerialiserSpec +safeCopySerialiserSpec = + SerialiserSpec { serialisationClassName = ''SafeCopy + , methodSerialiserName = 'safeCopyMethodSerialiser + , makeEventSerialiser = makeSafeCopyInstance + } + + +-- | A variant on 'makeAcidic' that makes it possible to explicitly choose the +-- serialisation implementation to be used for methods. +makeAcidicWithSerialiser :: SerialiserSpec -> Name -> [Name] -> Q [Dec] +makeAcidicWithSerialiser ss stateName eventNames = do stateInfo <- reify stateName case stateInfo of TyConI tycon ->case tycon of - DataD _cxt _name tyvars constructors _derivs - -> makeAcidic' eventNames stateName tyvars constructors - NewtypeD _cxt _name tyvars constructor _derivs - -> makeAcidic' eventNames stateName tyvars [constructor] + + DataD _cxt _name tyvars _kind constructors _derivs +#if MIN_VERSION_template_haskell(2,21,0) + -> makeAcidic' ss eventNames stateName (map void tyvars) constructors +#else + -> makeAcidic' ss eventNames stateName tyvars constructors +#endif + + NewtypeD _cxt _name tyvars _kind constructor _derivs +#if MIN_VERSION_template_haskell(2,21,0) + -> makeAcidic' ss eventNames stateName (map void tyvars) [constructor] +#else + -> makeAcidic' ss eventNames stateName tyvars [constructor] +#endif + 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." +#if MIN_VERSION_template_haskell(2,21,0) + -> makeAcidic' ss eventNames stateName (map void tyvars) [] +#else + -> makeAcidic' ss eventNames stateName tyvars [] +#endif -makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] -makeAcidic' eventNames stateName tyvars constructors - = do events <- sequence [ makeEvent eventName | eventName <- eventNames ] - acidic <- makeIsAcidic eventNames stateName tyvars constructors + _ -> 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' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec] +makeAcidic' ss eventNames stateName tyvars constructors + = do events <- sequence [ makeEvent ss eventName | eventName <- eventNames ] + acidic <- makeIsAcidic ss eventNames stateName tyvars constructors return $ acidic : concat events -makeEvent :: Name -> Q [Dec] -makeEvent eventName - = do eventType <- getEventType eventName - d <- makeEventDataType eventName eventType - b <- makeSafeCopyInstance eventName eventType - i <- makeMethodInstance eventName eventType - e <- makeEventInstance eventName eventType - return [d,b,i,e] +-- | Given an event name (e.g. @'myUpdate@), produce a data type like +-- +-- > data MyUpdate = MyUpdate Argument +-- +-- along with the 'Method' class instance, 'Event' class instance and +-- the instance of the appropriate serialisation class. +-- +-- However, if the event data type already exists, this will generate +-- the serialisation instance only. This makes it possible to call +-- 'makeAcidicWithSerialiser' multiple times on the same events but +-- with different 'SerialiserSpec's, to support multiple serialisation +-- backends. +makeEvent :: SerialiserSpec -> Name -> Q [Dec] +makeEvent ss eventName + = do exists <- recover (return False) (reify (toStructName eventName) >> return True) + eventType <- getEventType eventName + if exists + then do b <- makeEventSerialiser ss eventName eventType + return [b] + else do d <- makeEventDataType eventName eventType + b <- makeEventSerialiser ss eventName eventType + i <- makeMethodInstance eventName eventType + e <- makeEventInstance eventName eventType + return [d,b,i,e] getEventType :: Name -> Q Type getEventType eventName = do eventInfo <- reify eventName case eventInfo of - VarI _name eventType _decl _fixity - -> return eventType - _ -> error $ "Events must be functions: " ++ show eventName + VarI _name eventType _decl + -> 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) ] -makeIsAcidic eventNames stateName tyvars constructors +makeIsAcidic ss eventNames stateName tyvars constructors = do types <- mapM getEventType eventNames stateType' <- stateType - let preds = [ ''SafeCopy, ''Typeable ] + let preds = [ serialisationClassName ss, ''Typeable ] ty = appT (conT ''IsAcidic) stateType - handlers = zipWith makeEventHandler eventNames types + handlers = zipWith (makeEventHandler ss) eventNames types cxtFromEvents = nub $ concat $ zipWith (eventCxts stateType' tyvars) eventNames types cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents instanceD (return cxts') ty - [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ] - where stateType = foldl appT (conT stateName) [ varT var | PlainTV var <- tyvars ] + [ valD (varP 'acidEvents) (normalB (listE handlers)) [] + ] + where stateType = foldl appT (conT stateName) (map varT (allTyVarBndrNames tyvars)) -- | This function analyses an event function and extracts any -- additional class contexts which need to be added to the IsAcidic @@ -127,34 +198,48 @@ -- 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) - -> [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 +-- +-- 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 + -> [TyVarBndrUnit] -- ^ 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 -#if MIN_VERSION_template_haskell(2,10,0) unify table p = rename p table p -- in 2.10.0: type Pred = Type -#else - unify table p@(ClassP n tys) = ClassP n (map (rename p table) tys) - unify table p@(EqualP a b) = EqualP (rename p table a) (rename p table b) -#endif -- | rename the type variables in a Type rename :: Pred -> [(Name, Name)] -> Type -> Type rename pred table t@(ForallT tyvarbndrs cxt typ) = -- this is probably wrong? I don't think acid-state can really handle this type anyway.. ForallT (map renameTyVar tyvarbndrs) (map (unify table) cxt) (rename pred table typ) where +#if MIN_VERSION_template_haskell(2,17,0) + renameTyVar :: TyVarBndr a -> TyVarBndr a + renameTyVar (PlainTV name ann) = PlainTV (renameName pred table name) ann + renameTyVar (KindedTV name k ann) = KindedTV (renameName pred table name) k ann +#else + renameTyVar :: TyVarBndr -> TyVarBndr renameTyVar (PlainTV name) = PlainTV (renameName pred table name) renameTyVar (KindedTV name k) = KindedTV (renameName pred table name) k +#endif rename pred table (VarT n) = VarT $ renameName pred table n rename pred table (AppT a b) = AppT (rename pred table a) (rename pred table b) rename pred table (SigT a k) = SigT (rename pred table a) k @@ -164,8 +249,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 @@ -178,24 +265,33 @@ ] (Just n') -> n' --- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) -makeEventHandler :: Name -> Type -> ExpQ -makeEventHandler eventName eventType +-- | See the end of comment for 'eventCxts'. +renameState :: Type -> Type -> Cxt -> Cxt +renameState tfrom tto cxt = map renamePred cxt + where + renamePred p = renameType p -- in 2.10.0: type Pred = Type + 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) safeCopyMethodSerialiser +makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ +makeEventHandler ss eventName eventType = do assertTyVarsOk vars <- replicateM (length args) (newName "arg") let lamClause = conP eventStructName [varP var | var <- vars ] conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars)) + `appE` varE (methodSerialiserName ss) where constr = if isUpdate then 'UpdateEvent else 'QueryEvent - (tyvars, _cxt, args, stateType, _resultType, isUpdate) = analyseType eventName eventType - eventStructName = mkName (structName (nameBase eventName)) - structName [] = [] - structName (x:xs) = toUpper x : xs + TypeAnalysis { tyvars, argumentTypes = args, stateType, isUpdate } = analyseType eventName eventType + eventStructName = toStructName eventName stateTypeTyVars = findTyVars stateType tyVarNames = map tyVarBndrName tyvars 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: " @@ -207,26 +303,32 @@ , pprint stateType ] - - ---data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 --- deriving (Typeable) +-- data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 +makeEventDataType :: Name -> Type -> DecQ makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] + cxt = [] case args of - [_] -> newtypeD (return []) eventStructName tyvars con [''Typeable] - _ -> dataD (return []) eventStructName tyvars [con] [''Typeable] - where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType - eventStructName = mkName (structName (nameBase eventName)) - structName [] = [] - structName (x:xs) = toUpper x : xs +#if MIN_VERSION_template_haskell(2,21,0) + [_] -> newtypeD (return []) eventStructName (map (BndrReq <$) tyvars) Nothing con cxt + _ -> dataD (return []) eventStructName (map (BndrReq <$) tyvars) Nothing [con] cxt +#elif MIN_VERSION_template_haskell(2,11,0) + [_] -> newtypeD (return []) eventStructName tyvars Nothing con cxt + _ -> dataD (return []) eventStructName tyvars Nothing [con] cxt +#else + [_] -> newtypeD (return []) eventStructName tyvars con cxt + _ -> dataD (return []) eventStructName tyvars [con] cxt +#endif + where TypeAnalysis { tyvars, argumentTypes = args } = analyseType eventName eventType + eventStructName = toStructName eventName -- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where -- put (MyUpdateEvent a b) = do put a; put b -- get = MyUpdateEvent <$> get <*> get +makeSafeCopyInstance :: Name -> Type -> DecQ makeSafeCopyInstance eventName eventType = do let preds = [ ''SafeCopy ] - ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) + ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) getBase = appE (varE 'return) (conE eventStructName) getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'safeGet))) getBase args @@ -241,79 +343,134 @@ (return ty) [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []] , valD (varP 'getCopy) (normalB (contained getArgs)) [] + , funD 'errorTypeName [clause [wildP] (normalB (litE (stringL (pprint ty)))) []] ] - where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType - eventStructName = mkName (structName (nameBase eventName)) - structName [] = [] - structName (x:xs) = toUpper x : xs + where TypeAnalysis { tyvars, context, argumentTypes = args } = analyseType eventName eventType + eventStructName = toStructName eventName mkCxtFromTyVars preds tyvars extraContext - = cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ + = cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return extraContext {- -instance (SafeCopy key, Typeable key - ,SafeCopy val, Typeable val) => Method (MyUpdateEvent key val) where +instance (Typeable key, Typeable val) => Method (MyUpdateEvent key val) where 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) [ VarT tyvar | PlainTV tyvar <- tyvars ]) - structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ] - instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context) - (return ty) -#if __GLASGOW_HASKELL__ >= 707 - [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType)) - , tySynInstD ''MethodState (tySynEqn [structType] (return stateType)) +makeMethodInstance :: Name -> Type -> DecQ +makeMethodInstance eventName eventType = do + let preds = + [ ''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 MIN_VERSION_template_haskell(2,15,0) + [ tySynInstD $ tySynEqn Nothing (conT ''MethodResult `appT` structType) (return resultType) + , tySynInstD $ tySynEqn Nothing (conT ''MethodState `appT` structType) (return stateType) +#elif __GLASGOW_HASKELL__ >= 707 + [ 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 - eventStructName = mkName (structName (nameBase eventName)) - structName [] = [] - structName (x:xs) = toUpper x : xs + ] + where TypeAnalysis { tyvars, context, stateType, resultType } = analyseType eventName eventType + eventStructName = toStructName eventName ---instance (SafeCopy key, Typeable key --- ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val) +--instance (Typeable key, Typeable val) => UpdateEvent (MyUpdateEvent key val) +makeEventInstance :: Name -> Type -> DecQ makeEventInstance eventName eventType - = do let preds = [ ''SafeCopy, ''Typeable ] + = do let preds = [ ''Typeable ] eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent - ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) - instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context) + ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) + 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 - eventStructName = mkName (structName (nameBase eventName)) - structName [] = [] - structName (x:xs) = toUpper x : xs + where TypeAnalysis { tyvars, context, isUpdate } = analyseType eventName eventType + eventStructName = toStructName eventName +data TypeAnalysis = TypeAnalysis + { tyvars :: [TyVarBndrUnit] + , 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 + 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) + -- 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) +#if MIN_VERSION_template_haskell(2,17,0) + = go (tyvars ++ fmap void tyvars2) (cxt ++ cxt2) args a +#else + = go (tyvars ++ tyvars2) (cxt ++ cxt2) args a +#endif + -- (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] findTyVars :: Type -> [Name] @@ -324,6 +481,26 @@ findTyVars _ = [] -- | extract the 'Name' from a 'TyVarBndr' +#if MIN_VERSION_template_haskell(2,17,0) +tyVarBndrName :: TyVarBndr a -> Name +tyVarBndrName (PlainTV n _) = n +tyVarBndrName (KindedTV n _ _) = n + +allTyVarBndrNames :: [TyVarBndr a] -> [Name] +allTyVarBndrNames tyvars = map tyVarBndrName tyvars +#else tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV n) = n tyVarBndrName (KindedTV n _) = n + +allTyVarBndrNames :: [TyVarBndr] -> [Name] +allTyVarBndrNames tyvars = map tyVarBndrName tyvars +#endif + +-- | Convert the 'Name' of the event function into the name of the +-- corresponding data constructor. +toStructName :: Name -> Name +toStructName eventName = mkName (structName (nameBase eventName)) + where + structName [] = [] + structName (x:xs) = toUpper x : xs 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.IO.Class ( MonadIO(..) ) +import Control.Monad.Reader ( ask ) +import Control.Monad.State ( get, put ) +import Data.Acid +import Data.Acid.StateMachineTest +import Data.SafeCopy +import qualified Data.Map as Map +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) + +$(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,527 @@ +{-# LANGUAGE CPP #-} +{-# 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.IO.Class ( MonadIO(..) ) +import Control.Monad.State ( State, evalState, execState ) +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 + +#if MIN_VERSION_hedgehog(1,1,0) +instance FunctorB (Open s) where + bmap _ (Open s) = Open s +instance TraversableB (Open s) where + btraverse _ (Open s) = pure (Open s) +#else +instance HTraversable (Open s) where + htraverse _ (Open s) = pure (Open s) +#endif + +-- | 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) + +#if MIN_VERSION_hedgehog(1,1,0) +instance FunctorB (WithState s) where + bmap k (WithState l v) = WithState l (bmap k v) +instance TraversableB (WithState s) where + btraverse k (WithState l v) = WithState l <$> btraverse k v +#else +instance HTraversable (WithState s) where + htraverse k (WithState l v) = WithState l <$> htraverse k v +#endif + +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) + +#if MIN_VERSION_hedgehog(1,1,0) +instance FunctorB (AcidCommand s e) where + bmap k (AcidCommand e s) = AcidCommand e (bmap k s) +instance TraversableB (AcidCommand s e) where + btraverse k (AcidCommand e s) = AcidCommand e <$> btraverse k s +#else +instance HTraversable (AcidCommand s e) where + htraverse k (AcidCommand e s) = AcidCommand e <$> htraverse k s +#endif + +-- | 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,165 @@ +{-# 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 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 = + [ ConT ''MonadReader + `AppT` ConT ''Int + `AppT` VarT m + ] + , 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 :: [TyVarBndrUnit] +#if MIN_VERSION_template_haskell(2,17,0) + binders = [PlainTV (mkName "x") ()] +#else + binders = [PlainTV (mkName "x")] +#endif + stateType = ConT ''Maybe `AppT` VarT x + eventType <- runQ [t| forall a. (Ord a) => Int -> Query (Maybe a) Int|] + + eventCxts stateType binders name eventType + `shouldBe` + [ConT ''Ord `AppT` VarT x] + + 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` + [ConT ''Ord `AppT` ConT ''Char] + + +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