{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Acid.Local
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- AcidState container using a transaction log on disk. The term \'Event\' is
-- loosely used for transactions with ACID guarantees. \'Method\' is loosely
-- used for state operations without ACID guarantees (see "Data.Acid.Core").
--

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
import Data.Acid.Abstract

import Control.Concurrent             ( newEmptyMVar, putMVar, takeMVar, MVar )
import Control.Exception              ( onException, evaluate, Exception, throwIO )
import Control.Monad.State            ( runState )
import Control.Monad                  ( join )
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative            ( (<$>), (<*>) )
#endif
import Data.ByteString.Lazy           ( ByteString )
import qualified Data.ByteString.Lazy as Lazy ( length )

import Data.Serialize                 ( runPutLazy, runGetLazy )
import Data.SafeCopy                  ( SafeCopy(..), safeGet, safePut
                                      , primitive, contain )
import Data.Typeable                  ( Typeable, typeOf )
import Data.IORef
import System.FilePath                ( (</>), takeDirectory )
import System.FileLock
import System.Directory               ( createDirectoryIfMissing )


{-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)
    guarantees.

    [@Atomicity@]  State changes are all-or-nothing. This is what you'd expect of any state
                   variable in Haskell and AcidState doesn't change that.

    [@Consistency@] No event or set of events will break your data invariants.

    [@Isolation@] Transactions cannot interfere with each other even when issued in parallel.

    [@Durability@] Successful transaction are guaranteed to survive system failure (both
                   hardware and software).
-}
data LocalState st
    = LocalState { forall st. LocalState st -> Core st
localCore        :: Core st
                 , forall st. LocalState st -> IORef st
localCopy        :: IORef st
                 , forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents      :: FileLog (Tagged ByteString)
                 , forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints :: FileLog (Checkpoint st)
                 , forall st. LocalState st -> FileLock
localLock        :: FileLock
                 } deriving (Typeable)

newtype StateIsLocked = StateIsLocked FilePath deriving (Int -> StateIsLocked -> ShowS
[StateIsLocked] -> ShowS
StateIsLocked -> String
(Int -> StateIsLocked -> ShowS)
-> (StateIsLocked -> String)
-> ([StateIsLocked] -> ShowS)
-> Show StateIsLocked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StateIsLocked -> ShowS
showsPrec :: Int -> StateIsLocked -> ShowS
$cshow :: StateIsLocked -> String
show :: StateIsLocked -> String
$cshowList :: [StateIsLocked] -> ShowS
showList :: [StateIsLocked] -> ShowS
Show, Typeable)

instance Exception StateIsLocked

-- | Issue an Update event and return immediately. The event is not durable
--   before the MVar has been filled but the order of events is honored.
--   The behavior in case of exceptions is exactly the same as for 'update'.
--
--   If EventA is scheduled before EventB, EventA /will/ be executed before EventB:
--
--   @
--do scheduleUpdate acid EventA
--   scheduleUpdate acid EventB
--   @
scheduleLocalUpdate :: UpdateEvent event => LocalState (EventState event) -> event -> IO (MVar (EventResult event))
scheduleLocalUpdate :: forall event.
UpdateEvent event =>
LocalState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleLocalUpdate LocalState (EventState event)
acidState event
event
    = do MVar (EventResult event)
mvar <- IO (MVar (EventResult event))
forall a. IO (MVar a)
newEmptyMVar
         let encoded :: ByteString
encoded = MethodSerialiser event -> event -> ByteString
forall method. MethodSerialiser method -> method -> ByteString
encodeMethod MethodSerialiser event
ms event
event

         -- It is important that we encode the event now so that we can catch
         -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs)
         Int64 -> IO Int64
forall a. a -> IO a
evaluate (ByteString -> Int64
Lazy.length ByteString
encoded)

         Core (EventState event)
-> (EventState event -> IO (EventState event)) -> IO ()
forall st. Core st -> (st -> IO st) -> IO ()
modifyCoreState_ (LocalState (EventState event) -> Core (EventState event)
forall st. LocalState st -> Core st
localCore LocalState (EventState event)
acidState) ((EventState event -> IO (EventState event)) -> IO ())
-> (EventState event -> IO (EventState event)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EventState event
st ->
           do let !(EventResult event
result, !EventState event
st') = State (EventState event) (EventResult event)
-> EventState event -> (EventResult event, EventState event)
forall s a. State s a -> s -> (a, s)
runState State (EventState event) (EventResult event)
hotMethod EventState event
st
              -- Schedule the log entry. Very important that it happens when 'localCore' is locked
              -- to ensure that events are logged in the same order that they are executed.
              FileLog (Tagged ByteString) -> Tagged ByteString -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState (EventState event) -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState (EventState event)
acidState) (event -> ByteString
forall ev. Method ev => ev -> ByteString
methodTag event
event, ByteString
encoded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do IORef (EventState event) -> EventState event -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (LocalState (EventState event) -> IORef (EventState event)
forall st. LocalState st -> IORef st
localCopy LocalState (EventState event)
acidState) EventState event
st'
                                                                                MVar (EventResult event) -> EventResult event -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EventResult event)
mvar EventResult event
result
              EventState event -> IO (EventState event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventState event
st'
         MVar (EventResult event) -> IO (MVar (EventResult event))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (EventResult event)
mvar
    where (State (EventState event) (EventResult event)
hotMethod, MethodSerialiser event
ms) = MethodMap (EventState event)
-> event
-> (State (EventState event) (EventResult event),
    MethodSerialiser event)
forall method.
Method method =>
MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
lookupHotMethodAndSerialiser (Core (EventState event) -> MethodMap (EventState event)
forall st. Core st -> MethodMap st
coreMethods (LocalState (EventState event) -> Core (EventState event)
forall st. LocalState st -> Core st
localCore LocalState (EventState event)
acidState)) event
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
-- care to run actions of multiple Updates in the correct order as otherwise
-- Queries will operate on outdated state.
scheduleLocalUpdate' :: UpdateEvent event => LocalState (EventState event) -> event -> MVar (EventResult event) -> IO (IO ())
scheduleLocalUpdate' :: forall event.
UpdateEvent event =>
LocalState (EventState event)
-> event -> MVar (EventResult event) -> IO (IO ())
scheduleLocalUpdate' LocalState (EventState event)
acidState event
event MVar (EventResult event)
mvar
    = do
         let encoded :: ByteString
encoded = MethodSerialiser event -> event -> ByteString
forall method. MethodSerialiser method -> method -> ByteString
encodeMethod MethodSerialiser event
ms event
event

         -- It is important that we encode the event now so that we can catch
         -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs)
         Int64 -> IO Int64
forall a. a -> IO a
evaluate (ByteString -> Int64
Lazy.length ByteString
encoded)

         IO ()
act <- Core (EventState event)
-> (EventState event -> IO (EventState event, IO ())) -> IO (IO ())
forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState (LocalState (EventState event) -> Core (EventState event)
forall st. LocalState st -> Core st
localCore LocalState (EventState event)
acidState) ((EventState event -> IO (EventState event, IO ())) -> IO (IO ()))
-> (EventState event -> IO (EventState event, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \EventState event
st ->
           do let !(EventResult event
result, !EventState event
st') = State (EventState event) (EventResult event)
-> EventState event -> (EventResult event, EventState event)
forall s a. State s a -> s -> (a, s)
runState State (EventState event) (EventResult event)
hotMethod EventState event
st
              -- Schedule the log entry. Very important that it happens when 'localCore' is locked
              -- to ensure that events are logged in the same order that they are executed.
              FileLog (Tagged ByteString) -> Tagged ByteString -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState (EventState event) -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState (EventState event)
acidState) (event -> ByteString
forall ev. Method ev => ev -> ByteString
methodTag event
event, ByteString
encoded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              let action :: IO ()
action = do IORef (EventState event) -> EventState event -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (LocalState (EventState event) -> IORef (EventState event)
forall st. LocalState st -> IORef st
localCopy LocalState (EventState event)
acidState) EventState event
st'
                              MVar (EventResult event) -> EventResult event -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EventResult event)
mvar EventResult event
result
              (EventState event, IO ()) -> IO (EventState event, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventState event
st', IO ()
action)
         -- this is the action to update state for queries and release the
         -- result into the supplied mvar
         IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
act
    where (State (EventState event) (EventResult event)
hotMethod, MethodSerialiser event
ms) = MethodMap (EventState event)
-> event
-> (State (EventState event) (EventResult event),
    MethodSerialiser event)
forall method.
Method method =>
MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
lookupHotMethodAndSerialiser (Core (EventState event) -> MethodMap (EventState event)
forall st. Core st -> MethodMap st
coreMethods (LocalState (EventState event) -> Core (EventState event)
forall st. LocalState st -> Core st
localCore LocalState (EventState event)
acidState)) event
event

scheduleLocalColdUpdate :: LocalState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleLocalColdUpdate :: forall st.
LocalState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleLocalColdUpdate LocalState st
acidState Tagged ByteString
event
    = do MVar ByteString
mvar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
         Core st -> (st -> IO st) -> IO ()
forall st. Core st -> (st -> IO st) -> IO ()
modifyCoreState_ (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) ((st -> IO st) -> IO ()) -> (st -> IO st) -> IO ()
forall a b. (a -> b) -> a -> b
$ \st
st ->
           do let !(ByteString
result, !st
st') = State st ByteString -> st -> (ByteString, st)
forall s a. State s a -> s -> (a, s)
runState State st ByteString
coldMethod st
st
              -- Schedule the log entry. Very important that it happens when 'localCore' is locked
              -- to ensure that events are logged in the same order that they are executed.
              FileLog (Tagged ByteString) -> Tagged ByteString -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState) Tagged ByteString
event (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do IORef st -> st -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (LocalState st -> IORef st
forall st. LocalState st -> IORef st
localCopy LocalState st
acidState) st
st'
                                                           MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
mvar ByteString
result
              st -> IO st
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return st
st'
         MVar ByteString -> IO (MVar ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MVar ByteString
mvar
    where coldMethod :: State st ByteString
coldMethod = Core st -> Tagged ByteString -> State st ByteString
forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) Tagged ByteString
event

-- | Same as scheduleLocalColdUpdate but does not immediately change the
-- localCopy and return the result mvar - returns an IO action to do this
-- instead. Take care to run actions of multiple Updates in the correct order as
-- otherwise Queries will operate on outdated state.
scheduleLocalColdUpdate' :: LocalState st -> Tagged ByteString -> MVar ByteString -> IO (IO ())
scheduleLocalColdUpdate' :: forall st.
LocalState st -> Tagged ByteString -> MVar ByteString -> IO (IO ())
scheduleLocalColdUpdate' LocalState st
acidState Tagged ByteString
event MVar ByteString
mvar
    = do IO ()
act <- Core st -> (st -> IO (st, IO ())) -> IO (IO ())
forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) ((st -> IO (st, IO ())) -> IO (IO ()))
-> (st -> IO (st, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \st
st ->
           do let !(ByteString
result, !st
st') = State st ByteString -> st -> (ByteString, st)
forall s a. State s a -> s -> (a, s)
runState State st ByteString
coldMethod st
st
              -- Schedule the log entry. Very important that it happens when 'localCore' is locked
              -- to ensure that events are logged in the same order that they are executed.
              FileLog (Tagged ByteString) -> Tagged ByteString -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState) Tagged ByteString
event (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              let action :: IO ()
action = do IORef st -> st -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (LocalState st -> IORef st
forall st. LocalState st -> IORef st
localCopy LocalState st
acidState) st
st'
                              MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
mvar ByteString
result
              (st, IO ()) -> IO (st, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (st
st', IO ()
action)
         IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
act
    where coldMethod :: State st ByteString
coldMethod = Core st -> Tagged ByteString -> State st ByteString
forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) Tagged ByteString
event

-- | Issue a Query event and wait for its result. Events may be issued in parallel.
localQuery  :: QueryEvent event  => LocalState (EventState event) -> event -> IO (EventResult event)
localQuery :: forall event.
QueryEvent event =>
LocalState (EventState event) -> event -> IO (EventResult event)
localQuery LocalState (EventState event)
acidState event
event
    = do EventState event
st <- IORef (EventState event) -> IO (EventState event)
forall a. IORef a -> IO a
readIORef (LocalState (EventState event) -> IORef (EventState event)
forall st. LocalState st -> IORef st
localCopy LocalState (EventState event)
acidState)
         let (EventResult event
result, EventState event
_st) = State (EventState event) (EventResult event)
-> EventState event -> (EventResult event, EventState event)
forall s a. State s a -> s -> (a, s)
runState State (EventState event) (EventResult event)
hotMethod EventState event
st
         EventResult event -> IO (EventResult event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventResult event
result
    where hotMethod :: State (EventState event) (EventResult event)
hotMethod = MethodMap (EventState event)
-> event -> State (EventState event) (EventResult event)
forall method.
Method method =>
MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
lookupHotMethod (Core (EventState event) -> MethodMap (EventState event)
forall st. Core st -> MethodMap st
coreMethods (LocalState (EventState event) -> Core (EventState event)
forall st. LocalState st -> Core st
localCore LocalState (EventState event)
acidState)) event
event

-- Whoa, a buttload of refactoring is needed here. 2011-11-02
localQueryCold  :: LocalState st -> Tagged ByteString -> IO ByteString
localQueryCold :: forall st. LocalState st -> Tagged ByteString -> IO ByteString
localQueryCold LocalState st
acidState Tagged ByteString
event
    = do st
st <- IORef st -> IO st
forall a. IORef a -> IO a
readIORef (LocalState st -> IORef st
forall st. LocalState st -> IORef st
localCopy LocalState st
acidState)
         let (ByteString
result, st
_st) = State st ByteString -> st -> (ByteString, st)
forall s a. State s a -> s -> (a, s)
runState State st ByteString
coldMethod st
st
         ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
result
    where coldMethod :: State st ByteString
coldMethod = Core st -> Tagged ByteString -> State st ByteString
forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) Tagged ByteString
event

-- | Take a snapshot of the state and save it to disk. Creating checkpoints
--   makes it faster to resume AcidStates and you're free to create them as
--   often or seldom as fits your needs. Transactions can run concurrently
--   with this call.
--
--   This call will not return until the operation has succeeded.
createLocalCheckpoint :: IsAcidic st => LocalState st -> IO ()
createLocalCheckpoint :: forall st. IsAcidic st => LocalState st -> IO ()
createLocalCheckpoint LocalState st
acidState
    = do FileLog (Tagged ByteString) -> IO Int
forall object. FileLog object -> IO Int
cutFileLog (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState)
         MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
         Core st -> (st -> IO ()) -> IO ()
forall st a. Core st -> (st -> IO a) -> IO a
withCoreState (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) ((st -> IO ()) -> IO ()) -> (st -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \st
st ->
           do Int
eventId <- FileLog (Tagged ByteString) -> IO Int
forall object. FileLog object -> IO Int
askCurrentEntryId (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState)
              FileLog (Tagged ByteString) -> IO () -> IO ()
forall object. FileLog object -> IO () -> IO ()
pushAction (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                FileLog (Checkpoint st) -> Checkpoint st -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
acidState) (Int -> st -> Checkpoint st
forall s. Int -> s -> Checkpoint s
Checkpoint Int
eventId st
st) (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ())
         MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
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 :: (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose :: forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState st
abstract_state
    = do MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
         Core st -> (st -> IO ()) -> IO ()
forall st. Core st -> (st -> IO ()) -> IO ()
closeCore' (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState) ((st -> IO ()) -> IO ()) -> (st -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \st
st ->
           do Int
eventId <- FileLog (Tagged ByteString) -> IO Int
forall object. FileLog object -> IO Int
askCurrentEntryId (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState)
              FileLog (Tagged ByteString) -> IO () -> IO ()
forall object. FileLog object -> IO () -> IO ()
pushAction (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                FileLog (Checkpoint st) -> Checkpoint st -> IO () -> IO ()
forall object. FileLog object -> object -> IO () -> IO ()
pushEntry (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
acidState) (Int -> st -> Checkpoint st
forall s. Int -> s -> Checkpoint s
Checkpoint Int
eventId st
st) (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ())
         MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
         FileLog (Tagged ByteString) -> IO ()
forall object. FileLog object -> IO ()
closeFileLog (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState)
         FileLog (Checkpoint st) -> IO ()
forall object. FileLog object -> IO ()
closeFileLog (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
acidState)
         FileLock -> IO ()
unlockFile (LocalState st -> FileLock
forall st. LocalState st -> FileLock
localLock LocalState st
acidState)
  where acidState :: LocalState st
acidState = AcidState st -> LocalState st
forall (sub :: * -> *) st.
(Typeable sub, Typeable st) =>
AcidState st -> sub st
downcast AcidState st
abstract_state


data Checkpoint s = Checkpoint EntryId s

-- | 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 :: Kind (Checkpoint s)
kind = Kind (Checkpoint s)
forall a. Kind a
primitive
    putCopy :: Checkpoint s -> Contained Put
putCopy (Checkpoint Int
eventEntryId s
content)
        = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$
          do Int -> Put
forall a. SafeCopy a => a -> Put
safePut Int
eventEntryId
             ByteString -> Put
forall a. SafeCopy a => a -> Put
safePut (Put -> ByteString
runPutLazy (s -> Put
forall a. SafeCopy a => a -> Put
safePut s
content))
    getCopy :: Contained (Get (Checkpoint s))
getCopy = Get (Checkpoint s) -> Contained (Get (Checkpoint s))
forall a. a -> Contained a
contain (Get (Checkpoint s) -> Contained (Get (Checkpoint s)))
-> Get (Checkpoint s) -> Contained (Get (Checkpoint s))
forall a b. (a -> b) -> a -> b
$ Int -> s -> Checkpoint s
forall s. Int -> s -> Checkpoint s
Checkpoint (Int -> s -> Checkpoint s) -> Get Int -> Get (s -> Checkpoint s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. SafeCopy a => Get a
safeGet Get (s -> Checkpoint s) -> Get s -> Get (Checkpoint s)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> s
forall {a}. SafeCopy a => ByteString -> a
fromNested (ByteString -> s) -> Get ByteString -> Get s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall a. SafeCopy a => Get a
safeGet)
      where
        fromNested :: ByteString -> a
fromNested ByteString
b = case Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGetLazy Get a
forall a. SafeCopy a => Get a
safeGet ByteString
b of
                         Left String
msg -> String -> a
forall {a}. String -> a
checkpointRestoreError String
msg
                         Right a
v  -> a
v
    errorTypeName :: Proxy (Checkpoint s) -> String
errorTypeName Proxy (Checkpoint s)
s = String
"Checkpoint " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy (Checkpoint s) -> String
forall a. SafeCopy a => Proxy a -> String
errorTypeName Proxy (Checkpoint s)
s


-- | 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, SafeCopy st)
              => st                          -- ^ Initial state value. This value is only used if no checkpoint is
                                             --   found.
              -> IO (AcidState st)
openLocalState :: forall st.
(Typeable st, IsAcidic st, SafeCopy st) =>
st -> IO (AcidState st)
openLocalState st
initialState =
  String -> st -> IO (AcidState st)
forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (AcidState st)
openLocalStateFrom (st -> String
forall st. Typeable st => st -> String
defaultStateDirectory st
initialState) st
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, SafeCopy st)
                  => st                          -- ^ Initial state value. This value is only used if no checkpoint is
                                                 --   found.
                  -> IO (IO (AcidState st))
prepareLocalState :: forall st.
(Typeable st, IsAcidic st, SafeCopy st) =>
st -> IO (IO (AcidState st))
prepareLocalState st
initialState =
  String -> st -> IO (IO (AcidState st))
forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (IO (AcidState st))
prepareLocalStateFrom (st -> String
forall st. Typeable st => st -> String
defaultStateDirectory st
initialState) st
initialState

-- | Directory to load the state from unless otherwise specified,
-- namely \"state\/[typeOf state]\/\".
defaultStateDirectory :: Typeable st => st -> FilePath
defaultStateDirectory :: forall st. Typeable st => st -> String
defaultStateDirectory st
initialState = String
"state" String -> ShowS
</> TypeRep -> String
forall a. Show a => a -> String
show (st -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf st
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, 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 :: forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (AcidState st)
openLocalStateFrom String
directory st
initialState =
  String -> st -> SerialisationLayer st -> IO (AcidState st)
forall st.
IsAcidic st =>
String -> st -> SerialisationLayer st -> IO (AcidState st)
openLocalStateWithSerialiser String
directory st
initialState SerialisationLayer st
forall st. SafeCopy st => SerialisationLayer st
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@.
--   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 :: forall st.
IsAcidic st =>
String -> st -> SerialisationLayer st -> IO (AcidState st)
openLocalStateWithSerialiser String
directory st
initialState SerialisationLayer st
serialisationLayer =
  IO (IO (AcidState st)) -> IO (AcidState st)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (AcidState st)) -> IO (AcidState st))
-> IO (IO (AcidState st)) -> IO (AcidState st)
forall a b. (a -> b) -> a -> b
$ String
-> st -> Bool -> SerialisationLayer st -> IO (IO (AcidState st))
forall st.
IsAcidic st =>
String
-> st -> Bool -> SerialisationLayer st -> IO (IO (AcidState st))
resumeLocalStateFrom String
directory st
initialState Bool
False SerialisationLayer st
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, 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 :: forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (IO (AcidState st))
prepareLocalStateFrom String
directory st
initialState =
  String -> st -> SerialisationLayer st -> IO (IO (AcidState st))
forall st.
IsAcidic st =>
String -> st -> SerialisationLayer st -> IO (IO (AcidState st))
prepareLocalStateWithSerialiser String
directory st
initialState SerialisationLayer st
forall st. SafeCopy st => SerialisationLayer st
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 :: forall st.
IsAcidic st =>
String -> st -> SerialisationLayer st -> IO (IO (AcidState st))
prepareLocalStateWithSerialiser String
directory st
initialState SerialisationLayer st
serialisationLayer =
  String
-> st -> Bool -> SerialisationLayer st -> IO (IO (AcidState st))
forall st.
IsAcidic st =>
String
-> st -> Bool -> SerialisationLayer st -> IO (IO (AcidState st))
resumeLocalStateFrom String
directory st
initialState Bool
True SerialisationLayer st
serialisationLayer


data SerialisationLayer st =
    SerialisationLayer
        {  forall st. SerialisationLayer st -> Serialiser (Checkpoint st)
checkpointSerialiser :: Serialiser (Checkpoint st)
            -- ^ Serialisation strategy for checkpoints.
            --
            -- Use 'safeCopySerialiser' for the backwards-compatible
            -- implementation using "Data.SafeCopy".

        , forall st. SerialisationLayer st -> Serialiser (Tagged ByteString)
eventSerialiser :: Serialiser (Tagged ByteString)
            -- ^ Serialisation strategy for events.
            --
            -- Use 'safeCopySerialiser' for the backwards-compatible
            -- implementation using "Data.SafeCopy".

        , forall st. SerialisationLayer st -> Archiver
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 :: forall st. SafeCopy st => SerialisationLayer st
defaultSerialisationLayer = Serialiser (Checkpoint st)
-> Serialiser (Tagged ByteString)
-> Archiver
-> SerialisationLayer st
forall st.
Serialiser (Checkpoint st)
-> Serialiser (Tagged ByteString)
-> Archiver
-> SerialisationLayer st
SerialisationLayer Serialiser (Checkpoint st)
forall a. SafeCopy a => Serialiser a
safeCopySerialiser Serialiser (Tagged ByteString)
forall a. SafeCopy a => Serialiser a
safeCopySerialiser Archiver
defaultArchiver

mkEventsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Tagged ByteString)
mkEventsLogKey :: forall object.
String -> SerialisationLayer object -> LogKey (Tagged ByteString)
mkEventsLogKey String
directory SerialisationLayer object
serialisationLayer =
  LogKey { logDirectory :: String
logDirectory = String
directory
         , logPrefix :: String
logPrefix = String
"events"
         , logSerialiser :: Serialiser (Tagged ByteString)
logSerialiser = SerialisationLayer object -> Serialiser (Tagged ByteString)
forall st. SerialisationLayer st -> Serialiser (Tagged ByteString)
eventSerialiser SerialisationLayer object
serialisationLayer
         , logArchiver :: Archiver
logArchiver   = SerialisationLayer object -> Archiver
forall st. SerialisationLayer st -> Archiver
archiver SerialisationLayer object
serialisationLayer }

mkCheckpointsLogKey :: FilePath -> SerialisationLayer object -> LogKey (Checkpoint object)
mkCheckpointsLogKey :: forall object.
String -> SerialisationLayer object -> LogKey (Checkpoint object)
mkCheckpointsLogKey String
directory SerialisationLayer object
serialisationLayer =
  LogKey { logDirectory :: String
logDirectory = String
directory
         , logPrefix :: String
logPrefix = String
"checkpoints"
         , logSerialiser :: Serialiser (Checkpoint object)
logSerialiser = SerialisationLayer object -> Serialiser (Checkpoint object)
forall st. SerialisationLayer st -> Serialiser (Checkpoint st)
checkpointSerialiser SerialisationLayer object
serialisationLayer
         , logArchiver :: Archiver
logArchiver = SerialisationLayer object -> Archiver
forall st. SerialisationLayer st -> Archiver
archiver SerialisationLayer object
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 :: forall st.
IsAcidic st =>
String
-> st -> Bool -> SerialisationLayer st -> IO (IO (AcidState st))
resumeLocalStateFrom String
directory st
initialState Bool
delayLocking SerialisationLayer st
serialisationLayer =
  case Bool
delayLocking of
    Bool
True -> do
      (Int
n, st
st) <- IO (Int, st)
loadCheckpoint
      IO (AcidState st) -> IO (IO (AcidState st))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (AcidState st) -> IO (IO (AcidState st)))
-> IO (AcidState st) -> IO (IO (AcidState st))
forall a b. (a -> b) -> a -> b
$ do
        FileLock
lock  <- String -> IO FileLock
maybeLockFile String
lockFile
        FileLock -> Int -> st -> IO (AcidState st)
replayEvents FileLock
lock Int
n st
st
    Bool
False -> do
      FileLock
lock    <- String -> IO FileLock
maybeLockFile String
lockFile
      (Int
n, st
st) <- IO (Int, st)
loadCheckpoint IO (Int, st) -> IO () -> IO (Int, st)
forall a b. IO a -> IO b -> IO a
`onException` FileLock -> IO ()
unlockFile FileLock
lock
      IO (AcidState st) -> IO (IO (AcidState st))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (AcidState st) -> IO (IO (AcidState st)))
-> IO (AcidState st) -> IO (IO (AcidState st))
forall a b. (a -> b) -> a -> b
$ do
        FileLock -> Int -> st -> IO (AcidState st)
replayEvents FileLock
lock Int
n st
st
  where
    lockFile :: String
lockFile = String
directory String -> ShowS
</> String
"open.lock"
    eventsLogKey :: LogKey (Tagged ByteString)
eventsLogKey = String -> SerialisationLayer st -> LogKey (Tagged ByteString)
forall object.
String -> SerialisationLayer object -> LogKey (Tagged ByteString)
mkEventsLogKey String
directory SerialisationLayer st
serialisationLayer
    checkpointsLogKey :: LogKey (Checkpoint st)
checkpointsLogKey = String -> SerialisationLayer st -> LogKey (Checkpoint st)
forall object.
String -> SerialisationLayer object -> LogKey (Checkpoint object)
mkCheckpointsLogKey String
directory SerialisationLayer st
serialisationLayer
    loadCheckpoint :: IO (Int, st)
loadCheckpoint = do
      Maybe (Checkpoint st)
mbLastCheckpoint <- LogKey (Checkpoint st) -> IO (Maybe (Checkpoint st))
forall object. LogKey object -> IO (Maybe object)
Log.newestEntry LogKey (Checkpoint st)
checkpointsLogKey
      case Maybe (Checkpoint st)
mbLastCheckpoint of
        Maybe (Checkpoint st)
Nothing ->
          (Int, st) -> IO (Int, st)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, st
initialState)
        Just (Checkpoint Int
eventCutOff !st
val) ->
          -- N.B. We must be strict in val so that we force any
          -- lurking deserialisation error immediately.
          (Int, st) -> IO (Int, st)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
eventCutOff, st
val)
    replayEvents :: FileLock -> Int -> st -> IO (AcidState st)
replayEvents FileLock
lock Int
n st
st = do
      Core st
core <- [MethodContainer st] -> st -> IO (Core st)
forall st. [MethodContainer st] -> st -> IO (Core st)
mkCore ([Event st] -> [MethodContainer st]
forall st. [Event st] -> [MethodContainer st]
eventsToMethods [Event st]
forall st. IsAcidic st => [Event st]
acidEvents) st
st

      FileLog (Tagged ByteString)
eventsLog <- LogKey (Tagged ByteString) -> IO (FileLog (Tagged ByteString))
forall object. LogKey object -> IO (FileLog object)
openFileLog LogKey (Tagged ByteString)
eventsLogKey
      [Tagged ByteString]
events <- FileLog (Tagged ByteString) -> Int -> IO [Tagged ByteString]
forall object. FileLog object -> Int -> IO [object]
readEntriesFrom FileLog (Tagged ByteString)
eventsLog Int
n
      (Tagged ByteString -> IO ByteString)
-> [Tagged ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Core st -> Tagged ByteString -> IO ByteString
forall st. Core st -> Tagged ByteString -> IO ByteString
runColdMethod Core st
core) [Tagged ByteString]
events
      FileLog (Tagged ByteString) -> Int -> IO ()
forall object. FileLog object -> Int -> IO ()
ensureLeastEntryId FileLog (Tagged ByteString)
eventsLog Int
n
      FileLog (Checkpoint st)
checkpointsLog <- LogKey (Checkpoint st) -> IO (FileLog (Checkpoint st))
forall object. LogKey object -> IO (FileLog object)
openFileLog LogKey (Checkpoint st)
checkpointsLogKey
      IORef st
stateCopy <- st -> IO (IORef st)
forall a. a -> IO (IORef a)
newIORef st
forall a. HasCallStack => a
undefined
      Core st -> (st -> IO ()) -> IO ()
forall st a. Core st -> (st -> IO a) -> IO a
withCoreState Core st
core (IORef st -> st -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef st
stateCopy)

      AcidState st -> IO (AcidState st)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AcidState st -> IO (AcidState st))
-> AcidState st -> IO (AcidState st)
forall a b. (a -> b) -> a -> b
$ LocalState st -> AcidState st
forall st. IsAcidic st => LocalState st -> AcidState st
toAcidState LocalState { localCore :: Core st
localCore = Core st
core
                                      , localCopy :: IORef st
localCopy = IORef st
stateCopy
                                      , localEvents :: FileLog (Tagged ByteString)
localEvents = FileLog (Tagged ByteString)
eventsLog
                                      , localCheckpoints :: FileLog (Checkpoint st)
localCheckpoints = FileLog (Checkpoint st)
checkpointsLog
                                      , localLock :: FileLock
localLock = FileLock
lock
                                      }
    maybeLockFile :: String -> IO FileLock
maybeLockFile String
path = do
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
path)
      IO FileLock
-> (FileLock -> IO FileLock) -> Maybe FileLock -> IO FileLock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StateIsLocked -> IO FileLock
forall e a. Exception e => e -> IO a
throwIO (String -> StateIsLocked
StateIsLocked String
path))
                            FileLock -> IO FileLock
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileLock -> IO FileLock)
-> IO (Maybe FileLock) -> IO FileLock
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> SharedExclusive -> IO (Maybe FileLock)
tryLockFile String
path SharedExclusive
Exclusive


checkpointRestoreError :: String -> a
checkpointRestoreError String
msg
    = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Could not parse saved checkpoint due to the following error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg


-- | Close an AcidState and associated logs.
--   Any subsequent usage of the AcidState will throw an exception.
closeLocalState :: LocalState st -> IO ()
closeLocalState :: forall st. LocalState st -> IO ()
closeLocalState LocalState st
acidState
    = do Core st -> IO ()
forall st. Core st -> IO ()
closeCore (LocalState st -> Core st
forall st. LocalState st -> Core st
localCore LocalState st
acidState)
         FileLog (Tagged ByteString) -> IO ()
forall object. FileLog object -> IO ()
closeFileLog (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
acidState)
         FileLog (Checkpoint st) -> IO ()
forall object. FileLog object -> IO ()
closeFileLog (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
acidState)
         FileLock -> IO ()
unlockFile (LocalState st -> FileLock
forall st. LocalState st -> FileLock
localLock LocalState st
acidState)

createLocalArchive :: LocalState st -> IO ()
createLocalArchive :: forall st. LocalState st -> IO ()
createLocalArchive LocalState st
state
  = do -- We need to look at the last checkpoint saved to disk. Since checkpoints can be written
       -- in parallel with this call, we can't guarantee that the checkpoint we get really is the
       -- last one but that's alright.
       Int
currentCheckpointId <- FileLog (Checkpoint st) -> IO Int
forall object. FileLog object -> IO Int
cutFileLog (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
state)
       -- 'currentCheckpointId' is the ID of the next checkpoint that will be written to disk.
       -- 'currentCheckpointId-1' must then be the ID of a checkpoint on disk (or -1, of course).
       let durableCheckpointId :: Int
durableCheckpointId = Int
currentCheckpointIdInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
       [Checkpoint st]
checkpoints <- FileLog (Checkpoint st) -> Int -> IO [Checkpoint st]
forall object. FileLog object -> Int -> IO [object]
readEntriesFrom (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
state) Int
durableCheckpointId
       case [Checkpoint st]
checkpoints of
         []      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (Checkpoint Int
entryId st
_content : [Checkpoint st]
_)
           -> do -- 'entryId' is the lowest entryId that didn't contribute to the checkpoint.
                 -- 'archiveFileLog' moves all files that are lower than this entryId to the archive.
                 FileLog (Tagged ByteString) -> Int -> IO ()
forall object. FileLog object -> Int -> IO ()
archiveFileLog (LocalState st -> FileLog (Tagged ByteString)
forall st. LocalState st -> FileLog (Tagged ByteString)
localEvents LocalState st
state) Int
entryId
                 -- In the same style as above, we archive all log files that came before the log file
                 -- which contains our checkpoint.
                 FileLog (Checkpoint st) -> Int -> IO ()
forall object. FileLog object -> Int -> IO ()
archiveFileLog (LocalState st -> FileLog (Checkpoint st)
forall st. LocalState st -> FileLog (Checkpoint st)
localCheckpoints LocalState st
state) Int
durableCheckpointId

toAcidState :: IsAcidic st => LocalState st -> AcidState st
toAcidState :: forall st. IsAcidic st => LocalState st -> AcidState st
toAcidState LocalState st
local
  = AcidState { _scheduleUpdate :: forall event.
(UpdateEvent event, EventState event ~ st) =>
event -> IO (MVar (EventResult event))
_scheduleUpdate = LocalState (EventState event)
-> event -> IO (MVar (MethodResult event))
forall event.
UpdateEvent event =>
LocalState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleLocalUpdate LocalState st
LocalState (EventState event)
local
              , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString)
scheduleColdUpdate = LocalState st -> Tagged ByteString -> IO (MVar ByteString)
forall st.
LocalState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleLocalColdUpdate LocalState st
local
              , _query :: forall event.
(QueryEvent event, EventState event ~ st) =>
event -> IO (EventResult event)
_query = LocalState (EventState event) -> event -> IO (MethodResult event)
forall event.
QueryEvent event =>
LocalState (EventState event) -> event -> IO (EventResult event)
localQuery LocalState st
LocalState (EventState event)
local
              , queryCold :: Tagged ByteString -> IO ByteString
queryCold = LocalState st -> Tagged ByteString -> IO ByteString
forall st. LocalState st -> Tagged ByteString -> IO ByteString
localQueryCold LocalState st
local
              , createCheckpoint :: IO ()
createCheckpoint = LocalState st -> IO ()
forall st. IsAcidic st => LocalState st -> IO ()
createLocalCheckpoint LocalState st
local
              , createArchive :: IO ()
createArchive = LocalState st -> IO ()
forall st. LocalState st -> IO ()
createLocalArchive LocalState st
local
              , closeAcidState :: IO ()
closeAcidState = LocalState st -> IO ()
forall st. LocalState st -> IO ()
closeLocalState LocalState st
local
              , acidSubState :: AnyState st
acidSubState = LocalState st -> AnyState st
forall (sub_st :: * -> *) st.
Typeable sub_st =>
sub_st st -> AnyState st
mkAnyState LocalState st
local
              }