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.4.3 +Version: 0.5.0 -- A short (one-line) description of the package. Synopsis: Add ACID guarantees to any serializable Haskell data structure. @@ -46,12 +46,13 @@ Library -- Modules exported by the library. Exposed-Modules: Data.Acid, Data.Acid.Core, - Data.Acid.Local + Data.Acid.Local, Data.Acid.Memory, + Data.Acid.Memory.Pure -- Modules not exported by this package. Other-modules: Data.Acid.Log, Data.Acid.Archive, Data.Acid.CRC, Paths_acid_state, - Data.Acid.TemplateHaskell + Data.Acid.TemplateHaskell, Data.Acid.Common -- Packages needed in order to build this package. Build-depends: base >= 4 && < 5, cereal >= 0.3.2.0, safecopy >= 0.5, bytestring, stm, diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -2,6 +2,7 @@ module Main (main) where import Data.Acid +import qualified Data.Acid.Memory.Pure as Pure import Control.Monad.State import Control.Monad.Reader diff --git a/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid +import Data.Acid (makeAcidic) import Data.Acid.Local +import qualified Data.Acid.Memory.Pure as Pure import Control.Monad.State import Control.Monad.Reader diff --git a/src/Data/Acid/Common.hs b/src/Data/Acid/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Common.hs @@ -0,0 +1,78 @@ +{- LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, + FlexibleContexts, BangPatterns, CPP -} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Acid.Common +-- Copyright : PublicDomain +-- +-- Maintainer : lemmih@gmail.com +-- Portability : non-portable (uses GHC extensions) +-- +-- Common structures used by the various backends (local, memory). +-- +module Data.Acid.Common where + +import Data.Acid.Core + +import Control.Monad.State +import Control.Monad.Reader +import Data.SafeCopy +import Control.Applicative + +class (SafeCopy st) => 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 } +#if MIN_VERSION_mtl(2,0,0) + deriving (Monad, Functor, Applicative, MonadState st) +#else + deriving (Monad, Functor, MonadState st) +#endif + +-- | Context monad for Query events. +newtype Query st a = Query { unQuery :: Reader st a } +#if MIN_VERSION_mtl(2,0,0) + deriving (Monad, Functor, Applicative, MonadReader st) +#else + deriving (Monad, Functor, MonadReader st) +#endif + +-- | Run a query in the Update Monad. +runQuery :: Query st a -> Update st a +runQuery query + = do st <- get + return (runReader (unQuery query) st) + +-- | Events return the same thing as Methods. The exact type of 'EventResult' +-- depends on the event. +type EventResult ev = MethodResult ev + +type EventState ev = MethodState ev + +-- | We distinguish between events that modify the state and those that do not. +-- +-- UpdateEvents are executed in a MonadState context and have to be serialized +-- to disk before they are considered durable. +-- +-- 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) + +-- | All UpdateEvents are also Methods. +class Method ev => UpdateEvent ev +-- | All QueryEvents are also Methods. +class Method ev => QueryEvent ev + + +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) + ) diff --git a/src/Data/Acid/Core.hs b/src/Data/Acid/Core.hs --- a/src/Data/Acid/Core.hs +++ b/src/Data/Acid/Core.hs @@ -17,7 +17,7 @@ -- \'Method\' is loosely used for state operations without ACID guarantees -- module Data.Acid.Core - ( Core + ( Core(coreMethods) , Method(..) , MethodContainer(..) , Tagged @@ -31,6 +31,8 @@ , lookupColdMethod , runHotMethod , runColdMethod + , MethodMap + , mkMethodMap ) where import Control.Concurrent ( MVar, newMVar, withMVar @@ -149,13 +151,14 @@ runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method) runHotMethod core method = modifyCoreState core $ \st -> - do let (a, st') = runState (lookupHotMethod core method) st + do let (a, st') = runState (lookupHotMethod (coreMethods core) method) st return ( st', a) -- | Find the state action that corresponds to an in-memory method. -lookupHotMethod :: Method method => Core (MethodState method) -> method -> State (MethodState method) (MethodResult method) -lookupHotMethod core method - = case Map.lookup (methodTag method) (coreMethods core) of +lookupHotMethod :: Method method => MethodMap (MethodState method) -> method + -> State (MethodState method) (MethodResult method) +lookupHotMethod methodMap method + = case Map.lookup (methodTag method) methodMap of Nothing -> missingMethod (methodTag method) Just (Method methodHandler) -> -- If the methodTag doesn't index the right methodHandler then we're in deep 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 @@ -38,11 +38,11 @@ import Data.Acid.Log as Log import Data.Acid.Core +import Data.Acid.Common import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) --import Control.Exception ( evaluate ) -import Control.Monad.State ( MonadState, State, get, runState ) -import Control.Monad.Reader ( Reader, runReader, MonadReader ) +import Control.Monad.State ( runState ) import Control.Monad.Trans ( MonadIO(liftIO) ) import Control.Applicative ( (<$>), (<*>) ) import Data.ByteString.Lazy ( ByteString ) @@ -55,38 +55,7 @@ import Data.Typeable ( Typeable, typeOf ) import System.FilePath ( () ) -import Control.Applicative (Applicative(..)) --- | Events return the same thing as Methods. The exact type of 'EventResult' --- depends on the event. -type EventResult ev = MethodResult ev - -type EventState ev = MethodState ev - --- | We distinguish between events that modify the state and those that do not. --- --- UpdateEvents are executed in a MonadState context and have to be serialized --- to disk before they are considered durable. --- --- 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) - --- | All UpdateEvents are also Methods. -class Method ev => UpdateEvent ev --- | All QueryEvents are also Methods. -class Method ev => QueryEvent ev - - -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) - ) {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) guarantees. @@ -106,28 +75,7 @@ , localCheckpoints :: FileLog Checkpoint } --- | Context monad for Update events. -newtype Update st a = Update { unUpdate :: State st a } -#if MIN_VERSION_mtl(2,0,0) - deriving (Monad, Functor, Applicative, MonadState st) -#else - deriving (Monad, Functor, MonadState st) -#endif --- | Context monad for Query events. -newtype Query st a = Query { unQuery :: Reader st a } -#if MIN_VERSION_mtl(2,0,0) - deriving (Monad, Functor, Applicative, MonadReader st) -#else - deriving (Monad, Functor, MonadReader st) -#endif - --- | Run a query in the Update Monad. -runQuery :: Query st a -> Update st a -runQuery query - = do st <- get - return (runReader (unQuery query) st) - -- | Issue an Update event and wait for its result. Once this call returns, you are -- guaranteed that the changes to the state are durable. Events may be issued in -- parallel. @@ -160,7 +108,7 @@ pushEntry (localEvents acidState) (methodTag event, encoded) $ putMVar mvar result return st' return mvar - where hotMethod = lookupHotMethod (localCore acidState) event + where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event -- | Same as 'update' but lifted into any monad capable of doing IO. update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) @@ -178,7 +126,7 @@ pushAction (localEvents acidState) $ putMVar mvar result takeMVar mvar - where hotMethod = lookupHotMethod (localCore acidState) event + where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event -- | Same as 'query' but lifted into any monad capable of doing IO. query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) @@ -226,9 +174,6 @@ safePut content getCopy = contain $ Checkpoint <$> safeGet <*> safeGet -class (SafeCopy st) => IsAcidic st where - acidEvents :: [Event st] - -- ^ List of events capable of updating or querying the state. -- | Create an AcidState given an initial value. -- diff --git a/src/Data/Acid/Memory.hs b/src/Data/Acid/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Memory.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, + GeneralizedNewtypeDeriving, BangPatterns, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Acid.Memory +-- Copyright : PublicDomain +-- +-- Maintainer : lemmih@gmail.com +-- Portability : non-portable (uses GHC extensions) +-- +-- AcidState container without a transaction log. Mostly used for testing. +-- + +module Data.Acid.Memory + ( IsAcidic(..) + , AcidState + , Event(..) + , EventResult + , EventState + , UpdateEvent + , QueryEvent + , Update + , Query + , openAcidState + , closeAcidState + , createCheckpoint + , createCheckpointAndClose + , update + , scheduleUpdate + , query + , update' + , query' + , runQuery + ) where + +import Data.Acid.Core +import Data.Acid.Common + +import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) +import Control.Monad.State ( runState ) +import Control.Monad.Trans ( MonadIO(liftIO) ) + + +import Data.SafeCopy ( SafeCopy(..) ) + + +{-| 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). +-} +data AcidState st + = AcidState { localCore :: Core st + } + +-- | Issue an Update event and wait for its result. Once this call returns, you are +-- guaranteed that the changes to the state are durable. Events may be issued in +-- parallel. +-- +-- It's a run-time error to issue events that aren't supported by the AcidState. +update :: UpdateEvent event => AcidState (EventState event) -> event -> IO (EventResult event) +update acidState event + = takeMVar =<< scheduleUpdate acidState event + +-- | 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'. +-- +-- If EventA is scheduled before EventB, EventA /will/ be executed before EventB: +-- +-- @ +--do scheduleUpdate acid EventA +-- scheduleUpdate acid EventB +-- @ +scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event)) +scheduleUpdate acidState event + = do mvar <- newEmptyMVar + modifyCoreState_ (localCore acidState) $ \st -> + do let !(result, !st') = runState hotMethod st + putMVar mvar result + return st' + return mvar + where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event + +-- | Same as 'update' but lifted into any monad capable of doing IO. +update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) +update' acidState event + = liftIO (update acidState event) + +-- | 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 acidState event + = do mvar <- newEmptyMVar + withCoreState (localCore acidState) $ \st -> + do let (result, _st) = runState hotMethod st + putMVar mvar result + takeMVar mvar + where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event + +-- | 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) + +-- | This is a nop with the memory backend. +createCheckpoint :: SafeCopy st => AcidState st -> IO () +createCheckpoint acidState + = return () + +-- | This is an alias for 'closeAcidState' when using the memory backend. +createCheckpointAndClose :: SafeCopy st => AcidState st -> IO () +createCheckpointAndClose = closeAcidState + + +-- | Create an AcidState given an initial value. +openAcidState :: (IsAcidic st) + => st -- ^ Initial state value. + -> IO (AcidState st) +openAcidState initialState + = do core <- mkCore (eventsToMethods acidEvents) initialState + return AcidState { localCore = core } + +-- | Close an AcidState and associated logs. +-- Any subsequent usage of the AcidState will throw an exception. +closeAcidState :: AcidState st -> IO () +closeAcidState acidState + = closeCore (localCore acidState) + diff --git a/src/Data/Acid/Memory/Pure.hs b/src/Data/Acid/Memory/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Memory/Pure.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, + GeneralizedNewtypeDeriving, BangPatterns, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Acid.Memory.Pure +-- Copyright : PublicDomain +-- +-- Maintainer : lemmih@gmail.com +-- Portability : non-portable (uses GHC extensions) +-- +-- AcidState container without a transaction log. Mostly used for testing. +-- + +module Data.Acid.Memory.Pure + ( IsAcidic(..) + , AcidState + , Event(..) + , EventResult + , EventState + , UpdateEvent + , QueryEvent + , Update + , Query + , openAcidState + , update + , update_ + , query + , runQuery + ) where + +import Data.Acid.Core +import Data.Acid.Common + +import Control.Monad.State ( runState ) + + +{-| 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). +-} +data AcidState st + = AcidState { localMethods :: MethodMap st + , localState :: st + } + +-- | Issue an Update event and wait for its result. Once this call returns, you are +-- guaranteed that the changes to the state are durable. Events may be issued in +-- parallel. +-- +-- It's a run-time error to issue events that aren't supported by the AcidState. +update :: UpdateEvent event => AcidState (EventState event) -> event -> ( AcidState (EventState event) + , EventResult event) +update acidState event + = case runState hotMethod (localState acidState) of + !(result, !newState) -> ( acidState { localState = newState } + , result ) + where hotMethod = lookupHotMethod (localMethods acidState) event + +-- | Same as 'update' but ignoring the event result. +update_ :: UpdateEvent event => AcidState (EventState event) -> event -> AcidState (EventState event) +update_ acidState event + = fst (update acidState event) + +-- | Issue a Query event and wait for its result. +query :: QueryEvent event => AcidState (EventState event) -> event -> EventResult event +query acidState event + = case runState hotMethod (localState acidState) of + !(result, !_st) -> result + where hotMethod = lookupHotMethod (localMethods acidState) event + +-- | Create an AcidState given an initial value. +openAcidState :: (IsAcidic st) + => st -- ^ Initial state value. + -> (AcidState st) +openAcidState initialState + = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) + , localState = initialState } +