diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2018, Yuriy Syrovetskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/RON/Data.hs b/lib/RON/Data.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Typed and untyped RON tools +module RON.Data ( + Reducible (..), + Replicated (..), + ReplicatedAsObject (..), + ReplicatedAsPayload (..), + fromRon, + getObjectStateChunk, + mkStateChunk, + newRon, + objectEncoding, + payloadEncoding, + reduceObject, + reduceStateFrame, + reduceWireFrame, +) where + +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict ((!?)) +import qualified Data.Map.Strict as Map + +import RON.Data.Internal +import RON.Data.LWW (LwwPerField) +import RON.Data.ORSet (ORSetRaw) +import RON.Data.RGA (RgaRaw) +import RON.Data.VersionVector (VersionVector) +import RON.Error (MonadE, throwErrorString) +import RON.Types (ClosedOp (..), Object (..), Op (..), + StateChunk (..), StateFrame, UUID, + WireChunk (Closed, Query, Value), WireFrame, + WireReducedChunk (..)) +import RON.UUID (pattern Zero) +import qualified RON.UUID as UUID + +reducers :: Map UUID Reducer +reducers = Map.fromList + [ mkReducer @LwwPerField + , mkReducer @RgaRaw + , mkReducer @ORSetRaw + , mkReducer @VersionVector + ] + +reduceWireFrame :: WireFrame -> WireFrame +reduceWireFrame chunks = values' ++ queries where + chunkTypeAndObject = opTypeAndObject . \case + Closed op -> op + Value WireReducedChunk{wrcHeader = op} -> op + Query WireReducedChunk{wrcHeader = op} -> op + opTypeAndObject ClosedOp{..} = (reducerId, objectId) + (queries, values) = partition isQuery chunks + values' = + fold $ + Map.mapWithKey reduceWireFrameByType $ + NonEmpty.fromList <$> + Map.fromListWith (++) + [(chunkTypeAndObject value, [value]) | value <- values] + +reduceWireFrameByType :: (UUID, UUID) -> NonEmpty WireChunk -> [WireChunk] +reduceWireFrameByType (typ, obj) = case reducers !? typ of + Nothing -> + toList -- TODO(2018-11-08, cblp, #27) use default reducer + Just Reducer{wireReducer} -> wireReducer obj + +isQuery :: WireChunk -> Bool +isQuery = \case + Query _ -> True + _ -> False + +mkReducer :: forall a . Reducible a => (UUID, Reducer) +mkReducer = + ( reducibleOpType @a + , Reducer{wireReducer = mkWireReducer @a, stateReducer = reduceState @a} + ) + +mkWireReducer :: forall a . Reducible a => WireReducer +mkWireReducer obj chunks = chunks' <> leftovers where + chunks' + = maybeToList stateChunk' + ++ map (Value . wrapRChunk) unappliedPatches + ++ map (Closed . wrapOp) unappliedOps + mStates = nonEmpty states + (stateChunk', (unappliedPatches, unappliedOps)) = case mStates of + Nothing -> (Nothing, reduceUnappliedPatches @a (patches, closedOps)) + Just nStates -> let + nState = sconcat $ fmap snd nStates + (reducedState, unapplied') = + applyPatches nState (patches, closedOps) + StateChunk + { stateVersion = reducedStateVersion + , stateBody = reducedStateBody + } = + stateToChunk @a reducedState + MaxOnFst (seenStateVersion, seenState) = + sconcat $ fmap MaxOnFst nStates + stateVersion = if + | reducedStateVersion > seenStateVersion -> reducedStateVersion + | reducedState == seenState -> seenStateVersion + | otherwise -> UUID.succValue seenStateVersion + rc = ReducedChunk + { rcVersion = stateVersion + , rcRef = Zero + , rcBody = reducedStateBody + } + in + (Just $ Value $ wrapRChunk rc, reduceUnappliedPatches @a unapplied') + typ = reducibleOpType @a + wrapOp = ClosedOp typ obj + (states, patches, closedOps, leftovers) = foldMap load chunks + load chunk = fromMaybe ([], [], [], [chunk]) $ load' chunk + load' chunk = case chunk of + Closed closedOp@ClosedOp{op} -> do + guardSameObject closedOp + pure ([], [], [op], []) + Value WireReducedChunk{wrcHeader, wrcBody} -> do + guardSameObject wrcHeader + let ref = refId $ op wrcHeader + case ref of + Zero -> -- state + pure + ( [ ( opId $ op wrcHeader + , stateFromChunk wrcBody + ) ] + , [] + , [] + , [] + ) + _ -> -- patch + pure + ( [] + , [ ReducedChunk + { rcVersion = opId $ op wrcHeader + , rcRef = ref + , rcBody = wrcBody + } + ] + , [] + , [] + ) + _ -> Nothing + guardSameObject ClosedOp{reducerId, objectId} = + guard $ reducerId == typ && objectId == obj + wrapRChunk ReducedChunk{..} = WireReducedChunk + { wrcHeader = wrapOp Op{opId = rcVersion, refId = rcRef, payload = []} + , wrcBody = rcBody + } + +reduceState :: forall a . Reducible a => StateChunk -> StateChunk -> StateChunk +reduceState s1 s2 = + stateToChunk @a $ ((<>) `on` (stateFromChunk . stateBody)) s1 s2 + +reduceStateFrame :: MonadE m => StateFrame -> StateFrame -> m StateFrame +reduceStateFrame s1 s2 = + (`execStateT` s1) . (`Map.traverseWithKey` s2) $ \oid chunk -> let + StateChunk{stateType} = chunk + in + case reducers !? stateType of + Just Reducer{stateReducer} -> + modify' $ Map.insertWith stateReducer oid chunk + Nothing -> + throwErrorString $ + "Cannot reduce StateFrame of unknown type " ++ show stateType + +unsafeReduceObject :: MonadE m => Object a -> StateFrame -> m (Object a) +unsafeReduceObject obj@Object{frame = s1} s2 = do + frame' <- reduceStateFrame s1 s2 + pure obj{frame = frame'} + +-- | Reduce object with frame from another version of the same object. +reduceObject :: MonadE m => Object a -> Object a -> m (Object a) +reduceObject o1@Object{id = id1} Object{id = id2, frame = frame2} + | id1 == id2 = unsafeReduceObject o1 frame2 + | otherwise = throwErrorString $ "Object ids differ: " ++ show (id1, id2) + +newtype MaxOnFst a b = MaxOnFst (a, b) + +instance Ord a => Semigroup (MaxOnFst a b) where + mof1@(MaxOnFst (a1, _)) <> mof2@(MaxOnFst (a2, _)) + | a1 < a2 = mof2 + | otherwise = mof1 diff --git a/lib/RON/Data/Internal.hs b/lib/RON/Data/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/Internal.hs @@ -0,0 +1,279 @@ +{-# 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) + +-- | 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, #26) 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 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 + +-- | 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 :: forall m . MonadE m => [Atom] -> StateFrame -> m 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 :: (MonadE m, Replicated a) => [Atom] -> StateFrame -> m 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 Replicated a => ReplicatedAsPayload a where + + -- | Encode data + toPayload :: a -> [Atom] + + -- | Decode data + 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" + +-- | Instances of this class are encoded as objects. +-- An enclosing object's payload will be filled with this object's id. +class Replicated a => ReplicatedAsObject a where + + -- | UUID of the type + objectOpType :: UUID + + -- | Encode data + newObject :: ReplicaClock m => a -> m (Object a) + + -- | Decode data + 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" + +-- | 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 :: 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) -- none + +pattern Some :: Atom +pattern Some = AUuid (UUID 0xdf3c69000000000 0) -- some + +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) -- true + +pattern AFalse :: Atom +pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0) -- false + +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`" diff --git a/lib/RON/Data/LWW.hs b/lib/RON/Data/LWW.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/LWW.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | LWW-per-field RDT +module RON.Data.LWW + ( LwwPerField (..) + , assignField + , lwwType + , newObject + , readField + , viewField + , zoomField + ) where + +import qualified Data.Map.Strict as Map + +import RON.Data.Internal (Reducible, Replicated, collectFrame, + fromRon, getObjectStateChunk, mkStateChunk, + newRon, reducibleOpType, stateFromChunk, + stateToChunk) +import RON.Error (MonadE, errorContext) +import RON.Event (ReplicaClock, advanceToUuid, getEventUuid) +import RON.Types (Atom (AUuid), Object (..), Op (..), StateChunk (..), + StateFrame, UUID) +import RON.Util (Instance (Instance)) +import qualified RON.UUID as UUID + +-- | Last-Write-Wins: select an op with latter event +lww :: Op -> Op -> Op +lww = maxOn opId + +-- | Untyped LWW. Implementation: a map from 'opRef' to the original op. +newtype LwwPerField = LwwPerField (Map UUID Op) + deriving (Eq, Monoid, Show) + +instance Semigroup LwwPerField where + LwwPerField fields1 <> LwwPerField fields2 = + LwwPerField $ Map.unionWith lww fields1 fields2 + +instance Reducible LwwPerField where + reducibleOpType = lwwType + + stateFromChunk ops = + LwwPerField $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops] + + stateToChunk (LwwPerField fields) = mkStateChunk lwwType $ Map.elems fields + +-- | Name-UUID to use as LWW type marker. +lwwType :: UUID +lwwType = $(UUID.liftName "lww") + +-- | Create LWW object from a list of named fields. +newObject :: ReplicaClock m => [(UUID, Instance Replicated)] -> m (Object a) +newObject fields = collectFrame $ do + payloads <- for fields $ \(_, Instance value) -> newRon value + event <- lift getEventUuid + tell $ + Map.singleton event $ + StateChunk + { stateType = lwwType + , stateVersion = event + , stateBody = + [Op event name p | ((name, _), p) <- zip fields payloads] + } + pure event + +-- | Decode field value +viewField + :: (Replicated a, MonadE m) + => UUID -- ^ Field name + -> StateChunk -- ^ LWW object chunk + -> StateFrame + -> m a +viewField field StateChunk{..} frame = + errorContext ("LWW.viewField " <> show field) $ do + let ops = filter (\Op{refId} -> refId == field) stateBody + Op{payload} <- case ops of + [] -> throwError "no field in lww chunk" + [op] -> pure op + _ -> throwError "unreduced state" + fromRon payload frame + +-- | Decode field value +readField + :: (MonadE m, MonadState (Object a) m, Replicated b) + => UUID -- ^ Field name + -> m b +readField field = do + obj@Object{..} <- get + stateChunk <- getObjectStateChunk obj + viewField field stateChunk frame + +-- | Assign a value to a field +assignField + :: forall a b m + . (Replicated b, ReplicaClock m, MonadE m, MonadState (Object a) m) + => UUID -- ^ Field name + -> b -- ^ Value (from untyped world) + -> m () +assignField field value = do + obj@Object{id, frame} <- get + StateChunk{..} <- getObjectStateChunk obj + advanceToUuid stateVersion + let chunk = filter (\Op{refId} -> refId /= field) stateBody + event <- getEventUuid + (p, frame') <- runWriterT $ newRon value + let newOp = Op event field p + let chunk' = sortOn refId $ newOp : chunk + let state' = StateChunk + {stateVersion = event, stateBody = chunk', stateType = lwwType} + put obj{frame = Map.insert id state' frame <> frame'} + +-- | Anti-lens to an object inside a specified field +zoomField + :: MonadE m + => UUID -- ^ Field name + -> StateT (Object inner) m a -- ^ Nested object modifier + -> StateT (Object outer) m a +zoomField field innerModifier = + errorContext ("LWW.zoomField" <> show field) $ do + obj@Object{..} <- get + StateChunk{..} <- getObjectStateChunk obj + let ops = filter (\Op{refId} -> refId == field) stateBody + Op{payload} <- case ops of + [] -> throwError "empty chunk" + [op] -> pure op + _ -> throwError "unreduced state" + innerObjectId <- errorContext "inner object" $ case payload of + [AUuid oid] -> pure oid + _ -> throwError "Expected object UUID" + let innerObject = Object innerObjectId frame + (a, Object{frame = frame'}) <- + lift $ runStateT innerModifier innerObject + put obj{frame = frame'} + pure a diff --git a/lib/RON/Data/ORSet.hs b/lib/RON/Data/ORSet.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/ORSet.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | Observed-Remove Set (OR-Set) +module RON.Data.ORSet + ( ORSet (..) + , ObjectORSet (..) + , ORSetRaw + , addNewRef + , addRef + , addValue + , removeRef + , removeValue + ) where + +import qualified Data.Map.Strict as Map + +import RON.Data.Internal +import RON.Error (MonadE) +import RON.Event (ReplicaClock, getEventUuid) +import RON.Types (Atom, Object (Object, frame, id), + Op (Op, opId, payload, refId), + StateChunk (StateChunk, stateBody, stateType, stateVersion), + UUID) +import RON.UUID (pattern Zero) +import qualified RON.UUID as UUID + +-- | Untyped OR-Set. +-- Implementation: +-- a map from the last change (creation or deletion) to the original op. +newtype ORSetRaw = ORSetRaw (Map UUID Op) + deriving (Eq, Show) + +opKey :: Op -> UUID +opKey Op{opId, refId} = case refId of + Zero -> opId -- alive + _ -> refId -- tombstone + +observedRemove :: Op -> Op -> Op +observedRemove = maxOn refId + +instance Semigroup ORSetRaw where + ORSetRaw set1 <> ORSetRaw set2 = + ORSetRaw $ Map.unionWith observedRemove set1 set2 + +instance Monoid ORSetRaw where + mempty = ORSetRaw mempty + +instance Reducible ORSetRaw where + reducibleOpType = setType + + stateFromChunk ops = + ORSetRaw $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops] + + stateToChunk (ORSetRaw set) = + mkStateChunk setType . sortOn opId $ Map.elems set + +-- | Name-UUID to use as OR-Set type marker. +setType :: UUID +setType = $(UUID.liftName "set") + +-- | Type-directing wrapper for typed OR-Set of atomic values +newtype ORSet a = ORSet [a] + +-- | Type-directing wrapper for typed OR-Set of objects +newtype ObjectORSet a = ObjectORSet [a] + +instance ReplicatedAsPayload a => Replicated (ORSet a) where + encoding = objectEncoding + +instance ReplicatedAsPayload a => ReplicatedAsObject (ORSet a) where + objectOpType = setType + newObject = commonNewObject pure + getObject = commonGetObject pure + +instance ReplicatedAsObject a => Replicated (ObjectORSet a) where + encoding = objectEncoding + +instance ReplicatedAsObject a => ReplicatedAsObject (ObjectORSet a) where + objectOpType = setType + newObject = commonNewObject $ fmap (\Object{id} -> id) . newObject + getObject obj@Object{frame} = + commonGetObject (\itemId -> getObject (Object itemId frame)) obj + +commonNewObject + :: ( Coercible (orset item) [item] + , ReplicaClock m + , ReplicatedAsPayload itemRep + ) + => (item -> m itemRep) -> orset item -> m (Object (orset item)) +commonNewObject newItem items = collectFrame $ do + ops <- for (coerce items) $ \item -> do + event <- lift getEventUuid + payload <- lift $ newItem item + pure . Op event Zero $ toPayload payload + oid <- lift getEventUuid + let stateVersion = maximumDef oid $ map opId ops + tell $ + Map.singleton oid $ + StateChunk{stateType = setType, stateVersion, stateBody = ops} + pure oid + +commonGetObject + :: forall item m orset itemRep + . (Coercible (orset item) [item], MonadE m, ReplicatedAsPayload itemRep) + => (itemRep -> m item) -> Object (orset item) -> m (orset item) +commonGetObject getItem obj@Object{..} = do + StateChunk{..} <- getObjectStateChunk obj + mItems <- for stateBody $ \Op{refId, payload} -> case refId of + Zero -> Just <$> (fromPayload payload >>= getItem) + _ -> pure Nothing + pure . coerce @[item] $ catMaybes mItems + +-- | XXX Internal. Common implementation of 'addValue' and 'addRef'. +commonAdd :: (ReplicatedAsPayload b, ReplicaClock m, MonadE m) + => b -> StateT (Object a) m () +commonAdd item = do + obj@Object{id, frame} <- get + StateChunk{..} <- getObjectStateChunk obj + event <- getEventUuid + let payload = toPayload item + let newOp = Op event Zero payload + let chunk' = stateBody ++ [newOp] + let state' = StateChunk + {stateType = setType, stateVersion = event, stateBody = chunk'} + put obj{frame = Map.insert id state' frame} + +-- | Add atomic value to the OR-Set +addValue + :: (ReplicatedAsPayload a, ReplicaClock m, MonadE m) + => a -> StateT (Object (ORSet a)) m () +addValue = commonAdd + +-- | Add a reference to the object to the OR-Set +addRef + :: (ReplicaClock m, MonadE m) + => Object a -> StateT (Object (ObjectORSet a)) m () +addRef Object{id = itemId, frame = itemFrame} = do + modify' $ \Object{..} -> Object{frame = frame <> itemFrame, ..} + commonAdd itemId + +-- | Encode an object and add a reference to it to the OR-Set +addNewRef + :: forall a m + . (ReplicatedAsObject a, ReplicaClock m, MonadE m) + => a -> StateT (Object (ObjectORSet a)) m (Object a) +addNewRef item = do + itemObj@(Object _ itemFrame) <- lift $ newObject item + modify' $ \Object{..} -> Object{frame = frame <> itemFrame, ..} + addRef itemObj + pure itemObj + +-- | XXX Internal. Common implementation of 'removeValue' and 'removeRef'. +commonRemove + :: (MonadE m, ReplicaClock m) + => ([Atom] -> Bool) -> StateT (Object (orset a)) m () +commonRemove isTarget = do + obj@Object{id, frame} <- get + StateChunk{..} <- getObjectStateChunk obj + let state0@(ORSetRaw opMap) = stateFromChunk stateBody + let targetEvents = + [ opId + | Op{opId, refId, payload} <- toList opMap + , refId == Zero -- is alive + , isTarget payload + ] + case targetEvents of + [] -> pure () + _ -> do + tombstone <- getEventUuid + let patch = + [ Op{opId = tombstone, refId, payload = []} + | refId <- targetEvents + ] + let chunk' = state0 <> stateFromChunk patch + let state' = stateToChunk chunk' + put obj{frame = Map.insert id state' frame} + +-- | Remove an atomic value from the OR-Set +removeValue + :: (ReplicatedAsPayload a, MonadE m, ReplicaClock m) + => a -> StateT (Object (ORSet a)) m () +removeValue = commonRemove . eqPayload + +-- | Remove an object reference from the OR-Set +removeRef + :: (MonadE m, ReplicaClock m) + => Object a -> StateT (Object (ObjectORSet a)) m () +removeRef = commonRemove . eqRef diff --git a/lib/RON/Data/RGA.hs b/lib/RON/Data/RGA.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/RGA.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | Replicated Growable Array (RGA) +module RON.Data.RGA + ( RGA (..) + , RgaRaw + , RgaString + , edit + , editText + , getList + , getText + , newFromList + , newFromText + , rgaType + ) where + +import Data.Algorithm.Diff (Diff (Both, First, Second), + getGroupedDiffBy) +import qualified Data.HashMap.Strict as HashMap +import Data.Map.Strict ((!?)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text + +import RON.Data.Internal +import RON.Error (MonadE) +import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, + getEventUuids) +import RON.Types (Object (..), Op (..), StateChunk (..), UUID) +import RON.Util.Word (pattern B11, ls60) +import RON.UUID (pattern Zero, uuidVersion) +import qualified RON.UUID as UUID + +-- | opId = vertex id +-- refId: +-- 0 = value is alive, +-- _ = tombstone event, value is backup for undo +-- payload: the value +type Vertex = Op + +data VertexListItem = VertexListItem + { itemValue :: Vertex + , itemNext :: Maybe UUID + } + deriving (Eq, Show) + +data VertexList = VertexList + { listHead :: UUID + , listItems :: HashMap UUID VertexListItem + } + deriving (Eq, Show) + +instance Semigroup VertexList where + (<>) = merge + +vertexListToOps :: VertexList -> [Vertex] +vertexListToOps v@VertexList{..} = go listHead listItems + where + go root items = let + VertexListItem{..} = + HashMap.lookupDefault + (error $ unlines + $ ["Cannot find vertex id", show root, "in array"] + ++ map show (HashMap.toList items) + ++ ["Original array is", show v]) + root + items + rest = case itemNext of + Just next -> go next (HashMap.delete root items) + Nothing -> [] + in itemValue : rest + +vertexListFromOps :: [Vertex] -> Maybe VertexList +vertexListFromOps = foldr go mempty where + go v@Op{opId} vlist = Just $ VertexList{listHead = opId, listItems = vlist'} + where + item itemNext = VertexListItem{itemValue = v, itemNext} + vlist' = case vlist of + Nothing -> HashMap.singleton opId (item Nothing) + Just VertexList{listHead, listItems} -> + HashMap.insert opId (item $ Just listHead) listItems + +-- | Untyped RGA +newtype RgaRaw = RgaRaw (Maybe VertexList) + deriving (Eq, Monoid, Semigroup, Show) + +data PatchSet = PatchSet + { psPatches :: Map UUID VertexList + -- ^ the key is the parent event, the value is a non-empty VertexList + , psRemovals :: Map UUID UUID + -- ^ the key is the target event, the value is the tombstone event + } + deriving (Eq, Show) + +instance Semigroup PatchSet where + rga1 <> rga2 = reapplyPatchSet $ preMerge rga1 rga2 + +preMerge :: PatchSet -> PatchSet -> PatchSet +preMerge (PatchSet p1 r1) (PatchSet p2 r2) = PatchSet + {psPatches = Map.unionWith (<>) p1 p2, psRemovals = Map.unionWith max r1 r2} + +instance Monoid PatchSet where + mempty = PatchSet{psPatches = mempty, psRemovals = mempty} + +patchSetFromRawOp :: Op -> PatchSet +patchSetFromRawOp op@Op{opId, refId, payload} = case payload of + [] -> -- remove op + mempty{psRemovals = Map.singleton refId opId} + _:_ -> -- append op + mempty + { psPatches = + Map.singleton + refId + VertexList + { listHead = opId + , listItems = + HashMap.singleton + opId + VertexListItem + { itemValue = op{refId = Zero} + , itemNext = Nothing + } + } + } + +patchSetFromChunk :: ReducedChunk -> PatchSet +patchSetFromChunk ReducedChunk{rcRef, rcBody} = + case uuidVersion $ UUID.split rcRef of + B11 -> + -- derived event -- rm-patch compatibility + foldMap patchSetFromRawOp rcBody + _ -> -- patch + case vertexListFromOps rcBody of + Just patch -> mempty{psPatches = Map.singleton rcRef patch} + Nothing -> mempty + +instance Reducible RgaRaw where + reducibleOpType = rgaType + + stateFromChunk = RgaRaw . vertexListFromOps + + stateToChunk (RgaRaw rga) = StateChunk + {stateType = rgaType, stateVersion = chunkVersion stateBody, stateBody} + where + stateBody = maybe [] vertexListToOps rga + + applyPatches rga (patches, ops) = + bimap identity patchSetToChunks . reapplyPatchSetToState rga $ + foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + + reduceUnappliedPatches (patches, ops) = + patchSetToChunks . reapplyPatchSet $ + foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + +patchSetToChunks :: PatchSet -> Unapplied +patchSetToChunks PatchSet{..} = + ( [ ReducedChunk{rcVersion = chunkVersion rcBody, ..} + | (rcRef, vertices) <- Map.assocs psPatches + , let rcBody = vertexListToOps vertices + ] + , [ Op{opId = tombstone, refId, payload = []} + | (refId, tombstone) <- Map.assocs psRemovals + ] + ) + +chunkVersion :: [Op] -> UUID +chunkVersion ops = maximumDef Zero + [ max vertexId tombstone + | Op{opId = vertexId, refId = tombstone} <- ops + ] + +reapplyPatchSet :: PatchSet -> PatchSet +reapplyPatchSet ps = + continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches] + +reapplyPatchSetToState :: RgaRaw -> PatchSet -> (RgaRaw, PatchSet) +reapplyPatchSetToState rga ps = + continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState] + +continue :: x -> [x -> Maybe x] -> x +continue x fs = case asum $ map ($ x) fs of + Nothing -> x + Just x' -> continue x' fs + +reapplyPatchesToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet) +reapplyPatchesToState (RgaRaw rstate, ps@PatchSet{..}) = case rstate of + Just VertexList{listHead = targetHead, listItems = targetItems} -> asum + [ do + targetItems' <- applyPatch parent patch targetItems + pure + ( RgaRaw . Just $ VertexList targetHead targetItems' + , ps{psPatches = Map.delete parent psPatches} + ) + | (parent, patch) <- Map.assocs psPatches + ] + Nothing -> do + -- rstate is empty => only virtual 0 node exists + -- => we can apply only 0 patch + patch <- psPatches !? Zero + pure (RgaRaw $ Just patch, ps{psPatches = Map.delete Zero psPatches}) + +reapplyPatchesToOtherPatches :: PatchSet -> Maybe PatchSet +reapplyPatchesToOtherPatches ps@PatchSet{..} = asum + [ do + targetItems' <- applyPatch parent patch targetItems + pure ps + { psPatches = + Map.insert targetParent (VertexList targetHead targetItems') $ + Map.delete parent psPatches + } + | (parent, patch) <- Map.assocs psPatches + , (targetParent, targetPatch) <- Map.assocs psPatches + , parent /= targetParent + , let VertexList targetHead targetItems = targetPatch + ] + +applyPatch + :: UUID + -> VertexList + -> HashMap UUID VertexListItem + -> Maybe (HashMap UUID VertexListItem) +applyPatch parent patch targetItems = case parent of + Zero -> + error "chunk with zero ref mustn't be considered a state, not a patch" + _ -> do + item@VertexListItem{itemNext} <- HashMap.lookup parent targetItems + let VertexList next' newItems = case itemNext of + Nothing -> patch + Just next -> VertexList next targetItems <> patch + let item' = item{itemNext = Just next'} + pure $ HashMap.insert parent item' targetItems <> newItems + +reapplyRemovalsToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet) +reapplyRemovalsToState (RgaRaw rstate, ps@PatchSet{..}) = do + VertexList{listHead = targetHead, listItems = targetItems} <- rstate + asum + [ do + targetItems' <- applyRemoval parent tombstone targetItems + pure + ( RgaRaw . Just $ VertexList targetHead targetItems' + , ps{psRemovals = Map.delete parent psRemovals} + ) + | (parent, tombstone) <- Map.assocs psRemovals + ] + +reapplyRemovalsToPatches :: PatchSet -> Maybe PatchSet +reapplyRemovalsToPatches PatchSet{..} = asum + [ do + targetItems' <- applyRemoval parent tombstone targetItems + pure PatchSet + { psRemovals = Map.delete parent psRemovals + , psPatches = + Map.insert + targetParent (VertexList targetHead targetItems') psPatches + } + | (parent, tombstone) <- Map.assocs psRemovals + , (targetParent, targetPatch) <- Map.assocs psPatches + , let VertexList targetHead targetItems = targetPatch + ] + +applyRemoval + :: UUID + -> UUID + -> HashMap UUID VertexListItem + -> Maybe (HashMap UUID VertexListItem) +applyRemoval parent tombstone targetItems = do + item@VertexListItem{itemValue = v@Op{refId}} <- + HashMap.lookup parent targetItems + let item' = item{itemValue = v{refId = max refId tombstone}} + pure $ HashMap.insert parent item' targetItems + +merge :: VertexList -> VertexList -> VertexList +merge v1 v2 + = fromMaybe (error "merge of non-empty lists cannot be empty") + $ vertexListFromOps + $ (merge' `on` vertexListToOps) v1 v2 + +merge' :: [Vertex] -> [Vertex] -> [Vertex] +merge' [] vs2 = vs2 +merge' vs1 [] = vs1 +merge' w1@(v1 : vs1) w2@(v2 : vs2) = + case compare e1 e2 of + LT -> v2 : merge' w1 vs2 + GT -> v1 : merge' vs1 w2 + EQ -> mergeVertices : merge' vs1 vs2 + where + Op{opId = e1, refId = tombstone1, payload = p1} = v1 + Op{opId = e2, refId = tombstone2, payload = p2} = v2 + + -- priority of deletion + mergeVertices = Op + { opId = e1 + , refId = max tombstone1 tombstone2 + , payload = maxOn length p1 p2 + } + +-- | Name-UUID to use as RGA type marker. +rgaType :: UUID +rgaType = $(UUID.liftName "rga") + +-- | Typed RGA +newtype RGA a = RGA [a] + deriving (Eq) + +instance Replicated a => Replicated (RGA a) where encoding = objectEncoding + +instance Replicated a => ReplicatedAsObject (RGA a) where + objectOpType = rgaType + + newObject (RGA items) = collectFrame $ do + vertexIds <- lift $ getEventUuids $ ls60 $ genericLength items + ops <- for (zip items vertexIds) $ \(item, vertexId) -> do + payload <- newRon item + pure $ Op vertexId Zero payload + oid <- lift getEventUuid + let stateVersion = maximumDef oid $ map opId ops + tell $ + Map.singleton oid $ + StateChunk{stateType = rgaType, stateVersion, stateBody = ops} + pure oid + + getObject obj@Object{frame} = do + StateChunk{..} <- getObjectStateChunk obj + mItems <- for stateBody $ \Op{..} -> case refId of + Zero -> Just <$> fromRon payload frame + _ -> pure Nothing + pure . RGA $ catMaybes mItems + +-- | Replace content of the RGA throug introducing changes detected by +-- 'getGroupedDiffBy'. +edit + :: ( ReplicatedAsPayload a + , ReplicaClock m, MonadE m, MonadState (Object (RGA a)) m + ) + => [a] -> m () +edit newItems = do + obj@Object{id, frame} <- get + StateChunk{..} <- getObjectStateChunk obj + advanceToUuid stateVersion + + let newItems' = [Op Zero Zero $ toPayload item | item <- newItems] + let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems' + (stateBody', Last lastEvent) <- runWriterT . fmap fold . for diff $ \case + First removed -> for removed $ \case + op@Op{refId = Zero} -> do -- not deleted yet + -- TODO(2018-11-03, #15, cblp) get sequential ids + tombstone <- lift getEventUuid + tell . Last $ Just tombstone + pure op{refId = tombstone} + op -> -- deleted already + pure op + Both v _ -> pure v + Second added -> for added $ \op -> do + -- TODO(2018-11-03, #15, cblp) get sequential ids + opId <- lift getEventUuid + tell . Last $ Just opId + pure op{opId} + + case lastEvent of + Nothing -> pure () + Just stateVersion' -> do + let state' = StateChunk + { stateType = rgaType + , stateVersion = stateVersion' + , stateBody = stateBody' + } + put obj{frame = Map.insert id state' frame} + + where + eqAliveOnPayload + Op{refId = Zero, payload = p1} + Op{refId = Zero, payload = p2} + = p1 == p2 + eqAliveOnPayload _ _ = False + +-- | Speciaization of 'edit' for 'Text' +editText + :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m) + => Text -> m () +editText = edit . Text.unpack + +-- | Speciaization of 'RGA' to 'Char'. +-- This is the recommended way to store a string. +type RgaString = RGA Char + +-- | Create an RGA from a list +newFromList :: (Replicated a, ReplicaClock m) => [a] -> m (Object (RGA a)) +newFromList = newObject . RGA + +-- | Create an 'RgaString' from a text +newFromText :: ReplicaClock m => Text -> m (Object RgaString) +newFromText = newFromList . Text.unpack + +-- | Read elements from RGA +getList :: forall a m . (Replicated a, MonadE m) => Object (RGA a) -> m [a] +getList = fmap coerce . getObject + +-- | Read characters from 'RgaString' +getText :: MonadE m => Object RgaString -> m Text +getText = fmap Text.pack . getList diff --git a/lib/RON/Data/Time.hs b/lib/RON/Data/Time.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/Time.hs @@ -0,0 +1,26 @@ +{-# OPTIONS -Wno-orphans #-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 'Day' instances +module RON.Data.Time (Day) where + +import Data.Time (Day, fromGregorian, toGregorian) + +import RON.Data (Replicated (..), ReplicatedAsPayload (..), + payloadEncoding) +import RON.Types (Atom (..)) + +instance Replicated Day where encoding = payloadEncoding + +instance ReplicatedAsPayload Day where + toPayload + = (\(y, m, d) -> + map AInteger [fromIntegral y, fromIntegral m, fromIntegral d]) + . toGregorian + + fromPayload = \case + [AInteger y, AInteger m, AInteger d] -> pure $ + fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d) + _ -> throwError "bad Day" diff --git a/lib/RON/Data/VersionVector.hs b/lib/RON/Data/VersionVector.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/VersionVector.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Version Vector +module RON.Data.VersionVector + ( VersionVector + ) where + +import Data.Hashable (hashWithSalt) +import qualified Data.Map.Strict as Map + +import RON.Data.Internal +import RON.Event (getEventUuid) +import RON.Types (Op (..), StateChunk (..), UUID (UUID)) +import qualified RON.UUID as UUID + +type Origin = Word64 + +opTime :: Op -> Word64 +opTime Op{opId = UUID time _} = time + +opOrigin :: Op -> Word64 +opOrigin Op{opId = UUID _ origin} = origin + +latter :: Op -> Op -> Op +latter = maxOn opTime + +-- | Version Vector type. May be used both in typed and untyped contexts. +newtype VersionVector = VersionVector (Map Origin 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 + +instance Reducible VersionVector where + reducibleOpType = vvType + + stateFromChunk ops = + VersionVector $ Map.fromListWith latter [(opOrigin op, op) | op <- ops] + + stateToChunk (VersionVector vv) = mkStateChunk vvType $ Map.elems vv + +-- | 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 + objectOpType = vvType + + newObject (VersionVector vv) = collectFrame $ do + oid <- lift getEventUuid + let ops = Map.elems vv + let stateVersion = maximumDef oid $ map opId ops + tell $ + Map.singleton oid $ + StateChunk{stateType = vvType, stateVersion, stateBody = ops} + pure oid + + getObject obj = do + StateChunk{..} <- getObjectStateChunk obj + pure $ stateFromChunk stateBody diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs new file mode 100644 --- /dev/null +++ b/prelude/Prelude.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module Prelude ( + module X, + fmapL, + foldr1, + identity, + lastDef, + maximumDef, + maxOn, + minOn, + show, + whenJust, + (?:), +) where + +-- base +import Control.Applicative as X (Alternative, Applicative, liftA2, + many, optional, pure, some, (*>), + (<*), (<*>), (<|>)) +import Control.Exception as X (Exception, catch, evaluate, throwIO) +import Control.Monad as X (Monad, filterM, guard, unless, void, when, + (<=<), (=<<), (>=>), (>>=)) +import Control.Monad.Fail as X (MonadFail, fail) +import Control.Monad.IO.Class as X (MonadIO, liftIO) +import Data.Bifunctor as X (bimap) +import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||)) +import Data.Char as X (Char, chr, ord, toLower, toUpper) +import Data.Coerce as X (Coercible, coerce) +import Data.Data as X (Data) +import Data.Either as X (Either (Left, Right), either) +import Data.Eq as X (Eq, (/=), (==)) +import Data.Foldable as X (Foldable, and, asum, fold, foldMap, foldl', + foldr, for_, length, minimumBy, null, or, + toList, traverse_) +import Data.Function as X (const, flip, on, ($), (.)) +import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>)) +import Data.Functor.Identity as X (Identity) +import Data.Int as X (Int, Int16, Int32, Int64, Int8) +import Data.IORef as X (IORef, atomicModifyIORef', newIORef, + readIORef, writeIORef) +import Data.List as X (filter, genericLength, intercalate, isPrefixOf, + isSuffixOf, lookup, map, partition, repeat, + replicate, sortBy, sortOn, span, splitAt, take, + takeWhile, unlines, unwords, zip, (++)) +import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) +import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, + listToMaybe, maybe, maybeToList) +import Data.Monoid as X (Last (Last), Monoid, mempty) +import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT), + compare, comparing, max, min, (<), (<=), (>), + (>=)) +import Data.Ratio as X ((%)) +import Data.Semigroup as X (Semigroup, sconcat, (<>)) +import Data.String as X (String) +import Data.Traversable as X (for, sequence, sequenceA, traverse) +import Data.Tuple as X (fst, snd, uncurry) +import Data.Typeable as X (Typeable) +import Data.Word as X (Word, Word16, Word32, Word64, Word8) +import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound, + pred, succ, toEnum) +import GHC.Err as X (error, undefined) +import GHC.Exts as X (Double) +import GHC.Generics as X (Generic) +import GHC.Integer as X (Integer) +import GHC.Num as X (Num, negate, subtract, (*), (+), (-)) +import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round, + (^), (^^)) +import GHC.Stack as X (HasCallStack) +import System.IO as X (FilePath, IO) +import Text.Show as X (Show) + +#ifdef VERSION_bytestring +import Data.ByteString as X (ByteString) +#endif + +#ifdef VERSION_containers +import Data.Map.Strict as X (Map) +#endif + +#ifdef VERSION_deepseq +import Control.DeepSeq as X (NFData, force) +#endif + +#ifdef VERSION_filepath +import System.FilePath as X (()) +#endif + +#ifdef VERSION_hashable +import Data.Hashable as X (Hashable, hash) +#endif + +#ifdef VERSION_mtl +import Control.Monad.Except as X (ExceptT, MonadError, catchError, + liftEither, runExceptT, throwError) +import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader, + runReaderT) +import Control.Monad.State.Strict as X (MonadState, State, StateT, + evalState, evalStateT, + execStateT, get, gets, + modify', put, runState, + runStateT, state) +import Control.Monad.Trans as X (MonadTrans, lift) +import Control.Monad.Writer.Strict as X (MonadWriter, WriterT, + runWriterT, tell) +#endif + +#ifdef VERSION_text +import Data.Text as X (Text) +#endif + +#ifdef VERSION_time +import Data.Time as X (UTCTime) +#endif + +#ifdef VERSION_unordered_containers +import Data.HashMap.Strict as X (HashMap) +#endif + +-------------------------------------------------------------------------------- + +import qualified Data.Foldable +import Data.List (last, maximum) +import Data.String (IsString, fromString) +import qualified Text.Show + +fmapL :: (a -> b) -> Either a c -> Either b c +fmapL f = either (Left . f) Right + +foldr1 :: (a -> a -> a) -> NonEmpty a -> a +foldr1 = Data.Foldable.foldr1 + +identity :: a -> a +identity x = x + +lastDef :: a -> [a] -> a +lastDef def = list' def last + +list' :: b -> ([a] -> b) -> [a] -> b +list' onEmpty onNonEmpty = \case + [] -> onEmpty + xs -> onNonEmpty xs + +maximumDef :: Ord a => a -> [a] -> a +maximumDef def = list' def maximum + +maxOn :: Ord b => (a -> b) -> a -> a -> a +maxOn f x y = if f x < f y then y else x + +minOn :: Ord b => (a -> b) -> a -> a -> a +minOn f x y = if f x < f y then x else y + +show :: (Show a, IsString s) => a -> s +show = fromString . Text.Show.show + +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust m f = maybe (pure ()) f m + +-- | An infix form of 'fromMaybe' with arguments flipped. +(?:) :: Maybe a -> a -> a +maybeA ?: b = fromMaybe b maybeA +{-# INLINABLE (?:) #-} +infixr 0 ?: diff --git a/ron-rdt.cabal b/ron-rdt.cabal new file mode 100644 --- /dev/null +++ b/ron-rdt.cabal @@ -0,0 +1,74 @@ +cabal-version: 2.2 + +name: ron-rdt +version: 0.5 + +bug-reports: https://github.com/ff-notes/ron/issues +category: Distributed Systems, Protocol, Database +copyright: 2018-2019 Yuriy Syrovetskiy +homepage: https://github.com/ff-notes/ron +license: BSD-3-Clause +license-file: LICENSE +maintainer: Yuriy Syrovetskiy +synopsis: Replicated Data Types (RON-RDT) + +description: + Replicated Object Notation (RON), data types (RDT), and RON-Schema + . + Typical usage: + . + > import RON.Data + > import RON.Schema.TH + > import RON.Storage.IO as Storage + > + > [mkReplicated| + > (struct_lww Note + > active Boole + > text RgaString) + > |] + > + > instance Collection Note where + > collectionName = "note" + > + > main :: IO () + > main = do + > let dataDir = "./data/" + > h <- Storage.newHandle dataDir + > runStorage h $ do + > obj <- newObject + > Note{active = True, text = "Write a task manager"} + > createDocument obj + +build-type: Simple + +common language + build-depends: base >= 4.10 && < 4.13, integer-gmp + default-extensions: MonadFailDesugaring StrictData + default-language: Haskell2010 + hs-source-dirs: prelude + other-modules: Prelude + +library + import: language + build-depends: + -- global + containers, + Diff, + hashable, + mtl, + text, + time, + transformers, + unordered-containers, + -- project + ron + exposed-modules: + RON.Data + RON.Data.LWW + RON.Data.ORSet + RON.Data.RGA + RON.Data.Time + RON.Data.VersionVector + other-modules: + RON.Data.Internal + hs-source-dirs: lib