{-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies,
FlexibleContexts, BangPatterns,
DefaultSignatures, ScopedTypeVariables #-}
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)
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
data Serialiser a =
Serialiser
{ forall a. Serialiser a -> a -> ByteString
serialiserEncode :: a -> Lazy.ByteString
, forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode :: Lazy.ByteString -> Either String a
}
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)
data MethodSerialiser method =
MethodSerialiser
{ forall method. MethodSerialiser method -> Serialiser method
methodSerialiser :: Serialiser method
, forall method.
MethodSerialiser method -> Serialiser (MethodResult method)
resultSerialiser :: Serialiser (MethodResult method)
}
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
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)
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)
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)
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)
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))
data Core st
= Core { forall st. Core st -> MVar st
coreState :: MVar st
, forall st. Core st -> MethodMap st
coreMethods :: MethodMap st
}
mkCore :: [MethodContainer st]
-> st
-> 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 }
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 ())
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."
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)
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'
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)
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)
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?"
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)
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)
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)
->
(forall a b. a -> b
unsafeCoerce MethodBody method
methodHandler method
method, forall a b. a -> b
unsafeCoerce MethodSerialiser method
ms)
type Tag = Lazy.ByteString
type Tagged a = (Tag, a)
type MethodBody method = method -> State (MethodState method) (MethodResult method)
data MethodContainer st where
Method :: (Method method) => MethodBody method -> MethodSerialiser method -> MethodContainer (MethodState method)
type MethodMap st = Map.Map Tag (MethodContainer st)
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
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)