module Data.Acid.Local
( IsAcidic(..)
, AcidState
, Event(..)
, EventResult
, EventState
, UpdateEvent
, QueryEvent
, Update
, Query
, openAcidState
, openAcidStateFrom
, closeAcidState
, createCheckpoint
, createCheckpointAndClose
, update
, scheduleUpdate
, query
, update'
, query'
, runQuery
) where
import Data.Acid.Log as Log
import Data.Acid.Core
import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar )
import Control.Monad.State ( MonadState, State, get, runState )
import Control.Monad.Reader ( Reader, runReader, MonadReader )
import Control.Monad.Trans ( MonadIO(liftIO) )
import Control.Applicative ( (<$>), (<*>) )
import Data.ByteString.Lazy ( ByteString )
import Data.Serialize ( runPutLazy, runGetLazy )
import Data.SafeCopy ( SafeCopy(..), safeGet, safePut
, primitive, contain )
import Data.Typeable ( Typeable, typeOf )
import System.FilePath ( (</>) )
import Control.Applicative (Applicative(..))
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 <- get
return (runReader (unQuery $ fn ev) st)
)
data AcidState st
= AcidState { localCore :: Core st
, localEvents :: FileLog (Tagged ByteString)
, localCheckpoints :: FileLog Checkpoint
}
newtype Update st a = Update { unUpdate :: State st a }
deriving (Monad, Functor, Applicative, MonadState st)
newtype Query st a = Query { unQuery :: Reader st a }
deriving (Monad, Functor, Applicative, MonadReader st)
runQuery :: Query st a -> Update st a
runQuery query
= do st <- get
return (runReader (unQuery query) st)
update :: UpdateEvent event => AcidState (EventState event) -> event -> IO (EventResult event)
update acidState event
= takeMVar =<< scheduleUpdate acidState event
scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event))
scheduleUpdate acidState event
= do mvar <- newEmptyMVar
let encoded = runPutLazy (safePut event)
modifyCoreState_ (localCore acidState) $ \st ->
do let !(result, !st') = runState hotMethod st
pushEntry (localEvents acidState) (methodTag event, encoded) $ putMVar mvar result
return st'
return mvar
where hotMethod = lookupHotMethod (localCore acidState) event
update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)
update' acidState event
= liftIO (update acidState event)
query :: QueryEvent event => AcidState (EventState event) -> event -> IO (EventResult event)
query acidState event
= do mvar <- newEmptyMVar
withCoreState (localCore acidState) $ \st ->
do let (result, _st) = runState hotMethod st
pushAction (localEvents acidState) $
putMVar mvar result
takeMVar mvar
where hotMethod = lookupHotMethod (localCore acidState) event
query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)
query' acidState event
= liftIO (query acidState event)
createCheckpoint :: SafeCopy st => AcidState st -> IO ()
createCheckpoint acidState
= do 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 ())
takeMVar mvar
createCheckpointAndClose :: SafeCopy st => AcidState st -> IO ()
createCheckpointAndClose acidState
= 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 ())
takeMVar mvar
closeFileLog (localEvents acidState)
closeFileLog (localCheckpoints acidState)
data Checkpoint = Checkpoint EntryId ByteString
instance SafeCopy Checkpoint where
kind = primitive
putCopy (Checkpoint eventEntryId content)
= contain $
do safePut eventEntryId
safePut content
getCopy = contain $ Checkpoint <$> safeGet <*> safeGet
class (SafeCopy 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 -> case runGetLazy safeGet content of
Left msg -> checkpointRestoreError msg
Right val -> return val)
return eventCutOff
eventsLog <- openFileLog eventsLogKey
events <- readEntriesFrom eventsLog n
mapM_ (runColdMethod core) events
checkpointsLog <- openFileLog checkpointsLogKey
return AcidState { localCore = core
, localEvents = eventsLog
, localCheckpoints = checkpointsLog
}
checkpointRestoreError msg
= error $ "Could not parse saved checkpoint due to the following error: " ++ msg
closeAcidState :: AcidState st -> IO ()
closeAcidState acidState
= do closeCore (localCore acidState)
closeFileLog (localEvents acidState)
closeFileLog (localCheckpoints acidState)