diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -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 diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -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 ] diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -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 ] diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -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 ] diff --git a/repair/Main.hs b/repair/Main.hs new file mode 100644 --- /dev/null +++ b/repair/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Data.Acid.Repair +import System.Directory + +main :: IO () +main = do + directory <- getCurrentDirectory + repairEvents directory + repairCheckpoints directory diff --git a/src/Data/Acid/Advanced.hs b/src/Data/Acid/Advanced.hs --- a/src/Data/Acid/Advanced.hs +++ b/src/Data/Acid/Advanced.hs @@ -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 diff --git a/src/Data/Acid/Archive.hs b/src/Data/Acid/Archive.hs --- a/src/Data/Acid/Archive.hs +++ b/src/Data/Acid/Archive.hs @@ -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 diff --git a/src/Data/Acid/Common.hs b/src/Data/Acid/Common.hs --- a/src/Data/Acid/Common.hs +++ b/src/Data/Acid/Common.hs @@ -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 diff --git a/src/Data/Acid/Core.hs b/src/Data/Acid/Core.hs --- a/src/Data/Acid/Core.hs +++ b/src/Data/Acid/Core.hs @@ -1,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) diff --git a/src/Data/Acid/Local.hs b/src/Data/Acid/Local.hs --- a/src/Data/Acid/Local.hs +++ b/src/Data/Acid/Local.hs @@ -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 diff --git a/src/Data/Acid/Log.hs b/src/Data/Acid/Log.hs --- a/src/Data/Acid/Log.hs +++ b/src/Data/Acid/Log.hs @@ -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 diff --git a/src/Data/Acid/Memory.hs b/src/Data/Acid/Memory.hs --- a/src/Data/Acid/Memory.hs +++ b/src/Data/Acid/Memory.hs @@ -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 () diff --git a/src/Data/Acid/Remote.hs b/src/Data/Acid/Remote.hs --- a/src/Data/Acid/Remote.hs +++ b/src/Data/Acid/Remote.hs @@ -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) diff --git a/src/Data/Acid/Repair.hs b/src/Data/Acid/Repair.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Repair.hs @@ -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 diff --git a/src/Data/Acid/TemplateHaskell.hs b/src/Data/Acid/TemplateHaskell.hs --- a/src/Data/Acid/TemplateHaskell.hs +++ b/src/Data/Acid/TemplateHaskell.hs @@ -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 diff --git a/test-state/OldStateTest1/events-0000000681.log b/test-state/OldStateTest1/events-0000000681.log deleted file mode 100644 --- a/test-state/OldStateTest1/events-0000000681.log +++ /dev/null diff --git a/test-state/OldStateTest2/events-0000000149.log b/test-state/OldStateTest2/events-0000000149.log deleted file mode 100644 --- a/test-state/OldStateTest2/events-0000000149.log +++ /dev/null diff --git a/test-state/OldStateTest3/events-0000000100.log b/test-state/OldStateTest3/events-0000000100.log deleted file mode 100644 --- a/test-state/OldStateTest3/events-0000000100.log +++ /dev/null