{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module RON.Data.Internal where
import RON.Internal.Prelude
import Control.Monad.Writer.Strict (WriterT, lift, runWriterT, tell)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import RON.Event (ReplicaClock)
import RON.Types (Atom (..), Object (..), Op (..), StateChunk (..),
StateFrame, 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 opEvent
mkRC :: UUID -> [Op] -> ReducedChunk
mkRC ref rcBody =
ReducedChunk{rcVersion = mkChunkVersion rcBody, rcRef = ref, ..}
mkStateChunk :: [Op] -> StateChunk
mkStateChunk ops = StateChunk (mkChunkVersion ops) 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{..} = Patch
{ patchRef = opEvent
, 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{..} = ReducedChunk{..} where
rcRef = patchRef
StateChunk rcVersion rcBody = stateToChunk patchValue
class Replicated a where
encoding :: Encoding a
data Encoding a = Encoding
{ encodingNewRon
:: forall m . ReplicaClock m => a -> WriterT StateFrame m [Atom]
, encodingFromRon :: [Atom] -> StateFrame -> Either String a
}
newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame m [Atom]
newRon = encodingNewRon encoding
fromRon :: Replicated a => [Atom] -> StateFrame -> Either String 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 ReplicatedAsPayload a where
toPayload :: a -> [Atom]
fromPayload :: [Atom] -> Either String a
instance Replicated Int64 where encoding = payloadEncoding
instance ReplicatedAsPayload Int64 where
toPayload int = [AInteger int]
fromPayload atoms = case atoms of
[AInteger int] -> pure int
_ -> Left "Int64: bad payload"
instance Replicated UUID where encoding = payloadEncoding
instance ReplicatedAsPayload UUID where
toPayload u = [AUuid u]
fromPayload atoms = case atoms of
[AUuid u] -> pure u
_ -> Left "UUID: bad payload"
instance Replicated Text where encoding = payloadEncoding
instance ReplicatedAsPayload Text where
toPayload t = [AString t]
fromPayload atoms = case atoms of
[AString t] -> pure t
_ -> Left "String: bad payload"
instance Replicated Char where encoding = payloadEncoding
instance ReplicatedAsPayload Char where
toPayload c = [AString $ Text.singleton c]
fromPayload atoms = case atoms of
[AString s] -> case Text.uncons s of
Just (c, "") -> pure c
_ -> Left "too long string to encode a single character"
_ -> Left "Char: bad payload"
class ReplicatedAsObject a where
objectOpType :: UUID
newObject :: ReplicaClock m => a -> m (Object a)
getObject :: Object a -> Either String a
objectFromRon
:: (Object a -> Either String a) -> [Atom] -> StateFrame -> Either String a
objectFromRon handler atoms frame = case atoms of
[AUuid oid] -> handler $ Object oid frame
_ -> Left "bad payload"
collectFrame :: Functor m => WriterT StateFrame m UUID -> m (Object a)
collectFrame = fmap (uncurry Object) . runWriterT
getObjectStateChunk
:: forall a . ReplicatedAsObject a => Object a -> Either String StateChunk
getObjectStateChunk (Object oid frame) =
maybe (Left "no such object in chunk") Right $
Map.lookup (objectOpType @a, 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 -> case atoms of
Some : atoms' -> Just <$> fromRon atoms' frame
[None] -> pure Nothing
_ -> Left "Bad Option"
}
instance ReplicatedAsPayload a => ReplicatedAsPayload (Maybe a) where
toPayload = \case
Just a -> Some : toPayload a
Nothing -> [None]
fromPayload = \case
Some : atoms -> Just <$> fromPayload atoms
[None] -> pure Nothing
_ -> Left "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 = \case
[ATrue] -> pure True
[AFalse] -> pure False
_ -> fail "Expected single UUID"