module Data.State.Acid.Local
( AcidState
, Event(..)
, EventResult
, UpdateEvent
, QueryEvent
, Update
, Query
, mkAcidState
, closeAcidState
, createCheckpoint
, update
, query
) where
import Data.State.Acid.Log as Log
import Data.State.Acid.Core
import Control.Concurrent
import qualified Control.Monad.State as State
import Control.Monad.Reader
import Control.Applicative
import qualified Data.ByteString.Lazy as Lazy
import Data.Binary
import Data.Typeable
import System.FilePath
type EventResult ev = MethodResult ev
data Event st where
UpdateEvent :: UpdateEvent ev => (ev -> Update st (EventResult ev)) -> Event st
QueryEvent :: QueryEvent ev => (ev -> Query st (EventResult ev)) -> Event st
class Method ev => UpdateEvent ev
class Method ev => QueryEvent ev
eventsToMethods :: [Event st] -> [MethodContainer st]
eventsToMethods = map worker
where worker (UpdateEvent fn) = Method (unUpdate . fn)
worker (QueryEvent fn) = Method (\ev -> do st <- State.get
return (runReader (unQuery $ fn ev) st)
)
data AcidState st
= AcidState { localCore :: Core st
, localEvents :: FileLog (Tagged Lazy.ByteString)
, localCheckpoints :: FileLog Checkpoint
}
newtype Update st a = Update { unUpdate :: State.State st a }
deriving (Monad, State.MonadState st)
newtype Query st a = Query { unQuery :: Reader st a }
deriving (Monad, MonadReader st)
update :: UpdateEvent event => AcidState st -> event -> IO (EventResult event)
update acidState event
= do mvar <- newEmptyMVar
modifyCoreState_ (localCore acidState) $ \st ->
do let (result, st') = State.runState hotMethod st
pushEntry (localEvents acidState) (methodTag event, encode event) $ putMVar mvar result
return st'
takeMVar mvar
where hotMethod = lookupHotMethod (localCore acidState) event
query :: QueryEvent event => AcidState st -> event -> IO (EventResult event)
query acidState event
= runHotMethod (localCore acidState) event
createCheckpoint :: Binary st => AcidState st -> IO ()
createCheckpoint acidState
= do mvar <- newEmptyMVar
withCoreState (localCore acidState) $ \st ->
do eventId <- askCurrentEntryId (localEvents acidState)
pushEntry (localCheckpoints acidState) (Checkpoint eventId (encode st)) (putMVar mvar ())
takeMVar mvar
data Checkpoint = Checkpoint EntryId Lazy.ByteString
instance Binary Checkpoint where
put (Checkpoint eventEntryId content)
= do put eventEntryId
put content
get = Checkpoint <$> get <*> get
mkAcidState :: (Typeable st, Binary st)
=> [Event st]
-> st
-> IO (AcidState st)
mkAcidState events initialState
= do core <- mkCore (eventsToMethods events) initialState
let directory = "state" </> show (typeOf initialState)
let eventsLogKey = LogKey { logDirectory = directory
, logPrefix = "events" }
checkpointsLogKey = LogKey { logDirectory = directory
, logPrefix = "checkpoints" }
mbLastCheckpoint <- Log.newestEntry checkpointsLogKey
n <- case mbLastCheckpoint of
Nothing
-> return 0
Just (Checkpoint eventCutOff content)
-> do modifyCoreState_ core (\_oldState -> return (decode content))
return eventCutOff
events <- entriesAfterCutoff eventsLogKey n
mapM_ (runColdMethod core) events
eventsLog <- openFileLog eventsLogKey
checkpointsLog <- openFileLog checkpointsLogKey
return AcidState { localCore = core
, localEvents = eventsLog
, localCheckpoints = checkpointsLog
}
closeAcidState :: AcidState st -> IO ()
closeAcidState acidState
= do closeCore (localCore acidState)
closeFileLog (localEvents acidState)
closeFileLog (localCheckpoints acidState)