packages feed

acid-state 0.12.4 → 0.16.1.4

raw patch · 170 files changed

Files

+ CHANGELOG.md view
@@ -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))
acid-state.cabal view
@@ -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 <lemmih@gmail.com> -- 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
benchmarks/loading/Benchmark.hs view
@@ -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
+ benchmarks/loading/Benchmark/FileSystem.hs view
@@ -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
+ benchmarks/loading/Benchmark/Model.hs view
@@ -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]
+ benchmarks/loading/Benchmark/Prelude.hs view
@@ -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+
+ examples/CheckpointCutsEvent.hs view
@@ -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
+ examples/Examples.hs view
@@ -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
examples/HelloDatabase.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module HelloDatabase (main) where  import           Data.Acid
examples/HelloWorld.hs view
@@ -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)
examples/HelloWorldNoTH.hs view
@@ -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                  ]
examples/KeyValue.hs view
@@ -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)
examples/KeyValueNoTH.hs view
@@ -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                  ]
+ examples/MonadStateConstraint.hs view
@@ -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!"
+ examples/ParameterisedState.hs view
@@ -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
examples/Proxy.hs view
@@ -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
examples/RemoteClient.hs view
@@ -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
examples/RemoteCommon.hs view
@@ -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)
examples/RemoteServer.hs view
@@ -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")
examples/SlowCheckpoint.hs view
@@ -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
examples/StressTest.hs view
@@ -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)
examples/StressTestNoTH.hs view
@@ -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                  ]
examples/errors/ChangeState.hs view
@@ -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"
+ examples/errors/ChangeVersion.hs view
@@ -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"
examples/errors/Exceptions.hs view
@@ -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
examples/errors/RemoveEvent.hs view
@@ -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"
+ repair/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Data.Acid.Repair+import System.Directory++main :: IO ()+main = do+    directory <- getCurrentDirectory+    repairEvents directory+    repairCheckpoints directory
src-unix/FileIO.hs view
@@ -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---
src-win32/FileIO.hs view
@@ -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 ()
src/Data/Acid.hs view
@@ -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- <http://mirror.seize.it/acid-state/examples/>.+ <https://github.com/acid-state/acid-state/tree/master/examples>.  -}
src/Data/Acid/Abstract.hs view
@@ -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)
src/Data/Acid/Advanced.hs view
@@ -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
src/Data/Acid/Archive.hs view
@@ -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
src/Data/Acid/Common.hs view
@@ -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
src/Data/Acid/Core.hs view
@@ -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)
src/Data/Acid/Local.hs view
@@ -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               }-
src/Data/Acid/Log.hs view
@@ -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
src/Data/Acid/Memory.hs view
@@ -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 ()
src/Data/Acid/Memory/Pure.hs view
@@ -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.
src/Data/Acid/Remote.hs view
@@ -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)
+ src/Data/Acid/Repair.hs view
@@ -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
src/Data/Acid/TemplateHaskell.hs view
@@ -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
+ test-state/OldStateTest1/checkpoints-0000000000.log view
+ test-state/OldStateTest1/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest1/events-0000000000.log view
binary file changed (absent → 71486 bytes)
+ test-state/OldStateTest1/events-0000000681.log view
+ test-state/OldStateTest1/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest2/checkpoints-0000000000.log view
+ test-state/OldStateTest2/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest2/events-0000000000.log view
binary file changed (absent → 328 bytes)
+ test-state/OldStateTest2/events-0000000003.log view
binary file changed (absent → 446 bytes)
+ test-state/OldStateTest2/events-0000000007.log view
binary file changed (absent → 512 bytes)
+ test-state/OldStateTest2/events-0000000012.log view
binary file changed (absent → 225 bytes)
+ test-state/OldStateTest2/events-0000000014.log view
binary file changed (absent → 327 bytes)
+ test-state/OldStateTest2/events-0000000017.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000019.log view
binary file changed (absent → 1259 bytes)
+ test-state/OldStateTest2/events-0000000031.log view
binary file changed (absent → 1141 bytes)
+ test-state/OldStateTest2/events-0000000042.log view
binary file changed (absent → 215 bytes)
+ test-state/OldStateTest2/events-0000000044.log view
binary file changed (absent → 206 bytes)
+ test-state/OldStateTest2/events-0000000046.log view
binary file changed (absent → 1147 bytes)
+ test-state/OldStateTest2/events-0000000057.log view
binary file changed (absent → 205 bytes)
+ test-state/OldStateTest2/events-0000000059.log view
binary file changed (absent → 116 bytes)
+ test-state/OldStateTest2/events-0000000060.log view
binary file changed (absent → 936 bytes)
+ test-state/OldStateTest2/events-0000000069.log view
binary file changed (absent → 872 bytes)
+ test-state/OldStateTest2/events-0000000078.log view
binary file changed (absent → 111 bytes)
+ test-state/OldStateTest2/events-0000000079.log view
binary file changed (absent → 303 bytes)
+ test-state/OldStateTest2/events-0000000082.log view
binary file changed (absent → 1663 bytes)
+ test-state/OldStateTest2/events-0000000098.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000100.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000102.log view
binary file changed (absent → 209 bytes)
+ test-state/OldStateTest2/events-0000000104.log view
binary file changed (absent → 867 bytes)
+ test-state/OldStateTest2/events-0000000112.log view
binary file changed (absent → 553 bytes)
+ test-state/OldStateTest2/events-0000000117.log view
binary file changed (absent → 494 bytes)
+ test-state/OldStateTest2/events-0000000122.log view
binary file changed (absent → 414 bytes)
+ test-state/OldStateTest2/events-0000000126.log view
binary file changed (absent → 110 bytes)
+ test-state/OldStateTest2/events-0000000127.log view
binary file changed (absent → 396 bytes)
+ test-state/OldStateTest2/events-0000000131.log view
binary file changed (absent → 1059 bytes)
+ test-state/OldStateTest2/events-0000000141.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000143.log view
binary file changed (absent → 653 bytes)
+ test-state/OldStateTest2/events-0000000149.log view
+ test-state/OldStateTest2/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest3/checkpoints-0000000000.log view
binary file changed (absent → 96 bytes)
+ test-state/OldStateTest3/checkpoints-0000000001.log view
binary file changed (absent → 192 bytes)
+ test-state/OldStateTest3/checkpoints-0000000003.log view
binary file changed (absent → 134 bytes)
+ test-state/OldStateTest3/checkpoints-0000000004.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000005.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000006.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000007.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000008.log view
binary file changed (absent → 292 bytes)
+ test-state/OldStateTest3/checkpoints-0000000009.log view
binary file changed (absent → 301 bytes)
+ test-state/OldStateTest3/checkpoints-0000000010.log view
binary file changed (absent → 301 bytes)
+ test-state/OldStateTest3/checkpoints-0000000011.log view
binary file changed (absent → 330 bytes)
+ test-state/OldStateTest3/checkpoints-0000000012.log view
binary file changed (absent → 664 bytes)
+ test-state/OldStateTest3/checkpoints-0000000014.log view
binary file changed (absent → 708 bytes)
+ test-state/OldStateTest3/checkpoints-0000000016.log view
binary file changed (absent → 354 bytes)
+ test-state/OldStateTest3/checkpoints-0000000017.log view
binary file changed (absent → 708 bytes)
+ test-state/OldStateTest3/checkpoints-0000000019.log view
binary file changed (absent → 354 bytes)
+ test-state/OldStateTest3/checkpoints-0000000020.log view
binary file changed (absent → 747 bytes)
+ test-state/OldStateTest3/checkpoints-0000000022.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000023.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000024.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000025.log view
binary file changed (absent → 1169 bytes)
+ test-state/OldStateTest3/checkpoints-0000000028.log view
binary file changed (absent → 388 bytes)
+ test-state/OldStateTest3/checkpoints-0000000029.log view
binary file changed (absent → 778 bytes)
+ test-state/OldStateTest3/checkpoints-0000000031.log view
binary file changed (absent → 392 bytes)
+ test-state/OldStateTest3/checkpoints-0000000032.log view
binary file changed (absent → 392 bytes)
+ test-state/OldStateTest3/checkpoints-0000000033.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000034.log view
binary file changed (absent → 1175 bytes)
+ test-state/OldStateTest3/checkpoints-0000000037.log view
binary file changed (absent → 1183 bytes)
+ test-state/OldStateTest3/checkpoints-0000000040.log view
binary file changed (absent → 387 bytes)
+ test-state/OldStateTest3/checkpoints-0000000041.log view
binary file changed (absent → 781 bytes)
+ test-state/OldStateTest3/checkpoints-0000000043.log view
binary file changed (absent → 391 bytes)
+ test-state/OldStateTest3/checkpoints-0000000044.log view
binary file changed (absent → 400 bytes)
+ test-state/OldStateTest3/checkpoints-0000000045.log view
binary file changed (absent → 400 bytes)
+ test-state/OldStateTest3/checkpoints-0000000046.log view
binary file changed (absent → 404 bytes)
+ test-state/OldStateTest3/checkpoints-0000000047.log view
+ test-state/OldStateTest3/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest3/events-0000000000.log view
binary file changed (absent → 120 bytes)
+ test-state/OldStateTest3/events-0000000001.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000002.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000003.log view
binary file changed (absent → 310 bytes)
+ test-state/OldStateTest3/events-0000000006.log view
binary file changed (absent → 1075 bytes)
+ test-state/OldStateTest3/events-0000000016.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest3/events-0000000018.log view
binary file changed (absent → 541 bytes)
+ test-state/OldStateTest3/events-0000000023.log view
binary file changed (absent → 399 bytes)
+ test-state/OldStateTest3/events-0000000027.log view
binary file changed (absent → 214 bytes)
+ test-state/OldStateTest3/events-0000000029.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000030.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000031.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/events-0000000033.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000034.log view
binary file changed (absent → 213 bytes)
+ test-state/OldStateTest3/events-0000000036.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000037.log view
binary file changed (absent → 111 bytes)
+ test-state/OldStateTest3/events-0000000038.log view
binary file changed (absent → 324 bytes)
+ test-state/OldStateTest3/events-0000000041.log view
binary file changed (absent → 324 bytes)
+ test-state/OldStateTest3/events-0000000044.log view
binary file changed (absent → 665 bytes)
+ test-state/OldStateTest3/events-0000000051.log view
binary file changed (absent → 300 bytes)
+ test-state/OldStateTest3/events-0000000054.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000055.log view
binary file changed (absent → 353 bytes)
+ test-state/OldStateTest3/events-0000000058.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000059.log view
binary file changed (absent → 117 bytes)
+ test-state/OldStateTest3/events-0000000060.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000061.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000062.log view
binary file changed (absent → 214 bytes)
+ test-state/OldStateTest3/events-0000000064.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000065.log view
binary file changed (absent → 115 bytes)
+ test-state/OldStateTest3/events-0000000066.log view
binary file changed (absent → 117 bytes)
+ test-state/OldStateTest3/events-0000000067.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000068.log view
binary file changed (absent → 225 bytes)
+ test-state/OldStateTest3/events-0000000070.log view
binary file changed (absent → 558 bytes)
+ test-state/OldStateTest3/events-0000000075.log view
binary file changed (absent → 110 bytes)
+ test-state/OldStateTest3/events-0000000076.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000077.log view
binary file changed (absent → 116 bytes)
+ test-state/OldStateTest3/events-0000000078.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000079.log view
binary file changed (absent → 234 bytes)
+ test-state/OldStateTest3/events-0000000081.log view
binary file changed (absent → 223 bytes)
+ test-state/OldStateTest3/events-0000000083.log view
binary file changed (absent → 533 bytes)
+ test-state/OldStateTest3/events-0000000088.log view
binary file changed (absent → 120 bytes)
+ test-state/OldStateTest3/events-0000000089.log view
binary file changed (absent → 326 bytes)
+ test-state/OldStateTest3/events-0000000092.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest3/events-0000000094.log view
binary file changed (absent → 346 bytes)
+ test-state/OldStateTest3/events-0000000097.log view
binary file changed (absent → 212 bytes)
+ test-state/OldStateTest3/events-0000000099.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000100.log view
+ test-state/OldStateTest3/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test/Data/Acid/KeyValueStateMachine.hs view
@@ -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)
+ test/Data/Acid/StateMachineTest.hs view
@@ -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
+ test/Data/Acid/TemplateHaskellSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/StateMachine.hs view
@@ -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