{-# 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
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid                        ((<>))
#endif
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 forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ 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
        { forall a. Serialiser a -> a -> ByteString
serialiserEncode :: a -> Lazy.ByteString
          -- ^ Serialise a value to a bytestring.
        , forall a. 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 :: forall a. SafeCopy a => Serialiser a
safeCopySerialiser = forall a.
(a -> ByteString)
-> (ByteString -> Either String a) -> Serialiser a
Serialiser (Put -> ByteString
runPutLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SafeCopy a => a -> Put
safePut) (forall a. Get a -> ByteString -> Either String a
runGetLazy 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
        { forall method. MethodSerialiser method -> Serialiser method
methodSerialiser :: Serialiser method
        , forall 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 :: forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser = forall method.
Serialiser method
-> Serialiser (MethodResult method) -> MethodSerialiser method
MethodSerialiser forall a. SafeCopy a => Serialiser a
safeCopySerialiser forall a. SafeCopy a => Serialiser a
safeCopySerialiser

-- | Encode the arguments of a method using the given serialisation strategy.
encodeMethod :: MethodSerialiser method -> method -> ByteString
encodeMethod :: forall method. MethodSerialiser method -> method -> ByteString
encodeMethod MethodSerialiser method
ms = forall a. Serialiser a -> a -> ByteString
serialiserEncode (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 :: forall method.
MethodSerialiser method -> ByteString -> Either String method
decodeMethod MethodSerialiser method
ms = forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode (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 :: forall method.
MethodSerialiser method -> MethodResult method -> ByteString
encodeResult MethodSerialiser method
ms = forall a. Serialiser a -> a -> ByteString
serialiserEncode (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 :: forall method.
MethodSerialiser method
-> ByteString -> Either String (MethodResult method)
decodeResult MethodSerialiser method
ms = forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode (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 (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 { forall st. Core st -> MVar st
coreState   :: MVar st
           , forall 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 :: forall st. [MethodContainer st] -> st -> IO (Core st)
mkCore [MethodContainer st]
methods st
initialValue
    = do MVar st
mvar <- forall a. a -> IO (MVar a)
newMVar st
initialValue
         forall (m :: * -> *) a. Monad m => a -> m a
return Core{ coreState :: MVar st
coreState   = MVar st
mvar
                    , coreMethods :: MethodMap st
coreMethods = 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 :: forall st. Core st -> IO ()
closeCore Core st
core
    = forall st. Core st -> (st -> IO ()) -> IO ()
closeCore' Core st
core (\st
_st -> 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' :: forall st. Core st -> (st -> IO ()) -> IO ()
closeCore' Core st
core st -> IO ()
action
    = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall st. Core st -> MVar st
coreState Core st
core) forall a b. (a -> b) -> a -> b
$ \st
st ->
      do st -> IO ()
action st
st
         forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. a
errorMsg
    where errorMsg :: a
errorMsg = 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 :: forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core st
core st -> IO (st, a)
action
    = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (forall st. Core st -> MVar st
coreState Core st
core) forall a b. (a -> b) -> a -> b
$ \st
st -> do (!st
st', a
a) <- st -> IO (st, a)
action st
st
                                              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_ :: forall st. Core st -> (st -> IO st) -> IO ()
modifyCoreState_ Core st
core st -> IO st
action
    = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall st. Core st -> MVar st
coreState Core st
core) forall a b. (a -> b) -> a -> b
$ \st
st -> do !st
st' <- st -> IO st
action st
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 :: forall st a. Core st -> (st -> IO a) -> IO a
withCoreState Core st
core = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (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 :: forall st. Core st -> Tagged ByteString -> IO ByteString
runColdMethod Core st
core Tagged ByteString
taggedMethod
    = forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core st
core forall a b. (a -> b) -> a -> b
$ \st
st ->
      do let (ByteString
a, st
st') = forall s a. State s a -> s -> (a, s)
runState (forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod Core st
core Tagged ByteString
taggedMethod) st
st
         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 :: forall st. Core st -> Tagged ByteString -> State st ByteString
lookupColdMethod Core st
core (ByteString
storedMethodTag, ByteString
methodContent)
    = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
storedMethodTag (forall st. Core st -> MethodMap st
coreMethods Core st
core) of
        Maybe (MethodContainer st)
Nothing      -> forall a. ByteString -> a
missingMethod ByteString
storedMethodTag
        Just (Method MethodBody method
method MethodSerialiser method
ms)
          -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall method.
MethodSerialiser method -> MethodResult method -> ByteString
encodeResult MethodSerialiser method
ms) (MethodBody method
method (forall method. MethodSerialiser method -> ByteString -> method
lazyDecode MethodSerialiser method
ms ByteString
methodContent))

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

missingMethod :: Tag -> a
missingMethod :: forall a. ByteString -> a
missingMethod ByteString
tag
    = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Core: " forall a. Semigroup a => a -> a -> a
<> String
msg
    where msg :: String
msg = String
"This method is required but not available: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString -> String
Lazy.unpack ByteString
tag) 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 :: forall method.
Method method =>
Core (MethodState method) -> method -> IO (MethodResult method)
runHotMethod Core (MethodState method)
core method
method
    = forall st a. Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState Core (MethodState method)
core forall a b. (a -> b) -> a -> b
$ \MethodState method
st ->
      do let (MethodResult method
a, MethodState method
st') = forall s a. State s a -> s -> (a, s)
runState (forall method.
Method method =>
MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
lookupHotMethod (forall st. Core st -> MethodMap st
coreMethods Core (MethodState method)
core) method
method) MethodState method
st
         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 :: forall method.
Method method =>
MethodMap (MethodState method)
-> method -> State (MethodState method) (MethodResult method)
lookupHotMethod MethodMap (MethodState method)
methodMap method
method = forall a b. (a, b) -> a
fst (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 :: forall method.
Method method =>
MethodMap (MethodState method)
-> method
-> (State (MethodState method) (MethodResult method),
    MethodSerialiser method)
lookupHotMethodAndSerialiser MethodMap (MethodState method)
methodMap method
method
    = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall ev. Method ev => ev -> ByteString
methodTag method
method) MethodMap (MethodState method)
methodMap of
        Maybe (MethodContainer (MethodState method))
Nothing -> forall a. ByteString -> a
missingMethod (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.
             (forall a b. a -> b
unsafeCoerce MethodBody method
methodHandler method
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 :: forall st. [MethodContainer st] -> MethodMap st
mkMethodMap [MethodContainer st]
methods
    = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (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 :: forall st. 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 :: forall ev st res. (ev -> State st res) -> ev
ev ev -> State st res
_ = forall a. HasCallStack => a
undefined
                                          in forall ev. Method ev => ev -> ByteString
methodTag (forall ev st res. (ev -> State st res) -> ev
ev MethodBody method
fn)