VersionVector.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Version Vector
module RON.Data.VersionVector (
    VersionVector,
    VV (..),
    lookup,
    mkVV,
    serializeVV,
    (·≻),
    (·≼),
) where

import RON.Prelude hiding (lookup)

import Data.Hashable (hashWithSalt)
import Data.Map.Strict qualified as Map

import RON.Data.Internal (
    Reducible,
    Rep,
    Replicated (encoding),
    ReplicatedAsObject,
    getObjectState,
    newObject,
    objectEncoding,
    readObject,
    reducibleOpType,
    stateFromChunk,
    stateToChunk,
 )
import RON.Event (
    Event (Event),
    Replica,
    Time,
    encodeEvent,
    getEventUuid,
    unsafeDecodeEvent,
 )
import RON.Event qualified
import RON.Semilattice (Semilattice, (≼))
import RON.Text.Serialize (serializePayload)
import RON.Types (
    Atom (AUuid),
    ObjectRef (ObjectRef),
    Op (Op, opId),
    UUID (UUID),
    WireStateChunk (WireStateChunk, stateBody, stateType),
 )
import RON.UUID qualified as UUID

opTime :: Op -> Word64
opTime Op{opId = UUID time _} = time

-- | Assume opId is event
opReplica :: Op -> Replica
opReplica Op{opId} = (unsafeDecodeEvent opId).replica

latter :: Op -> Op -> Op
latter = maxOn opTime

-- | Version Vector type. May be used both in typed and untyped contexts.
newtype VersionVector = VersionVector (Map Replica Op)
    deriving (Eq, Show)

instance Hashable VersionVector where
    hashWithSalt s (VersionVector vv) = hashWithSalt s $ Map.assocs vv

instance Semigroup VersionVector where
    (<>) = coerce $ Map.unionWith latter

instance Monoid VersionVector where
    mempty = VersionVector mempty

{- | Laws:
1. Idempotent because 'Map.unionWith' is idempotent.
2. Commutative because 'latter' is commutative.
-}
instance Semilattice VersionVector where
    VersionVector a ≼ VersionVector b =
        case leftJoin (Map.assocs a) (Map.assocs b) of
            Nothing -> False
            Just joined -> and [opTime opA <= opTime opB | (opA, opB) <- joined]
      where
        -- leftJoin :: Ord k => [(k, v1)] -> [(k, v2)] -> Maybe [(v1, v2)]
        leftJoin [] _ = Just []
        leftJoin (_ : _) [] = Nothing
        leftJoin ((xk, xv) : xs') ((yk, yv) : ys') =
            case compare xk yk of
                LT -> Nothing -- x must present but doesn't
                EQ -> ((xv, yv) :) <$> leftJoin xs' ys' -- intersection
                GT -> leftJoin xs' ys' -- skip extra y

instance Reducible VersionVector where
    reducibleOpType = vvType

    stateFromChunk ops =
        VersionVector $ Map.fromListWith latter [(opReplica op, op) | op <- ops]

    stateToChunk (VersionVector vv) = Map.elems vv

wireStateChunk :: [Op] -> WireStateChunk
wireStateChunk stateBody = WireStateChunk{stateType = vvType, stateBody}

-- | Name-UUID to use as Version Vector type marker.
vvType :: UUID
vvType = $(UUID.liftName "vv")

instance Replicated VersionVector where
    encoding = objectEncoding

instance ReplicatedAsObject VersionVector where
    type Rep VersionVector = VersionVector

    newObject (VersionVector vv) = do
        oid <- getEventUuid
        let ops = Map.elems vv
        modify' $ Map.insert oid $ wireStateChunk ops
        pure $ ObjectRef oid

    readObject = getObjectState

lookup :: Replica -> VersionVector -> Maybe Op
lookup replica (VersionVector vv) = Map.lookup replica vv

-- | Simplified version vector
newtype VV = VV (Map Replica Time)
    deriving (Show)

instance Semigroup VV where
    VV a <> VV b = VV $ Map.unionWith max a b

instance Monoid VV where
    mempty = VV Map.empty

-- | Assuming all UUIDs are events.
mkVV :: [UUID] -> VV
mkVV uuids =
    VV $
        Map.fromList
            [ (replica, time)
            | uuid <- uuids
            , let Event{replica, time} = unsafeDecodeEvent uuid
            ]

unVV :: VV -> [UUID]
unVV (VV vv) =
    [encodeEvent Event{replica, time} | (replica, time) <- Map.assocs vv]

(·≻) :: UUID -> VV -> Bool
uuid ·≻ VV vv =
    maybe True (time >) $ Map.lookup replica vv
  where
    Event{replica, time} = unsafeDecodeEvent uuid

(·≼) :: UUID -> VV -> Bool
uuid ·≼ VV vv =
    maybe False (time <=) $ Map.lookup replica vv
  where
    Event{replica, time} = unsafeDecodeEvent uuid

serializeVV :: VV -> ByteStringL
serializeVV = serializePayload . map AUuid . unVV