acid-state 0.15.0 → 0.15.1

raw patch · 18 files changed

+589/−180 lines, 18 filesdep ~basenew-component:exe:acid-state-repairPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• acid-state.cabal +11/−1
• examples/HelloWorldNoTH.hs +2/−2
• examples/KeyValueNoTH.hs +2/−2
• examples/StressTestNoTH.hs +2/−2
• repair/Main.hs +10/−0
• src/Data/Acid/Advanced.hs +5/−0
• src/Data/Acid/Archive.hs +47/−0
• src/Data/Acid/Common.hs +9/−20
• src/Data/Acid/Core.hs +85/−18
• src/Data/Acid/Local.hs +128/−32
• src/Data/Acid/Log.hs +33/−35
• src/Data/Acid/Memory.hs +2/−4
• src/Data/Acid/Remote.hs +21/−19
• src/Data/Acid/Repair.hs +142/−0
• src/Data/Acid/TemplateHaskell.hs +90/−45
• test-state/OldStateTest1/events-0000000681.log +0/−0
• test-state/OldStateTest2/events-0000000149.log +0/−0
• test-state/OldStateTest3/events-0000000100.log +0/−0

@@ -1,5 +1,5 @@ Name:                acid-state-Version:             0.15.0+Version:             0.15.1 Synopsis:            Add ACID guarantees to any serializable Haskell data structure. Description:         Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage:            https://github.com/acid-state/acid-state@@ -39,6 +39,7 @@                        Data.Acid.Log, Data.Acid.CRC,                        Data.Acid.Abstract, Data.Acid.Core,                        Data.Acid.TemplateHaskell+                       Data.Acid.Repair    Other-modules:       Paths_acid_state,                        FileIO@@ -72,6 +73,15 @@    default-language:    Haskell2010   GHC-Options:         -fwarn-unused-imports -fwarn-unused-binds++executable acid-state-repair+  hs-source-dirs: repair+  build-depends: acid-state+               , base+               , directory+  main-is: Main.hs+  default-language:    Haskell2010+  test-suite specs   type:                exitcode-stdio-1.0

@@ -77,6 +77,6 @@   instance IsAcidic HelloWorldState where-    acidEvents = [ UpdateEvent (\(WriteState newState) -> writeState newState)-                 , QueryEvent (\QueryState             -> queryState)+    acidEvents = [ UpdateEvent (\(WriteState newState) -> writeState newState) safeCopyMethodSerialiser+                 , QueryEvent (\QueryState             -> queryState)          safeCopyMethodSerialiser                  ]

@@ -93,6 +93,6 @@ instance QueryEvent LookupKey  instance IsAcidic KeyValue where-    acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value)-                 , QueryEvent (\(LookupKey key) -> lookupKey key)+    acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value) safeCopyMethodSerialiser+                 , QueryEvent (\(LookupKey key) -> lookupKey key)              safeCopyMethodSerialiser                  ]

@@ -84,6 +84,6 @@ instance QueryEvent QueryState  instance IsAcidic StressState where-    acidEvents = [ UpdateEvent (\PokeState -> pokeState)-                 , QueryEvent (\QueryState -> queryState)+    acidEvents = [ UpdateEvent (\PokeState -> pokeState)  safeCopyMethodSerialiser+                 , QueryEvent (\QueryState -> queryState) safeCopyMethodSerialiser                  ]

@@ -0,0 +1,10 @@+module Main where++import Data.Acid.Repair+import System.Directory++main :: IO ()+main = do+    directory <- getCurrentDirectory+    repairEvents directory+    repairCheckpoints directory

@@ -17,9 +17,14 @@     , Method(..)     , IsAcidic(..)     , Event(..)++    , safeCopySerialiser+    , safeCopyMethodSerialiser+    , defaultArchiver     ) where  import Data.Acid.Abstract+import Data.Acid.Archive import Data.Acid.Core import Data.Acid.Common 

@@ -12,6 +12,8 @@     , readEntries     , entriesToList     , entriesToListNoFail+    , Archiver(..)+    , defaultArchiver     ) where  import           Data.Acid.CRC@@ -23,19 +25,64 @@ import           Data.Serialize.Get     hiding (Result (..)) import qualified Data.Serialize.Get     as Serialize +-- | A bytestring that represents an entry in an archive. type Entry = Lazy.ByteString++-- | Result of unpacking an archive.  This is essentially a list of+-- 'Entry', but may terminate in 'Fail' if the archive format is+-- incorrect. data Entries = Done | Next Entry Entries | Fail String     deriving (Show) +-- | Convert 'Entries' to a normal list, calling 'error' if there was+-- a failure in unpacking the archive. entriesToList :: Entries -> [Entry] entriesToList Done              = [] entriesToList (Next entry next) = entry : entriesToList next entriesToList (Fail msg)        = error $ "Data.Acid.Archive: " <> msg +-- | Convert 'Entries' to a normal list, silently ignoring a failure+-- to unpack the archive and instead returning a truncated list. entriesToListNoFail :: Entries -> [Entry] entriesToListNoFail Done              = [] entriesToListNoFail (Next entry next) = entry : entriesToListNoFail next entriesToListNoFail Fail{}            = []+++-- | Interface for the lowest level of the serialisation layer, which+-- handles packing lists of 'Entry' elements (essentially just+-- bytestrings) into a single bytestring, perhaps with error-checking.+--+-- Any @'Archiver'{'archiveWrite', 'archiveRead'}@ must satisfy the+-- round-trip property:+--+-- > forall xs . entriesToList (archiveRead (archiveWrite xs)) == xs+--+-- Moreover, 'archiveWrite' must be a monoid homomorphism, so that+-- concatenating archives is equivalent to concatenating the lists of+-- entries that they represent:+--+-- > archiveWrite [] == empty+-- > forall xs ys . archiveWrite xs <> archiveWrite ys == archiveWrite (xs ++ ys)+data Archiver+    = Archiver+      { archiveWrite :: [Entry] -> Lazy.ByteString+        -- ^ Pack a list of entries into a bytestring.++      , archiveRead  :: Lazy.ByteString -> Entries+        -- ^ Unpack a bytestring as a list of 'Entries', including the+        -- possibility of failure if the format is invalid.+      }++-- | Standard (and historically the only) implementation of the+-- 'Archiver' interface.  This represents each entry in the following+-- format:+--+-- > | entry length | crc16   | entry   |+-- > | 8 bytes      | 2 bytes | n bytes |+defaultArchiver :: Archiver+defaultArchiver = Archiver packEntries readEntries+  putEntry :: Entry -> Builder putEntry content

@@ -15,25 +15,14 @@  import Control.Monad.State import Control.Monad.Reader-import Data.ByteString.Lazy  ( ByteString )-import Data.SafeCopy-import Data.Serialize        ( Get, 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 :: Get a-           -> ByteString-           -> Either String a-runGetLazyFix getter inp-  = case runGet getter Strict.empty of-      Left _msg  -> runGetLazy getter inp-      Right val -> Right val -class (SafeCopy st) => IsAcidic st where+class IsAcidic st where     acidEvents :: [Event st]       -- ^ List of events capable of updating or querying the state. + -- | Context monad for Update events. newtype Update st a = Update { unUpdate :: State st a }     deriving (Monad, Functor, MonadState st)@@ -72,9 +61,10 @@ --   QueryEvents are executed in a MonadReader context and obviously do not have --   to be serialized to disk. data Event st where-    UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> Event (EventState ev)-    QueryEvent  :: QueryEvent  ev => (ev -> Query (EventState ev) (EventResult ev)) -> Event (EventState ev)+    UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev)+    QueryEvent  :: QueryEvent  ev => (ev -> Query (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev) + -- | All UpdateEvents are also Methods. class Method ev => UpdateEvent ev -- | All QueryEvents are also Methods.@@ -84,8 +74,7 @@ eventsToMethods :: [Event st] -> [MethodContainer st] eventsToMethods = map worker     where worker :: Event st -> MethodContainer st-          worker (UpdateEvent fn) = Method (unUpdate . fn)-          worker (QueryEvent fn)  = Method (\ev -> do st <- get-                                                      return (runReader (unQuery $ fn ev) st)-                                           )-+          worker (UpdateEvent fn ms) = Method (unUpdate . fn) ms+          worker (QueryEvent  fn ms) = Method (\ev -> do st <- get+                                                         return (runReader (unQuery $ fn ev) st)+                                              ) ms

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies,-             FlexibleContexts, BangPatterns #-}+             FlexibleContexts, BangPatterns,+             DefaultSignatures, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Acid.Core@@ -28,11 +29,21 @@     , modifyCoreState_     , withCoreState     , lookupHotMethod+    , lookupHotMethodAndSerialiser     , lookupColdMethod     , runHotMethod     , runColdMethod     , MethodMap     , mkMethodMap++    , Serialiser(..)+    , safeCopySerialiser+    , MethodSerialiser(..)+    , safeCopyMethodSerialiser+    , encodeMethod+    , decodeMethod+    , encodeResult+    , decodeResult     ) where  import Control.Concurrent                 ( MVar, newMVar, withMVar@@ -74,16 +85,66 @@  #endif ++-- | Interface for (de)serialising values of type @a@.+--+-- A @'Serialiser' { 'serialiserEncode', 'serialiserDecode' }@ must+-- satisfy the round-trip property:+--+-- > forall x . serialiserDecode (serialiserEncode x) == Right x+data Serialiser a =+    Serialiser+        { serialiserEncode :: a -> Lazy.ByteString+          -- ^ Serialise a value to a bytestring.+        , serialiserDecode :: Lazy.ByteString -> Either String a+          -- ^ Deserialise a value, generating a string error message+          -- on failure.+        }++-- | Default implementation of 'Serialiser' interface using 'SafeCopy'.+safeCopySerialiser :: SafeCopy a => Serialiser a+safeCopySerialiser = Serialiser (runPutLazy . safePut) (runGetLazy safeGet)+++-- | Interface for (de)serialising a method, namely 'Serialiser's for+-- its arguments type and its result type.+data MethodSerialiser method =+    MethodSerialiser+        { methodSerialiser :: Serialiser method+        , resultSerialiser :: Serialiser (MethodResult method)+        }++-- | Default implementation of 'MethodSerialiser' interface using 'SafeCopy'.+safeCopyMethodSerialiser :: (SafeCopy method, SafeCopy (MethodResult method)) => MethodSerialiser method+safeCopyMethodSerialiser = MethodSerialiser safeCopySerialiser safeCopySerialiser++-- | Encode the arguments of a method using the given serialisation strategy.+encodeMethod :: MethodSerialiser method -> method -> ByteString+encodeMethod ms = serialiserEncode (methodSerialiser ms)++-- | Decode the arguments of a method using the given serialisation strategy.+decodeMethod :: MethodSerialiser method -> ByteString -> Either String method+decodeMethod ms = serialiserDecode (methodSerialiser ms)++-- | Encode the result of a method using the given serialisation strategy.+encodeResult :: MethodSerialiser method -> MethodResult method -> ByteString+encodeResult ms = serialiserEncode (resultSerialiser ms)++-- | Decode the result of a method using the given serialisation strategy.+decodeResult :: MethodSerialiser method -> ByteString -> Either String (MethodResult method)+decodeResult ms = serialiserDecode (resultSerialiser ms)++ -- | The basic Method class. Each Method has an indexed result type --   and a unique tag.-class ( Typeable ev, SafeCopy ev-      , Typeable (MethodResult ev), SafeCopy (MethodResult ev)) =>-      Method ev where+class Method ev where     type MethodResult ev     type MethodState ev     methodTag :: ev -> Tag+    default methodTag :: Typeable ev => ev -> Tag     methodTag ev = Lazy.pack (showQualifiedTypeRep (typeOf ev)) + -- | The control structure at the very center of acid-state. --   This module provides access to a mutable state through --   methods. No efforts towards durability, checkpointing or@@ -155,12 +216,12 @@ lookupColdMethod core (storedMethodTag, methodContent)     = case Map.lookup storedMethodTag (coreMethods core) of         Nothing      -> missingMethod storedMethodTag-        Just (Method method)-          -> liftM (runPutLazy . safePut) (method (lazyDecode methodContent))+        Just (Method method ms)+          -> liftM (encodeResult ms) (method (lazyDecode ms methodContent)) -lazyDecode :: SafeCopy a => Lazy.ByteString -> a-lazyDecode inp-    = case runGetLazy safeGet inp of+lazyDecode :: MethodSerialiser method -> Lazy.ByteString -> method+lazyDecode ms inp+    = case decodeMethod ms inp of         Left msg  -> error $ "Data.Acid.Core: " <> msg         Right val -> val @@ -180,21 +241,29 @@ -- | Find the state action that corresponds to an in-memory method. lookupHotMethod :: Method method => MethodMap (MethodState method) -> method                 -> State (MethodState method) (MethodResult method)-lookupHotMethod methodMap method+lookupHotMethod methodMap method = fst (lookupHotMethodAndSerialiser methodMap method)++-- | Find the state action and serialiser that correspond to an+-- in-memory method.+lookupHotMethodAndSerialiser :: Method method => MethodMap (MethodState method) -> method+                             -> (State (MethodState method) (MethodResult method), MethodSerialiser method)+lookupHotMethodAndSerialiser methodMap method     = case Map.lookup (methodTag method) methodMap of         Nothing -> missingMethod (methodTag method)-        Just (Method methodHandler)+        Just (Method methodHandler ms)           -> -- If the methodTag doesn't index the right methodHandler then we're in deep              -- trouble. Luckly, it would take deliberate malevolence for that to happen.-             unsafeCoerce methodHandler method+             (unsafeCoerce methodHandler method, unsafeCoerce ms)  -- | Method tags must be unique and are most commonly generated automatically. type Tag = Lazy.ByteString type Tagged a = (Tag, a) +type MethodBody method = method -> State (MethodState method) (MethodResult method)+ -- | Method container structure that hides the exact type of the method. data MethodContainer st where-    Method :: (Method method) => (method -> State (MethodState method) (MethodResult method)) -> MethodContainer (MethodState method)+    Method :: (Method method) => MethodBody method -> MethodSerialiser method -> MethodContainer (MethodState method)  -- | Collection of Methods indexed by a Tag. type MethodMap st = Map.Map Tag (MethodContainer st)@@ -206,8 +275,6 @@     where -- A little bit of ugliness is required to access the methodTags.           methodType :: MethodContainer st -> Tag           methodType m = case m of-                           Method fn -> let ev :: (ev -> State st res) -> ev-                                            ev _ = undefined-                                        in methodTag (ev fn)--+                           Method fn _ -> let ev :: (ev -> State st res) -> ev+                                              ev _ = undefined+                                          in methodTag (ev fn)

@@ -15,15 +15,23 @@ module Data.Acid.Local     ( openLocalState     , openLocalStateFrom+    , openLocalStateWithSerialiser     , prepareLocalState     , prepareLocalStateFrom+    , prepareLocalStateWithSerialiser+    , defaultStateDirectory     , scheduleLocalUpdate'     , scheduleLocalColdUpdate'     , createCheckpointAndClose     , LocalState(..)     , Checkpoint(..)+    , SerialisationLayer(..)+    , defaultSerialisationLayer+    , mkEventsLogKey+    , mkCheckpointsLogKey     ) where +import Data.Acid.Archive import Data.Acid.Log as Log import Data.Acid.Core import Data.Acid.Common@@ -64,7 +72,7 @@     = LocalState { localCore        :: Core st                  , localCopy        :: IORef st                  , localEvents      :: FileLog (Tagged ByteString)-                 , localCheckpoints :: FileLog Checkpoint+                 , localCheckpoints :: FileLog (Checkpoint st)                  , localLock        :: FileLock                  } deriving (Typeable) @@ -85,7 +93,7 @@ scheduleLocalUpdate :: UpdateEvent event => LocalState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleLocalUpdate acidState event     = do mvar <- newEmptyMVar-         let encoded = runPutLazy (safePut event)+         let encoded = encodeMethod ms event           -- It is important that we encode the event now so that we can catch          -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs)@@ -99,7 +107,7 @@                                                                                 putMVar mvar result               return st'          return mvar-    where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event+    where (hotMethod, ms) = lookupHotMethodAndSerialiser (coreMethods (localCore acidState)) event  -- | Same as scheduleLocalUpdate but does not immediately change the localCopy -- and return the result mvar - returns an IO action to do this instead. Take@@ -108,7 +116,7 @@ scheduleLocalUpdate' :: UpdateEvent event => LocalState (EventState event) -> event -> MVar (EventResult event) -> IO (IO ()) scheduleLocalUpdate' acidState event mvar     = do-         let encoded = runPutLazy (safePut event)+         let encoded = encodeMethod ms event           -- It is important that we encode the event now so that we can catch          -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs)@@ -125,7 +133,7 @@          -- this is the action to update state for queries and release the          -- result into the supplied mvar          return act-    where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event+    where (hotMethod, ms) = lookupHotMethodAndSerialiser (coreMethods (localCore acidState)) event  scheduleLocalColdUpdate :: LocalState st -> Tagged ByteString -> IO (MVar ByteString) scheduleLocalColdUpdate acidState event@@ -179,27 +187,26 @@ --   with this call. -- --   This call will not return until the operation has succeeded.-createLocalCheckpoint :: SafeCopy st => LocalState st -> IO ()+createLocalCheckpoint :: IsAcidic st => LocalState st -> IO () createLocalCheckpoint acidState     = do cutFileLog (localEvents acidState)          mvar <- newEmptyMVar          withCoreState (localCore acidState) $ \st ->            do eventId <- askCurrentEntryId (localEvents acidState)               pushAction (localEvents acidState) $-                do let encoded = runPutLazy (safePut st)-                   pushEntry (localCheckpoints acidState) (Checkpoint eventId encoded) (putMVar mvar ())+                pushEntry (localCheckpoints acidState) (Checkpoint eventId st) (putMVar mvar ())          takeMVar mvar  -- | Save a snapshot to disk and close the AcidState as a single atomic --   action. This is useful when you want to make sure that no events --   are saved to disk after a checkpoint.-createCheckpointAndClose :: (SafeCopy st, Typeable st) => AcidState st -> IO ()+createCheckpointAndClose :: (IsAcidic st, Typeable st) => AcidState st -> IO () createCheckpointAndClose abstract_state     = do mvar <- newEmptyMVar          closeCore' (localCore acidState) $ \st ->            do eventId <- askCurrentEntryId (localEvents acidState)               pushAction (localEvents acidState) $-                pushEntry (localCheckpoints acidState) (Checkpoint eventId (runPutLazy (safePut st))) (putMVar mvar ())+                pushEntry (localCheckpoints acidState) (Checkpoint eventId st) (putMVar mvar ())          takeMVar mvar          closeFileLog (localEvents acidState)          closeFileLog (localCheckpoints acidState)@@ -207,75 +214,166 @@   where acidState = downcast abstract_state  -data Checkpoint = Checkpoint EntryId ByteString+data Checkpoint s = Checkpoint EntryId s -instance SafeCopy Checkpoint where+-- | Previous versions of @acid-state@ had+--+-- > data Checkpoint = Checkpoint EntryId ByteString+--+-- where the 'ByteString' is the @safecopy@-serialization of the+-- original checkpoint data.  Thus we give a 'SafeCopy' instance that+-- is backwards-compatible with this by making nested calls to+-- 'safePut' and 'safeGet'.+--+-- Note that if the inner data cannot be deserialised, 'getCopy' will+-- not report an error immediately but will return a 'Checkpoint'+-- whose payload is an error thunk.  This means consumers can skip+-- deserialising intermediate checkpoint data when they care only+-- about the last checkpoint in a file.  However, they must be sure to+-- force the returned data promptly.+instance SafeCopy s => SafeCopy (Checkpoint s) where     kind = primitive     putCopy (Checkpoint eventEntryId content)         = contain $           do safePut eventEntryId-             safePut content-    getCopy = contain $ Checkpoint <$> safeGet <*> safeGet+             safePut (runPutLazy (safePut content))+    getCopy = contain $ Checkpoint <$> safeGet <*> (fromNested <$> safeGet)+      where+        fromNested b = case runGetLazy safeGet b of+                         Left msg -> checkpointRestoreError msg+                         Right v  -> v   -- | Create an AcidState given an initial value. -- --   This will create or resume a log found in the \"state\/[typeOf state]\/\" directory.-openLocalState :: (Typeable st, IsAcidic st)+openLocalState :: (Typeable st, IsAcidic st, SafeCopy st)               => st                          -- ^ Initial state value. This value is only used if no checkpoint is                                              --   found.               -> IO (AcidState st) openLocalState initialState =-  openLocalStateFrom ("state" </> show (typeOf initialState)) initialState+  openLocalStateFrom (defaultStateDirectory initialState) initialState  -- | Create an AcidState given an initial value. -- --   This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. --   The most recent checkpoint will be loaded immediately but the AcidState will not be opened --   until the returned function is executed.-prepareLocalState :: (Typeable st, IsAcidic st)+prepareLocalState :: (Typeable st, IsAcidic st, SafeCopy st)                   => st                          -- ^ Initial state value. This value is only used if no checkpoint is                                                  --   found.                   -> IO (IO (AcidState st)) prepareLocalState initialState =-  prepareLocalStateFrom ("state" </> show (typeOf initialState)) initialState+  prepareLocalStateFrom (defaultStateDirectory initialState) initialState +-- | Directory to load the state from unless otherwise specified,+-- namely \"state\/[typeOf state]\/\".+defaultStateDirectory :: Typeable st => st -> FilePath+defaultStateDirectory initialState = "state" </> show (typeOf 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.-openLocalStateFrom :: (IsAcidic st)+openLocalStateFrom :: (IsAcidic st, SafeCopy 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) openLocalStateFrom directory initialState =-  join $ resumeLocalStateFrom directory initialState False+  openLocalStateWithSerialiser directory initialState defaultSerialisationLayer --- | Create an AcidState given an initial value.+-- | Create an AcidState given a log directory, an initial value and a serialisation layer. -- --   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.+openLocalStateWithSerialiser :: (IsAcidic st)+                  => FilePath            -- ^ Location of the checkpoint and transaction files.+                  -> st                  -- ^ Initial state value. This value is only used if no checkpoint is+                                         --   found.+                  -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives.+                  -> IO (AcidState st)+openLocalStateWithSerialiser directory initialState serialisationLayer =+  join $ resumeLocalStateFrom directory initialState False serialisationLayer++-- | Create an AcidState given a log directory and an initial value.+--+--   This will create or resume a log found in @directory@. --   The most recent checkpoint will be loaded immediately but the AcidState will not be opened --   until the returned function is executed.-prepareLocalStateFrom :: (IsAcidic st)+prepareLocalStateFrom :: (IsAcidic st, SafeCopy st)                   => FilePath            -- ^ Location of the checkpoint and transaction files.                   -> st                  -- ^ Initial state value. This value is only used if no checkpoint is                                          --   found.                   -> IO (IO (AcidState st)) prepareLocalStateFrom directory initialState =-  resumeLocalStateFrom directory initialState True+  prepareLocalStateWithSerialiser directory initialState defaultSerialisationLayer +-- | Create an AcidState given a log directory, an initial value and a serialisation layer.+--+--   This will create or resume a log found in @directory@.+--   The most recent checkpoint will be loaded immediately but the AcidState will not be opened+--   until the returned function is executed.+prepareLocalStateWithSerialiser :: (IsAcidic st)+                  => FilePath            -- ^ Location of the checkpoint and transaction files.+                  -> st                  -- ^ Initial state value. This value is only used if no checkpoint is+                                         --   found.+                  -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives.+                  -> IO (IO (AcidState st))+prepareLocalStateWithSerialiser directory initialState serialisationLayer =+  resumeLocalStateFrom directory initialState True serialisationLayer  +data SerialisationLayer st =+    SerialisationLayer+        {  checkpointSerialiser :: Serialiser (Checkpoint st)+            -- ^ Serialisation strategy for checkpoints.+            --+            -- Use 'safeCopySerialiser' for the backwards-compatible+            -- implementation using "Data.SafeCopy".++        , eventSerialiser :: Serialiser (Tagged ByteString)+            -- ^ Serialisation strategy for events.+            --+            -- Use 'safeCopySerialiser' for the backwards-compatible+            -- implementation using "Data.SafeCopy".++        , archiver :: Archiver+            -- ^ Serialisation strategy for archive log files.+            --+            -- Use 'defaultArchiver' for the backwards-compatible+            -- implementation using "Data.Serialize".+        }++-- | Standard (and historically the only) serialisation layer, using+-- 'safeCopySerialiser' and 'defaultArchiver'.+defaultSerialisationLayer :: SafeCopy st => SerialisationLayer st+defaultSerialisationLayer = SerialisationLayer safeCopySerialiser safeCopySerialiser defaultArchiver++mkEventsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Tagged ByteString)+mkEventsLogKey directory serialisationLayer =+  LogKey { logDirectory = directory+         , logPrefix = "events"+         , logSerialiser = eventSerialiser serialisationLayer+         , logArchiver   = archiver serialisationLayer }++mkCheckpointsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Checkpoint object)+mkCheckpointsLogKey directory serialisationLayer =+  LogKey { logDirectory = directory+         , logPrefix = "checkpoints"+         , logSerialiser = checkpointSerialiser serialisationLayer+         , logArchiver = archiver serialisationLayer }+ resumeLocalStateFrom :: (IsAcidic st)                   => FilePath            -- ^ Location of the checkpoint and transaction files.                   -> st                  -- ^ Initial state value. This value is only used if no checkpoint is                                          --   found.                   -> Bool                -- ^ True => load checkpoint before acquiring the lock.+                  -> SerialisationLayer st -- ^ Serialisation layer to use for checkpoints, events and archives.                   -> IO (IO (AcidState st))-resumeLocalStateFrom directory initialState delayLocking =+resumeLocalStateFrom directory initialState delayLocking serialisationLayer =   case delayLocking of     True -> do       (n, st) <- loadCheckpoint@@ -289,19 +387,17 @@         replayEvents lock n st   where     lockFile = directory </> "open.lock"-    eventsLogKey = LogKey { logDirectory = directory-                          , logPrefix = "events" }-    checkpointsLogKey = LogKey { logDirectory = directory-                               , logPrefix = "checkpoints" }+    eventsLogKey = mkEventsLogKey directory serialisationLayer+    checkpointsLogKey = mkCheckpointsLogKey directory serialisationLayer     loadCheckpoint = do       mbLastCheckpoint <- Log.newestEntry checkpointsLogKey       case mbLastCheckpoint of         Nothing ->           return (0, initialState)-        Just (Checkpoint eventCutOff content) -> do-          case runGetLazy safeGet content of-            Left msg  -> checkpointRestoreError msg-            Right val -> return (eventCutOff, val)+        Just (Checkpoint eventCutOff !val) ->+          -- N.B. We must be strict in val so that we force any+          -- lurking deserialisation error immediately.+          return (eventCutOff, val)     replayEvents lock n st = do       core <- mkCore (eventsToMethods acidEvents) st 

@@ -18,9 +18,11 @@     , askCurrentEntryId     , cutFileLog     , archiveFileLog+    , findLogFiles     ) where -import Data.Acid.Archive as Archive+import Data.Acid.Archive (Archiver(..), Entries(..), entriesToList)+import Data.Acid.Core import System.Directory import System.FilePath import System.IO@@ -36,10 +38,6 @@ import Data.List import Data.Maybe import Data.Monoid                               ((<>))-import qualified Data.Serialize.Get as Get-import qualified Data.Serialize.Put as Put-import Data.SafeCopy                             ( safePut, safeGet, SafeCopy )- import Text.Printf                               ( printf )  import Paths_acid_state                          ( version )@@ -60,6 +58,8 @@     = LogKey       { logDirectory :: FilePath       , logPrefix    :: String+      , logSerialiser :: Serialiser object+      , logArchiver   :: Archiver       }  formatLogFile :: String -> EntryId -> String@@ -90,7 +90,7 @@   queue <- newTVarIO ([], [])   nextEntryRef <- newTVarIO 0   tid1 <- myThreadId-  tid2 <- forkIO $ fileWriter currentState queue tid1+  tid2 <- forkIO $ fileWriter (logArchiver identifier) currentState queue tid1   let fLog = FileLog { logIdentifier  = identifier                      , logCurrent     = currentState                      , logNextEntryId = nextEntryRef@@ -101,15 +101,15 @@              handle <- open (logDirectory identifier </> formatLogFile (logPrefix identifier) currentEntryId)              putMVar currentState handle      else do let (lastFileEntryId, lastFilePath) = maximum logFiles-             entries <- readEntities lastFilePath+             entries <- readEntities (logArchiver identifier) lastFilePath              let currentEntryId = lastFileEntryId + length entries              atomically $ writeTVar nextEntryRef currentEntryId              handle <- open (logDirectory identifier </> formatLogFile (logPrefix identifier) currentEntryId)              putMVar currentState handle   return fLog -fileWriter :: MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO ()-fileWriter currentState queue parentTid = forever $ do+fileWriter :: Archiver -> MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO ()+fileWriter archiver currentState queue parentTid = forever $ do   (entries, actions) <- atomically $ do     (entries, actions) <- readTVar queue     when (null entries && null actions) retry@@ -117,7 +117,7 @@     return (reverse entries, reverse actions)   handle (\e -> throwTo parentTid (e :: IOException)) $     withMVar currentState $ \fd -> do-      let arch = Archive.packEntries entries+      let arch = archiveWrite archiver entries       writeToDisk fd (repack arch)   sequence_ actions   yield@@ -151,14 +151,10 @@     _ <- forkIO $ forM_ (logThreads fLog) killThread     return $ error "Data.Acid.Log: FileLog has been closed" -readEntities :: FilePath -> IO [Lazy.ByteString]-readEntities path = do+readEntities :: Archiver -> FilePath -> IO [Lazy.ByteString]+readEntities archiver path = do   archive <- Lazy.readFile path-  return $ worker (Archive.readEntries archive)- where-  worker Done              = []-  worker (Next entry next) = entry : worker next-  worker (Fail msg)        = error $ "Data.Acid.Log: " <> msg+  return $ entriesToList (archiveRead archiver archive)  ensureLeastEntryId :: FileLog object -> EntryId -> IO () ensureLeastEntryId fLog youngestEntry = do@@ -171,7 +167,7 @@ -- Read all durable entries younger than the given EntryId. -- Note that entries written during or after this call won't -- be included in the returned list.-readEntriesFrom :: SafeCopy object => FileLog object -> EntryId -> IO [object]+readEntriesFrom :: FileLog object -> EntryId -> IO [object] readEntriesFrom fLog youngestEntry = do   -- Cut the log so we can read written entries without interfering   -- with the writing of new entries.@@ -187,15 +183,16 @@   -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back   -- to lazy bytestrings once the bug has been fixed.   archive <- liftM Lazy.fromChunks $ mapM (Strict.readFile . snd) relevant-  let entries = entriesToList $ readEntries archive-  return $ map decode'+  let entries = entriesToList $ archiveRead (logArchiver identifier) archive+  return $ map (decode' identifier)          $ take (entryCap - youngestEntry)             -- Take events under the eventCap.          $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young.  where   rangeStart (firstEntryId, _path) = firstEntryId+  identifier = logIdentifier fLog  -- Obliterate log entries younger than or equal to the EventId. Very unsafe, can't be undone-rollbackTo :: SafeCopy object => LogKey object -> EntryId -> IO ()+rollbackTo :: LogKey object -> EntryId -> IO () rollbackTo identifier youngestEntry = do   logFiles <- findLogFiles identifier   let sorted = sort logFiles@@ -205,24 +202,24 @@         | otherwise = do             archive <- Strict.readFile path             pathHandle <- openFile path WriteMode-            let entries = entriesToList $ readEntries (Lazy.fromChunks [archive])+            let entries = entriesToList $ archiveRead (logArchiver identifier) (Lazy.fromChunks [archive])                 entriesToKeep = take (youngestEntry - rangeStart + 1) entries-                lengthToKeep = Lazy.length (packEntries entriesToKeep)+                lengthToKeep = Lazy.length (archiveWrite (logArchiver identifier) entriesToKeep)             hSetFileSize pathHandle (fromIntegral lengthToKeep)             hClose pathHandle   loop (reverse sorted)  -- Obliterate log entries as long as the filterFn returns True.-rollbackWhile :: SafeCopy object => LogKey object -> (object -> Bool) -> IO ()+rollbackWhile :: LogKey object -> (object -> Bool) -> IO () rollbackWhile identifier filterFn = do   logFiles <- findLogFiles identifier   let sorted = sort logFiles       loop [] = return ()       loop ((_rangeStart, path) : xs) = do         archive <- Strict.readFile path-        let entries = entriesToList $ readEntries (Lazy.fromChunks [archive])-            entriesToSkip = takeWhile (filterFn . decode') $ reverse entries-            skip_size = Lazy.length (packEntries entriesToSkip)+        let entries = entriesToList $ archiveRead (logArchiver identifier) (Lazy.fromChunks [archive])+            entriesToSkip = takeWhile (filterFn . decode' identifier) $ reverse entries+            skip_size = Lazy.length (archiveWrite (logArchiver identifier) entriesToSkip)             orig_size = fromIntegral $ Strict.length archive             new_size = orig_size - skip_size         if new_size == 0@@ -295,7 +292,7 @@ -- Implementation: Search the newest log files first. Once a file --                 containing at least one valid entry is found, --                 return the last entry in that file.-newestEntry :: SafeCopy object => LogKey object -> IO (Maybe object)+newestEntry :: LogKey object -> IO (Maybe object) newestEntry identifier = do   logFiles <- findLogFiles identifier   let sorted = reverse $ sort logFiles@@ -308,9 +305,9 @@     -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back     -- to lazy bytestrings once the bug has been fixed.     archive <- fmap Lazy.fromStrict $ Strict.readFile logFile-    case Archive.readEntries archive of+    case archiveRead (logArchiver identifier) archive of       Done            -> worker logFiles-      Next entry next -> return $ Just (decode' (lastEntry entry next))+      Next entry next -> return $ Just (decode' identifier (lastEntry entry next))       Fail msg        -> error $ "Data.Acid.Log: " <> msg   lastEntry entry Done          = entry   lastEntry entry (Fail msg)    = error $ "Data.Acid.Log: " <> msg@@ -319,14 +316,15 @@ -- Schedule a new log entry. This call does not block -- The given IO action runs once the object is durable. The IO action -- blocks the serialization of events so it should be swift.-pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO ()+pushEntry :: FileLog object -> object -> IO () -> IO () pushEntry fLog object finally = atomically $ do   tid <- readTVar (logNextEntryId fLog)   writeTVar (logNextEntryId fLog) $! tid+1   (entries, actions) <- readTVar (logQueue fLog)   writeTVar (logQueue fLog) ( encoded : entries, finally : actions )  where-  encoded = Lazy.fromChunks [ Strict.copy $ Put.runPut (safePut object) ]+  encoded = Lazy.fromChunks [ Strict.copy $ Lazy.toStrict $+              serialiserEncode (logSerialiser (logIdentifier fLog)) object ]  -- The given IO action is executed once all previous entries are durable. pushAction :: FileLog object -> IO () -> IO ()@@ -340,8 +338,8 @@   -- FIXME: Check for unused input.-decode' :: SafeCopy object => Lazy.ByteString -> object-decode' inp =-  case Get.runGetLazy safeGet inp of+decode' :: LogKey object -> Lazy.ByteString -> object+decode' s inp =+  case serialiserDecode (logSerialiser s) inp of     Left msg  -> error $ "Data.Acid.Log: " <> msg     Right val -> val

@@ -24,9 +24,7 @@ import Data.Typeable                  ( Typeable ) import Data.IORef                     ( IORef, newIORef, readIORef, writeIORef ) -import Data.SafeCopy                  ( SafeCopy(..) ) - {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)     guarantees. @@ -103,12 +101,12 @@     where coldMethod = lookupColdMethod (localCore acidState) event  -- | This is a nop with the memory backend.-createMemoryCheckpoint :: SafeCopy st => MemoryState st -> IO ()+createMemoryCheckpoint :: MemoryState st -> IO () createMemoryCheckpoint acidState     = return ()  -- | This is a nop with the memory backend.-createMemoryArchive :: SafeCopy st => MemoryState st -> IO ()+createMemoryArchive :: MemoryState st -> IO () createMemoryArchive acidState     = return () 

@@ -114,7 +114,6 @@ import qualified Data.ByteString.Lazy                as Lazy import Data.IORef                                    ( newIORef, readIORef, writeIORef ) import Data.Serialize-import Data.SafeCopy                                 ( SafeCopy, safeGet, safePut ) import Data.Set                                      ( Set, member ) import Data.Typeable                                 ( Typeable ) import GHC.IO.Exception                              ( IOErrorType(..) )@@ -217,8 +216,7 @@       see also: 'openRemoteState' and 'sharedSecretCheck'.  -}-acidServer :: SafeCopy st =>-              (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'+acidServer :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'            -> PortID                   -- ^ Port to listen on            -> AcidState st             -- ^ state to serve            -> IO ()@@ -240,8 +238,7 @@      Can be useful when fine-tuning of socket binding parameters is needed      (for example, listening on a particular network interface, IPv4/IPv6 options).  -}-acidServer' :: SafeCopy st =>-              (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'+acidServer' :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'            -> Socket                   -- ^ binded socket to accept connections from            -> AcidState st             -- ^ state to serve            -> IO ()@@ -312,8 +309,7 @@       This function is generally only needed if you are adding a new communication channel. -}-process :: SafeCopy st =>-           CommChannel  -- ^ a connected, authenticated communication channel+process :: CommChannel  -- ^ a connected, authenticated communication channel         -> AcidState st -- ^ state to share         -> IO () process CommChannel{..} acidState@@ -483,13 +479,15 @@         return (toAcidState $ RemoteState actor (shutdown actorTID)) -remoteQuery :: QueryEvent event => RemoteState (EventState event) -> event -> IO (EventResult event)-remoteQuery acidState event-  = do let encoded = runPutLazy (safePut event)+remoteQuery :: QueryEvent event => RemoteState (EventState event) -> MethodMap (EventState event) -> event -> IO (EventResult event)+remoteQuery acidState mmap event+  = do let encoded = encodeMethod ms event        resp <- remoteQueryCold acidState (methodTag event, encoded)-       return (case runGetLazyFix safeGet resp of+       return (case decodeResult ms resp of                  Left msg -> error $ "Data.Acid.Remote: " <> msg                  Right result -> result)+  where+    (_, ms) = lookupHotMethodAndSerialiser mmap event  remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString remoteQueryCold rs@(RemoteState fn _shutdown) event@@ -500,16 +498,18 @@                                remoteQueryCold rs event          Acknowledgement    -> error "Data.Acid.Remote: remoteQueryCold got Acknowledgement. That should never happen." -scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> event -> IO (MVar (EventResult event))-scheduleRemoteUpdate (RemoteState fn _shutdown) event-  = do let encoded = runPutLazy (safePut event)+scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> MethodMap (EventState event) -> event -> IO (MVar (EventResult event))+scheduleRemoteUpdate (RemoteState fn _shutdown) mmap event+  = do let encoded = encodeMethod ms event        parsed <- newEmptyMVar        respRef <- fn (RunUpdate (methodTag event, encoded))        forkIO $ do Result resp <- takeMVar respRef-                   putMVar parsed (case runGetLazyFix safeGet resp of+                   putMVar parsed (case decodeResult ms resp of                                       Left msg -> error $ "Data.Acid.Remote: " <> msg                                       Right result -> result)        return parsed+  where+    (_, ms) = lookupHotMethodAndSerialiser mmap event  scheduleRemoteColdUpdate :: RemoteState st -> Tagged Lazy.ByteString -> IO (MVar Lazy.ByteString) scheduleRemoteColdUpdate (RemoteState fn _shutdown) event@@ -532,15 +532,17 @@   = do Acknowledgement <- takeMVar =<< fn CreateArchive        return () -toAcidState :: IsAcidic st => RemoteState st -> AcidState st+toAcidState :: forall st . IsAcidic st => RemoteState st -> AcidState st toAcidState remote-  = AcidState { _scheduleUpdate    = scheduleRemoteUpdate remote+  = AcidState { _scheduleUpdate    = scheduleRemoteUpdate remote mmap               , scheduleColdUpdate = scheduleRemoteColdUpdate remote-              , _query             = remoteQuery remote+              , _query             = remoteQuery remote mmap               , queryCold          = remoteQueryCold remote               , createCheckpoint   = createRemoteCheckpoint remote               , createArchive      = createRemoteArchive remote               , closeAcidState     = closeRemoteState remote               , acidSubState       = mkAnyState remote               }-+  where+    mmap :: MethodMap st+    mmap = mkMethodMap (eventsToMethods acidEvents)

@@ -0,0 +1,142 @@+{-# LANGUAGE LambdaCase #-}++module Data.Acid.Repair+  ( repairFile+  , repairEvents+  , repairCheckpoints+  ) where++import qualified Data.Acid.Archive as Archive+import Data.Acid.Local (mkEventsLogKey, mkCheckpointsLogKey)+import Data.Acid.Log (LogKey)+import qualified Data.Acid.Log as Log+import qualified Data.ByteString.Lazy as Lazy+import Data.List+import System.Directory+import System.FilePath.Posix+import System.IO (hClose, openTempFile)++repairEntries :: Lazy.ByteString -> Lazy.ByteString+repairEntries =+  Archive.packEntries . Archive.entriesToListNoFail . Archive.readEntries++-- | @'repairFile' path@ will truncate the entries in @file@ until there are+-- only valid entries (if a corrupted entry is found, then the rest of the file+-- is truncated).+--+-- The old file will be copied to @path.bak@ (or @path.bak.1@, etc… if the file+-- already exists).+--+-- 'repairFile' tries very hard to avoid leaving files in an inconsistent state:+-- the truncated file is written in a temporary file, which is then moved into+-- place, similarly copies are performed with moves instead. Still this is not+-- fully atomic: there are two consecutive moves, so 'repairFile' may, in case+-- of crash, yield a state where the @path.bak@ file is there but no @path@ is+-- there anymore, this would require manual intervention.+repairFile :: FilePath -> IO ()+repairFile fp = do+    broken <- Lazy.readFile fp+    let repaired = repairEntries broken+    (tmp, temph) <- openTempFile (takeDirectory fp) (takeFileName fp)+      -- We use `openTempFile`, here, rather than `findNext` because we want to+      -- make extra-sure that we are not overriding an important file.+    hClose temph+      -- Closing immediately to benefit from the bracket guarantees of+      -- `writeFile`. A more elegant solution would be to use a `withTempFile`+      -- function, such as that from package `temporary`.+    Lazy.writeFile tmp repaired+    dropFile fp+    renameFile tmp fp++-- Repairs the files corresponding to the given 'LogKey'. It implements the+-- logic described in 'repairEvents'.+repairLogs :: LogKey object -> IO ()+repairLogs identifier = do+    logFiles <- Log.findLogFiles identifier+    let sorted = sort logFiles+        (_eventIds, files) = unzip sorted+    broken_files <- mapM needsRepair files+      -- We're doing a second deserialisation of the files here (see+      -- 'needsRepair'). It would be better, computation-time-wise to make as+      -- single pass and let `repairEntries`, for instance, return whether a fix+      -- is needed. But it's a lot of complication and requires loading the+      -- entire base in memory, rather than streaming files one-by-one. So it's+      -- better to just do the second pass.+    repair $ map snd $ dropWhile (\(b,_) -> not b) $ zip broken_files files+  where+    repair [] = return ()+    repair (file:rest) = do+      mapM_ dropFile (reverse rest)+      repairFile file++-- Moves (atomically) a file `path` to `path.bak` (or `path.bak.1`, etc… if the+-- file already exists).+dropFile :: FilePath -> IO ()+dropFile fp = do+    bak <- findNext (fp ++ ".bak")+      -- We're using `findNext` rather than `openTempFile`, here, because we+      -- want predictable names+    renameFile fp bak++-- | Repairs the WAL files with the following strategy:+--+-- * Let `f` be the oldest corrupted file.+-- * All files older than `f` is left untouched+-- * `f` is repaired with `repairFile`+-- * Old files younger than `f` is dropped (and saved to `path.bak`, or+--   `path.bak.1`, etc…)+--+-- In other words, all the log entries after the first corrupted entry is+-- dropped. The reasoning is that newer entries are likely not to make sense+-- after some entries have been removed from the log. This strategy guarantees a+-- consistent state, albeit a potentially old one.+repairEvents+  :: FilePath -- ^ Directory in which the events files can be found.+  -> IO ()+repairEvents directory =+    repairLogs (mkEventsLogKey directory noserialisation)+  where+    noserialisation =+      error "Repair.repairEvents: the serialisation layer shouldn't be forced"++-- | Repairs the checkpoints file using the following strategy:+--+-- * Every checkpoints file is repaired with `repairFile`+--+-- Checkpoints are mostly independent. Contrary to 'repairEvents', dropping a+-- checkpoint doesn't affect the consistency of later checkpoints.+repairCheckpoints+  :: FilePath -- ^ Directory in which the checkpoints files can be found.+  -> IO ()+repairCheckpoints directory = do+    let checkpointLogKey = mkCheckpointsLogKey directory noserialisation+    checkpointFiles <- Log.findLogFiles checkpointLogKey+    let (_eventIds, files) = unzip checkpointFiles+    mapM_ repairFile files+  where+    noserialisation =+      error "Repair.repairCheckpoints: the serialisation layer shouldn't be forced"++needsRepair :: FilePath -> IO Bool+needsRepair fp = do+    contents <- Lazy.readFile fp+    let entries = Archive.readEntries contents+    return $ entriesNeedRepair entries+  where+    entriesNeedRepair Archive.Fail{} = True+    entriesNeedRepair Archive.Done = False+    entriesNeedRepair (Archive.Next _ rest) = entriesNeedRepair rest++findNext :: FilePath -> IO (FilePath)+findNext fp = go 0+  where+    go n =+      let next = fileWithSuffix fp n in+      doesFileExist next >>= \case+        False -> return next+        True -> go (n+1)++fileWithSuffix :: FilePath -> Int -> FilePath+fileWithSuffix fp i =+  if i == 0 then fp+  else fp ++ "." ++ show i

@@ -11,7 +11,6 @@ import Data.Acid.Common  import Data.List ((\\), nub, delete)-import Data.Maybe (mapMaybe) import Data.SafeCopy import Data.Typeable import Data.Char@@ -46,7 +45,37 @@  -} makeAcidic :: Name -> [Name] -> Q [Dec]-makeAcidic stateName eventNames+makeAcidic = makeAcidicWithSerialiser safeCopySerialiserSpec+++-- | Specifies how to customise the 'IsAcidic' instance and event data+-- type serialisation instances for a particular serialisation layer.+data SerialiserSpec =+    SerialiserSpec+        { serialisationClassName :: Name+          -- ^ Class for serialisable types, e.g. @''Safecopy@.+        , methodSerialiserName :: Name+          -- ^ Name of the 'MethodSerialiser' to use in the list of+          -- events in the 'IsAcidic' instance.+        , makeEventSerialiser :: Name -> Type -> DecQ+          -- ^ Function to generate an instance of the class named by+          -- 'serialisationClassName', given the event name and its type.+        }++-- | Default implementation of 'SerialiserSpec' that uses 'SafeCopy'+-- for serialising events.+safeCopySerialiserSpec :: SerialiserSpec+safeCopySerialiserSpec =+    SerialiserSpec { serialisationClassName = ''SafeCopy+                   , methodSerialiserName   = 'safeCopyMethodSerialiser+                   , makeEventSerialiser    = makeSafeCopyInstance+                   }+++-- | A variant on 'makeAcidic' that makes it possible to explicitly choose the+-- serialisation implementation to be used for methods.+makeAcidicWithSerialiser :: SerialiserSpec -> Name -> [Name] -> Q [Dec]+makeAcidicWithSerialiser ss stateName eventNames     = do stateInfo <- reify stateName          case stateInfo of            TyConI tycon@@ -56,32 +85,48 @@ #else                  DataD _cxt _name tyvars constructors _derivs #endif-                   -> makeAcidic' eventNames stateName tyvars constructors+                   -> makeAcidic' ss eventNames stateName tyvars constructors #if MIN_VERSION_template_haskell(2,11,0)                  NewtypeD _cxt _name tyvars _kind constructor _derivs #else                  NewtypeD _cxt _name tyvars constructor _derivs #endif-                   -> makeAcidic' eventNames stateName tyvars [constructor]+                   -> makeAcidic' ss eventNames stateName tyvars [constructor]                  TySynD _name tyvars _ty-                   -> makeAcidic' eventNames stateName tyvars []+                   -> makeAcidic' ss eventNames stateName tyvars []                  _ -> error "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported."            _ -> error "Data.Acid.TemplateHaskell: Given state is not a type." -makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]-makeAcidic' eventNames stateName tyvars constructors-    = do events <- sequence [ makeEvent eventName | eventName <- eventNames ]-         acidic <- makeIsAcidic eventNames stateName tyvars constructors+makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]+makeAcidic' ss eventNames stateName tyvars constructors+    = do events <- sequence [ makeEvent ss eventName | eventName <- eventNames ]+         acidic <- makeIsAcidic ss eventNames stateName tyvars constructors          return $ acidic : concat events -makeEvent :: Name -> Q [Dec]-makeEvent eventName-    = do eventType <- getEventType eventName-         d <- makeEventDataType eventName eventType-         b <- makeSafeCopyInstance eventName eventType-         i <- makeMethodInstance eventName eventType-         e <- makeEventInstance eventName eventType-         return [d,b,i,e]+-- | Given an event name (e.g. @'myUpdate@), produce a data type like+--+-- > data MyUpdate = MyUpdate Argument+--+-- along with the 'Method' class instance, 'Event' class instance and+-- the instance of the appropriate serialisation class.+--+-- However, if the event data type already exists, this will generate+-- the serialisation instance only.  This makes it possible to call+-- 'makeAcidicWithSerialiser' multiple times on the same events but+-- with different 'SerialiserSpec's, to support multiple serialisation+-- backends.+makeEvent :: SerialiserSpec -> Name -> Q [Dec]+makeEvent ss eventName+    = do exists <- recover (return False) (reify (toStructName eventName) >> return True)+         eventType <- getEventType eventName+         if exists+           then do b <- makeEventSerialiser ss eventName eventType+                   return [b]+           else do d <- makeEventDataType      eventName eventType+                   b <- makeEventSerialiser ss eventName eventType+                   i <- makeMethodInstance     eventName eventType+                   e <- makeEventInstance      eventName eventType+                   return [d,b,i,e]  getEventType :: Name -> Q Type getEventType eventName@@ -97,16 +142,17 @@  --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where --  acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ]-makeIsAcidic eventNames stateName tyvars constructors+makeIsAcidic ss eventNames stateName tyvars constructors     = do types <- mapM getEventType eventNames          stateType' <- stateType-         let preds = [ ''SafeCopy, ''Typeable ]+         let preds = [ serialisationClassName ss, ''Typeable ]              ty = appT (conT ''IsAcidic) stateType-             handlers = zipWith makeEventHandler eventNames types+             handlers = zipWith (makeEventHandler ss) eventNames types              cxtFromEvents = nub $ concat $ zipWith (eventCxts stateType' tyvars) eventNames types          cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents          instanceD (return cxts') ty-                   [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ]+                   [ valD (varP 'acidEvents) (normalB (listE handlers)) []+                   ]     where stateType = foldl appT (conT stateName) (map varT (allTyVarBndrNames tyvars))  -- | This function analyses an event function and extracts any@@ -223,18 +269,17 @@     renameType (SigT a k)     = SigT (renameType a) k     renameType typ            = typ --- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2)-makeEventHandler :: Name -> Type -> ExpQ-makeEventHandler eventName eventType+-- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) safeCopyMethodSerialiser+makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ+makeEventHandler ss eventName eventType     = 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))+                     `appE` varE (methodSerialiserName ss)     where constr = if isUpdate then 'UpdateEvent else 'QueryEvent           TypeAnalysis { tyvars, argumentTypes = args, stateType, isUpdate } = analyseType eventName eventType-          eventStructName = mkName (structName (nameBase eventName))-          structName [] = []-          structName (x:xs) = toUpper x : xs+          eventStructName = toStructName eventName           stateTypeTyVars = findTyVars stateType           tyVarNames = map tyVarBndrName tyvars           assertTyVarsOk =@@ -273,13 +318,12 @@           _   -> dataD (return []) eventStructName tyvars [con] cxt #endif     where TypeAnalysis { tyvars, argumentTypes = args } = analyseType eventName eventType-          eventStructName = mkName (structName (nameBase eventName))-          structName [] = []-          structName (x:xs) = toUpper x : xs+          eventStructName = toStructName eventName  -- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where --    put (MyUpdateEvent a b) = do put a; put b --    get = MyUpdateEvent <$> get <*> get+makeSafeCopyInstance :: Name -> Type -> DecQ makeSafeCopyInstance eventName eventType     = do let preds = [ ''SafeCopy ]              ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))@@ -299,23 +343,21 @@                    , valD (varP 'getCopy) (normalB (contained getArgs)) []                    ]     where TypeAnalysis { tyvars, context, argumentTypes = args } = analyseType eventName eventType-          eventStructName = mkName (structName (nameBase eventName))-          structName [] = []-          structName (x:xs) = toUpper x : xs+          eventStructName = toStructName eventName  mkCxtFromTyVars preds tyvars extraContext     = cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++             map return extraContext  {--instance (SafeCopy key, Typeable key-         ,SafeCopy val, Typeable val) => Method (MyUpdateEvent key val) where+instance (Typeable key, Typeable val) => Method (MyUpdateEvent key val) where   type MethodResult (MyUpdateEvent key val) = Return   type MethodState (MyUpdateEvent key val) = State key val -}+makeMethodInstance :: Name -> Type -> DecQ makeMethodInstance eventName eventType = do     let preds =-            [ ''SafeCopy, ''Typeable ]+            [ ''Typeable ]         ty =             AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))         structType =@@ -339,24 +381,19 @@ #endif         ]     where TypeAnalysis { tyvars, context, stateType, resultType } = analyseType eventName eventType-          eventStructName = mkName (structName (nameBase eventName))-          structName [] = []-          structName (x:xs) = toUpper x : xs+          eventStructName = toStructName eventName ---instance (SafeCopy key, Typeable key---         ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val)+--instance (Typeable key, Typeable val) => UpdateEvent (MyUpdateEvent key val) makeEventInstance :: Name -> Type -> DecQ makeEventInstance eventName eventType-    = do let preds = [ ''SafeCopy, ''Typeable ]+    = do let preds = [ ''Typeable ]              eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent              ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))          instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context)                    (return ty)                    []     where TypeAnalysis { tyvars, context, isUpdate } = analyseType eventName eventType-          eventStructName = mkName (structName (nameBase eventName))-          structName [] = []-          structName (x:xs) = toUpper x : xs+          eventStructName = toStructName eventName  data TypeAnalysis = TypeAnalysis     { tyvars :: [TyVarBndr]@@ -454,3 +491,11 @@  allTyVarBndrNames :: [TyVarBndr] -> [Name] allTyVarBndrNames tyvars = map tyVarBndrName tyvars++-- | Convert the 'Name' of the event function into the name of the+-- corresponding data constructor.+toStructName :: Name -> Name+toStructName eventName = mkName (structName (nameBase eventName))+  where+    structName [] = []+    structName (x:xs) = toUpper x : xs