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.11.4 +Version: 0.12.0 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/ diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs --- a/examples/RemoteClient.hs +++ b/examples/RemoteClient.hs @@ -2,7 +2,7 @@ module Main (main) where import Control.Monad ( replicateM_ ) -import Data.Acid ( AcidState, closeAcidState, createCheckpoint, query, update ) +import Data.Acid ( AcidState, closeAcidState, createCheckpoint, createArchive, query, update ) import Data.Acid.Advanced ( scheduleUpdate ) import Data.Acid.Remote ( openRemoteState, sharedSecretPerform ) import Data.ByteString.Char8 ( pack ) @@ -20,6 +20,7 @@ putStrLn $ " query Prints out the current state." putStrLn $ " poke Spawn 100k transactions." putStrLn $ " checkpoint Create a new checkpoint." + putStrLn $ " archive Create archive." putStrLn $ " clear Clear the state and create a new checkpoint." putStrLn $ " quit Exit with out creating a checkpoint." @@ -38,6 +39,9 @@ case cmd of "checkpoint" -> do createCheckpoint acid + go + "archive" + -> do createArchive acid go "query" -> do n <- query acid QueryState diff --git a/src/Data/Acid.hs b/src/Data/Acid.hs --- a/src/Data/Acid.hs +++ b/src/Data/Acid.hs @@ -12,13 +12,14 @@ . -} - + module Data.Acid ( AcidState , openLocalState , openLocalStateFrom , closeAcidState , createCheckpoint + , createArchive , update , query , EventResult @@ -29,7 +30,7 @@ , Query , IsAcidic , makeAcidic - , runQuery + , liftQuery ) where import Data.Acid.Local 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 @@ -51,6 +51,7 @@ -- -- This call will not return until the operation has succeeded. createCheckpoint :: IO () + , createArchive :: IO () , -- | Close an AcidState and associated resources. -- Any subsequent usage of the AcidState will throw an exception. diff --git a/src/Data/Acid/Common.hs b/src/Data/Acid/Common.hs --- a/src/Data/Acid/Common.hs +++ b/src/Data/Acid/Common.hs @@ -53,8 +53,8 @@ (<*>) = ap -- | Run a query in the Update Monad. -runQuery :: Query st a -> Update st a -runQuery query +liftQuery :: Query st a -> Update st a +liftQuery query = do st <- get return (runReader (unQuery query) st) 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 , prepareLocalState , prepareLocalStateFrom - , createArchive + , createLocalArchive , createCheckpointAndClose ) where @@ -287,8 +287,8 @@ -- 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 +createLocalArchive :: LocalState st -> IO () +createLocalArchive state = do -- We need to look at the last checkpoint saved to disk. Since checkpoints can be written -- in parallel with this call, we can't guarantee that the checkpoint we get really is the -- last one but that's alright. @@ -306,7 +306,6 @@ -- In the same style as above, we archive all log files that came before the log file -- which contains our checkpoint. archiveFileLog (localCheckpoints state) durableCheckpointId - where state = downcast abstract_state toAcidState :: IsAcidic st => LocalState st -> AcidState st toAcidState local @@ -315,6 +314,7 @@ , _query = localQuery local , queryCold = localQueryCold local , createCheckpoint = createLocalCheckpoint local + , createArchive = createLocalArchive local , closeAcidState = closeLocalState local , acidSubState = mkAnyState local } diff --git a/src/Data/Acid/Memory.hs b/src/Data/Acid/Memory.hs --- a/src/Data/Acid/Memory.hs +++ b/src/Data/Acid/Memory.hs @@ -107,6 +107,11 @@ createMemoryCheckpoint acidState = return () +-- | This is a nop with the memory backend. +createMemoryArchive :: SafeCopy st => MemoryState st -> IO () +createMemoryArchive acidState + = return () + -- | Close an AcidState and associated logs. -- Any subsequent usage of the AcidState will throw an exception. closeMemoryState :: MemoryState st -> IO () @@ -120,6 +125,7 @@ , _query = memoryQuery memory , queryCold = memoryQueryCold memory , createCheckpoint = createMemoryCheckpoint memory + , createArchive = createMemoryArchive memory , closeAcidState = closeMemoryState memory , acidSubState = mkAnyState memory } diff --git a/src/Data/Acid/Memory/Pure.hs b/src/Data/Acid/Memory/Pure.hs --- a/src/Data/Acid/Memory/Pure.hs +++ b/src/Data/Acid/Memory/Pure.hs @@ -24,14 +24,16 @@ , update , update_ , query + , liftQuery + , runUpdate , runQuery ) where import Data.Acid.Core import Data.Acid.Common -import Control.Monad.State ( runState ) - +import Control.Monad.State +import Control.Monad.Reader {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) guarantees. @@ -84,3 +86,10 @@ = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) , localState = initialState } +-- | Execute the 'Update' monad in a pure environment. +runUpdate :: Update s r -> s -> (r, s) +runUpdate update = runState $ unUpdate update + +-- | Execute the 'Query' monad in a pure environment. +runQuery :: Query s r -> s -> r +runQuery query = runReader $ unQuery query diff --git a/src/Data/Acid/Remote.hs b/src/Data/Acid/Remote.hs --- a/src/Data/Acid/Remote.hs +++ b/src/Data/Acid/Remote.hs @@ -145,7 +145,6 @@ deriving (Eq, Show, Typeable) instance Exception AcidRemoteException - -- | create a 'CommChannel' from a 'Handle'. The 'Handle' should be -- some two-way communication channel, such as a socket -- connection. Passing in a 'Handle' to a normal is file is unlikely @@ -214,6 +213,10 @@ using a socket file. To control access, you can set the permissions of the parent directory which contains the socket file. + The message @SerializeError "too few bytes\nFrom:\tdemandInput\n\n"@ is + displayed on the standard error channel of the server whenever a + client disconnects. + see also: 'openRemoteState' and 'sharedSecretCheck'. -} acidServer :: SafeCopy st => @@ -262,17 +265,20 @@ data Command = RunQuery (Tagged Lazy.ByteString) | RunUpdate (Tagged Lazy.ByteString) | CreateCheckpoint + | CreateArchive instance Serialize Command where put cmd = case cmd of RunQuery query -> do putWord8 0; put query RunUpdate update -> do putWord8 1; put update CreateCheckpoint -> putWord8 2 + CreateArchive -> putWord8 3 get = do tag <- getWord8 case tag of 0 -> liftM RunQuery get 1 -> liftM RunUpdate get 2 -> return CreateCheckpoint + 3 -> return CreateArchive _ -> error $ "Serialize.get for Command, invalid tag: " ++ show tag data Response = Result Lazy.ByteString | Acknowledgement | ConnectionError @@ -316,7 +322,8 @@ writeChan chan (liftM Result $ takeMVar result) CreateCheckpoint -> do createCheckpoint acidState writeChan chan (return Acknowledgement) - + CreateArchive -> do createArchive acidState + writeChan chan (return Acknowledgement) data RemoteState st = RemoteState (Command -> IO (MVar Response)) (IO ()) deriving (Typeable) @@ -477,7 +484,6 @@ remoteQueryCold rs event Acknowledgement -> error "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) @@ -505,6 +511,11 @@ = do Acknowledgement <- takeMVar =<< fn CreateCheckpoint return () +createRemoteArchive :: RemoteState st -> IO () +createRemoteArchive (RemoteState fn _shutdown) + = do Acknowledgement <- takeMVar =<< fn CreateArchive + return () + toAcidState :: IsAcidic st => RemoteState st -> AcidState st toAcidState remote = AcidState { _scheduleUpdate = scheduleRemoteUpdate remote @@ -512,6 +523,8 @@ , _query = remoteQuery remote , queryCold = remoteQueryCold remote , createCheckpoint = createRemoteCheckpoint remote + , createArchive = createRemoteArchive remote , closeAcidState = closeRemoteState remote , acidSubState = mkAnyState remote } +