{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module RON.Data.Internal (
ReducedChunk (..),
Reducer (..),
Reducible (..),
Replicated (..),
ReplicatedAsObject (..),
ReplicatedAsPayload (..),
Unapplied,
WireReducer,
advanceToObject,
eqPayload,
eqRef,
getObjectStateChunk,
mkStateChunk,
modifyObjectStateChunk,
modifyObjectStateChunk_,
newObjectState,
objectEncoding,
payloadEncoding,
fromRon,
newRon,
ObjectStateT,
MonadObjectState,
) where
import RON.Prelude
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import RON.Error (MonadE, errorContext, liftMaybe)
import RON.Event (ReplicaClock, advanceToUuid)
import RON.Types (Atom (AInteger, AString, AUuid), Object (Object),
ObjectState (ObjectState, frame, uuid),
Op (Op, opId, payload, refId),
StateChunk (StateChunk, stateBody, stateType, stateVersion),
StateFrame, UUID (UUID), WireChunk)
import RON.UUID (zero)
type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk]
data Reducer = Reducer
{ wireReducer :: WireReducer
, stateReducer :: StateChunk -> StateChunk -> StateChunk
}
type Unapplied = ([ReducedChunk], [Op])
class (Eq a, Monoid a) => Reducible a where
reducibleOpType :: UUID
stateFromChunk :: [Op] -> a
stateToChunk :: a -> StateChunk
applyPatches :: a -> Unapplied -> (a, Unapplied)
applyPatches a (patches, ops) =
( a <> foldMap (patchValue . patchFromChunk) patches
<> foldMap (patchValue . patchFromRawOp) ops
, mempty
)
reduceUnappliedPatches :: Unapplied -> Unapplied
reduceUnappliedPatches (patches, ops) =
( maybeToList .
fmap (patchToChunk @a . sconcat) .
nonEmpty $
map patchFromChunk patches <> map patchFromRawOp ops
, []
)
data ReducedChunk = ReducedChunk
{ rcVersion :: UUID
, rcRef :: UUID
, rcBody :: [Op]
}
deriving (Show)
mkChunkVersion :: [Op] -> UUID
mkChunkVersion = maximumDef zero . map opId
mkStateChunk :: UUID -> [Op] -> StateChunk
mkStateChunk stateType ops =
StateChunk{stateType, stateVersion = mkChunkVersion ops, stateBody = ops}
data Patch a = Patch{patchRef :: UUID, patchValue :: a}
instance Semigroup a => Semigroup (Patch a) where
Patch ref1 a1 <> Patch ref2 a2 = Patch (min ref1 ref2) (a1 <> a2)
patchFromRawOp :: Reducible a => Op -> Patch a
patchFromRawOp op@Op{opId} = Patch
{ patchRef = opId
, patchValue = stateFromChunk [op]
}
patchFromChunk :: Reducible a => ReducedChunk -> Patch a
patchFromChunk ReducedChunk{..} =
Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody}
patchToChunk :: Reducible a => Patch a -> ReducedChunk
patchToChunk Patch{patchRef, patchValue} =
ReducedChunk{rcRef = patchRef, rcVersion = stateVersion, rcBody = stateBody}
where
StateChunk{stateVersion, stateBody} = stateToChunk patchValue
class Replicated a where
encoding :: Encoding a
data Encoding a = Encoding
{ encodingNewRon
:: forall m
. (ReplicaClock m, MonadState StateFrame m) => a -> m [Atom]
, encodingFromRon
:: forall m . (MonadE m, MonadState StateFrame m) => [Atom] -> m a
}
newRon
:: (Replicated a, ReplicaClock m, MonadState StateFrame m) => a -> m [Atom]
newRon = encodingNewRon encoding
fromRon :: (MonadE m, Replicated a, MonadState StateFrame m) => [Atom] -> m a
fromRon = encodingFromRon encoding
objectEncoding :: ReplicatedAsObject a => Encoding a
objectEncoding = Encoding
{ encodingNewRon = \a -> do
Object uuid <- newObject a
pure [AUuid uuid]
, encodingFromRon = objectFromRon $ runReaderT getObject
}
payloadEncoding :: ReplicatedAsPayload a => Encoding a
payloadEncoding = Encoding
{ encodingNewRon = pure . toPayload
, encodingFromRon = fromPayload
}
class Replicated a => ReplicatedAsPayload a where
toPayload :: a -> [Atom]
fromPayload :: MonadE m => [Atom] -> m a
instance Replicated Int64 where encoding = payloadEncoding
instance ReplicatedAsPayload Int64 where
toPayload int = [AInteger int]
fromPayload atoms = errorContext "Integer" $ case atoms of
[AInteger int] -> pure int
_ -> throwError "Expected Integer syntax"
instance Replicated UUID where encoding = payloadEncoding
instance ReplicatedAsPayload UUID where
toPayload u = [AUuid u]
fromPayload atoms = errorContext "UUID" $ case atoms of
[AUuid u] -> pure u
_ -> throwError "Expected UUID syntax"
instance Replicated Text where encoding = payloadEncoding
instance ReplicatedAsPayload Text where
toPayload t = [AString t]
fromPayload atoms = errorContext "String" $ case atoms of
[AString t] -> pure t
_ -> throwError "Expected string syntax"
instance Replicated Char where encoding = payloadEncoding
instance ReplicatedAsPayload Char where
toPayload c = [AString $ Text.singleton c]
fromPayload atoms = errorContext "Char" $ case atoms of
[AString (Text.uncons -> Just (c, ""))] -> pure c
_ -> throwError "Expected one-character string"
class Replicated a => ReplicatedAsObject a where
objectOpType :: UUID
newObject :: (ReplicaClock m, MonadState StateFrame m) => a -> m (Object a)
getObject :: (MonadE m, MonadObjectState a m) => m a
objectFromRon :: MonadE m => (Object a -> m a) -> [Atom] -> m a
objectFromRon handler atoms = case atoms of
[AUuid uuid] -> handler $ Object uuid
_ -> throwError "Expected object UUID"
newObjectState
:: (ReplicatedAsObject a, ReplicaClock m) => a -> m (ObjectState a)
newObjectState a = do
(Object uuid, frame) <- runStateT (newObject a) mempty
pure $ ObjectState{uuid, frame}
getObjectStateChunk :: (MonadE m, MonadObjectState a m) => m StateChunk
getObjectStateChunk = do
Object uuid <- ask
frame <- get
liftMaybe "no such object in chunk" $ Map.lookup uuid frame
modifyObjectStateChunk
:: (MonadObjectState a m, ReplicaClock m, MonadE m)
=> (StateChunk -> m (b, StateChunk)) -> m b
modifyObjectStateChunk f = do
Object uuid <- ask
chunk@StateChunk{stateVersion} <- getObjectStateChunk
advanceToUuid stateVersion
(a, chunk') <- f chunk
modify' $ Map.insert uuid chunk'
pure a
modifyObjectStateChunk_
:: (MonadObjectState a m, ReplicaClock m, MonadE m)
=> (StateChunk -> m StateChunk) -> m ()
modifyObjectStateChunk_ f = modifyObjectStateChunk $ \chunk -> do
chunk' <- f chunk
pure ((), chunk')
eqRef :: Object a -> [Atom] -> Bool
eqRef (Object uuid) atoms = case atoms of
[AUuid ref] -> uuid == ref
_ -> False
eqPayload :: ReplicatedAsPayload a => a -> [Atom] -> Bool
eqPayload a atoms = toPayload a == atoms
pattern None :: Atom
pattern None = AUuid (UUID 0xcb3ca9000000000 0)
pattern Some :: Atom
pattern Some = AUuid (UUID 0xdf3c69000000000 0)
instance Replicated a => Replicated (Maybe a) where
encoding = Encoding
{ encodingNewRon = \case
Just a -> (Some :) <$> newRon a
Nothing -> pure [None]
, encodingFromRon = \atoms ->
errorContext "Option" $ case atoms of
Some : atoms' -> Just <$> fromRon atoms'
[None] -> pure Nothing
_ -> throwError "Bad Option"
}
instance ReplicatedAsPayload a => ReplicatedAsPayload (Maybe a) where
toPayload = \case
Just a -> Some : toPayload a
Nothing -> [None]
fromPayload = errorContext "Option" . \case
Some : atoms -> Just <$> fromPayload atoms
[None] -> pure Nothing
_ -> throwError "Bad Option"
pattern ATrue :: Atom
pattern ATrue = AUuid (UUID 0xe36e69000000000 0)
pattern AFalse :: Atom
pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0)
instance Replicated Bool where encoding = payloadEncoding
instance ReplicatedAsPayload Bool where
toPayload b
| b = [ATrue]
| otherwise = [AFalse]
fromPayload = errorContext "Bool" . \case
[ATrue] -> pure True
[AFalse] -> pure False
_ -> throwError "Expected single UUID `true` or `false`"
type ObjectStateT b m a = ReaderT (Object b) (StateT StateFrame m) a
type MonadObjectState b m = (MonadReader (Object b) m, MonadState StateFrame m)
advanceToObject :: (MonadE m, MonadObjectState a m, ReplicaClock m) => m ()
advanceToObject = do
Object uuid <- ask
StateChunk{stateBody} <- getObjectStateChunk
advanceToUuid $
maximumDef
uuid
[ max opId $ maximumDef refId $ mapMaybe atomAsUuid payload
| Op{opId, refId, payload} <- stateBody
]
where
atomAsUuid = \case
AUuid u -> Just u
_ -> Nothing