diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.6.3 +Version: 0.6.4 -- A short (one-line) description of the package. Synopsis: Add ACID guarantees to any serializable Haskell data structure. diff --git a/examples/QuickCheck.hs b/examples/QuickCheck.hs deleted file mode 100644 --- a/examples/QuickCheck.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Test.QuickCheck - -import Data.Acid - diff --git a/src/Data/Acid/Local.hs b/src/Data/Acid/Local.hs --- a/src/Data/Acid/Local.hs +++ b/src/Data/Acid/Local.hs @@ -17,7 +17,7 @@ , openLocalStateFrom , createArchive , createCheckpointAndClose - ) where + ) where import Data.Acid.Log as Log import Data.Acid.Core @@ -36,6 +36,7 @@ import Data.SafeCopy ( SafeCopy(..), safeGet, safePut , primitive, contain ) import Data.Typeable ( Typeable, typeOf ) +import Data.IORef import System.FilePath ( () ) @@ -54,6 +55,7 @@ -} data LocalState st = LocalState { localCore :: Core st + , localCopy :: IORef st , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog Checkpoint } deriving (Typeable) @@ -79,7 +81,8 @@ 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) $ putMVar mvar result + pushEntry (localEvents acidState) (methodTag event, encoded) $ do writeIORef (localCopy acidState) st' + putMVar mvar result return st' return mvar where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event @@ -91,7 +94,8 @@ 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 $ putMVar mvar result + pushEntry (localEvents acidState) event $ do writeIORef (localCopy acidState) st' + putMVar mvar result return st' return mvar where coldMethod = lookupColdMethod (localCore acidState) event @@ -99,27 +103,17 @@ -- | 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 - = do mvar <- newEmptyMVar - withCoreState (localCore acidState) $ \st -> - do let (result, _st) = runState hotMethod st - -- Make sure that we do not return the result before the event log has - -- been flushed to disk. - pushAction (localEvents acidState) $ - putMVar mvar result - takeMVar mvar + = do st <- readIORef (localCopy acidState) + let (result, _st) = runState hotMethod st + return result where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event -- Whoa, a buttload of refactoring is needed here. 2011-11-02 localQueryCold :: LocalState st -> Tagged ByteString -> IO ByteString localQueryCold acidState event - = do mvar <- newEmptyMVar - withCoreState (localCore acidState) $ \st -> - do let (result, _st) = runState coldMethod st - -- Make sure that we do not return the result before the event log has - -- been flushed to disk. - pushAction (localEvents acidState) $ - putMVar mvar result - takeMVar mvar + = do st <- readIORef (localCopy acidState) + let (result, _st) = runState coldMethod st + return result where coldMethod = lookupColdMethod (localCore acidState) event -- | Take a snapshot of the state and save it to disk. Creating checkpoints @@ -205,7 +199,11 @@ events <- readEntriesFrom eventsLog n mapM_ (runColdMethod core) events checkpointsLog <- openFileLog checkpointsLogKey + stateCopy <- newIORef undefined + withCoreState core (writeIORef stateCopy) + return $ toAcidState LocalState { localCore = core + , localCopy = stateCopy , localEvents = eventsLog , localCheckpoints = checkpointsLog } @@ -226,7 +224,7 @@ -- folder in the state directory. This folder can then be backed up or thrown out as you see fit. -- Reverting to a state before the last checkpoint will not be possible if the 'Archive' folder -- has been thrown out. --- +-- -- This method is idempotent and does not block the normal operation of the AcidState. createArchive :: AcidState st -> IO () createArchive abstract_state 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 @@ -11,6 +11,8 @@ , pushEntry , pushAction , readEntriesFrom + , rollbackTo + , rollbackWhile , newestEntry , askCurrentEntryId , cutFileLog @@ -20,6 +22,7 @@ import Data.Acid.Archive as Archive import System.Directory import System.FilePath +import System.IO import FileIO import Foreign.Ptr @@ -106,8 +109,6 @@ do (entries, actions) <- atomically $ do (entries, actions) <- readTVar queue when (null entries && null actions) retry writeTVar queue ([], []) - -- We don't actually have to reverse the actions - -- but I don't think it hurts performance much. return (reverse entries, reverse actions) withMVar currentState $ \fd -> do let arch = Archive.packEntries entries @@ -171,8 +172,46 @@ return $ map decode' $ take (entryCap - youngestEntry) -- Take events under the eventCap. $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young. - where rangeStart (firstEntryId, _path) = firstEntryId + +-- Obliterate log entries younger than or equal to the EventId. Very unsafe, can't be undone +rollbackTo :: SafeCopy object => LogKey object -> EntryId -> IO () +rollbackTo identifier youngestEntry + = do logFiles <- findLogFiles identifier + let sorted = sort logFiles + loop [] = return () + loop ((rangeStart, path) : xs) + = if rangeStart >= youngestEntry + then do {-putStrLn ("Removing file: "++path); -}removeFile path; loop xs + else do archive <- Strict.readFile path + pathHandle <- openFile path WriteMode + let entries = entriesToList $ readEntries (Lazy.fromChunks [archive]) + entriesToKeep = take (youngestEntry - rangeStart + 1) entries + lengthToKeep = Lazy.length (packEntries entriesToKeep) + --putStrLn $ "FileSize: " ++ show (lengthToKeep, Strict.length archive) + 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 () +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) + orig_size = fromIntegral $ Strict.length archive + new_size = orig_size - skip_size + if new_size == 0 + then do removeFile path; loop xs + else do pathHandle <- openFile path WriteMode + hSetFileSize pathHandle (fromIntegral new_size) + hClose pathHandle + loop (reverse sorted) -- Filter out log files that are outside the min_entry/max_entry range. -- minEntryId <= x < maxEntryId