packages feed

appendful (empty) → 0.0.0.0

raw patch · 3 files changed

+424/−0 lines, 3 filesdep +aesondep +basedep +containers

Dependencies added: aeson, base, containers, deepseq, mtl, validity, validity-containers

Files

+ appendful.cabal view
@@ -0,0 +1,39 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name:           appendful+version:        0.0.0.0+description:    Append-only cooperative agreement+homepage:       https://github.com/NorfairKing/appendful#readme+bug-reports:    https://github.com/NorfairKing/appendful/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright: (c) 2020-2022 Tom Sydney Kerckhove+license:        MIT+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/NorfairKing/appendful++library+  exposed-modules:+      Data.Appendful+      Data.Appendful.Collection+  other-modules:+      Paths_appendful+  hs-source-dirs:+      src+  ghc-options: -Wall -fwarn-redundant-constraints+  build-depends:+      aeson+    , base >=4.11 && <5+    , containers+    , deepseq+    , mtl+    , validity+    , validity-containers+  default-language: Haskell2010
+ src/Data/Appendful.hs view
@@ -0,0 +1,6 @@+module Data.Appendful+  ( module Data.Appendful.Collection,+  )+where++import Data.Appendful.Collection
+ src/Data/Appendful/Collection.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A way to synchronise items without merge conflicts.+--+-- This concept has a few requirements:+--+-- * Items must be immutable.+-- * Items must allow for a centrally unique identifier monotone identifier.+-- * Items must allow for a client-side unique identifier.+-- * Identifiers for items must be generated in such a way that they are certainly unique.+--+-- Should mutation be a requirement, then there is another library: 'mergeful' for exactly this purpose.+--+--+-- There are a few obvious candidates for identifiers:+--+-- * incremental identifiers+-- * universally unique identifiers (recommended).+--+--+--+-- The typical setup is as follows:+--+-- * A central server is set up to synchronise with+-- * Each client synchronises with the central server, but never with eachother+--+--+-- A central server should operate as follows:+--+-- * The server accepts a 'SyncRequest'.+-- * The server performs operations according to the functionality of 'processServerSync'.+-- * The server respons with a 'SyncResponse'.+--+--+-- A client should operate as follows:+--+-- * The client produces a 'SyncRequest' with 'makeSyncRequest'.+-- * The client sends that request to the central server and gets a 'SyncResponse'.+-- * The client then updates its local store with 'mergeSyncResponse'.+module Data.Appendful.Collection+  ( ClientStore (..),+    SyncRequest (..),+    SyncResponse (..),++    -- * Client-side Synchronisation++    -- ** General+    ClientSyncProcessor (..),+    mergeSyncResponseCustom,++    -- ** Pure+    emptyClientStore,+    ClientId (..),+    storeSize,+    addItemToClientStore,+    emptySyncRequest,+    makeSyncRequest,+    mergeSyncResponse,+    pureClientSyncProcessor,++    -- * Server-side Synchronisation++    -- ** General synchronisation+    ServerSyncProcessor (..),+    processServerSyncCustom,++    -- ** Synchronisation with a simple central store+    ServerStore (..),+    emptyServerStore,+    emptySyncResponse,+    processServerSync,+  )+where++import Control.DeepSeq+import Control.Monad.State.Strict+import Data.Aeson+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Validity+import Data.Validity.Containers ()+import Data.Word+import GHC.Generics (Generic)++{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}++-- | A Client-side identifier for items for use with pure client stores+--+-- These only need to be unique at the client.+newtype ClientId = ClientId+  { unClientId :: Word64+  }+  deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)++instance Validity ClientId++instance NFData ClientId++-- | A client-side store of items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@+data ClientStore ci si a = ClientStore+  { clientStoreAdded :: !(Map ci a),+    clientStoreSynced :: !(Map si a)+  }+  deriving (Show, Eq, Ord, Generic)++instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a)++instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (ClientStore ci si a) where+  validate cs@ClientStore {..} =+    mconcat+      [ genericValidate cs,+        declare "the store items have distinct ids" $+          distinct $+            M.keys clientStoreSynced+      ]++instance (Ord ci, FromJSON ci, FromJSONKey ci, Ord si, FromJSON si, FromJSONKey si, FromJSON a) => FromJSON (ClientStore ci si a) where+  parseJSON =+    withObject "ClientStore" $ \o ->+      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty++instance (Ord ci, ToJSON ci, ToJSONKey ci, Ord si, ToJSON si, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where+  toJSON ClientStore {..} =+    object+      ["added" .= clientStoreAdded, "synced" .= clientStoreSynced]++-- | The client store with no items.+emptyClientStore :: ClientStore ci si a+emptyClientStore =+  ClientStore+    { clientStoreAdded = M.empty,+      clientStoreSynced = M.empty+    }++-- | The number of items in a store+--+-- This does not count the deleted items, so that those really look deleted.+storeSize :: ClientStore ci si a -> Int+storeSize ClientStore {..} = M.size clientStoreAdded + M.size clientStoreSynced++clientStoreIds :: ClientStore ci si a -> Set si+clientStoreIds ClientStore {..} = M.keysSet clientStoreSynced++-- | Add an item to a client store as an added item.+--+-- This will take care of the uniqueness constraint of the 'ci's in the map.+--+-- The values wrap around when reaching 'maxBound'.+addItemToClientStore :: (Enum ci, Bounded ci, Ord ci) => a -> ClientStore ci si a -> ClientStore ci si a+addItemToClientStore a cs =+  let oldAddedItems = clientStoreAdded cs+      newAddedItems =+        let newKey = findFreeSpot oldAddedItems+         in M.insert newKey a oldAddedItems+   in cs {clientStoreAdded = newAddedItems}++-- | Find a free client id to use+--+-- You shouldn't need this function, 'addItemToClientStore' takes care of this.+--+-- The values wrap around when reaching 'maxBound'.+findFreeSpot :: (Ord ci, Enum ci, Bounded ci) => Map ci a -> ci+findFreeSpot m =+  if M.null m+    then minBound+    else+      let (i, _) = M.findMax m+       in go (next i)+  where+    go i =+      if M.member i m+        then go (next i)+        else i+    next ci+      | ci == maxBound = minBound+      | otherwise = succ ci++-- | A synchronisation request for items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@+data SyncRequest ci si a = SyncRequest+  { syncRequestAdded :: !(Map ci a),+    syncRequestMaximumSynced :: !(Maybe si)+  }+  deriving (Show, Eq, Ord, Generic)++instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a)++instance (Validity ci, Validity si, Validity a, Ord ci, Ord si, Show ci) => Validity (SyncRequest ci si a)++instance (FromJSON ci, FromJSON si, FromJSON a, FromJSONKey ci, Ord ci, Ord si, Ord a) => FromJSON (SyncRequest ci si a) where+  parseJSON =+    withObject "SyncRequest" $ \o ->+      SyncRequest <$> o .: "added" <*> o .:? "max-synced"++instance (ToJSON ci, ToJSON si, ToJSON a, ToJSONKey ci) => ToJSON (SyncRequest ci si a) where+  toJSON SyncRequest {..} =+    object+      [ "added" .= syncRequestAdded,+        "max-synced" .= syncRequestMaximumSynced+      ]++emptySyncRequest :: SyncRequest ci si a+emptySyncRequest =+  SyncRequest+    { syncRequestAdded = M.empty,+      syncRequestMaximumSynced = Nothing+    }++-- | Produce a synchronisation request for a client-side store.+--+-- This request can then be sent to a central store for synchronisation.+makeSyncRequest :: ClientStore ci si a -> SyncRequest ci si a+makeSyncRequest ClientStore {..} =+  SyncRequest+    { syncRequestAdded = clientStoreAdded,+      syncRequestMaximumSynced = fst <$> M.lookupMax clientStoreSynced+    }++-- | A synchronisation response for items with identifiers of type @i@ and values of type @a@+data SyncResponse ci si a = SyncResponse+  { syncResponseClientAdded :: !(Map ci si),+    syncResponseServerAdded :: !(Map si a)+  }+  deriving (Show, Eq, Ord, Generic)++instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a)++instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (SyncResponse ci si a) where+  validate sr@SyncResponse {..} =+    mconcat+      [ genericValidate sr,+        declare "the sync response items have distinct uuids" $+          distinct $+            concat+              [ M.elems syncResponseClientAdded,+                M.keys syncResponseServerAdded+              ]+      ]++instance (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, Ord a, FromJSON a) => FromJSON (SyncResponse ci si a) where+  parseJSON =+    withObject "SyncResponse" $ \o ->+      SyncResponse <$> o .: "client-added" <*> o .: "server-added"++instance (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncResponse ci si a) where+  toJSON SyncResponse {..} =+    object+      [ "client-added" .= syncResponseClientAdded,+        "server-added" .= syncResponseServerAdded+      ]++emptySyncResponse :: SyncResponse ci si a+emptySyncResponse =+  SyncResponse+    { syncResponseClientAdded = M.empty,+      syncResponseServerAdded = M.empty+    }++-- | Merge a synchronisation response back into a client-side store.+mergeSyncResponse ::+  forall ci si a.+  (Ord ci, Ord si) =>+  ClientStore ci si a ->+  SyncResponse ci si a ->+  ClientStore ci si a+mergeSyncResponse s sr =+  flip execState s $+    mergeSyncResponseCustom+      pureClientSyncProcessor+      sr++pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a))+pureClientSyncProcessor =+  ClientSyncProcessor+    { clientSyncProcessorSyncServerAdded = \m -> modify $ \cs ->+        cs {clientStoreSynced = M.union (clientStoreSynced cs) (m `diffSet` clientStoreIds cs)},+      clientSyncProcessorSyncClientAdded = \addedItems -> modify $ \cs ->+        let oldAdded = clientStoreAdded cs+            oldSynced = clientStoreSynced cs+            go :: (Map ci a, Map si a) -> ci -> si -> (Map ci a, Map si a)+            go (added, synced) cid i =+              case M.lookup cid added of+                Nothing -> (added, synced)+                Just a -> (M.delete cid added, M.insert i a synced)+            (newAdded, newSynced) = M.foldlWithKey go (oldAdded, oldSynced) addedItems+         in cs {clientStoreAdded = newAdded, clientStoreSynced = newSynced}+    }++data ClientSyncProcessor ci si a m = ClientSyncProcessor+  { clientSyncProcessorSyncClientAdded :: Map ci si -> m (),+    clientSyncProcessorSyncServerAdded :: Map si a -> m ()+  }+  deriving (Generic)++mergeSyncResponseCustom :: Monad m => ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()+mergeSyncResponseCustom ClientSyncProcessor {..} SyncResponse {..} = do+  -- The order here matters!+  clientSyncProcessorSyncServerAdded syncResponseServerAdded+  clientSyncProcessorSyncClientAdded syncResponseClientAdded++-- | A record of the basic operations that are necessary to build a synchronisation processor.+data ServerSyncProcessor ci si a m = ServerSyncProcessor+  { serverSyncProcessorRead :: m (Map si a),+    serverSyncProcessorAddItems :: Map ci a -> m (Map ci si)+  }+  deriving (Generic)++processServerSyncCustom ::+  forall ci si a m.+  (Ord si, Monad m) =>+  ServerSyncProcessor ci si a m ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a)+processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do+  serverItems <- serverSyncProcessorRead+  let syncResponseServerAdded = maybe id (\ms -> M.dropWhileAntitone (<= ms)) syncRequestMaximumSynced serverItems+  syncResponseClientAdded <- serverSyncProcessorAddItems syncRequestAdded+  pure SyncResponse {..}++-- | A central store of items with identifiers of type @i@ and values of type @a@+newtype ServerStore si a = ServerStore+  { serverStoreItems :: Map si a+  }+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)++instance (NFData si, NFData a) => NFData (ServerStore si a)++instance (Validity si, Validity a, Show si, Show a, Ord si) => Validity (ServerStore si a)++-- | An empty central store to start with+emptyServerStore :: ServerStore si a+emptyServerStore = ServerStore {serverStoreItems = M.empty}++-- | Process a server-side synchronisation request using a server id generator+--+-- see 'processSyncCustom'+processServerSync ::+  forall m ci si a.+  (Ord si, Monad m) =>+  m si ->+  ServerStore si a ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a, ServerStore si a)+processServerSync genUuid cs sr =+  flip runStateT cs $+    processServerSyncCustom+      ServerSyncProcessor+        { serverSyncProcessorRead = gets serverStoreItems,+          serverSyncProcessorAddItems = insertMany+        }+      sr+  where+    insertMany :: Map ci a -> StateT (ServerStore si a) m (Map ci si)+    insertMany =+      traverse $ \a -> do+        u <- lift genUuid+        ins u a+        pure u+    ins :: si -> a -> StateT (ServerStore si a) m ()+    ins i val = modC $ M.insert i val+    modC :: (Map si a -> Map si a) -> StateT (ServerStore si a) m ()+    modC func = modify (\(ServerStore m) -> ServerStore $ func m)++diffSet :: Ord si => Map si a -> Set si -> Map si a+diffSet m s = m `M.difference` toMap s++toMap :: Set si -> Map si ()+toMap = M.fromSet (const ())++distinct :: Ord a => [a] -> Bool+distinct ls = sort ls == S.toAscList (S.fromList ls)