module Happstack.State.Checkpoint
( createTxControl
, closeTxControl
, restoreState
, createCheckpoint
) where
import Happstack.State.Saver
import Happstack.Data.Serialize
import Happstack.Data.SerializeTH
import Happstack.State.Transaction
import Happstack.State.ComponentSystem
import Data.Typeable
import Data.Maybe
import Control.Concurrent
import Control.Monad
import Control.Exception as E
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import System.IO
import qualified Data.Map as M
import System.Log.Logger
logMC :: Priority -> String -> IO ()
logMC = logM "Happstack.State.Checkpoint"
data State = State
{ stateVersion :: Int
, stateCutoff :: Int
} deriving (Typeable,Show)
instance Version State
$(deriveSerialize ''State)
createTxControl :: (Methods state, Component state) =>
Saver -> Proxy state -> IO (MVar TxControl)
createTxControl saver prox
= do
eventSaverVar <- newMVar =<< createWriter NullSaver "events" 0
lock <- obtainLock saver
newMVar $ TxControl
{ ctlSaver = saver
, ctlEventSaver = eventSaverVar
, ctlAllComponents = allStateTypes prox
, ctlComponentVersions = componentVersions prox
, ctlChildren = []
, ctlPrefixLock = lock }
closeTxControl :: MVar TxControl -> IO ()
closeTxControl ctlVar
= do ctl <- takeMVar ctlVar
writerClose =<< takeMVar (ctlEventSaver ctl)
releaseLock (ctlPrefixLock ctl)
restoreState :: MVar TxControl -> IO (IO ())
restoreState ctlVar
= withMVar ctlVar $ \ctl ->
do
mbState <- readState ctl
case mbState of
Nothing ->
do writeState ctl (State 0 0)
return $ do swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" 0
return ()
Just state ->
do let cutoff = stateCutoff state
loadState ctl cutoff
offset <- loadEvents ctl cutoff
return $ do swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" (cutoff+offset)
return ()
loadState :: TxControl -> Int -> IO ()
loadState ctl cutoff
= do logMC NOTICE $ "Loading components from storage."
checkpoints <- withReader ctl "checkpoints" cutoff $ loadCheckpoints
forM_ (ctlAllComponents ctl) $ \stateType
-> case M.lookup stateType (ctlComponentVersions ctl) of
Just versions -> forM_ versions $ \stateTypeVersion
-> case M.lookup (L.unpack stateTypeVersion) checkpoints of
Just state -> setNewState stateType state
Nothing -> return ()
Nothing -> return ()
logMC NOTICE "All components successfully loaded"
loadEvents :: TxControl -> Int -> IO Int
loadEvents ctl cutoff
= do logMC NOTICE "Loading events from storage"
(events, offset) <- withReader ctl "events" cutoff $ readerGet
forM_ events $ \(EventLogEntry context object) -> runColdEvent context object
logMC NOTICE "All events successfully replayed."
return offset
withReader :: (Serialize a) => TxControl -> String -> Int
-> (ReaderStream a -> IO c) -> IO c
withReader ctl key cutoff
= bracket (createReader (ctlSaver ctl) key cutoff)
(readerClose)
withWriter :: (Serialize a) => TxControl -> String -> Int
-> (WriterStream a -> IO c) -> IO c
withWriter ctl key cutoff
= bracket (createWriter (ctlSaver ctl) key cutoff)
(writerClose)
readState :: (Serialize a) => TxControl -> IO (Maybe a)
readState ctl
= withReader ctl "current" 0 $ \s ->
liftM listToMaybe $ readerGetUncut s
writeState :: TxControl -> State -> IO ()
writeState ctl state
= bracket (createWriter (ctlSaver ctl) "current" 0)
(writerClose)
(\saver -> writerAtomicReplace saver state)
loadCheckpoints :: ReaderStream (M.Map String L.ByteString) -> IO (M.Map String L.ByteString)
loadCheckpoints saver
= do checkpointss <- readerGetUncut saver
case checkpointss of
[checkpoints] -> return checkpoints
[] -> return M.empty
_ -> error "Failed to read checkpoints."
saveCheckpoints :: WriterStream (M.Map String L.ByteString) -> M.Map String L.ByteString -> IO ()
saveCheckpoints saver checkpoints
= do mv <- newEmptyMVar
writerAdd saver checkpoints (putMVar mv ())
takeMVar mv
createCheckpoint :: MVar TxControl -> IO ()
createCheckpoint ctlVar
= withMVar ctlVar $ \ctl ->
do logMC NOTICE "Initiating checkpoint."
newCut <- writerCut =<< readMVar (ctlEventSaver ctl)
withWriter ctl "checkpoints" newCut $ \saver ->
do allStates <- mapM getState (ctlAllComponents ctl)
saveCheckpoints saver (M.fromList $ zip (ctlAllComponents ctl) allStates)
writeState ctl $ State {stateVersion = 0
,stateCutoff = newCut}
logMC NOTICE "Checkpoint successfully serialized."