acid-state 0.5.2 → 0.6.0

raw patch · 28 files changed

+817/−205 lines, 28 filesdep +networkdep ~basedep ~safecopyPVP ok

version bump matches the API change (PVP)

Dependencies added: network

Dependency ranges changed: base, safecopy

API changes (from Hackage documentation)

Files

• acid-state.cabal +8/−6
• examples/HelloDatabase.hs +1/−1
• examples/HelloWorld.hs +1/−1
• examples/HelloWorldNoTH.hs +3/−3
• examples/KeyValue.hs +7/−4
• examples/KeyValueNoTH.hs +3/−3
• examples/Proxy.hs +80/−0
• examples/QuickCheck.hs +6/−0
• examples/RemoteClient.hs +48/−0
• examples/RemoteCommon.hs +36/−0
• examples/RemoteServer.hs +21/−0
• examples/SlowCheckpoint.hs +2/−2
• examples/StressTest.hs +7/−10
• examples/StressTestNoTH.hs +6/−8
• examples/errors/ChangeState.hs +2/−2
• examples/errors/Exceptions.hs +3/−1
• examples/errors/RemoveEvent.hs +2/−2
• src/Data/Acid.hs +4/−6
• src/Data/Acid/Abstract.hs +102/−0
• src/Data/Acid/Advanced.hs +24/−0
• src/Data/Acid/Common.hs +9/−2
• src/Data/Acid/Core.hs +3/−4
• src/Data/Acid/Local.hs +67/−65
• src/Data/Acid/Log.hs +5/−10
• src/Data/Acid/Memory.hs +51/−63
• src/Data/Acid/Memory/Pure.hs +3/−4
• src/Data/Acid/Remote.hs +186/−0
• src/Data/Acid/TemplateHaskell.hs +127/−8

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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