acid-state 0.6.3 → 0.6.4

raw patch · 4 files changed

+61/−30 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• acid-state.cabal +1/−1
• examples/QuickCheck.hs +0/−6
• src/Data/Acid/Local.hs +18/−20
• src/Data/Acid/Log.hs +42/−3

@@ -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.

@@ -1,6 +0,0 @@-module Main (main) where--import Test.QuickCheck--import Data.Acid-

@@ -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

@@ -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