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.5.2 +Version: 0.6.0 -- A short (one-line) description of the package. Synopsis: Add ACID guarantees to any serializable Haskell data structure. @@ -45,18 +45,20 @@ Library -- Modules exported by the library. - Exposed-Modules: Data.Acid, Data.Acid.Core, + Exposed-Modules: Data.Acid, Data.Acid.Local, Data.Acid.Memory, - Data.Acid.Memory.Pure + Data.Acid.Memory.Pure, Data.Acid.Remote, + Data.Acid.Advanced -- 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.Common, FileIO + Data.Acid.TemplateHaskell, Data.Acid.Common, FileIO, + Data.Acid.Abstract, Data.Acid.Core -- Packages needed in order to build this package. - Build-depends: base >= 4 && < 5, cereal >= 0.3.2.0, safecopy == 0.5.* , bytestring, stm, - filepath, directory, mtl, array, containers, template-haskell + Build-depends: base >= 4 && < 5, cereal >= 0.3.2.0, safecopy >= 0.6, bytestring, stm, + filepath, directory, mtl, array, containers, template-haskell, network if os(windows) Build-depends: Win32 diff --git a/examples/HelloDatabase.hs b/examples/HelloDatabase.hs --- a/examples/HelloDatabase.hs +++ b/examples/HelloDatabase.hs @@ -31,7 +31,7 @@ main :: IO () main = do args <- getArgs - database <- openAcidStateFrom "myDatabase/" (Database ["Welcome to the acid-state database."]) + database <- openLocalStateFrom "myDatabase/" (Database ["Welcome to the acid-state database."]) if null args then do messages <- query database (ViewMessages 10) putStrLn "Last 10 messages:" diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -35,7 +35,7 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (HelloWorldState "Hello world") +main = do acid <- openLocalState (HelloWorldState "Hello world") args <- getArgs if null args then do string <- query acid QueryState diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} module Main (main) where -import Data.Acid.Core -import Data.Acid.Local +import Data.Acid +import Data.Acid.Advanced import Control.Monad.State import Control.Monad.Reader @@ -37,7 +37,7 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (HelloWorldState "Hello world") +main = do acid <- openLocalState (HelloWorldState "Hello world") args <- getArgs if null args then do string <- query acid QueryState diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -2,12 +2,15 @@ module Main (main) where import Data.Acid +import Data.Acid.Remote import Control.Monad.State import Control.Monad.Reader import Control.Applicative import System.Environment import System.IO +import System.Exit +import Network import Data.SafeCopy import Data.Typeable @@ -44,8 +47,8 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (KeyValue Map.empty) - args <- getArgs +main = do args <- getArgs + acid <- openLocalState (KeyValue Map.empty) case args of [key] -> do mbKey <- query acid (LookupKey key) @@ -56,6 +59,6 @@ -> do update acid (InsertKey key val) putStrLn "Done." _ -> do putStrLn "Usage:" - putStrLn " key Lookup the value of 'key'." - putStrLn " key value Set the value of 'key' to 'value'." + putStrLn " key Lookup the value of 'key'." + putStrLn " key value Set the value of 'key' to 'value'." closeAcidState acid diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} module Main (main) where -import Data.Acid.Core -import Data.Acid.Local +import Data.Acid +import Data.Acid.Advanced import qualified Control.Monad.State as State import Control.Monad.Reader @@ -45,7 +45,7 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidState (KeyValue Map.empty) +main = do acid <- openLocalState (KeyValue Map.empty) args <- getArgs case args of [key] diff --git a/examples/Proxy.hs b/examples/Proxy.hs new file mode 100644 --- /dev/null +++ b/examples/Proxy.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies #-} +module Main (main) where + +import Data.Acid +import Data.Acid.Remote +import Data.Acid.Advanced ( scheduleUpdate ) + +import Control.Monad.State +import Control.Monad.Reader +import System.Environment +import System.IO +import Network +import Data.SafeCopy + +import Data.Typeable + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data ProxyStressState = StressState !Int + deriving (Typeable) + +$(deriveSafeCopy 0 'base ''ProxyStressState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +pokeState :: Update ProxyStressState () +pokeState = do StressState i <- get + put (StressState (i+1)) + +queryState :: Query ProxyStressState Int +queryState = do StressState i <- ask + return i + +clearState :: Update ProxyStressState () +clearState = put $ StressState 0 + +$(makeAcidic ''ProxyStressState ['pokeState, 'queryState, 'clearState]) + +openLocal :: IO (AcidState ProxyStressState) +openLocal = openLocalState (StressState 0) + +openRemote :: String -> IO (AcidState ProxyStressState) +openRemote socket = openRemoteState "localhost" (UnixSocket socket) + +main :: IO () +main = do args <- getArgs + case args of + ["server", socket] + -> do acid <- openLocal + acidServer acid (UnixSocket socket) + ["proxy", from, to] + -> do acid <- openRemote from + acidServer acid (UnixSocket to) + ["query", socket] + -> do acid <- openRemote socket + n <- query acid QueryState + putStrLn $ "State value: " ++ show n + ["poke", socket] + -> do acid <- openRemote socket + putStr "Issuing 100k transactions... " + hFlush stdout + replicateM_ (100000-1) (scheduleUpdate acid PokeState) + update acid PokeState + putStrLn "Done" + ["clear", socket] + -> do acid <- openRemote socket + update acid ClearState + createCheckpoint acid + ["checkpoint", socket] + -> do acid <- openRemote socket + createCheckpoint acid + _ -> do putStrLn $ "Commands:" + putStrLn $ " server socket Start a new server instance." + putStrLn $ " proxy from to Pipe events between 'from' and 'to'." + putStrLn $ " query socket Prints out the current state." + putStrLn $ " poke socket Spawn 100k transactions." + putStrLn $ " clear socket Reset the state and write a checkpoint." + putStrLn $ " checkpoint socket Create a new checkpoint." diff --git a/examples/QuickCheck.hs b/examples/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/examples/QuickCheck.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.QuickCheck + +import Data.Acid + diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteClient.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid +import Data.Acid.Advanced +import Data.Acid.Remote + +import Control.Monad.State +import Control.Monad.Reader +import System.Environment +import System.IO +import Data.SafeCopy +import Data.Typeable +import Network + +import RemoteCommon + +------------------------------------------------------ +-- This is how AcidState is used: + +open :: IO (AcidState StressState) +open = openRemoteState "localhost" (PortNumber 8080) + +main :: IO () +main = do args <- getArgs + case args of + ["checkpoint"] + -> do acid <- open + createCheckpoint acid + ["query"] + -> do acid <- open + n <- query acid QueryState + putStrLn $ "State value: " ++ show n + ["poke"] + -> do acid <- open + putStr "Issuing 100k transactions... " + hFlush stdout + replicateM_ (100000-1) (scheduleUpdate acid PokeState) + update acid PokeState + putStrLn "Done" + ["clear"] + -> do acid <- open + update acid ClearState + createCheckpoint acid + _ -> do putStrLn $ "Commands:" + putStrLn $ " query Prints out the current state." + putStrLn $ " poke Spawn 100k transactions." + putStrLn $ " checkpoint Create a new checkpoint." diff --git a/examples/RemoteCommon.hs b/examples/RemoteCommon.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteCommon.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies #-} +module RemoteCommon where + +import Data.Acid + +import Control.Monad.State +import Control.Monad.Reader +import System.Environment +import System.IO +import Data.SafeCopy + +import Data.Typeable + +------------------------------------------------------ +-- The Haskell structure that we want to encapsulate + +data StressState = StressState !Int + deriving (Typeable) + +$(deriveSafeCopy 0 'base ''StressState) + +------------------------------------------------------ +-- The transaction we will execute over the state. + +pokeState :: Update StressState () +pokeState = do StressState i <- get + put (StressState (i+1)) + +queryState :: Query StressState Int +queryState = do StressState i <- ask + return i + +clearState :: Update StressState () +clearState = put $ StressState 0 + +$(makeAcidic ''StressState ['pokeState, 'queryState, 'clearState]) diff --git a/examples/RemoteServer.hs b/examples/RemoteServer.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteServer.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Main (main) where + +import Data.Acid +import Data.Acid.Remote (acidServer) + +import Control.Exception (bracket) +import Data.Typeable + +import Network + +import RemoteCommon + +-- open a server on port 8080 + +main :: IO () +main = + bracket + (openLocalState $ StressState 0) + closeAcidState + (\s -> acidServer s (PortNumber 8080)) diff --git a/examples/SlowCheckpoint.hs b/examples/SlowCheckpoint.hs --- a/examples/SlowCheckpoint.hs +++ b/examples/SlowCheckpoint.hs @@ -40,11 +40,11 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) +main = do acid <- openLocalStateFrom "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 "If you don't see any ticks while the checkpoint is being created, something" putStrLn "has gone awry." putStrLn "" doTick acid diff --git a/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid (makeAcidic) -import Data.Acid.Local +import Data.Acid +import Data.Acid.Advanced (scheduleUpdate) import Control.Monad.State import Control.Monad.Reader @@ -41,24 +41,21 @@ main :: IO () main = do args <- getArgs + acid <- openLocalState (StressState 0) case args of ["checkpoint"] - -> do acid <- openAcidState (StressState 0) - createCheckpoint acid + -> createCheckpoint acid ["query"] - -> do acid <- openAcidState (StressState 0) - n <- query acid QueryState + -> do n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] - -> do acid <- openAcidState (StressState 0) - putStr "Issuing 100k transactions... " + -> do putStr "Issuing 100k transactions... " hFlush stdout replicateM_ (100000-1) (scheduleUpdate acid PokeState) update acid PokeState putStrLn "Done" ["clear"] - -> do acid <- openAcidState (StressState 0) - update acid ClearState + -> do update acid ClearState createCheckpoint acid _ -> do putStrLn $ "Commands:" putStrLn $ " query Prints out the current state." diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} module Main (main) where -import Data.Acid.Core -import Data.Acid.Local +import Data.Acid +import Data.Acid.Advanced import Control.Monad.State import Control.Monad.Reader @@ -39,17 +39,15 @@ main :: IO () main = do args <- getArgs + acid <- openLocalState (StressState 0) case args of ["checkpoint"] - -> do acid <- openAcidState (StressState 0) - createCheckpoint acid + -> createCheckpoint acid ["query"] - -> do acid <- openAcidState (StressState 0) - n <- query acid QueryState + -> do n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] - -> do acid <- openAcidState (StressState 0) - putStr "Issuing 100k transactions... " + -> do putStr "Issuing 100k transactions... " hFlush stdout replicateM_ (100000-1) (scheduleUpdate acid PokeState) update acid PokeState diff --git a/examples/errors/ChangeState.hs b/examples/errors/ChangeState.hs --- a/examples/errors/ChangeState.hs +++ b/examples/errors/ChangeState.hs @@ -41,10 +41,10 @@ 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") + firstAcid <- openLocalStateFrom "state/ChangeState" (FirstState "first state") createCheckpoint firstAcid closeAcidState firstAcid - secondAcid <- openAcidStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used")) + secondAcid <- openLocalStateFrom "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 --- a/examples/errors/Exceptions.hs +++ b/examples/errors/Exceptions.hs @@ -2,6 +2,7 @@ module Main (main) where import Data.Acid +import Data.Acid.Local ( createCheckpointAndClose ) import Control.Monad.State import System.Environment @@ -43,7 +44,7 @@ -- This is how AcidState is used: main :: IO () -main = do acid <- openAcidStateFrom "state/Exceptions" (MyState 0) +main = do acid <- openLocalStateFrom "state/Exceptions" (MyState 0) args <- getArgs case args of ["1"] -> update acid (undefined :: FailEvent) @@ -51,6 +52,7 @@ ["3"] -> update acid ErrorEvent ["4"] -> update acid StateError _ -> do putStrLn "Call with '1', '2', '3' or '4' to test error scenarios." + putStrLn "If the tick doesn't get stuck, everything is fine." n <- update acid Tick putStrLn $ "Tick: " ++ show n `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException) diff --git a/examples/errors/RemoveEvent.hs b/examples/errors/RemoveEvent.hs --- a/examples/errors/RemoveEvent.hs +++ b/examples/errors/RemoveEvent.hs @@ -41,10 +41,10 @@ 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 + firstAcid <- openLocalStateFrom "state/RemoveEvent" FirstState update firstAcid FirstEvent closeAcidState firstAcid - secondAcid <- openAcidStateFrom "state/RemoveEvent" SecondState + secondAcid <- openLocalStateFrom "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 @@ -15,16 +15,12 @@ module Data.Acid ( AcidState - , openAcidState - , openAcidStateFrom + , openLocalState + , openLocalStateFrom , closeAcidState , createCheckpoint - , createCheckpointAndClose - , createArchive , update , query - , update' - , query' , EventResult , EventState , UpdateEvent @@ -37,4 +33,6 @@ ) where import Data.Acid.Local +import Data.Acid.Common +import Data.Acid.Abstract import Data.Acid.TemplateHaskell diff --git a/src/Data/Acid/Abstract.hs b/src/Data/Acid/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Abstract.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE RankNTypes, TypeFamilies, GADTs #-} +module Data.Acid.Abstract + ( AcidState(..) + , scheduleUpdate + , update + , update' + , query + , query' + , mkAnyState + , downcast + ) where + +import Data.Acid.Common +import Data.Acid.Core + +import Control.Concurrent ( MVar, takeMVar ) +import Data.ByteString.Lazy ( ByteString ) +import Control.Monad.Trans ( MonadIO(liftIO) ) +import Data.Typeable ( Typeable1, gcast1, typeOf1 ) + +data AnyState st where + AnyState :: Typeable1 sub_st => sub_st st -> AnyState st + +-- Haddock doesn't get the types right on its own. +{-| 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 unexpected system shutdowns + (both those caused by hardware and software). +-} +data AcidState st + = AcidState { + _scheduleUpdate :: forall event. (UpdateEvent event, EventState event ~ st) => event -> IO (MVar (EventResult event)) + , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString) + , _query :: (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event) + , queryCold :: Tagged ByteString -> IO ByteString + , +-- | 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 :: IO () + , +-- | Close an AcidState and associated resources. +-- Any subsequent usage of the AcidState will throw an exception. + closeAcidState :: IO () + , acidSubState :: AnyState st + } + +-- | 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 = _scheduleUpdate -- Redirection to make Haddock happy. + +-- | 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 + +-- | 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 = _query -- Redirection to make Haddock happy. + +-- | 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) + +mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st +mkAnyState = AnyState + +downcast :: Typeable1 sub => AcidState st -> sub st +downcast AcidState{acidSubState = AnyState sub} + = case gcast1 (Just sub) of + Just (Just typed_sub_struct) -> typed_sub_struct `asTypeOf` result + Nothing -> error $ "Data.Acid: Invalid subtype cast: " ++ show tag ++ " -> " ++ show (typeOf1 result) + where result = undefined + tag = show (typeOf1 sub) + diff --git a/src/Data/Acid/Advanced.hs b/src/Data/Acid/Advanced.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Advanced.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +{- | + Module : Data.Acid.Advanced + Copyright : PublicDomain + + Maintainer : lemmih@gmail.com + Portability : non-portable (uses GHC extensions) + + Home of the more specialized functions. + +-} +module Data.Acid.Advanced + ( scheduleUpdate + , update' + , query' + , Method(..) + , IsAcidic(..) + , Event(..) + ) where + +import Data.Acid.Abstract +import Data.Acid.Core +import Data.Acid.Common + 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 @@ -1,5 +1,3 @@ -{- LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, - FlexibleContexts, BangPatterns, CPP -} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, GADTs #-} ----------------------------------------------------------------------------- -- | @@ -18,8 +16,16 @@ import Control.Monad.State import Control.Monad.Reader import Data.SafeCopy +import Data.Serialize (runGet, runGetLazy) import Control.Applicative +import qualified Data.ByteString as Strict +-- Silly fix for bug in cereal-0.3.3.0's version of runGetLazy. +runGetLazyFix getter inp + = case runGet getter Strict.empty of + Left msg -> runGetLazy getter inp + Right val -> Right val + class (SafeCopy st) => IsAcidic st where acidEvents :: [Event st] -- ^ List of events capable of updating or querying the state. @@ -76,3 +82,4 @@ 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, +{-# LANGUAGE GADTs, DeriveDataTypeable, TypeFamilies, FlexibleContexts, BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -112,8 +112,7 @@ -- | Access the state component. withCoreState :: Core st -> (st -> IO a) -> IO a -withCoreState core action - = withMVar (coreState core) action +withCoreState core = withMVar (coreState core) -- | Execute a method as given by a type identifier and an encoded string. -- The exact format of the encoded string depends on the type identifier. @@ -165,7 +164,7 @@ -- trouble. Luckly, it would take deliberate malevolence for that to happen. unsafeCoerce methodHandler method --- | Method tags must be unique and are most commenly generated automatically. +-- | Method tags must be unique and are most commonly generated automatically. type Tag = Lazy.ByteString type Tagged a = (Tag, a) 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,4 @@ -{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, - GeneralizedNewtypeDeriving, BangPatterns, CPP #-} +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local @@ -14,37 +13,20 @@ -- module Data.Acid.Local - ( IsAcidic(..) - , AcidState - , Event(..) - , EventResult - , EventState - , UpdateEvent - , QueryEvent - , Update - , Query - , openAcidState - , openAcidStateFrom - , closeAcidState - , createCheckpoint - , createCheckpointAndClose + ( openLocalState + , openLocalStateFrom , createArchive - , update - , scheduleUpdate - , query - , update' - , query' - , runQuery - ) where + , createCheckpointAndClose + ) where import Data.Acid.Log as Log import Data.Acid.Core import Data.Acid.Common +import Data.Acid.Abstract import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) --import Control.Exception ( evaluate ) import Control.Monad.State ( runState ) -import Control.Monad.Trans ( MonadIO(liftIO) ) import Control.Applicative ( (<$>), (<*>) ) import Data.ByteString.Lazy ( ByteString ) --import qualified Data.ByteString.Lazy as Lazy ( length ) @@ -70,22 +52,13 @@ [@Durability@] Successful transaction are guaranteed to survive system failure (both hardware and software). -} -data AcidState st - = AcidState { localCore :: Core st - , localEvents :: FileLog (Tagged ByteString) - , localCheckpoints :: FileLog Checkpoint - } +data LocalState st + = LocalState { localCore :: Core st + , localEvents :: FileLog (Tagged ByteString) + , localCheckpoints :: FileLog Checkpoint + } deriving (Typeable) --- | 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'. @@ -96,8 +69,8 @@ --do scheduleUpdate acid EventA -- scheduleUpdate acid EventB -- @ -scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event)) -scheduleUpdate acidState event +scheduleLocalUpdate :: UpdateEvent event => LocalState (EventState event) -> event -> IO (MVar (EventResult event)) +scheduleLocalUpdate acidState event = do mvar <- newEmptyMVar let encoded = runPutLazy (safePut event) --evaluate (Lazy.length encoded) -- It would be best to encode the event before we lock the core @@ -111,14 +84,21 @@ 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) +scheduleLocalColdUpdate :: LocalState st -> Tagged ByteString -> IO (MVar ByteString) +scheduleLocalColdUpdate acidState event + = do mvar <- newEmptyMVar + modifyCoreState_ (localCore acidState) $ \st -> + 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 + return st' + return mvar + where coldMethod = lookupColdMethod (localCore 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 +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 @@ -129,10 +109,18 @@ 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) +-- 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 + where coldMethod = lookupColdMethod (localCore 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 @@ -140,8 +128,8 @@ -- with this call. -- -- This call will not return until the operation has succeeded. -createCheckpoint :: SafeCopy st => AcidState st -> IO () -createCheckpoint acidState +createLocalCheckpoint :: SafeCopy st => LocalState st -> IO () +createLocalCheckpoint acidState = do mvar <- newEmptyMVar withCoreState (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) @@ -154,7 +142,7 @@ -- 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 +createCheckpointAndClose abstract_state = do mvar <- newEmptyMVar closeCore' (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) @@ -163,6 +151,7 @@ takeMVar mvar closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) + where acidState = downcast abstract_state data Checkpoint = Checkpoint EntryId ByteString @@ -179,24 +168,24 @@ -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. -openAcidState :: (Typeable st, IsAcidic st) +openLocalState :: (Typeable st, IsAcidic st) => st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) -openAcidState initialState - = openAcidStateFrom ("state" show (typeOf initialState)) initialState +openLocalState initialState + = openLocalStateFrom ("state" show (typeOf initialState)) initialState -- | Create an AcidState given a log directory and an initial value. -- -- This will create or resume a log found in @directory@. -- Running two AcidState's from the same directory is an error -- but will not result in dataloss. -openAcidStateFrom :: (IsAcidic st) +openLocalStateFrom :: (IsAcidic st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) -openAcidStateFrom directory initialState +openLocalStateFrom directory initialState = do core <- mkCore (eventsToMethods acidEvents) initialState let eventsLogKey = LogKey { logDirectory = directory , logPrefix = "events" } @@ -216,18 +205,18 @@ events <- readEntriesFrom eventsLog n mapM_ (runColdMethod core) events checkpointsLog <- openFileLog checkpointsLogKey - return AcidState { localCore = core - , localEvents = eventsLog - , localCheckpoints = checkpointsLog - } + return $ toAcidState LocalState { localCore = core + , 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. -closeAcidState :: AcidState st -> IO () -closeAcidState acidState +closeLocalState :: LocalState st -> IO () +closeLocalState acidState = do closeCore (localCore acidState) closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) @@ -240,7 +229,7 @@ -- -- This method is idempotent and does not block the normal operation of the AcidState. createArchive :: AcidState st -> IO () -createArchive state +createArchive abstract_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. @@ -258,3 +247,16 @@ -- 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 + = AcidState { _scheduleUpdate = scheduleLocalUpdate local + , scheduleColdUpdate = scheduleLocalColdUpdate local + , _query = localQuery local + , queryCold = localQueryCold local + , createCheckpoint = createLocalCheckpoint local + , closeAcidState = closeLocalState local + , acidSubState = mkAnyState local + } + 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,4 +1,3 @@ -{-# 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. @@ -58,8 +57,7 @@ } formatLogFile :: String -> EntryId -> String -formatLogFile tag n - = printf "%s-%010d.log" tag n +formatLogFile = printf "%s-%010d.log" findLogFiles :: LogKey object -> IO [(EntryId, FilePath)] findLogFiles identifier @@ -130,13 +128,11 @@ writeToDisk handle xs = do mapM_ worker xs flush handle - return () where worker bs = do let len = Strict.length bs count <- Strict.unsafeUseAsCString bs $ \ptr -> write handle (castPtr ptr) (fromIntegral len) - if fromIntegral count < len - then worker (Strict.drop (fromIntegral count) bs) - else return () + when (fromIntegral count < len) $ + worker (Strict.drop (fromIntegral count) bs) closeFileLog :: FileLog object -> IO () @@ -170,7 +166,6 @@ firstEntryId = case relevant of [] -> 0 ( logFile : _logFiles) -> rangeStart logFile - archive <- liftM Lazy.concat $ mapM (Lazy.readFile . snd) relevant let entries = entriesToList $ readEntries archive return $ map decode' @@ -198,9 +193,9 @@ | otherwise -- If 'left' starts after our maxEntryId then we're done. = [] ltMinEntryId = case minEntryIdMb of Nothing -> const False - Just minEntryId -> \entryId -> entryId < minEntryId + Just minEntryId -> (< minEntryId) ltMaxEntryId = case maxEntryIdMb of Nothing -> const True - Just maxEntryId -> \entryId -> entryId < maxEntryId + Just maxEntryId -> (< maxEntryId) rangeStart (firstEntryId, _path) = firstEntryId -- Move all log files that do not contain entries equal or higher than the given entryId 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 @@ -1,5 +1,4 @@ -{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, - GeneralizedNewtypeDeriving, BangPatterns, CPP #-} +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory @@ -12,34 +11,17 @@ -- module Data.Acid.Memory - ( IsAcidic(..) - , AcidState - , Event(..) - , EventResult - , EventState - , UpdateEvent - , QueryEvent - , Update - , Query - , openAcidState - , closeAcidState - , createCheckpoint - , createCheckpointAndClose - , update - , scheduleUpdate - , query - , update' - , query' - , runQuery + ( openMemoryState ) where import Data.Acid.Core import Data.Acid.Common +import Data.Acid.Abstract import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) import Control.Monad.State ( runState ) -import Control.Monad.Trans ( MonadIO(liftIO) ) - +import Data.ByteString.Lazy ( ByteString ) +import Data.Typeable ( Typeable ) import Data.SafeCopy ( SafeCopy(..) ) @@ -57,19 +39,19 @@ [@Durability@] Successful transaction are guaranteed to survive system failure (both hardware and software). -} -data AcidState st - = AcidState { localCore :: Core st - } +data MemoryState st + = MemoryState { localCore :: Core st + } deriving (Typeable) --- | 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 +-- | Create an AcidState given an initial value. +openMemoryState :: (IsAcidic st) + => st -- ^ Initial state value. + -> IO (AcidState st) +openMemoryState initialState + = do core <- mkCore (eventsToMethods acidEvents) initialState + return $ toAcidState MemoryState { localCore = core } + -- | 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'. @@ -80,8 +62,8 @@ --do scheduleUpdate acid EventA -- scheduleUpdate acid EventB -- @ -scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event)) -scheduleUpdate acidState event +scheduleMemoryUpdate :: UpdateEvent event => MemoryState (EventState event) -> event -> IO (MVar (EventResult event)) +scheduleMemoryUpdate acidState event = do mvar <- newEmptyMVar modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState hotMethod st @@ -90,14 +72,19 @@ 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) +scheduleMemoryColdUpdate :: MemoryState st -> Tagged ByteString -> IO (MVar ByteString) +scheduleMemoryColdUpdate acidState event + = do mvar <- newEmptyMVar + modifyCoreState_ (localCore acidState) $ \st -> + do let !(result, !st') = runState coldMethod st + putMVar mvar result + return st' + return mvar + where coldMethod = lookupColdMethod (localCore 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 +memoryQuery :: QueryEvent event => MemoryState (EventState event) -> event -> IO (EventResult event) +memoryQuery acidState event = do mvar <- newEmptyMVar withCoreState (localCore acidState) $ \st -> do let (result, _st) = runState hotMethod st @@ -105,32 +92,33 @@ 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) +memoryQueryCold :: MemoryState st -> Tagged ByteString -> IO ByteString +memoryQueryCold acidState event + = do mvar <- newEmptyMVar + withCoreState (localCore acidState) $ \st -> + do let (result, _st) = runState coldMethod st + putMVar mvar result + takeMVar mvar + where coldMethod = lookupColdMethod (localCore acidState) event -- | This is a nop with the memory backend. -createCheckpoint :: SafeCopy st => AcidState st -> IO () -createCheckpoint acidState +createMemoryCheckpoint :: SafeCopy st => MemoryState st -> IO () +createMemoryCheckpoint 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 +closeMemoryState :: MemoryState st -> IO () +closeMemoryState acidState = closeCore (localCore acidState) +toAcidState :: IsAcidic st => MemoryState st -> AcidState st +toAcidState memory + = AcidState { _scheduleUpdate = scheduleMemoryUpdate memory + , scheduleColdUpdate = scheduleMemoryColdUpdate memory + , _query = memoryQuery memory + , queryCold = memoryQueryCold memory + , createCheckpoint = createMemoryCheckpoint 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 @@ -1,5 +1,4 @@ -{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies, - GeneralizedNewtypeDeriving, BangPatterns, CPP #-} +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory.Pure @@ -78,9 +77,9 @@ where hotMethod = lookupHotMethod (localMethods acidState) event -- | Create an AcidState given an initial value. -openAcidState :: (IsAcidic st) +openAcidState :: IsAcidic st => st -- ^ Initial state value. - -> (AcidState st) + -> AcidState st openAcidState initialState = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) , localState = initialState } diff --git a/src/Data/Acid/Remote.hs b/src/Data/Acid/Remote.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Remote.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +{- | + Module : Data.Acid.Remote + Copyright : PublicDomain + + Maintainer : lemmih@gmail.com + Portability : non-portable (uses GHC extensions) + + Network backend. + +-} +module Data.Acid.Remote + ( acidServer + , openRemoteState + ) where + + +import Data.Acid.Abstract +import Data.Acid.Core +import Data.Acid.Common + +import Network +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Control.Exception ( throwIO, ErrorCall(..), finally ) +import Control.Monad ( forever, liftM, join ) +import Control.Concurrent +import Data.IORef ( newIORef, readIORef, writeIORef ) +import Data.Serialize +import Data.SafeCopy ( SafeCopy, safeGet, safePut ) +import System.IO ( Handle, hFlush, hClose ) +import qualified Data.Sequence as Seq +import Data.Typeable ( Typeable ) + +{- | Accept connections on @port@ and serve requests using the given 'AcidState'. + This call doesn't return. + -} +acidServer :: SafeCopy st => AcidState st -> PortID -> IO () +acidServer acidState port + = do socket <- listenOn port + forever $ do (handle, _host, _port) <- accept socket + forkIO (process acidState handle) + `finally` sClose socket + +data Command = RunQuery (Tagged Lazy.ByteString) + | RunUpdate (Tagged Lazy.ByteString) + | CreateCheckpoint + +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 + get = do tag <- getWord8 + case tag of + 0 -> liftM RunQuery get + 1 -> liftM RunUpdate get + 2 -> return CreateCheckpoint + +data Response = Result Lazy.ByteString | Acknowledgement + +instance Serialize Response where + put resp = case resp of + Result result -> do putWord8 0; put result + Acknowledgement -> putWord8 1 + get = do tag <- getWord8 + case tag of + 0 -> liftM Result get + 1 -> return Acknowledgement + +process :: SafeCopy st => AcidState st -> Handle -> IO () +process acidState handle + = do chan <- newChan + forkIO $ forever $ do response <- join (readChan chan) + Strict.hPut handle (encode response) + hFlush handle + worker chan (runGetPartial get Strict.empty) + where worker chan inp + = case inp of + Fail msg -> return () -- error msg + Partial cont -> do inp <- Strict.hGetSome handle 1024 + worker chan (cont inp) + Done cmd rest -> do processCommand chan cmd; worker chan (runGetPartial get rest) + processCommand chan cmd = + case cmd of + RunQuery query -> do result <- queryCold acidState query + writeChan chan (return $ Result result) + RunUpdate update -> do result <- scheduleColdUpdate acidState update + writeChan chan (liftM Result $ takeMVar result) + CreateCheckpoint -> do createCheckpoint acidState + writeChan chan (return Acknowledgement) + + +data RemoteState st = RemoteState (Command -> IO (MVar Response)) (IO ()) + deriving (Typeable) + +{- | Connect to a remotely running 'AcidState'. -} +openRemoteState :: IsAcidic st => HostName -> PortID -> IO (AcidState st) +openRemoteState host port + = do handle <- connectTo host port + writeLock <- newMVar () + -- callbacks are added to the right and read from the left + callbacks <- newMVar (Seq.empty :: Seq.Seq (Response -> IO ())) + isClosed <- newIORef False + let getCallback = + modifyMVar callbacks $ \s -> return $ + case Seq.viewl s of + Seq.EmptyL -> noCallback + (cb Seq.:< s') -> (s', cb) + noCallback = error "openRemote: Internal error: Missing callback." + newCallback cb = modifyMVar_ callbacks (\s -> return (s Seq.|> cb)) + + listener inp + = case inp of + Fail msg -> error msg + Partial cont -> do inp <- Strict.hGetSome handle 1024 + listener (cont inp) + Done resp rest -> do callback <- getCallback + callback (resp :: Response) + listener (runGetPartial get rest) + actor cmd = do readIORef isClosed >>= closedError + ref <- newEmptyMVar + withMVar writeLock $ \() -> do + newCallback (putMVar ref) + Strict.hPut handle (encode cmd) >> hFlush handle + return ref + + closedError False = return () + closedError True = throwIO $ ErrorCall "The AcidState has been closed" + + shutdown = do writeIORef isClosed True + hClose handle + forkIO (listener (runGetPartial get Strict.empty)) + return (toAcidState $ RemoteState actor shutdown) + +remoteQuery :: QueryEvent event => RemoteState (EventState event) -> event -> IO (EventResult event) +remoteQuery acidState event + = do let encoded = runPutLazy (safePut event) + resp <- remoteQueryCold acidState (methodTag event, encoded) + return (case runGetLazyFix safeGet resp of + Left msg -> error msg + Right result -> result) + +remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString +remoteQueryCold (RemoteState fn _shutdown) event + = do Result resp <- takeMVar =<< fn (RunQuery event) + return resp + +scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> event -> IO (MVar (EventResult event)) +scheduleRemoteUpdate (RemoteState fn _shutdown) event + = do let encoded = runPutLazy (safePut event) + parsed <- newEmptyMVar + respRef <- fn (RunUpdate (methodTag event, encoded)) + forkIO $ do Result resp <- takeMVar respRef + putMVar parsed (case runGetLazyFix safeGet resp of + Left msg -> error msg + Right result -> result) + return parsed + +scheduleRemoteColdUpdate :: RemoteState st -> Tagged Lazy.ByteString -> IO (MVar Lazy.ByteString) +scheduleRemoteColdUpdate (RemoteState fn _shutdown) event + = do parsed <- newEmptyMVar + respRef <- fn (RunUpdate event) + forkIO $ do Result resp <- takeMVar respRef + putMVar parsed resp + return parsed + +closeRemoteState :: RemoteState st -> IO () +closeRemoteState (RemoteState _fn shutdown) = shutdown + +createRemoteCheckpoint :: RemoteState st -> IO () +createRemoteCheckpoint (RemoteState fn _shutdown) + = do Acknowledgement <- takeMVar =<< fn CreateCheckpoint + return () + +toAcidState :: IsAcidic st => RemoteState st -> AcidState st +toAcidState remote + = AcidState { _scheduleUpdate = scheduleRemoteUpdate remote + , scheduleColdUpdate = scheduleRemoteColdUpdate remote + , _query = remoteQuery remote + , queryCold = remoteQueryCold remote + , createCheckpoint = createRemoteCheckpoint remote + , closeAcidState = closeRemoteState remote + , acidSubState = mkAnyState remote + } 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 @@ -5,10 +5,12 @@ ) where import Language.Haskell.TH +import Language.Haskell.TH.Ppr import Data.Acid.Core -import Data.Acid.Local +import Data.Acid.Common +import Data.List ((\\), nub) import Data.SafeCopy import Data.Typeable import Data.Char @@ -78,34 +80,137 @@ _ -> error $ "Events must be functions: " ++ show eventName --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where --- acidEvents = [ UpdateEven (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] +-- acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] makeIsAcidic eventNames stateName tyvars constructors = do types <- mapM getEventType eventNames + stateType' <- stateType let preds = [ ''SafeCopy, ''Typeable ] ty = appT (conT ''IsAcidic) stateType handlers = zipWith makeEventHandler eventNames types - instanceD (mkCxtFromTyVars preds tyvars []) ty + cxtFromEvents = nub $ concat $ zipWith (eventCxts stateType' tyvars) eventNames types + cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents + instanceD (return cxts') ty [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ] where stateType = foldl appT (conT stateName) [ varT var | PlainTV var <- tyvars ] +-- | This function analyses an event function and extracts any +-- additional class contexts which need to be added to the IsAcidic +-- instance. +-- +-- For example, if we have: +-- +-- > data State a = ... +-- +-- > setState :: (Ord a) => a -> UpdateEvent (State a) () +-- +-- Then we need to generate an IsAcidic instance like: +-- +-- > instance (SafeCopy a, Typeable a, Ord a) => IsAcidic (State a) +-- +-- Note that we can only add constraints for type variables which +-- appear in the State type. If we tried to do this: +-- +-- > setState :: (Ord a, Ord b) => a -> b -> UpdateEvent (State a) () +-- +-- We will get an ambigious type variable when trying to create the +-- 'IsAcidic' instance, because there is no way to figure out what +-- type 'b' should be. +-- +-- The tricky part of this code is that we need to unify the type +-- variables. +-- +-- Let's say the user writes their code using 'b' instead of 'a': +-- +-- > setState :: (Ord b) => b -> UpdateEvent (State b) () +-- +-- In the 'IsAcidic' instance, we are still going to use 'a'. So we +-- need to rename the variables in the context to match. +-- +-- The contexts returned by this function will have the variables renamed. +eventCxts :: Type -- ^ State type (used for error messages) + -> [TyVarBndr] -- ^ type variables that will be used for the State type in the IsAcidic instance + -> Name -- ^ 'Name' of the event + -> Type -- ^ 'Type' of the event + -> [Pred] -- ^ extra context to add to 'IsAcidic' instance +eventCxts targetStateType targetTyVars eventName eventType = + let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate) + = analyseType eventName eventType + eventTyVars = findTyVars stateType -- find the type variable names that this event is using for the State type + table = zip eventTyVars (map tyVarBndrName targetTyVars) -- create a lookup table + in map (unify table) cxt -- rename the type variables + where + -- | rename the type variables in a Pred + unify :: [(Name, Name)] -> Pred -> Pred + unify table p@(ClassP n tys) = ClassP n (map (rename p table) tys) + unify table p@(EqualP a b) = EqualP (rename p table a) (rename p table b) + + -- | rename the type variables in a Type + rename :: Pred -> [(Name, Name)] -> Type -> Type + rename pred table t@(ForallT tyvarbndrs cxt typ) = -- this is probably wrong? I don't think acid-state can really handle this type anyway.. + ForallT (map renameTyVar tyvarbndrs) (map (unify table) cxt) (rename pred table typ) + where + renameTyVar (PlainTV name) = PlainTV (renameName pred table name) + renameTyVar (KindedTV name k) = KindedTV (renameName pred table name) k + rename pred table (VarT n) = VarT $ renameName pred table n + rename pred table (AppT a b) = AppT (rename pred table a) (rename pred table b) + rename pred table (SigT a k) = SigT (rename pred table a) k + rename _ _ typ = typ + + -- | rename a 'Name' + renameName :: Pred -> [(Name, Name)] -> Name -> Name + renameName pred table n = + case lookup n table of + Nothing -> error $ unlines [ show $ ppr_sig eventName eventType + , "" + , "can not be used as an UpdateEvent because the class context: " + , "" + , pprint pred + , "" + , "contains a type variable which is not found in the state type: " + , "" + , pprint targetStateType + , "" + , "You may be able to fix this by providing a type signature that fixes these type variable(s)" + ] + (Just n') -> n' + -- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) makeEventHandler :: Name -> Type -> ExpQ makeEventHandler eventName eventType - = do vars <- replicateM (length args) (newName "arg") + = do assertTyVarsOk + vars <- replicateM (length args) (newName "arg") 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 + stateTypeTyVars = findTyVars stateType + tyVarNames = map tyVarBndrName tyvars + assertTyVarsOk = + case tyVarNames \\ stateTypeTyVars of + [] -> return () + ns -> error $ unlines + [show $ ppr_sig eventName eventType + , "" + , "can not be used as an UpdateEvent because it contains the type variables: " + , "" + , pprint ns + , "" + , "which do not appear in the state type:" + , "" + , pprint stateType + ] + + --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 -- deriving (Typeable) 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 + dataD (return []) eventStructName tyvars [con] [''Typeable] + where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs @@ -182,7 +287,7 @@ ForallT binds [] t' -> (binds, [], t') ForallT binds cxt t' -> - error $ "Context restrictions on events aren't supported yet: " ++ show eventName + (binds, cxt, t') _ -> ([], [], t) args = getArgs t' (stateType, resultType, isUpdate) = findMonad t' @@ -197,3 +302,17 @@ | con == ''Update = (state, result, True) | con == ''Query = (state, result, False) findMonad _ = error $ "Event has an invalid type signature: Not an Update or a Query: " ++ show eventName + +-- | find the type variables +-- | e.g. State a b ==> [a,b] +findTyVars :: Type -> [Name] +findTyVars (ForallT _ _ a) = findTyVars a +findTyVars (VarT n) = [n] +findTyVars (AppT a b) = findTyVars a ++ findTyVars b +findTyVars (SigT a _) = findTyVars a +findTyVars _ = [] + +-- | extract the 'Name' from a 'TyVarBndr' +tyVarBndrName :: TyVarBndr -> Name +tyVarBndrName (PlainTV n) = n +tyVarBndrName (KindedTV n _) = n