{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module RON.Data.Internal (
Encoding (..),
ReducedChunk (..),
Reducer (..),
Reducible (..),
Replicated (..),
ReplicatedAsObject (..),
ReplicatedAsPayload (..),
Unapplied,
WireReducer,
advanceToObject,
eqPayload,
eqRef,
getObjectState,
getObjectStateChunk,
modifyObjectStateChunk,
modifyObjectStateChunk_,
newObjectFrame,
reduceState,
reduceObjectStates,
stateFromWireChunk,
stateToWireChunk,
tryFromRon,
tryOptionFromRon,
wireStateChunk,
pattern Some,
objectEncoding,
rconcat,
payloadEncoding,
fromRon,
newRon,
ObjectStateT,
MonadObjectState,
) where
import RON.Prelude
import Data.List (minimum)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import RON.Error (Error (Error), MonadE, correct, errorContext,
liftMaybe)
import RON.Event (ReplicaClock, advanceToUuid)
import RON.Semilattice (BoundedSemilattice)
import RON.Types (Atom (AInteger, AString, AUuid), Object (Object),
ObjectFrame (ObjectFrame, frame, uuid),
Op (Op, opId, payload, refId), Payload,
StateChunk (StateChunk), StateFrame, UUID (UUID),
WireChunk,
WireStateChunk (WireStateChunk, stateBody, stateType))
type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk]
data Reducer = Reducer
{ wireReducer :: WireReducer
, stateReducer :: WireStateChunk -> WireStateChunk -> WireStateChunk
}
type Unapplied = ([ReducedChunk], [Op])
class (Eq a, BoundedSemilattice a) => Reducible a where
reducibleOpType :: UUID
stateFromChunk :: [Op] -> a
stateToChunk :: a -> [Op]
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
, []
)
stateToWireChunk :: forall rep . Reducible rep => rep -> WireStateChunk
stateToWireChunk rep = wireStateChunk @rep $ StateChunk $ stateToChunk @rep rep
stateFromWireChunk
:: forall a m . (MonadE m, Reducible a) => WireStateChunk -> m a
stateFromWireChunk WireStateChunk{stateType, stateBody} = do
unless (stateType == reducibleOpType @a) $
throwError $
Error "bad type"
[ Error ("expected " <> show (reducibleOpType @a)) []
, Error ("got " <> show stateType) []
]
pure $ stateFromChunk stateBody
data ReducedChunk = ReducedChunk
{ rcRef :: UUID
, rcBody :: [Op]
}
deriving (Show)
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{rcRef, rcBody} =
Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody}
patchToChunk :: Reducible a => Patch a -> ReducedChunk
patchToChunk Patch{patchRef, patchValue} =
ReducedChunk{rcRef = patchRef, rcBody = stateBody}
where
WireStateChunk{stateBody} = stateToWireChunk patchValue
class Replicated a where
encoding :: Encoding a
data Encoding a = Encoding
{ encodingNewRon
:: forall m
. (ReplicaClock m, MonadState StateFrame m) => a -> m Payload
, encodingFromRon
:: forall m . (MonadE m, MonadState StateFrame m) => Payload -> m a
}
newRon
:: (Replicated a, ReplicaClock m, MonadState StateFrame m) => a -> m Payload
newRon = encodingNewRon encoding
fromRon :: (MonadE m, Replicated a, MonadState StateFrame m) => Payload -> 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 -> Payload
fromPayload :: MonadE m => Payload -> 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"
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"
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"
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 (Reducible (Rep a), Replicated a) => ReplicatedAsObject a where
type Rep a
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) -> Payload -> m a
objectFromRon handler atoms = case atoms of
[AUuid uuid] -> handler $ Object uuid
_ -> throwError "Expected object UUID"
newObjectFrame
:: (ReplicatedAsObject a, ReplicaClock m) => a -> m (ObjectFrame a)
newObjectFrame a = do
(Object uuid, frame) <- runStateT (newObject a) mempty
pure $ ObjectFrame{uuid, frame}
getObjectStateChunk
:: forall a m . (MonadE m, MonadObjectState a m) => m (StateChunk (Rep a))
getObjectStateChunk = do
Object uuid <- ask
frame <- get
WireStateChunk{stateType, stateBody} <-
liftMaybe "no such object in chunk" $ Map.lookup uuid frame
unless (stateType == reducibleOpType @(Rep a)) $
throwError $
Error "bad type"
[ Error ("expected " <> show (reducibleOpType @(Rep a))) []
, Error ("got " <> show stateType) []
]
pure $ StateChunk stateBody
modifyObjectStateChunk
:: forall a b m
. (MonadObjectState a m, ReplicaClock m, MonadE m)
=> (StateChunk (Rep a) -> m (b, StateChunk (Rep a))) -> m b
modifyObjectStateChunk f = do
advanceToObject
Object uuid <- ask
chunk <- getObjectStateChunk
(a, StateChunk chunk') <- f chunk
modify' $
Map.insert uuid $
WireStateChunk{stateType = reducibleOpType @(Rep a), stateBody = chunk'}
pure a
modifyObjectStateChunk_
:: (MonadObjectState a m, ReplicaClock m, MonadE m)
=> (StateChunk (Rep a) -> m (StateChunk (Rep a))) -> m ()
modifyObjectStateChunk_ f = modifyObjectStateChunk $ \chunk -> do
chunk' <- f chunk
pure ((), chunk')
eqRef :: Object a -> Payload -> Bool
eqRef (Object uuid) atoms = case atoms of
[AUuid ref] -> uuid == ref
_ -> False
eqPayload :: ReplicatedAsPayload a => a -> Payload -> Bool
eqPayload a atoms = toPayload a == atoms
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 a m =
(MonadReader (Object a) m, MonadState StateFrame m, Reducible (Rep a))
advanceToObject :: (MonadE m, MonadObjectState a m, ReplicaClock m) => m ()
advanceToObject = do
Object uuid <- ask
StateChunk chunk <- getObjectStateChunk
advanceToUuid $
maximumDef
uuid
[ max opId $ maximumDef refId $ mapMaybe atomAsUuid payload
| Op{opId, refId, payload} <- chunk
]
where
atomAsUuid = \case
AUuid u -> Just u
_ -> Nothing
reduceState
:: forall rep
. Reducible rep => StateChunk rep -> StateChunk rep -> StateChunk rep
reduceState (StateChunk s1) (StateChunk s2) =
StateChunk $ stateToChunk @rep $ stateFromChunk s1 <> stateFromChunk s2
reduceObjectStates
:: forall a m
. (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)
=> NonEmpty (Object a) -> m (Object a)
reduceObjectStates (obj :| objs) = do
c :| cs <- for (obj :| objs) $ runReaderT getObjectStateChunk
let chunk = foldl' (reduceState @(Rep a)) c cs
oid = minimum [i | Object i <- obj:objs]
modify' $ Map.insert oid $ wireStateChunk chunk
pure $ Object oid
rconcat
:: forall a m
. (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)
=> NonEmpty UUID -> m a
rconcat uuids =
errorContext "rconcat" $ do
Object ref <- reduceObjectStates @a $ Object <$> uuids
fromRon [AUuid ref]
tryFromRon
:: (MonadE m, MonadState StateFrame m, Replicated a)
=> Payload -> m (Maybe a)
tryFromRon = correct Nothing . fmap Just . fromRon
tryOptionFromRon
:: (MonadE m, MonadState StateFrame m, Replicated a)
=> Payload -> m (Maybe a)
tryOptionFromRon payload = case payload of
Some : payload' ->
correct Nothing $
(Just <$> fromRon payload)
`catchError` \e1 ->
(Just <$> fromRon payload')
`catchError` \e2 ->
throwError $ Error "tryOptionFromRon" [e1, e2]
_ -> tryFromRon payload
pattern Some :: Atom
pattern Some = AUuid (UUID 0xdf3c69000000000 0)
{-# DEPRECATED Some "Will be removed soon" #-}
getObjectState :: (MonadE m, MonadObjectState a m) => m (Rep a)
getObjectState = do
StateChunk chunk <- getObjectStateChunk
pure $ stateFromChunk chunk
wireStateChunk :: forall rep . Reducible rep => StateChunk rep -> WireStateChunk
wireStateChunk (StateChunk stateBody) =
WireStateChunk{stateType = reducibleOpType @rep, stateBody}