{-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies,
             FlexibleContexts, BangPatterns,
             DefaultSignatures, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Acid.Core
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- Low-level controls for transaction-based state changes. This module defines
-- structures and tools for running state modifiers indexed either by an Method
-- or a serialized Method. This module should rarely be used directly although
-- the 'Method' class is needed when defining events manually.
--
-- The term \'Event\' is loosely used for transactions with ACID guarantees.
-- \'Method\' is loosely used for state operations without ACID guarantees
--
module Data.Acid.Core
    ( Core(coreMethods)
    , Method(..)
    , MethodContainer(..)
    , Tagged
    , mkCore
    , closeCore
    , closeCore'
    , modifyCoreState
    , modifyCoreState_
    , withCoreState
    , lookupHotMethod
    , lookupHotMethodAndSerialiser
    , lookupColdMethod
    , runHotMethod
    , runColdMethod
    , MethodMap
    , mkMethodMap

    , Serialiser(..)
    , safeCopySerialiser
    , MethodSerialiser(..)
    , safeCopyMethodSerialiser
    , encodeMethod
    , decodeMethod
    , encodeResult
    , decodeResult
    ) where

import Control.Concurrent                 ( MVar, newMVar, withMVar
                                          , modifyMVar, modifyMVar_ )
import Control.Monad                      ( liftM )
import Control.Monad.State                ( State, runState )
import qualified Data.Map as Map
import Data.Monoid                        ((<>))
import Data.ByteString.Lazy as Lazy       ( ByteString )
import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack )

import Data.Serialize                     ( runPutLazy, runGetLazy )
import Data.SafeCopy                      ( SafeCopy, safeGet, safePut )

import Data.Typeable                      ( Typeable, TypeRep, typeRepTyCon, typeOf )
import Unsafe.Coerce                      ( unsafeCoerce )

#if MIN_VERSION_base(4,5,0)
import Data.Typeable                      ( tyConModule )
#else
import Data.Typeable.Internal             ( tyConModule )
#endif

#if MIN_VERSION_base(4,4,0)

-- in base >= 4.4 the Show instance for TypeRep no longer provides a
-- fully qualified name. But we have old data around that expects the
-- FQN. So we will recreate the old naming system for newer versions
-- of base. We could do something better, but happstack-state is
-- end-of-life anyway.
showQualifiedTypeRep :: TypeRep -> String
showQualifiedTypeRep :: TypeRep -> String
showQualifiedTypeRep TypeRep
tr = TyCon -> String
tyConModule TyCon
con String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tr
  where con :: TyCon
con = TypeRep -> TyCon
typeRepTyCon TypeRep
tr

#else

showQualifiedTypeRep :: TypeRep -> String
showQualifiedTypeRep tr = show tr

#endif


-- | Interface for (de)serialising values of type @a@.
--
-- A @'Serialiser' { 'serialiserEncode', 'serialiserDecode' }@ must
-- satisfy the round-trip property:
--
-- > forall x . serialiserDecode (serialiserEncode x) == Right x
data Serialiser a =
    Serialiser
        { Serialiser a -> a -> ByteString
serialiserEncode :: a -> Lazy.ByteString
          -- ^ Serialise a value to a bytestring.
        , Serialiser a -> ByteString -> Either String a
serialiserDecode :: Lazy.ByteString -> Either String a
          -- ^ Deserialise a value, generating a string error message
          -- on failure.
        }

-- | Default implementation of 'Serialiser' interface using 'SafeCopy'.
safeCopySerialiser :: SafeCopy a => Serialiser a
safeCopySerialiser :: Serialiser a
safeCopySerialiser = (a -> ByteString)
-> (ByteString -> Either String a) -> Serialiser a
forall a.
(a -> ByteString)
-> (ByteString -> Either String a) -> Serialiser a
Serialiser (Put -> ByteString
runPutLazy (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall a. SafeCopy a => a -> Put
safePut) (Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGetLazy Get a
forall a. SafeCopy a => Get a
safeGet)


-- | Interface for (de)serialising a method, namely 'Serialiser's for
-- its arguments type and its result type.
data MethodSerialiser method =
    MethodSerialiser
        { MethodSerialiser method -> Serialiser method
methodSerialiser :: Serialiser method
        , MethodSerialiser method -> Serialiser (MethodResult method)
resultSerialiser :: Serialiser (MethodResult method)
        }

-- | Default implementation of 'MethodSerialiser' interface using 'SafeCopy'.
safeCopyMethodSerialiser :: (SafeCopy method, SafeCopy (MethodResult method)) => MethodSerialiser method
safeCopyMethodSerialiser :: MethodSerialiser method
safeCopyMethodSerialiser = Serialiser method
-> Serialiser (MethodResult method) -> MethodSerialiser method
forall method.
Serialiser method
-> Serialiser (MethodResult method) -> MethodSerialiser method
MethodSerialiser Serialiser method
forall a. SafeCopy a => Serialiser a
safeCopySerialiser Serialiser (MethodResult method)
forall a. SafeCopy a => Serialiser a
safeCopySerialiser

-- | Encode the arguments of a method using the given serialisation strategy.
encodeMethod :: MethodSerialiser method -> method -> ByteString
encodeMethod :: MethodSerialiser method -> method -> ByteString
encodeMethod MethodSerialiser method
ms = Serialiser method -> method -> ByteString
forall a. Serialiser a -> a -> ByteString
serialiserEncode (MethodSerialiser method -> Serialiser method
forall method. MethodSerialiser method -> Serialiser method
methodSerialiser MethodSerialiser method
ms)

-- | Decode the arguments of a method using the given serialisation strategy.
decodeMethod :: MethodSerialiser method -> ByteString -> Either String method
decodeMethod :: MethodSerialiser method -> ByteString -> Either String method
decodeMethod MethodSerialiser method
ms = Serialiser method -> ByteString -> Either String method
forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode (MethodSerialiser method -> Serialiser method
forall method. MethodSerialiser method -> Serialiser method
methodSerialiser MethodSerialiser method
ms)

-- | Encode the result of a method using the given serialisation strategy.
encodeResult :: MethodSerialiser method -> MethodResult method -> ByteString
encodeResult :: MethodSerialiser method -> MethodResult method -> ByteString
encodeResult MethodSerialiser method
ms = Serialiser (MethodResult method)
-> MethodResult method -> ByteString
forall a. Serialiser a -> a -> ByteString
serialiserEncode (MethodSerialiser method -> Serialiser (MethodResult method)
forall method.
MethodSerialiser method -> Serialiser (MethodResult method)
resultSerialiser MethodSerialiser method
ms)

-- | Decode the result of a method using the given serialisation strategy.
decodeResult :: MethodSerialiser method -> ByteString -> Either String (MethodResult method)
decodeResult :: MethodSerialiser method
-> ByteString -> Either String (MethodResult method)
decodeResult MethodSerialiser method
ms = Serialiser (MethodResult method)
-> ByteString -> Either String (MethodResult method)
forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode (MethodSerialiser method -> Serialiser (MethodResult method)
forall method.
MethodSerialiser method -> Serialiser (MethodResult method)
resultSerialiser MethodSerialiser method
ms)


-- | The basic Method class. Each Method has an indexed result type
--   and a unique tag.
class Method ev where
    type MethodResult ev
    type MethodState ev
    methodTag :: ev -> Tag
    default methodTag :: Typeable ev => ev -> Tag
    methodTag ev
ev = String -> ByteString
Lazy.pack (TypeRep -> String
showQualifiedTypeRep (ev -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf ev
ev))


-- | The control structure at the very center of acid-state.
--   This module provides access to a mutable state through
--   methods. No efforts towards durability, checkpointing or
--   sharding happens at this level.
--   Important things to keep in mind in this module:
--     * We don't distinguish between updates and queries.
--     * We allow direct access to the core state as well
--       as through events.
data Core st
    = Core { Core st -> MVar st
coreState   :: MVar st
           , Core st -> MethodMap st
coreMethods :: MethodMap st
           }

-- | Construct a new Core using an initial state and a list of Methods.
mkCore :: [MethodContainer st]   -- ^ List of methods capable of modifying the state.
       -> st                     -- ^ Initial state value.
       -> IO (Core st)
mkCore :: [MethodContainer st] -> st -> IO (Core st)
mkCore [MethodContainer st]
methods st
initialValue
    = do MVar st
mvar <- st -> IO (MVar st)
forall a. a -> IO (MVar a)
newMVar st
initialValue
         Core st -> IO (Core st)
forall (m :: * -> *) a. Monad m => a -> m a
return Core :: forall st. MVar st -> MethodMap st -> Core st
Core{ coreState :: MVar st
coreState   = MVar st
mvar
                    , coreMethods :: MethodMap st
coreMethods = [MethodContainer st] -> MethodMap st
forall st. [MethodContainer st] -> MethodMap st
mkMethodMap [MethodContainer st]
methods }

-- | Mark Core as closed. Any subsequent use will throw an exception.
closeCore :: Core st -> IO ()
closeCore :: Core st -> IO ()
closeCore Core st
core
    = Core st -> (st -> IO ()) -> IO ()
forall st. Core st -> (st -> IO ()) -> IO ()
closeCore' Core st
core (\st
_st -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Access the state and then mark the Core as closed. Any subsequent use
--   will throw an exception.
closeCore' :: Core st -> (st -> IO ()) -> IO ()
closeCore' :: Core st -> (st -> IO ()) -> IO ()
closeCore' Core st
core st -> IO ()
action
    = MVar st -> (st -> IO st) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Core st -> MVar st
forall st. Core st -> MVar st
coreState Core st
core) ((st -> IO st) -> IO ()) -> (st -> IO st) -> IO ()
forall a b. (a -> b) -> a -> b
$ \st
st ->
      do st -> IO ()
action st
st
         st -> IO st
forall (m :: * -> *) a. Monad m => a -> m a
return st
forall a. a
errorMsg
    where errorMsg :: a
errorMsg = String -> a
forall a. HasCallStack => String -> a
error String
"Data.Acid.Core: Access failure: Core closed."

-- | Modify the state component. The resulting state is ensured to be in
--   WHNF.
modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core st
core st -> IO (st, a)
action
    = MVar st -> (st -> IO (st, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Core st -> MVar st
forall st. Core st -> MVar st
coreState Core st
core) ((st -> IO (st, a)) -> IO a) -> (st -> IO (st, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \st
st -> do (!st
st', a
a) <- st -> IO (st, a)
action st
st
                                              (st, a) -> IO (st, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (st
st', a
a)

-- | Modify the state component. The resulting state is ensured to be in
--   WHNF.
modifyCoreState_ :: Core st -> (st -> IO st) -> IO ()
modifyCoreState_ :: Core st -> (st -> IO st) -> IO ()
modifyCoreState_ Core st
core st -> IO st
action
    = MVar st -> (st -> IO st) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Core st -> MVar st
forall st. Core st -> MVar st
coreState Core st
core) ((st -> IO st) -> IO ()) -> (st -> IO st) -> IO ()
forall a b. (a -> b) -> a -> b
$ \st
st -> do !st
st' <- st -> IO st
action st
st
                                               st -> IO st
forall (m :: * -> *) a. Monad m => a -> m a
return st
st'

-- | Access the state component.
withCoreState :: Core st -> (st -> IO a) -> IO a
withCoreState :: Core st -> (st -> IO a) -> IO a
withCoreState Core st
core = MVar st -> (st -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Core st -> MVar st
forall st. Core st -> MVar st
coreState Core st
core)

-- | Execute a method as given by a type identifier and an encoded string.
--   The exact format of the encoded string depends on the type identifier.
--   Results are encoded and type tagged before they're handed back out.
--   This function is used when running events from a log-file or from another
--   server. Events that originate locally are most likely executed with
--   the faster 'runHotMethod'.
runColdMethod :: Core st -> Tagged Lazy.ByteString -> IO Lazy.ByteString
runColdMethod :: Core st -> Tagged ByteString -> IO ByteString
runColdMethod Core st
core Tagged ByteString
taggedMethod
    = Core st -> (st -> IO (st, ByteString)) -> IO ByteString
forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core st
core ((st -> IO (st, ByteString)) -> IO ByteString)
-> (st -> IO (st, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \st
st ->
      do let (ByteString
a, st
st') = State st ByteString -> st -> (ByteString, st)
forall s a. State s a -> s -> (a, s)
runState (Core st -> Tagged ByteString -> State st ByteString
forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod Core st
core Tagged ByteString
taggedMethod) st
st
         (st, ByteString) -> IO (st, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ( st
st', ByteString
a)

-- | Find the state action that corresponds to a tagged and serialized method.
lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> State st Lazy.ByteString
lookupColdMethod :: Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod Core st
core (ByteString
storedMethodTag, ByteString
methodContent)
    = case ByteString
-> Map ByteString (MethodContainer st)
-> Maybe (MethodContainer st)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
storedMethodTag (Core st -> Map ByteString (MethodContainer st)
forall st. Core st -> MethodMap st
coreMethods Core st
core) of
        Maybe (MethodContainer st)
Nothing      -> ByteString -> State st ByteString
forall a. ByteString -> a
missingMethod ByteString
storedMethodTag
        Just (Method MethodBody method
method MethodSerialiser method
ms)
          -> (MethodResult method -> ByteString)
-> StateT st Identity (MethodResult method) -> State st ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (MethodSerialiser method -> MethodResult method -> ByteString
forall method.
MethodSerialiser method -> MethodResult method -> ByteString
encodeResult MethodSerialiser method
ms) (MethodBody method
method (MethodSerialiser method -> ByteString -> method
forall method. MethodSerialiser method -> ByteString -> method
lazyDecode MethodSerialiser method
ms ByteString
methodContent))

lazyDecode :: MethodSerialiser method -> Lazy.ByteString -> method
lazyDecode :: MethodSerialiser method -> ByteString -> method
lazyDecode MethodSerialiser method
ms ByteString
inp
    = case MethodSerialiser method -> ByteString -> Either String method
forall method.
MethodSerialiser method -> ByteString -> Either String method
decodeMethod MethodSerialiser method
ms ByteString
inp of
        Left String
msg  -> String -> method
forall a. HasCallStack => String -> a
error (String -> method) -> String -> method
forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Core: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
        Right method
val -> method
val

missingMethod :: Tag -> a
missingMethod :: ByteString -> a
missingMethod ByteString
tag
    = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Core: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
    where msg :: String
msg = String
"This method is required but not available: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (ByteString -> String
Lazy.unpack ByteString
tag) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
". Did you perhaps remove it before creating a checkpoint?"

-- | Apply an in-memory method to the state.
runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method)
runHotMethod :: Core (MethodState method) -> method -> IO (MethodResult method)
runHotMethod Core (MethodState method)
core method
method
    = Core (MethodState method)
-> (MethodState method
    -> IO (MethodState method, MethodResult method))
-> IO (MethodResult method)
forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core (MethodState method)
core ((MethodState method
  -> IO (MethodState method, MethodResult method))
 -> IO (MethodResult method))
-> (MethodState method
    -> IO (MethodState method, MethodResult method))
-> IO (MethodResult method)
forall a b. (a -> b) -> a -> b
$ \MethodState method
st ->
      do let (MethodResult method
a, MethodState method
st') = State (MethodState method) (MethodResult method)
-> MethodState method -> (MethodResult method, MethodState method)
forall s a. State s a -> s -> (a, s)
runState (MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
forall method.
Method method =>
MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
lookupHotMethod (Core (MethodState method) -> MethodMap (MethodState method)
forall st. Core st -> MethodMap st
coreMethods Core (MethodState method)
core) method
method) MethodState method
st
         (MethodState method, MethodResult method)
-> IO (MethodState method, MethodResult method)
forall (m :: * -> *) a. Monad m => a -> m a
return ( MethodState method
st', MethodResult method
a)

-- | Find the state action that corresponds to an in-memory method.
lookupHotMethod :: Method method => MethodMap (MethodState method) -> method
                -> State (MethodState method) (MethodResult method)
lookupHotMethod :: MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
lookupHotMethod MethodMap (MethodState method)
methodMap method
method = (State (MethodState method) (MethodResult method),
 MethodSerialiser method)
-> State (MethodState method) (MethodResult method)
forall a b. (a, b) -> a
fst (MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
forall method.
Method method =>
MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
lookupHotMethodAndSerialiser MethodMap (MethodState method)
methodMap method
method)

-- | Find the state action and serialiser that correspond to an
-- in-memory method.
lookupHotMethodAndSerialiser :: Method method => MethodMap (MethodState method) -> method
                             -> (State (MethodState method) (MethodResult method), MethodSerialiser method)
lookupHotMethodAndSerialiser :: MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
lookupHotMethodAndSerialiser MethodMap (MethodState method)
methodMap method
method
    = case ByteString
-> MethodMap (MethodState method)
-> Maybe (MethodContainer (MethodState method))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (method -> ByteString
forall ev. Method ev => ev -> ByteString
methodTag method
method) MethodMap (MethodState method)
methodMap of
        Maybe (MethodContainer (MethodState method))
Nothing -> ByteString
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
forall a. ByteString -> a
missingMethod (method -> ByteString
forall ev. Method ev => ev -> ByteString
methodTag method
method)
        Just (Method MethodBody method
methodHandler MethodSerialiser method
ms)
          -> -- If the methodTag doesn't index the right methodHandler then we're in deep
             -- trouble. Luckly, it would take deliberate malevolence for that to happen.
             (MethodBody method
-> method
-> StateT (MethodState method) Identity (MethodResult method)
forall a b. a -> b
unsafeCoerce MethodBody method
methodHandler method
method, MethodSerialiser method -> MethodSerialiser method
forall a b. a -> b
unsafeCoerce MethodSerialiser method
ms)

-- | Method tags must be unique and are most commonly generated automatically.
type Tag = Lazy.ByteString
type Tagged a = (Tag, a)

type MethodBody method = method -> State (MethodState method) (MethodResult method)

-- | Method container structure that hides the exact type of the method.
data MethodContainer st where
    Method :: (Method method) => MethodBody method -> MethodSerialiser method -> MethodContainer (MethodState method)

-- | Collection of Methods indexed by a Tag.
type MethodMap st = Map.Map Tag (MethodContainer st)

-- | Construct a 'MethodMap' from a list of Methods using their associated tag.
mkMethodMap :: [MethodContainer st] -> MethodMap st
mkMethodMap :: [MethodContainer st] -> MethodMap st
mkMethodMap [MethodContainer st]
methods
    = [(ByteString, MethodContainer st)] -> MethodMap st
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (MethodContainer st -> ByteString
forall st. MethodContainer st -> ByteString
methodType MethodContainer st
method, MethodContainer st
method) | MethodContainer st
method <- [MethodContainer st]
methods ]
    where -- A little bit of ugliness is required to access the methodTags.
          methodType :: MethodContainer st -> Tag
          methodType :: MethodContainer st -> ByteString
methodType MethodContainer st
m = case MethodContainer st
m of
                           Method MethodBody method
fn MethodSerialiser method
_ -> let ev :: (ev -> State st res) -> ev
                                              ev :: (ev -> State st res) -> ev
ev ev -> State st res
_ = ev
forall a. HasCallStack => a
undefined
                                          in method -> ByteString
forall ev. Method ev => ev -> ByteString
methodTag ((method -> State st (MethodResult method)) -> method
forall ev st res. (ev -> State st res) -> ev
ev method -> State st (MethodResult method)
MethodBody method
fn)