Internal.hs

{-# 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)

-- | Reduce all chunks of specific type and object in the frame
type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk]

data Reducer = Reducer
    { wireReducer  :: WireReducer
    , stateReducer :: StateChunk -> StateChunk -> StateChunk
    }

-- | Unapplied patches and raw ops
type Unapplied = ([ReducedChunk], [Op])

-- TODO(2018-08-24, cblp) Semilattice a?
-- | Untyped-reducible types.
-- Untyped means if this type is a container then the types of data contained in
-- it is not considered.
class (Eq a, Monoid a) => Reducible a where

    -- | UUID of the type
    reducibleOpType :: UUID

    -- | Load a state from a state chunk
    stateFromChunk :: [Op] -> a

    -- | Store a state to a state chunk
    stateToChunk :: a -> StateChunk

    -- | Merge a state with patches and raw ops
    applyPatches :: a -> Unapplied -> (a, Unapplied)
    applyPatches a (patches, ops) =
        ( a <> foldMap (patchValue . patchFromChunk) patches
            <> foldMap (patchValue . patchFromRawOp) ops
        , mempty
        )

    -- | Merge patches and raw ops into bigger patches or throw obsolete ops
    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

-- | Base class for typed encoding
class Replicated a where
    -- | Instances SHOULD implement 'encoding' either as 'objectEncoding' or as
    -- 'payloadEncoding'
    encoding :: Encoding a

data Encoding a = Encoding
    { encodingNewRon
        :: forall m . ReplicaClock m => a -> WriterT StateFrame m [Atom]
    , encodingFromRon :: [Atom] -> StateFrame -> Either String a
    }

-- | Encode typed data to a payload with possible addition objects
newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame m [Atom]
newRon = encodingNewRon encoding

-- | Decode typed data from a payload.
-- The implementation may use other objects in the frame to resolve references.
fromRon :: Replicated a => [Atom] -> StateFrame -> Either String a
fromRon = encodingFromRon encoding

-- | Standard implementation of 'Replicated' for 'ReplicatedAsObject' types.
objectEncoding :: ReplicatedAsObject a => Encoding a
objectEncoding = Encoding
    { encodingNewRon = \a -> do
        Object oid frame <- lift $ newObject a
        tell frame
        pure [AUuid oid]
    , encodingFromRon = objectFromRon getObject
    }

-- | Standard implementation of 'Replicated' for 'ReplicatedAsPayload' types.
payloadEncoding :: ReplicatedAsPayload a => Encoding a
payloadEncoding = Encoding
    { encodingNewRon  = pure . toPayload
    , encodingFromRon = \atoms _ -> fromPayload atoms
    }

-- | Instances of this class are encoded as payload only.
class ReplicatedAsPayload a where

    -- | Encode data
    toPayload :: a -> [Atom]

    -- | Decode data
    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"

-- | Instances of this class are encoded as objects.
-- An enclosing object's payload will be filled with this object's id.
class ReplicatedAsObject a where

    -- | UUID of the type
    objectOpType :: UUID

    -- | Encode data
    newObject :: ReplicaClock m => a -> m (Object a)

    -- | Decode data
    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"

-- | Helper to build an object frame using arbitrarily nested serializers.
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"