{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Acid.Memory
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- AcidState container without a transaction log. Mostly used for testing.
-- Supports Atomicity, Consistency and Isolation, but not Durability.
--

module Data.Acid.Memory
    ( openMemoryState
    ) where

import Data.Acid.Core
import Data.Acid.Common
import Data.Acid.Abstract

import Control.Concurrent             ( newEmptyMVar, putMVar, MVar )
import Control.Monad.State            ( runState )
import Data.ByteString.Lazy           ( ByteString )
import Data.Typeable                  ( Typeable )
import Data.IORef                     ( IORef, newIORef, readIORef, writeIORef )


{-| 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 MemoryState st
    = MemoryState { forall st. MemoryState st -> Core st
localCore    :: Core st
                  , forall st. MemoryState st -> IORef st
localCopy    :: IORef st
                  } deriving (Typeable)

-- | Create an 'AcidState' given an initial value.  The state is kept only in
-- memory, so it is not durable.
openMemoryState :: (IsAcidic st)
              => st                          -- ^ Initial state value.
              -> IO (AcidState st)
openMemoryState :: forall st. IsAcidic st => st -> IO (AcidState st)
openMemoryState st
initialState
    = 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
initialState
         IORef st
ref  <- st -> IO (IORef st)
forall a. a -> IO (IORef a)
newIORef st
initialState
         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
$ MemoryState st -> AcidState st
forall st. IsAcidic st => MemoryState st -> AcidState st
toAcidState MemoryState { localCore :: Core st
localCore = Core st
core, localCopy :: IORef st
localCopy = IORef st
ref }


-- | Issue an Update event and return immediately. 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
--   @
scheduleMemoryUpdate :: UpdateEvent event => MemoryState (EventState event) -> event -> IO (MVar (EventResult event))
scheduleMemoryUpdate :: forall event.
UpdateEvent event =>
MemoryState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleMemoryUpdate MemoryState (EventState event)
acidState event
event
    = do MVar (EventResult event)
mvar <- IO (MVar (EventResult event))
forall a. IO (MVar a)
newEmptyMVar
         Core (EventState event)
-> (EventState event -> IO (EventState event)) -> IO ()
forall st. Core st -> (st -> IO st) -> IO ()
modifyCoreState_ (MemoryState (EventState event) -> Core (EventState event)
forall st. MemoryState st -> Core st
localCore MemoryState (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
              IORef (EventState event) -> EventState event -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (MemoryState (EventState event) -> IORef (EventState event)
forall st. MemoryState st -> IORef st
localCopy MemoryState (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 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 (MemoryState (EventState event) -> Core (EventState event)
forall st. MemoryState st -> Core st
localCore MemoryState (EventState event)
acidState)) event
event

scheduleMemoryColdUpdate :: MemoryState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleMemoryColdUpdate :: forall st.
MemoryState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleMemoryColdUpdate MemoryState 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_ (MemoryState st -> Core st
forall st. MemoryState st -> Core st
localCore MemoryState 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
              IORef st -> st -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (MemoryState st -> IORef st
forall st. MemoryState st -> IORef st
localCopy MemoryState 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 (MemoryState st -> Core st
forall st. MemoryState st -> Core st
localCore MemoryState st
acidState) Tagged ByteString
event

-- | Issue a Query event and wait for its result. Events may be issued in parallel.
memoryQuery  :: QueryEvent event  => MemoryState (EventState event) -> event -> IO (EventResult event)
memoryQuery :: forall event.
QueryEvent event =>
MemoryState (EventState event) -> event -> IO (EventResult event)
memoryQuery MemoryState (EventState event)
acidState event
event
    = do EventState event
st <- IORef (EventState event) -> IO (EventState event)
forall a. IORef a -> IO a
readIORef (MemoryState (EventState event) -> IORef (EventState event)
forall st. MemoryState st -> IORef st
localCopy MemoryState (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 (MemoryState (EventState event) -> Core (EventState event)
forall st. MemoryState st -> Core st
localCore MemoryState (EventState event)
acidState)) event
event

memoryQueryCold  :: MemoryState st -> Tagged ByteString -> IO ByteString
memoryQueryCold :: forall st. MemoryState st -> Tagged ByteString -> IO ByteString
memoryQueryCold MemoryState st
acidState Tagged ByteString
event
    = do st
st <- IORef st -> IO st
forall a. IORef a -> IO a
readIORef (MemoryState st -> IORef st
forall st. MemoryState st -> IORef st
localCopy MemoryState 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 (MemoryState st -> Core st
forall st. MemoryState st -> Core st
localCore MemoryState st
acidState) Tagged ByteString
event

-- | This is a nop with the memory backend.
createMemoryCheckpoint :: MemoryState st -> IO ()
createMemoryCheckpoint :: forall st. MemoryState st -> IO ()
createMemoryCheckpoint MemoryState st
acidState
    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | This is a nop with the memory backend.
createMemoryArchive :: MemoryState st -> IO ()
createMemoryArchive :: forall st. MemoryState st -> IO ()
createMemoryArchive MemoryState st
acidState
    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Close an AcidState and associated logs.
--   Any subsequent usage of the AcidState will throw an exception.
closeMemoryState :: MemoryState st -> IO ()
closeMemoryState :: forall st. MemoryState st -> IO ()
closeMemoryState MemoryState st
acidState
    = Core st -> IO ()
forall st. Core st -> IO ()
closeCore (MemoryState st -> Core st
forall st. MemoryState st -> Core st
localCore MemoryState st
acidState)

toAcidState :: IsAcidic st => MemoryState st -> AcidState st
toAcidState :: forall st. IsAcidic st => MemoryState st -> AcidState st
toAcidState MemoryState st
memory
  = AcidState { _scheduleUpdate :: forall event.
(UpdateEvent event, EventState event ~ st) =>
event -> IO (MVar (EventResult event))
_scheduleUpdate    = MemoryState (EventState event)
-> event -> IO (MVar (MethodResult event))
forall event.
UpdateEvent event =>
MemoryState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleMemoryUpdate MemoryState st
MemoryState (EventState event)
memory
              , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString)
scheduleColdUpdate = MemoryState st -> Tagged ByteString -> IO (MVar ByteString)
forall st.
MemoryState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleMemoryColdUpdate MemoryState st
memory
              , _query :: forall event.
(QueryEvent event, EventState event ~ st) =>
event -> IO (EventResult event)
_query             = MemoryState (EventState event) -> event -> IO (MethodResult event)
forall event.
QueryEvent event =>
MemoryState (EventState event) -> event -> IO (EventResult event)
memoryQuery MemoryState st
MemoryState (EventState event)
memory
              , queryCold :: Tagged ByteString -> IO ByteString
queryCold          = MemoryState st -> Tagged ByteString -> IO ByteString
forall st. MemoryState st -> Tagged ByteString -> IO ByteString
memoryQueryCold MemoryState st
memory
              , createCheckpoint :: IO ()
createCheckpoint   = MemoryState st -> IO ()
forall st. MemoryState st -> IO ()
createMemoryCheckpoint MemoryState st
memory
              , createArchive :: IO ()
createArchive      = MemoryState st -> IO ()
forall st. MemoryState st -> IO ()
createMemoryArchive MemoryState st
memory
              , closeAcidState :: IO ()
closeAcidState     = MemoryState st -> IO ()
forall st. MemoryState st -> IO ()
closeMemoryState MemoryState st
memory
              , acidSubState :: AnyState st
acidSubState       = MemoryState st -> AnyState st
forall (sub_st :: * -> *) st.
Typeable sub_st =>
sub_st st -> AnyState st
mkAnyState MemoryState st
memory
              }