Local.hs

{-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies,
             MagicHash, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Acid.Local
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- AcidState container using a transaction log on disk. The term \'Event\' is
-- loosely used for transactions with ACID guarantees. \'Method\' is loosely
-- used for state operations without ACID guarantees (see "Data.Acid.Core").
--

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

-- | Events return the same thing as Methods. The exact type of 'EventResult'
--   depends on the event.
type EventResult ev = MethodResult ev

type EventState ev = MethodState ev

-- | We distinguish between events that modify the state and those that do not.
--
--   UpdateEvents are executed in a MonadState context and have to be serialized
--   to disk before they are considered durable.
--
--   QueryEvents are executed in a MonadReader context and obviously do not have
--   to be serialized to disk.
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)

-- | All UpdateEvents are also Methods.
class Method ev => UpdateEvent ev
-- | All QueryEvents are also Methods.
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)
                                           )
{-| 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. This includes
                    power outages, 

    [@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 AcidState st
    = AcidState { localCore        :: Core st
                , localEvents      :: FileLog (Tagged Lazy.ByteString)
                , localCheckpoints :: FileLog Checkpoint
                }

-- | Context monad for Update events.
newtype Update st a = Update { unUpdate :: State.State st a }
    deriving (Monad, State.MonadState st)

-- | Context monad for Query events.
newtype Query st a  = Query { unQuery :: Reader st a }
    deriving (Monad, MonadReader st)

-- | Issue an Update event and wait for its result. Once this call returns, you are
--   guaranteed that the changes to the state are durable. Events may be issued in
--   parallel.
--   
--   It's a run-time error to issue events that aren't supported by the AcidState.
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
                -- Schedule the log entry. Very important that it happens when 'localCore' is locked
                -- to ensure that events are logged in the same order that they are executed.
                pushEntry (localEvents acidState) (methodTag event, encodedEvent) $ putMVar mvar result
                return st'
         takeMVar mvar
    where hotMethod = lookupHotMethod (localCore acidState) event

-- | Issue a Query event and wait for its result. Events may be issued in parallel.
query  :: QueryEvent event  => AcidState (EventState event) -> event -> IO (EventResult event)
query acidState event
    = runHotMethod (localCore acidState) event

-- | Take a snapshot of the state and save it to disk. Creating checkpoints
--   makes it faster to resume AcidStates and you're free to create them as
--   often or seldom as fits your needs. Transactions can run concurrently
--   with this call.
--   
--   This call will not return until the operation has succeeded.
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]
      -- ^ List of events capable of updating or querying the state.

-- | Create an AcidState given an initial value.
--   
--   This will create or resume a log found in the \"state\/[typeOf state]\/\" directory.
openAcidState :: (Typeable st, IsAcidic st)
              => st                          -- ^ Initial state value. This value is only used if no checkpoint is
                                             --   found.
              -> IO (AcidState st)
openAcidState initialState
    = openAcidStateFrom ("state" </> show (typeOf initialState)) initialState

-- | Create an AcidState given a log directory and an initial value.
--   
--   This will create or resume a log found in @directory@.
--   Running two AcidState's from the same directory is an error
--   but will not result in dataloss.
openAcidStateFrom :: (IsAcidic st)
                  => FilePath            -- ^ Location of the checkpoint and transaction files.
                  -> st                  -- ^ Initial state value. This value is only used if no checkpoint is
                                         --   found.
                  -> 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
                          }

-- | Close an AcidState and associated logs.
--   Any subsequent usage of the AcidState will throw an exception.
closeAcidState :: AcidState st -> IO ()
closeAcidState acidState
    = do closeCore (localCore acidState)
         closeFileLog (localEvents acidState)
         closeFileLog (localCheckpoints acidState)