diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.14.1 +====== + + - fix bug in archiveLog that resulted in logs being moved prematurely (bug #22) + - tweaks for GHC 8.0.x, template-haskell 2.11.x + - fix compilation of benchmarks + 0.14.0 ====== diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -1,5 +1,5 @@ Name: acid-state -Version: 0.14.0 +Version: 0.14.1 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/ @@ -71,12 +71,16 @@ 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, + criterion >= 0.8 && < 1.2, mtl, base, acid-state diff --git a/benchmarks/loading/Benchmark/FileSystem.hs b/benchmarks/loading/Benchmark/FileSystem.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/FileSystem.hs @@ -0,0 +1,57 @@ +module Benchmark.FileSystem + ( + copy, + removeTreeIfExists, + exists, + getTemporaryDirectory, + module Filesystem, + module Filesystem.Path.CurrentOS + ) + where + +import Benchmark.Prelude hiding (stripPrefix, last) +import Filesystem.Path.CurrentOS +import Filesystem +import qualified System.Directory as Directory +import Debug.Trace +import qualified Data.List as List + + + +removeTreeIfExists :: FilePath -> IO () +removeTreeIfExists path = removeTree path `catch` \e -> case e of + _ | isDoesNotExistError e -> return () + | otherwise -> throwIO e + +exists :: FilePath -> IO Bool +exists path = do + isDir <- isDirectory path + isFile <- isFile path + return $ isDir || isFile + +getTemporaryDirectory :: IO FilePath +getTemporaryDirectory = + Directory.getTemporaryDirectory >>= return . decodeString + +copy :: FilePath -> FilePath -> IO () +copy from to = do + isDir <- isDirectory from + if isDir + then copyDirectory from to + else copyFile from to + +copyDirectory :: FilePath -> FilePath -> IO () +copyDirectory path path' = do + members <- listDirectory path + let members' = do + member <- members + let relative = + fromMaybe (error "Unexpectedly empty member path") $ + last member + return $ path' <> relative + sequence_ $ zipWith copy members members' + +last :: FilePath -> Maybe FilePath +last p = case splitDirectories p of + [] -> Nothing + l -> Just $ List.last l diff --git a/benchmarks/loading/Benchmark/Model.hs b/benchmarks/loading/Benchmark/Model.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/Model.hs @@ -0,0 +1,13 @@ +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 . (:) + +Acid.makeAcidic ''Model ['insert] diff --git a/benchmarks/loading/Benchmark/Prelude.hs b/benchmarks/loading/Benchmark/Prelude.hs new file mode 100644 --- /dev/null +++ b/benchmarks/loading/Benchmark/Prelude.hs @@ -0,0 +1,42 @@ +module Benchmark.Prelude + ( + module Prelude, + module Control.Monad, + module Control.Applicative, + module Control.Arrow, + module Data.Monoid, + module Data.Foldable, + module Data.Traversable, + module Data.Maybe, + module Data.List, + module Data.Data, + + -- mtl + module Control.Monad.State, + module Control.Monad.Reader, + + -- exceptions + module Control.Exception, + module System.IO.Error, + ) + where + +import Prelude hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath) +import Control.Monad hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Applicative +import Control.Arrow +import Data.Monoid +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Data.List hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Data + +-- mtl +import Control.Monad.State hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.Reader hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) + +-- exceptions +import Control.Exception +import System.IO.Error + diff --git a/examples/MultipleCheckpoint.hs b/examples/MultipleCheckpoint.hs new file mode 100644 --- /dev/null +++ b/examples/MultipleCheckpoint.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import Data.Acid + +import Control.Concurrent +import Control.Monad.State +import Data.SafeCopy +import Data.Time +import System.IO + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data SlowCheckpoint = SlowCheckpoint Int Int + +$(deriveSafeCopy 0 'base ''SlowCheckpoint) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +-- This transaction adds a very computationally heavy entry +-- into our state. However, since the state is lazy, the +-- chunk will not be forced until we create a checkpoint. +-- Computing 'last [0..100000000]' takes roughly 2 seconds +-- on my machine. XXX Lemmih, 2011-04-26 +setComputationallyHeavyData :: Update SlowCheckpoint () +setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get + put $ SlowCheckpoint (last [0..100000000]) tick + +tick :: Update SlowCheckpoint Int +tick = do SlowCheckpoint slow tick <- get + put $ SlowCheckpoint slow (tick+1) + return tick + +$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick]) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) + doTick acid + createCheckpoint acid + doTick acid + createCheckpoint acid + doTick acid + createCheckpoint acid + createArchive acid + pure () +{- + update acid SetComputationallyHeavyData + forkIO $ do putStrLn "Seriazing checkpoint..." + t <- timeIt $ createCheckpoint acid + t <- timeIt $ createCheckpoint acid + putStrLn $ "Checkpoint created in: " ++ show t + replicateM_ 20 $ + do doTick acid + threadDelay (10^5) +-} +-- threadDelay (10^6) +-- tick <- update acid Tick +-- threadDelay (10^6) +-- createArchive acid + +doTick acid + = do tick <- update acid Tick + putStrLn $ "Tick: " ++ show tick + +timeIt action + = do t1 <- getCurrentTime + ret <- action + t2 <- getCurrentTime + return (diffUTCTime t2 t1) diff --git a/src/Data/Acid/Abstract.hs b/src/Data/Acid/Abstract.hs --- a/src/Data/Acid/Abstract.hs +++ b/src/Data/Acid/Abstract.hs @@ -48,7 +48,7 @@ = 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 diff --git a/src/Data/Acid/Log.hs b/src/Data/Acid/Log.hs --- a/src/Data/Acid/Log.hs +++ b/src/Data/Acid/Log.hs @@ -262,7 +262,7 @@ logFiles <- findLogFiles (logIdentifier fLog) let sorted = sort logFiles relevant = filterLogFiles Nothing (Just entryId) sorted \\ - filterLogFiles (Just (entryId+1)) (Just entryId) sorted + filterLogFiles (Just entryId) (Just (entryId+1)) sorted createDirectoryIfMissing True archiveDir forM_ relevant $ \(_startEntry, logFilePath) -> diff --git a/src/Data/Acid/TemplateHaskell.hs b/src/Data/Acid/TemplateHaskell.hs --- a/src/Data/Acid/TemplateHaskell.hs +++ b/src/Data/Acid/TemplateHaskell.hs @@ -48,9 +48,17 @@ case stateInfo of TyConI tycon ->case tycon of +#if MIN_VERSION_template_haskell(2,11,0) + DataD _cxt _name tyvars _kind constructors _derivs +#else DataD _cxt _name tyvars constructors _derivs +#endif -> makeAcidic' eventNames stateName tyvars constructors +#if MIN_VERSION_template_haskell(2,11,0) + NewtypeD _cxt _name tyvars _kind constructor _derivs +#else NewtypeD _cxt _name tyvars constructor _derivs +#endif -> makeAcidic' eventNames stateName tyvars [constructor] TySynD _name tyvars _ty -> makeAcidic' eventNames stateName tyvars [] @@ -76,7 +84,11 @@ getEventType eventName = do eventInfo <- reify eventName case eventInfo of +#if MIN_VERSION_template_haskell(2,11,0) + VarI _name eventType _decl +#else VarI _name eventType _decl _fixity +#endif -> return eventType _ -> error $ "Events must be functions: " ++ show eventName @@ -214,9 +226,19 @@ -- deriving (Typeable) makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] +#if MIN_VERSION_template_haskell(2,11,0) + cxt = mapM conT [''Typeable] +#else + cxt = [''Typeable] +#endif case args of - [_] -> newtypeD (return []) eventStructName tyvars con [''Typeable] - _ -> dataD (return []) eventStructName tyvars [con] [''Typeable] +#if 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 (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = []