{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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,
collectFrame,
eqPayload,
eqRef,
fromRon,
getObjectStateChunk,
mkStateChunk,
newRon,
objectEncoding,
payloadEncoding,
) where
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import RON.Error (MonadE, errorContext, liftMaybe)
import RON.Event (ReplicaClock)
import RON.Types (Atom (AInteger, AString, AUuid), Object (Object),
Op (Op, opId),
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 => a -> WriterT StateFrame m [Atom]
, encodingFromRon :: forall m . MonadE m => [Atom] -> StateFrame -> m a
}
newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame m [Atom]
newRon = encodingNewRon encoding
fromRon :: (MonadE m, Replicated a) => [Atom] -> StateFrame -> m a
fromRon = encodingFromRon encoding
objectEncoding :: ReplicatedAsObject a => Encoding a
objectEncoding = Encoding
{ encodingNewRon = \a -> do
Object oid frame <- lift $ newObject a
tell frame
pure [AUuid oid]
, encodingFromRon = objectFromRon getObject
}
payloadEncoding :: ReplicatedAsPayload a => Encoding a
payloadEncoding = Encoding
{ encodingNewRon = pure . toPayload
, encodingFromRon = \atoms _ -> fromPayload atoms
}
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 => a -> m (Object a)
getObject :: MonadE m => Object a -> m a
objectFromRon :: MonadE m => (Object a -> m a) -> [Atom] -> StateFrame -> m a
objectFromRon handler atoms frame = case atoms of
[AUuid oid] -> handler $ Object oid frame
_ -> throwError "Expected object UUID"
collectFrame :: Functor m => WriterT StateFrame m UUID -> m (Object a)
collectFrame = fmap (uncurry Object) . runWriterT
getObjectStateChunk :: MonadE m => Object a -> m StateChunk
getObjectStateChunk (Object oid frame) =
liftMaybe "no such object in chunk" $ Map.lookup oid frame
eqRef :: Object a -> [Atom] -> Bool
eqRef (Object oid _) atoms = case atoms of
[AUuid ref] -> oid == 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 frame ->
errorContext "Option" $ case atoms of
Some : atoms' -> Just <$> fromRon atoms' frame
[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 "Boole" . \case
[ATrue] -> pure True
[AFalse] -> pure False
_ -> throwError "Expected single UUID `true` or `false`"