module Data.Acid.Local
( IsAcidic(..)
, AcidState
, Event(..)
, EventResult
, UpdateEvent
, QueryEvent
, Update
, Query
, openAcidState
, openAcidStateFrom
, closeAcidState
, createCheckpoint
, update
, query
) where
import Data.Acid.Log as Log
import Data.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
type EventState ev = MethodState ev
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)
class Method ev => UpdateEvent ev
class Method ev => QueryEvent ev
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 <- 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 (EventState event) -> event -> IO (EventResult event)
update acidState event
= do mvar <- newEmptyMVar
let encodedEvent = encode event
Lazy.length encodedEvent `seq`
modifyCoreState_ (localCore acidState) $ \st ->
do let !(result, st') = State.runState hotMethod st
pushEntry (localEvents acidState) (methodTag event, encodedEvent) $ putMVar mvar result
return st'
takeMVar mvar
where hotMethod = lookupHotMethod (localCore acidState) event
query :: QueryEvent event => AcidState (EventState event) -> 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
class (Binary st) => IsAcidic st where
acidEvents :: [Event st]
openAcidState :: (Typeable st, IsAcidic st)
=> st
-> IO (AcidState st)
openAcidState initialState
= openAcidStateFrom ("state" </> show (typeOf initialState)) initialState
openAcidStateFrom :: (IsAcidic st)
=> FilePath
-> st
-> IO (AcidState st)
openAcidStateFrom directory initialState
= do core <- mkCore (eventsToMethods acidEvents) 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
eventsLog <- openFileLog eventsLogKey
events <- readEntriesFrom eventsLog n
mapM_ (runColdMethod core) events
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)