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.3.3 +Version: 0.4 -- A short (one-line) description of the package. Synopsis: Add ACID guarantees to any serializable Haskell data structure. @@ -37,7 +37,7 @@ -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: examples/*.hs +Extra-source-files: examples/*.hs, examples/errors/*.hs -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6 @@ -54,11 +54,13 @@ Data.Acid.TemplateHaskell -- Packages needed in order to build this package. - Build-depends: base >= 4 && < 5, binary, bytestring, stm, filepath, directory, - mtl, array, containers, template-haskell + Build-depends: base >= 4 && < 5, cereal >= 0.3.2.0, safecopy >= 0.5, bytestring, stm, + filepath, directory, mtl, array, containers, template-haskell, unix - Hs-Source-Dirs: src/ - + Hs-Source-Dirs: src/ + + GHC-Options: -fwarn-unused-imports -fwarn-unused-binds + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: diff --git a/examples/HelloDatabase.hs b/examples/HelloDatabase.hs --- a/examples/HelloDatabase.hs +++ b/examples/HelloDatabase.hs @@ -7,14 +7,12 @@ import Control.Monad.Reader ( ask ) import Control.Applicative ( (<$>) ) import System.Environment ( getArgs ) -import qualified Data.Binary as Binary +import Data.SafeCopy type Message = String data Database = Database [Message] -instance Binary.Binary Database where - get = Database <$> Binary.get - put (Database msg) = Binary.put msg +$(deriveSafeCopy 0 'base ''Database) -- Transactions are defined to run in either the 'Update' monad -- or the 'Query' monad. diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,13 +1,12 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid -import qualified Control.Monad.State as State +import Control.Monad.State import Control.Monad.Reader import System.Environment -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -17,16 +16,14 @@ data HelloWorldState = HelloWorldState String deriving (Show, Typeable) -instance Binary HelloWorldState where - put (HelloWorldState state) = put state - get = liftM HelloWorldState get +$(deriveSafeCopy 0 'base ''HelloWorldState) ------------------------------------------------------ -- The transaction we will execute over the state. writeState :: String -> Update HelloWorldState () writeState newValue - = State.put (HelloWorldState newValue) + = put (HelloWorldState newValue) queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -4,10 +4,10 @@ import Data.Acid.Core import Data.Acid.Local -import qualified Control.Monad.State as State +import Control.Monad.State import Control.Monad.Reader import System.Environment -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -17,16 +17,16 @@ data HelloWorldState = HelloWorldState String deriving (Show, Typeable) -instance Binary HelloWorldState where - put (HelloWorldState state) = put state - get = liftM HelloWorldState get +instance SafeCopy HelloWorldState where + putCopy (HelloWorldState state) = contain $ safePut state + getCopy = contain $ liftM HelloWorldState safeGet ------------------------------------------------------ -- The transaction we will execute over the state. writeState :: String -> Update HelloWorldState () writeState newValue - = State.put (HelloWorldState newValue) + = put (HelloWorldState newValue) queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask @@ -55,18 +55,18 @@ deriving instance Typeable WriteState -instance Binary WriteState where - put (WriteState st) = put st - get = liftM WriteState get +instance SafeCopy WriteState where + putCopy (WriteState st) = contain $ safePut st + getCopy = contain $ liftM WriteState safeGet instance Method WriteState where type MethodResult WriteState = () type MethodState WriteState = HelloWorldState instance UpdateEvent WriteState deriving instance Typeable QueryState -instance Binary QueryState where - put QueryState = return () - get = return QueryState +instance SafeCopy QueryState where + putCopy QueryState = contain $ return () + getCopy = contain $ return QueryState instance Method QueryState where type MethodResult QueryState = String type MethodState QueryState = HelloWorldState diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -1,15 +1,14 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid -import qualified Control.Monad.State as State +import Control.Monad.State import Control.Monad.Reader import Control.Applicative import System.Environment import System.IO -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -24,17 +23,15 @@ data KeyValue = KeyValue !(Map.Map Key Value) deriving (Typeable) -instance Binary KeyValue where - put (KeyValue state) = put state - get = liftM KeyValue get +$(deriveSafeCopy 0 'base ''KeyValue) ------------------------------------------------------ -- The transaction we will execute over the state. insertKey :: Key -> Value -> Update KeyValue () insertKey key value - = do KeyValue m <- State.get - State.put (KeyValue (Map.insert key value m)) + = do KeyValue m <- get + put (KeyValue (Map.insert key value m)) lookupKey :: Key -> Query KeyValue (Maybe Value) lookupKey key diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -9,7 +9,7 @@ import Control.Applicative import System.Environment import System.IO -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -24,9 +24,9 @@ data KeyValue = KeyValue !(Map.Map Key Value) deriving (Typeable) -instance Binary KeyValue where - put (KeyValue state) = put state - get = liftM KeyValue get +instance SafeCopy KeyValue where + putCopy (KeyValue state) = contain $ safePut state + getCopy = contain $ liftM KeyValue safeGet ------------------------------------------------------ -- The transaction we will execute over the state. @@ -72,18 +72,18 @@ deriving instance Typeable InsertKey -instance Binary InsertKey where - put (InsertKey key value) = put key >> put value - get = InsertKey <$> get <*> get +instance SafeCopy InsertKey where + putCopy (InsertKey key value) = contain $ safePut key >> safePut value + getCopy = contain $ InsertKey <$> safeGet <*> safeGet instance Method InsertKey where type MethodResult InsertKey = () type MethodState InsertKey = KeyValue instance UpdateEvent InsertKey deriving instance Typeable LookupKey -instance Binary LookupKey where - put (LookupKey key) = put key - get = LookupKey <$> get +instance SafeCopy LookupKey where + putCopy (LookupKey key) = contain $ safePut key + getCopy = contain $ LookupKey <$> safeGet instance Method LookupKey where type MethodResult LookupKey = Maybe Value type MethodState LookupKey = KeyValue diff --git a/examples/SlowCheckpoint.hs b/examples/SlowCheckpoint.hs new file mode 100644 --- /dev/null +++ b/examples/SlowCheckpoint.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid + +import Control.Monad.State +import Control.Concurrent +import Data.Time +import System.IO +import Data.SafeCopy + +------------------------------------------------------ +-- 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 <- openAcidStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) + putStrLn "This example illustrates that the state is still accessible while" + putStrLn "a checkpoint is being serialized. This is an important property when" + putStrLn "the size of a checkpoint reaches several hundred megabytes." + putStrLn "If you don't see any ticks while the creating is being created, something" + putStrLn "has gone awry." + putStrLn "" + doTick acid + update acid SetComputationallyHeavyData + forkIO $ do putStrLn "Seriazing checkpoint..." + t <- timeIt $ createCheckpoint acid + putStrLn $ "Checkpoint created in: " ++ show t + replicateM_ 20 $ + do doTick acid + threadDelay (10^5) + +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/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -1,14 +1,14 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid +import Data.Acid.Local -import qualified Control.Monad.State as State +import Control.Monad.State import Control.Monad.Reader import System.Environment import System.IO -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -16,18 +16,16 @@ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int - deriving (Show, Typeable) + deriving (Typeable) -instance Binary StressState where - put (StressState state) = put state - get = liftM StressState get +$(deriveSafeCopy 0 'base ''StressState) ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update StressState () -pokeState = do StressState i <- State.get - State.put (StressState (i+1)) +pokeState = do StressState i <- get + put (StressState (i+1)) queryState :: Query StressState Int queryState = do StressState i <- ask @@ -39,21 +37,23 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (StressState 0) - args <- getArgs +main = do args <- getArgs case args of ["checkpoint"] - -> createCheckpoint acid + -> do acid <- openAcidState (StressState 0) + createCheckpoint acid ["query"] - -> do n <- query acid QueryState + -> do acid <- openAcidState (StressState 0) + n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] - -> do putStr "Issuing 10k sequential transactions... " + -> do acid <- openAcidState (StressState 0) + putStr "Issuing 100k transactions... " hFlush stdout - replicateM_ 10000 (update acid PokeState) + replicateM_ (100000-1) (scheduleUpdate acid PokeState) + update acid PokeState putStrLn "Done" _ -> do putStrLn $ "Commands:" putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 10k transactions." + putStrLn $ " poke Spawn 100k transactions." putStrLn $ " checkpoint Create a new checkpoint." - closeAcidState acid diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -4,11 +4,11 @@ import Data.Acid.Core import Data.Acid.Local -import qualified Control.Monad.State as State +import Control.Monad.State import Control.Monad.Reader import System.Environment import System.IO -import Data.Binary +import Data.SafeCopy import Data.Typeable @@ -16,18 +16,18 @@ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int - deriving (Show, Typeable) + deriving (Typeable) -instance Binary StressState where - put (StressState state) = put state - get = liftM StressState get +instance SafeCopy StressState where + putCopy (StressState state) = contain $ safePut state + getCopy = contain $ liftM StressState safeGet ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update StressState () -pokeState = do StressState i <- State.get - State.put (StressState (i+1)) +pokeState = do StressState i <- get + put (StressState (i+1)) queryState :: Query StressState Int queryState = do StressState i <- ask @@ -38,27 +38,28 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (StressState 0) - args <- getArgs +main = do args <- getArgs case args of ["checkpoint"] - -> createCheckpoint acid + -> do acid <- openAcidState (StressState 0) + createCheckpoint acid ["query"] - -> do n <- query acid QueryState + -> do acid <- openAcidState (StressState 0) + n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] - -> do putStr "Issuing 10k sequential transactions... " + -> do acid <- openAcidState (StressState 0) + putStr "Issuing 100k transactions... " hFlush stdout - replicateM_ 10000 (update acid PokeState) + replicateM_ (100000-1) (scheduleUpdate acid PokeState) + update acid PokeState putStrLn "Done" _ -> do putStrLn $ "Commands:" putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 10k transactions." + putStrLn $ " poke Spawn 100k transactions." putStrLn $ " checkpoint Create a new checkpoint." - closeAcidState acid - ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future. @@ -68,18 +69,18 @@ deriving instance Typeable PokeState -instance Binary PokeState where - put PokeState = return () - get = return PokeState +instance SafeCopy PokeState where + putCopy PokeState = contain $ return () + getCopy = contain $ return PokeState instance Method PokeState where type MethodResult PokeState = () type MethodState PokeState = StressState instance UpdateEvent PokeState deriving instance Typeable QueryState -instance Binary QueryState where - put QueryState = return () - get = return QueryState +instance SafeCopy QueryState where + putCopy QueryState = contain $ return () + getCopy = contain $ return QueryState instance Method QueryState where type MethodResult QueryState = Int type MethodState QueryState = StressState diff --git a/examples/errors/ChangeState.hs b/examples/errors/ChangeState.hs new file mode 100644 --- /dev/null +++ b/examples/errors/ChangeState.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid + +import Control.Monad.State +import System.Environment +import Data.SafeCopy + +import Data.Typeable + +import Control.Exception +import Prelude hiding (catch) + +import qualified Data.Text as Text + + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data FirstState = FirstState String + deriving (Show) + +data SecondState = SecondState Text.Text + deriving (Show) + +$(deriveSafeCopy 0 'base ''FirstState) +$(deriveSafeCopy 0 'base ''SecondState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +$(makeAcidic ''FirstState []) +$(makeAcidic ''SecondState []) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do putStrLn "This example simulates what happens when you modify your state type" + putStrLn "without telling AcidState how to migrate from the old version to the new." + putStrLn "Hopefully this program will fail with a readable error message." + putStrLn "" + firstAcid <- openAcidStateFrom "state/ChangeState" (FirstState "first state") + createCheckpoint firstAcid + closeAcidState firstAcid + + secondAcid <- openAcidStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used")) + closeAcidState secondAcid + putStrLn "If you see this message then something has gone wrong!" diff --git a/examples/errors/Exceptions.hs b/examples/errors/Exceptions.hs new file mode 100644 --- /dev/null +++ b/examples/errors/Exceptions.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid + +import Control.Monad.State +import System.Environment +import Data.SafeCopy + +import Data.Typeable + +import Control.Exception +import Prelude hiding (catch) + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +newtype MyState = MyState Integer + deriving (Show, Typeable) + +$(deriveSafeCopy 0 'base ''MyState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +failEvent :: Update MyState () +failEvent = fail "fail!" + +errorEvent :: Update MyState () +errorEvent = error "error!" + +stateError :: Update MyState () +stateError = put (error "state error!") + +tick :: Update MyState Integer +tick = do MyState n <- get + put $ MyState (n+1) + return n + +$(makeAcidic ''MyState ['failEvent, 'errorEvent, 'stateError, 'tick]) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do acid <- openAcidStateFrom "state/Exceptions" (MyState 0) + args <- getArgs + case args of + ["1"] -> update acid (undefined :: FailEvent) + ["2"] -> update acid FailEvent + ["3"] -> update acid ErrorEvent + ["4"] -> update acid StateError + _ -> do putStrLn "Call with '1', '2', '3' or '4' to test error scenarios." + n <- update acid Tick + putStrLn $ "Tick: " ++ show n + `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException) + createCheckpointAndClose acid diff --git a/examples/errors/RemoveEvent.hs b/examples/errors/RemoveEvent.hs new file mode 100644 --- /dev/null +++ b/examples/errors/RemoveEvent.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid + +import Control.Monad.State +import System.Environment +import Data.SafeCopy + +import Data.Typeable + +import Control.Exception +import Prelude hiding (catch) + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data FirstState = FirstState + deriving (Show) + +data SecondState = SecondState + deriving (Show) + +$(deriveSafeCopy 0 'base ''FirstState) +$(deriveSafeCopy 0 'base ''SecondState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +firstEvent :: Update FirstState () +firstEvent = return () + +$(makeAcidic ''FirstState ['firstEvent]) +$(makeAcidic ''SecondState []) + +------------------------------------------------------ +-- This is how AcidState is used: + +main :: IO () +main = do putStrLn "This example simulates what happens when you remove an event" + putStrLn "that is required to replay the journal." + putStrLn "Hopefully this program will fail with a readable error message." + putStrLn "" + firstAcid <- openAcidStateFrom "state/RemoveEvent" FirstState + update firstAcid FirstEvent + closeAcidState firstAcid + + secondAcid <- openAcidStateFrom "state/RemoveEvent" SecondState + closeAcidState secondAcid + putStrLn "If you see this message then something has gone wrong!" diff --git a/src/Data/Acid.hs b/src/Data/Acid.hs --- a/src/Data/Acid.hs +++ b/src/Data/Acid.hs @@ -19,9 +19,13 @@ , openAcidStateFrom , closeAcidState , createCheckpoint + , createCheckpointAndClose , update , query + , update' + , query' , EventResult + , EventState , UpdateEvent , QueryEvent , Update diff --git a/src/Data/Acid/Archive.hs b/src/Data/Acid/Archive.hs --- a/src/Data/Acid/Archive.hs +++ b/src/Data/Acid/Archive.hs @@ -17,8 +17,9 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict -import Data.Binary.Get -import Data.Binary.Builder +import qualified Data.Serialize.Get as Serialize +import Data.Serialize.Get hiding (Result(..)) +import Data.Serialize.Builder import Data.Monoid type Entry = Lazy.ByteString @@ -51,23 +52,25 @@ readEntries :: Lazy.ByteString -> Entries readEntries bs - | Lazy.null bs - = Done - | Lazy.length header < headerSize - = Fail "Incomplete header." - | Lazy.length content /= fromIntegral contentLength - = Fail "Insuficient content." - | crc16 content /= contentHash - = Fail "Invalid hash" - | otherwise - = Next content (readEntries rest) - where header = Lazy.take headerSize bs - headerSize = 10 - contentLength = fromIntegral $ runGet getWord64le header - contentHash = runGet getWord16le $ Lazy.drop 8 header - content = Lazy.take contentLength $ Lazy.drop headerSize bs - rest = Lazy.drop (contentLength+headerSize) bs - -lazyToStrict :: Lazy.ByteString -> Strict.ByteString -lazyToStrict = Strict.concat . Lazy.toChunks + = worker (Lazy.toChunks bs) + where worker [] = Done + worker (x:xs) + = check (runGetPartial readEntry x) xs + check result more + = case result of + Serialize.Done entry rest + | Strict.null rest -> Next entry (worker more) + | otherwise -> Next entry (worker (rest:more)) + Serialize.Fail msg -> Fail msg + Serialize.Partial cont -> case more of + [] -> check (cont Strict.empty) [] + (x:xs) -> check (cont x) xs +readEntry :: Get Entry +readEntry + = do contentLength <- getWord64le + contentChecksum <-getWord16le + content <- getLazyByteString (fromIntegral contentLength) + if crc16 content /= contentChecksum + then fail "Invalid hash" + else return content 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 @@ -23,6 +23,7 @@ , Tagged , mkCore , closeCore + , closeCore' , modifyCoreState , modifyCoreState_ , withCoreState @@ -32,37 +33,37 @@ , runColdMethod ) where -import Control.Concurrent -import Control.Monad -import Control.Monad.State (State, runState ) +import Control.Concurrent ( MVar, newMVar, withMVar + , modifyMVar, modifyMVar_ ) +import Control.Monad ( liftM ) +import Control.Monad.State ( State, runState ) import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8 +import Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) -import Data.Binary +import Data.Serialize ( runPutLazy, runGetLazy ) +import Data.SafeCopy ( SafeCopy, safeGet, safePut ) -import Data.Typeable -import Unsafe.Coerce (unsafeCoerce) +import Data.Typeable ( Typeable, typeOf ) +import Unsafe.Coerce ( unsafeCoerce ) -- | The basic Method class. Each Method has an indexed result type -- and a unique tag. -class ( Typeable ev, Binary ev - , Typeable (MethodResult ev), Binary (MethodResult ev)) => +class ( Typeable ev, SafeCopy ev + , Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where type MethodResult ev type MethodState ev methodTag :: ev -> Tag - methodTag ev = Lazy.Char8.pack (show (typeOf ev)) + methodTag ev = Lazy.pack (show (typeOf ev)) -- | The control structure at the very center of acid-state. -- This module provides access to a mutable state through -- methods. No efforts towards durability, checkpointing or -- sharding happens at this level. -- Important things to keep in mind in this module: --- -- * We don't distinguish between updates and queries. --- -- * We allow direct access to the core state as well -- as through events. data Core st @@ -82,16 +83,23 @@ -- | Mark Core as closed. Any subsequent use will throw an exception. closeCore :: Core st -> IO () closeCore core - = do swapMVar (coreState core) errorMsg - return () + = closeCore' core (\_st -> return ()) + +-- | Access the state and then mark the Core as closed. Any subsequent use +-- will throw an exception. +closeCore' :: Core st -> (st -> IO ()) -> IO () +closeCore' core action + = modifyMVar_ (coreState core) $ \st -> + do action st + return errorMsg where errorMsg = error "Access failure: Core closed." -- | Modify the state component. The resulting state is ensured to be in -- WHNF. modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a modifyCoreState core action - = modifyMVar (coreState core) $ \st -> do (!st, a) <- action st - return (st, a) + = modifyMVar (coreState core) $ \st -> do (!st', a) <- action st + return (st', a) -- | Modify the state component. The resulting state is ensured to be in -- WHNF. @@ -118,13 +126,25 @@ return ( st', a) -- | Find the state action that corresponds to a tagged and serialized method. -lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> (State st Lazy.ByteString) -lookupColdMethod core (methodTag, methodContent) - = case Map.lookup methodTag (coreMethods core) of - Nothing -> error $ "Method tag doesn't exist: " ++ show methodTag +lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> State st Lazy.ByteString +lookupColdMethod core (storedMethodTag, methodContent) + = case Map.lookup storedMethodTag (coreMethods core) of + Nothing -> missingMethod storedMethodTag Just (Method method) - -> liftM encode (method (decode methodContent)) - + -> liftM (runPutLazy . safePut) (method (lazyDecode methodContent)) + +lazyDecode :: SafeCopy a => Lazy.ByteString -> a +lazyDecode inp + = case runGetLazy safeGet inp of + Left msg -> error msg + Right val -> val + +missingMethod :: Tag -> a +missingMethod tag + = error msg + where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) ++ + ". Did you perhaps remove it before creating a checkpoint?" + -- | Apply an in-memory method to the state. runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method) runHotMethod core method @@ -136,7 +156,7 @@ lookupHotMethod :: Method method => Core (MethodState method) -> method -> State (MethodState method) (MethodResult method) lookupHotMethod core method = case Map.lookup (methodTag method) (coreMethods core) of - Nothing -> error $ "Method type doesn't exist: " ++ show (typeOf method) + Nothing -> missingMethod (methodTag method) Just (Method methodHandler) -> -- If the methodTag doesn't index the right methodHandler then we're in deep -- trouble. Luckly, it would take deliberate malevolence for that to happen. 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 @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, - MagicHash, GeneralizedNewtypeDeriving #-} + GeneralizedNewtypeDeriving, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local @@ -18,6 +18,7 @@ , AcidState , Event(..) , EventResult + , EventState , UpdateEvent , QueryEvent , Update @@ -26,23 +27,33 @@ , openAcidStateFrom , closeAcidState , createCheckpoint + , createCheckpointAndClose , update + , scheduleUpdate , query + , update' + , query' ) where import Data.Acid.Log as Log import Data.Acid.Core -import Control.Concurrent -import qualified Control.Monad.State as State -import Control.Monad.Reader -import Control.Applicative -import qualified Data.ByteString.Lazy as Lazy +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.Trans ( MonadIO(liftIO) ) +import Control.Applicative ( (<$>), (<*>) ) +import Data.ByteString.Lazy ( ByteString ) +--import qualified Data.ByteString.Lazy as Lazy ( length ) -import Data.Binary -import Data.Typeable -import System.FilePath +import Data.Serialize ( runPutLazy, runGetLazy ) +import Data.SafeCopy ( SafeCopy(..), safeGet, safePut + , primitive, contain ) +import Data.Typeable ( Typeable, typeOf ) +import System.FilePath ( () ) + -- | Events return the same thing as Methods. The exact type of 'EventResult' -- depends on the event. type EventResult ev = MethodResult ev @@ -70,7 +81,7 @@ eventsToMethods = map worker where worker :: Event st -> MethodContainer st worker (UpdateEvent fn) = Method (unUpdate . fn) - worker (QueryEvent fn) = Method (\ev -> do st <- State.get + worker (QueryEvent fn) = Method (\ev -> do st <- get return (runReader (unQuery $ fn ev) st) ) {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) @@ -89,13 +100,13 @@ -} data AcidState st = AcidState { localCore :: Core st - , localEvents :: FileLog (Tagged Lazy.ByteString) + , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog Checkpoint } -- | Context monad for Update events. -newtype Update st a = Update { unUpdate :: State.State st a } - deriving (Monad, State.MonadState st) +newtype Update st a = Update { unUpdate :: State st a } + deriving (Monad, MonadState st) -- | Context monad for Query events. newtype Query st a = Query { unQuery :: Reader st a } @@ -108,48 +119,98 @@ -- 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 - let encodedEvent = encode event - Lazy.length encodedEvent `seq` - modifyCoreState_ (localCore acidState) $ \st -> - do let !(result, st') = State.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, encodedEvent) $ putMVar mvar result - return st' - takeMVar mvar + let encoded = runPutLazy (safePut event) + --evaluate (Lazy.length encoded) -- It would be best to encode the event before we lock the core + -- but it hurts performance /-: + modifyCoreState_ (localCore acidState) $ \st -> + 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 + return st' + return mvar where hotMethod = lookupHotMethod (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 - = runHotMethod (localCore 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 + where hotMethod = lookupHotMethod (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) + -- | Take a snapshot of the state and save it to disk. Creating checkpoints -- makes it faster to resume AcidStates and you're free to create them as -- often or seldom as fits your needs. Transactions can run concurrently -- with this call. -- -- This call will not return until the operation has succeeded. -createCheckpoint :: Binary st => AcidState st -> IO () +createCheckpoint :: SafeCopy st => AcidState st -> IO () createCheckpoint acidState = do mvar <- newEmptyMVar withCoreState (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) - pushEntry (localCheckpoints acidState) (Checkpoint eventId (encode st)) (putMVar mvar ()) + pushAction (localEvents acidState) $ + do let encoded = runPutLazy (safePut st) + pushEntry (localCheckpoints acidState) (Checkpoint eventId encoded) (putMVar mvar ()) takeMVar mvar - +-- | Save a snapshot to disk and close the AcidState as a single atomic +-- action. This is useful when you want to make sure that no events +-- are saved to disk after a checkpoint. +createCheckpointAndClose :: SafeCopy st => AcidState st -> IO () +createCheckpointAndClose acidState + = do mvar <- newEmptyMVar + closeCore' (localCore acidState) $ \st -> + do eventId <- askCurrentEntryId (localEvents acidState) + pushAction (localEvents acidState) $ + pushEntry (localCheckpoints acidState) (Checkpoint eventId (runPutLazy (safePut st))) (putMVar mvar ()) + takeMVar mvar + closeFileLog (localEvents acidState) + closeFileLog (localCheckpoints acidState) -data Checkpoint = Checkpoint EntryId Lazy.ByteString -instance Binary Checkpoint where - put (Checkpoint eventEntryId content) - = do put eventEntryId - put content - get = Checkpoint <$> get <*> get +data Checkpoint = Checkpoint EntryId ByteString -class (Binary st) => IsAcidic st where +instance SafeCopy Checkpoint where + kind = primitive + putCopy (Checkpoint eventEntryId content) + = contain $ + do safePut eventEntryId + 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. @@ -184,7 +245,9 @@ Nothing -> return 0 Just (Checkpoint eventCutOff content) - -> do modifyCoreState_ core (\_oldState -> return (decode content)) + -> do modifyCoreState_ core (\_oldState -> case runGetLazy safeGet content of + Left msg -> checkpointRestoreError msg + Right val -> return val) return eventCutOff eventsLog <- openFileLog eventsLogKey @@ -195,6 +258,9 @@ , localEvents = eventsLog , localCheckpoints = checkpointsLog } + +checkpointRestoreError msg + = error $ "Could not parse saved checkpoint due to the following error: " ++ msg -- | Close an AcidState and associated logs. -- Any subsequent usage of the AcidState will throw an exception. 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} -- A log is a stack of entries that supports efficient pushing of -- new entries and fetching of old. It can be considered an -- extendible array of entries. @@ -9,6 +10,7 @@ , openFileLog , closeFileLog , pushEntry + , pushAction , readEntriesFrom , newestEntry , askCurrentEntryId @@ -18,14 +20,21 @@ import System.Directory import System.FilePath import System.IO +import System.Posix ( handleToFd, Fd(..), fdWriteBuf + , closeFd ) +import Foreign.C +import Foreign.Ptr import Control.Monad import Control.Concurrent import Control.Concurrent.STM import qualified Data.ByteString.Lazy as Lazy ---import qualified Data.ByteString as Strict +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Unsafe as Strict import Data.List import Data.Maybe -import Data.Binary +import qualified Data.Serialize.Get as Get +import qualified Data.Serialize.Put as Put +import Data.SafeCopy ( safePut, safeGet, SafeCopy ) import Text.Printf ( printf ) @@ -36,7 +45,7 @@ data FileLog object = FileLog { logIdentifier :: LogKey object - , logCurrent :: MVar (Handle) + , logCurrent :: MVar Fd -- Handle , logNextEntryId :: TVar EntryId , logQueue :: TVar ([Lazy.ByteString], [IO ()]) , logThreads :: [ThreadId] @@ -76,23 +85,28 @@ queue <- newTVarIO ([], []) nextEntryRef <- newTVarIO 0 tid2 <- forkIO $ fileWriter currentState queue - let log = FileLog { logIdentifier = identifier - , logCurrent = currentState - , logNextEntryId = nextEntryRef - , logQueue = queue - , logThreads = [tid2] } + let fLog = FileLog { logIdentifier = identifier + , logCurrent = currentState + , logNextEntryId = nextEntryRef + , logQueue = queue + , logThreads = [tid2] } if null logFiles then do let currentEntryId = 0 currentHandle <- openBinaryFile (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) WriteMode - putMVar currentState currentHandle + fd <- handleToFd currentHandle + putMVar currentState fd else do let (lastFileEntryId, lastFilePath) = maximum logFiles entries <- readEntities lastFilePath let currentEntryId = lastFileEntryId + length entries atomically $ writeTVar nextEntryRef currentEntryId - currentHandle <- openFile (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) WriteMode - putMVar currentState currentHandle - return log + currentHandle <- openBinaryFile (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) WriteMode + fd <- handleToFd currentHandle + putMVar currentState fd + return fLog +foreign import ccall "fsync" c_fsync :: CInt -> IO CInt + +fileWriter :: MVar Fd -> TVar ([Lazy.ByteString], [IO ()]) -> IO () fileWriter currentState queue = forever $ do (entries, actions) <- atomically $ do (entries, actions) <- readTVar queue @@ -101,20 +115,39 @@ -- 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 $ \handle -> + withMVar currentState $ \fd -> do let arch = Archive.packEntries entries - Lazy.hPutStr handle arch - hFlush handle - return () + writeToDisk fd (repack arch) sequence_ actions yield +-- Repack a lazy bytestring into larger blocks that can be efficiently written to disk. +repack :: Lazy.ByteString -> [Strict.ByteString] +repack = worker + where worker bs + | Lazy.null bs = [] + | otherwise = Strict.concat (Lazy.toChunks (Lazy.take blockSize bs)) : worker (Lazy.drop blockSize bs) + blockSize = 4*1024 +writeToDisk :: Fd -> [Strict.ByteString] -> IO () +writeToDisk _ [] = return () +writeToDisk fd@(Fd c_fd) xs + = do mapM_ worker xs + c_fsync c_fd + return () + where worker bs + = do let len = Strict.length bs + count <- Strict.unsafeUseAsCString bs $ \ptr -> fdWriteBuf fd (castPtr ptr) (fromIntegral len) + if fromIntegral count < len + then worker (Strict.drop (fromIntegral count) bs) + else return () + + closeFileLog :: FileLog object -> IO () -closeFileLog log - = modifyMVar_ (logCurrent log) $ \handle -> - do hClose handle - forkIO $ forM_ (logThreads log) killThread +closeFileLog fLog + = modifyMVar_ (logCurrent fLog) $ \fd -> + do closeFd fd + _ <- forkIO $ forM_ (logThreads fLog) killThread return $ error "FileLog has been closed" readEntities :: FilePath -> IO [Lazy.ByteString] @@ -129,13 +162,13 @@ -- Read all durable entries younger than the given EntryId. -- Note that entries written during or after this call won't -- be included in the returned list. -readEntriesFrom :: Binary object => FileLog object -> EntryId -> IO [object] -readEntriesFrom log youngestEntry +readEntriesFrom :: SafeCopy object => FileLog object -> EntryId -> IO [object] +readEntriesFrom fLog youngestEntry = do -- Cut the log so we can read written entries without interfering -- with the writing of new entries. - entryCap <- cutFileLog log + entryCap <- cutFileLog fLog -- We're interested in these entries: youngestEntry <= x < entryCap. - logFiles <- findLogFiles (logIdentifier log) + logFiles <- findLogFiles (logIdentifier fLog) let sorted = sort logFiles findRelevant [] = [] findRelevant [ logFile ] @@ -156,9 +189,9 @@ [] -> 0 ( logFile : _logFiles) -> rangeStart logFile - archive <- liftM Lazy.concat $ mapM Lazy.readFile (map snd relevant) + archive <- liftM Lazy.concat $ mapM (Lazy.readFile . snd) relevant let entries = entriesToList $ readEntries archive - return $ map decode + return $ map decode' $ take (entryCap - youngestEntry) -- Take events under the eventCap. $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young. @@ -166,39 +199,37 @@ cutFileLog :: FileLog object -> IO EntryId -cutFileLog log +cutFileLog fLog = do mvar <- newEmptyMVar let action = do currentEntryId <- atomically $ - do (entries, _) <- readTVar (logQueue log) - next <- readTVar (logNextEntryId log) + do (entries, _) <- readTVar (logQueue fLog) + next <- readTVar (logNextEntryId fLog) return (next - length entries) - modifyMVar_ (logCurrent log) $ \old -> - do hClose old - openFile (logDirectory key formatLogFile (logPrefix key) currentEntryId) WriteMode + modifyMVar_ (logCurrent fLog) $ \old -> + do closeFd old + handleToFd =<< openBinaryFile (logDirectory key formatLogFile (logPrefix key) currentEntryId) WriteMode putMVar mvar currentEntryId - atomically $ - do (entries, actions) <- readTVar (logQueue log) - writeTVar (logQueue log) (entries, action : actions) + pushAction fLog action takeMVar mvar - where key = logIdentifier log + where key = logIdentifier fLog -- Finds the newest entry in the log. Doesn't work on open logs. -- Do not use after the log has been opened. -- Implementation: Search the newest log files first. Once a file -- containing at least one valid entry is found, -- return the last entry in that file. -newestEntry :: Binary object => LogKey object -> IO (Maybe object) +newestEntry :: SafeCopy object => LogKey object -> IO (Maybe object) newestEntry identifier = do logFiles <- findLogFiles identifier let sorted = reverse $ sort logFiles - (eventIds, files) = unzip sorted + (_eventIds, files) = unzip sorted archives <- mapM Lazy.readFile files return $ worker archives where worker [] = Nothing worker (archive:archives) = case Archive.readEntries archive of Done -> worker archives - Next entry next -> Just (decode (lastEntry entry next)) + Next entry next -> Just (decode' (lastEntry entry next)) Fail{} -> worker archives lastEntry entry Done = entry lastEntry entry Fail{} = entry @@ -207,15 +238,30 @@ -- Schedule a new log entry. This call does not block -- The given IO action runs once the object is durable. The IO action -- blocks the serialization of events so it should be swift. -pushEntry :: Binary object => FileLog object -> object -> IO () -> IO () -pushEntry log object finally +pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO () +pushEntry fLog object finally = atomically $ - do tid <- readTVar (logNextEntryId log) - writeTVar (logNextEntryId log) (tid+1) - (entries, actions) <- readTVar (logQueue log) - writeTVar (logQueue log) ( encoded : entries, finally : actions ) - where encoded = encode object + do tid <- readTVar (logNextEntryId fLog) + writeTVar (logNextEntryId fLog) (tid+1) + (entries, actions) <- readTVar (logQueue fLog) + writeTVar (logQueue fLog) ( encoded : entries, finally : actions ) + where encoded = Lazy.fromChunks [ Strict.copy $ Put.runPut (safePut object) ] +-- The given IO action is executed once all previous entries are durable. +pushAction :: FileLog object -> IO () -> IO () +pushAction fLog finally + = atomically $ + do (entries, actions) <- readTVar (logQueue fLog) + writeTVar (logQueue fLog) (entries, finally : actions) + askCurrentEntryId :: FileLog object -> IO EntryId -askCurrentEntryId log - = atomically $ readTVar (logNextEntryId log) +askCurrentEntryId fLog + = atomically $ readTVar (logNextEntryId fLog) + + +-- FIXME: Check for unused input. +decode' :: SafeCopy object => Lazy.ByteString -> object +decode' inp + = case Get.runGetLazy safeGet inp of + Left msg -> error msg + Right val -> val 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 @@ -9,7 +9,7 @@ import Data.Acid.Core import Data.Acid.Local -import Data.Binary +import Data.SafeCopy import Data.Typeable import Data.Char import Control.Applicative @@ -52,12 +52,12 @@ _ -> error "Unsupported state type. Only 'data' and 'newtype' are supported." _ -> error "Given state is not a type." -makeEvent :: Name -> Name -> Q [Dec] -makeEvent eventName stateName +makeEvent :: Name -> Q [Dec] +makeEvent eventName = do eventInfo <- reify eventName eventType <- getEventType eventName d <- makeEventDataType eventName eventType - b <- makeBinaryInstance eventName eventType + b <- makeSafeCopyInstance eventName eventType i <- makeMethodInstance eventName eventType e <- makeEventInstance eventName eventType return [d,b,i,e] @@ -70,13 +70,13 @@ -> return eventType _ -> error $ "Events must be functions: " ++ show eventName ---instance (Binary key, Typeable key, Binary val, Typeable val) => IsAcidic State where +--instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where -- acidEvents = [ UpdateEven (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] makeIsAcidic eventNames stateName tyvars constructors = do types <- mapM getEventType eventNames - let preds = [ ''Binary, ''Typeable ] + let preds = [ ''SafeCopy, ''Typeable ] ty = appT (conT ''IsAcidic) stateType - handlers = map (uncurry makeEventHandler) (zip eventNames types) + handlers = zipWith makeEventHandler eventNames types instanceD (mkCxtFromTyVars preds tyvars []) ty [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ] where stateType = foldl appT (conT stateName) [ varT var | PlainTV var <- tyvars ] @@ -88,7 +88,7 @@ let lamClause = conP eventStructName [varP var | var <- vars ] conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars)) where constr = if isUpdate then 'UpdateEvent else 'QueryEvent - (tyvars, cxt, args, stateType, resultType, isUpdate) = analyseType eventName eventType + (_tyvars, _cxt, args, _stateType, _resultType, isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -98,32 +98,33 @@ makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] dataD (return cxt) eventStructName tyvars [con] [''Typeable] - where (tyvars, cxt, args, stateType, resultType, isUpdate) = analyseType eventName eventType + where (tyvars, cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs --- instance (Binary key, Binary val) => Binary (MyUpdateEvent key val) where +-- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where -- put (MyUpdateEvent a b) = do put a; put b -- get = MyUpdateEvent <$> get <*> get -makeBinaryInstance eventName eventType - = do let preds = [ ''Binary ] - ty = AppT (ConT ''Binary) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) +makeSafeCopyInstance eventName eventType + = do let preds = [ ''SafeCopy ] + ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) getBase = appE (varE 'return) (conE eventStructName) - getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'get))) getBase args + getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'safeGet))) getBase args + contained val = varE 'contain `appE` val putVars <- replicateM (length args) (newName "arg") let putClause = conP eventStructName [varP var | var <- putVars ] - putExp = doE $ [ noBindS $ appE (varE 'put) (varE var) | var <- putVars ] ++ + putExp = doE $ [ noBindS $ appE (varE 'safePut) (varE var) | var <- putVars ] ++ [ noBindS $ appE (varE 'return) (tupE []) ] instanceD (mkCxtFromTyVars preds tyvars context) (return ty) - [ funD 'put [clause [putClause] (normalB putExp) []] - , valD (varP 'get) (normalB getArgs) [] + [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []] + , valD (varP 'getCopy) (normalB (contained getArgs)) [] ] - where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType + where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -133,13 +134,13 @@ map return extraContext {- -instance (Binary key, Typeable key - ,Binary val, Typeable val) => Method (MyUpdateEvent key val) where +instance (SafeCopy key, Typeable key + ,SafeCopy val, Typeable val) => Method (MyUpdateEvent key val) where type MethodResult (MyUpdateEvent key val) = Return type MethodState (MyUpdateEvent key val) = State key val -} makeMethodInstance eventName eventType - = do let preds = [ ''Binary, ''Typeable ] + = do let preds = [ ''SafeCopy, ''Typeable ] ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ] instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context) @@ -147,22 +148,21 @@ [ tySynInstD ''MethodResult [structType] (return resultType) , tySynInstD ''MethodState [structType] (return stateType) ] - where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType + where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs ---instance (Binary key, Typeable key --- ,Binary val, Typeable val) => UpdateEvent (MyUpdateEvent key val) +--instance (SafeCopy key, Typeable key +-- ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val) makeEventInstance eventName eventType - = do let preds = [ ''Binary, ''Typeable ] + = do let preds = [ ''SafeCopy, ''Typeable ] eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ]) - structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ] instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context) (return ty) [] - where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType + where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -172,9 +172,9 @@ analyseType :: Name -> Type -> ([TyVarBndr], Cxt, [Type], Type, Type, Bool) analyseType eventName t = let (tyvars, cxt, t') = case t of - ForallT binds [] t' -> + ForallT binds [] t' -> (binds, [], t') - ForallT binds cxt t' -> + ForallT binds cxt t' -> error $ "Context restrictions on events aren't supported yet: " ++ show eventName _ -> ([], [], t) args = getArgs t' @@ -193,6 +193,6 @@ makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] makeAcidic' eventNames stateName tyvars constructors - = do events <- sequence [ makeEvent eventName stateName | eventName <- eventNames ] + = do events <- sequence [ makeEvent eventName | eventName <- eventNames ] acidic <- makeIsAcidic eventNames stateName tyvars constructors return $ acidic : concat events