{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Data.MergefulSpec
( spec
) where
import Data.Functor.Identity
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.UUID
import GHC.Generics (Generic)
import System.Random
import Text.Show.Pretty
import Control.Monad.State
import Test.Hspec
import Test.Validity
import Test.Validity.Aeson
import Data.GenValidity.UUID ()
import Data.Mergeful
import Data.Mergeful.Timed
import Data.GenValidity.Mergeful ()
import Data.GenValidity.Mergeful.Item ()
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
spec :: Spec
spec = do
genValidSpec @ClientId
jsonSpecOnValid @ClientId
genValidSpec @(ClientStore Int Int)
jsonSpecOnValid @(ClientStore Int Int)
genValidSpec @(ServerStore Int Int)
jsonSpecOnValid @(ServerStore Int Int)
genValidSpec @(SyncRequest Int Int)
jsonSpecOnValid @(SyncRequest Int Int)
genValidSpec @(SyncResponse Int Int)
jsonSpecOnValid @(SyncResponse Int Int)
describe "initialClientStore" $ it "is valid" $ shouldBeValid $ initialClientStore @Int @Int
describe "addItemToClientStore" $
it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @Int @Int)
describe "markItemDeletedInClientStore" $
it "produces valid stores" $ producesValidsOnValids2 (markItemDeletedInClientStore @Int @Int)
describe "changeItemInClientStore" $
it "produces valid stores" $ producesValidsOnValids3 (changeItemInClientStore @Int @Int)
describe "deleteItemFromClientStore" $
it "produces valid stores" $ producesValidsOnValids2 (deleteItemFromClientStore @Int @Int)
describe "initialServerStore" $ it "is valid" $ shouldBeValid $ initialServerStore @Int @Int
describe "initialSyncRequest" $ it "is valid" $ shouldBeValid $ initialSyncRequest @Int @Int
describe "emptySyncResponse" $ it "is valid" $ shouldBeValid $ emptySyncResponse @Int @Int
describe "makeSyncRequest" $
it "produces valid requests" $ producesValidsOnValids (makeSyncRequest @Int @Int)
describe "mergeAddedItems" $
it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)
describe "mergeSyncedButChangedItems" $
it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)
describe "mergeAddedItems" $
it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)
describe "mergeSyncedButChangedItems" $
it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)
describe "mergeDeletedItems" $
it "produces valid results" $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)
describe "mergeSyncResponseIgnoreProblems" $
it "produces valid requests" $
forAllValid $ \store ->
forAllValid $ \response ->
let res = mergeSyncResponseIgnoreProblems @Int @Int store response
in case prettyValidate res of
Right _ -> pure ()
Left err ->
expectationFailure $
unlines
[ "Store:"
, ppShow store
, "Response:"
, ppShow response
, "Invalid result:"
, ppShow res
, "error:"
, err
]
describe "mergeSyncResponseFromServer" $ do
it "only differs from mergeSyncResponseIgnoreProblems on conflicts" $
forAllValid $ \cstore ->
forAllValid $ \sresp@SyncResponse {..} -> do
let cstoreA = mergeSyncResponseFromServer (cstore :: ClientStore (UUID) Int) sresp
cstoreB = mergeSyncResponseIgnoreProblems cstore sresp
if cstoreA == cstoreB
then pure ()
else unless
(or
[ not (M.null syncResponseConflicts)
, not (M.null syncResponseConflictsClientDeleted)
, not (S.null syncResponseConflictsServerDeleted)
]) $
expectationFailure $
unlines
[ "There was a difference between mergeSyncResponseFromServer and mergeSyncResponseIgnoreProblems that was somehow unrelated to the conflicts:"
, "syncResponseConflicts:"
, ppShow syncResponseConflicts
, "syncResponseConflictsClientDeleted:"
, ppShow syncResponseConflictsClientDeleted
, "syncResponseConflictsServerDeleted:"
, ppShow syncResponseConflictsServerDeleted
, "client store after mergeSyncResponseFromServer:"
, ppShow cstoreA
, "client store after mergeSyncResponseIgnoreProblems:"
, ppShow cstoreB
]
describe "processServerSync with mergeSyncResponseIgnoreProblems" $ do
it "produces valid tuples of a response and a store" $
producesValidsOnValids2
(\store request -> evalD $ processServerSync genD (store :: ServerStore (UUID) Int) request)
describe "Single client" $ do
describe "Multi-item" $ do
it "succesfully downloads everything from the server for an empty client" $
forAllValid $ \sstore1 ->
evalDM $ do
let cstore1 = initialClientStore :: ClientStore (UUID) Int
let req = makeSyncRequest cstore1
(resp, sstore2) <- processServerSync genD sstore1 req
let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp
lift $ do
sstore2 `shouldBe` sstore1
clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2
it "succesfully uploads everything to the server for an empty server" $
forAllValid $ \items ->
evalDM $ do
let cstore1 = initialClientStore {clientStoreAddedItems = items}
let sstore1 = initialServerStore :: ServerStore (UUID) Int
let req = makeSyncRequest cstore1
(resp, sstore2) <- processServerSync genD sstore1 req
let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp
lift $ do
sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2))) `shouldBe`
sort (M.elems items)
clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2
it "is idempotent with one client" $
forAllValid $ \cstore1 ->
forAllValid $ \sstore1 ->
evalDM $ do
let req1 = makeSyncRequest (cstore1 :: ClientStore (UUID) Int)
(resp1, sstore2) <- processServerSync genD sstore1 req1
let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp1
req2 = makeSyncRequest cstore2
(resp2, sstore3) <- processServerSync genD sstore2 req2
let cstore3 = mergeSyncResponseIgnoreProblems cstore2 resp2
lift $ do
cstore2 `shouldBe` cstore3
sstore2 `shouldBe` sstore3
describe "Multiple clients" $ do
describe "Single-item" $ do
it "successfully syncs an addition accross to a second client" $
forAllValid $ \i ->
evalDM $ do
let cAstore1 = initialClientStore {clientStoreAddedItems = M.singleton (ClientId 0) i}
-- Client B is empty
let cBstore1 = initialClientStore :: ClientStore (UUID) Int
-- The server is empty
let sstore1 = initialServerStore
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
let addedItems = syncResponseClientAdded resp1
case M.toList addedItems of
[(ClientId 0, (uuid, st))] -> do
let time = initialServerTime
lift $ st `shouldBe` time
let items = M.singleton uuid (Timed i st)
lift $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1
lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2
lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})
-- Client A and Client B now have the same store
lift $ cAstore2 `shouldBe` cBstore2
_ -> lift $ expectationFailure "Should have found exactly one added item."
it "successfully syncs a modification accross to a second client" $
forAllValid $ \uuid ->
forAllValid $ \i ->
forAllValid $ \j ->
forAllValid $ \time1 ->
evalDM $ do
let cAstore1 =
initialClientStore
{ clientStoreSyncedItems =
M.singleton (uuid :: UUID) (Timed (i :: Int) time1)
}
-- Client B had synced that same item, but has since modified it
let cBstore1 =
initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed j time1)}
-- The server is has the item that both clients had before
let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}
-- Client B makes sync request 1
let req1 = makeSyncRequest cBstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
let time2 = incrementServerTime time1
lift $ do
resp1 `shouldBe`
emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}
sstore2 `shouldBe`
ServerStore {serverStoreItems = M.singleton uuid (Timed j time2)}
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1
lift $
cBstore2 `shouldBe`
initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}
-- Client A makes sync request 2
let req2 = makeSyncRequest cAstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe`
emptySyncResponse
{syncResponseServerChanged = M.singleton uuid (Timed j time2)}
sstore3 `shouldBe` sstore2
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2
lift $
cAstore2 `shouldBe`
initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}
-- Client A and Client B now have the same store
lift $ cAstore2 `shouldBe` cBstore2
it "succesfully syncs a deletion across to a second client" $
forAllValid $ \uuid ->
forAllValid $ \time1 ->
forAllValid $ \i ->
evalDM $ do
let cAstore1 =
initialClientStore
{ clientStoreSyncedItems =
M.singleton (uuid :: UUID) (Timed (i :: Int) time1)
}
-- Client A has a synced item.
-- Client B had synced that same item, but has since deleted it.
let cBstore1 =
initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}
-- The server still has the undeleted item
let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}
-- Client B makes sync request 1
let req1 = makeSyncRequest cBstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
lift $ do
resp1 `shouldBe`
emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}
sstore2 `shouldBe` initialServerStore
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1
lift $ cBstore2 `shouldBe` initialClientStore
-- Client A makes sync request 2
let req2 = makeSyncRequest cAstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe`
emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}
sstore3 `shouldBe` sstore2
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2
lift $ cAstore2 `shouldBe` initialClientStore
-- Client A and Client B now have the same store
lift $ cAstore2 `shouldBe` cBstore2
it "does not run into a conflict if two clients both try to sync a deletion" $
forAllValid $ \uuid ->
forAllValid $ \time1 ->
forAllValid $ \i ->
evalDM $ do
let cAstore1 =
initialClientStore
{clientStoreDeletedItems = M.singleton (uuid :: UUID) time1}
-- Both client a and client b delete an item.
let cBstore1 =
initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}
-- The server still has the undeleted item
let sstore1 =
ServerStore {serverStoreItems = M.singleton uuid (Timed (i :: Int) time1)}
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
lift $ do
resp1 `shouldBe`
(emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})
sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1
lift $ cAstore2 `shouldBe` initialClientStore
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe`
(emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2
lift $ do
cBstore2 `shouldBe` initialClientStore
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
it "does not lose data after a conflict occurs" $
forAllValid $ \uuid ->
forAllValid $ \time1 ->
forAllValid $ \i1 ->
forAllValid $ \i2 ->
forAllValid $ \i3 ->
evalDM $ do
let sstore1 =
ServerStore
{ serverStoreItems =
M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)
}
-- The server has an item
-- The first client has synced it, and modified it.
let cAstore1 =
initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}
-- The second client has synced it too, and modified it too.
let cBstore1 =
initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
let time2 = incrementServerTime time1
-- The server updates the item accordingly
lift $ do
resp1 `shouldBe`
(emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})
sstore2 `shouldBe`
(ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1
lift $
cAstore2 `shouldBe`
(initialClientStore
{clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
-- The server reports a conflict and does not change its store
lift $ do
resp2 `shouldBe`
(emptySyncResponse
{syncResponseConflicts = M.singleton uuid (Timed i2 time2)})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2
-- Client does not update, but keeps its conflict
lift $ do
cBstore2 `shouldBe`
(initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)})
-- Client A and Client B now *do not* have the same store
describe "Multiple items" $ do
it "successfully syncs additions accross to a second client" $
forAllValid $ \is ->
evalDM $ do
let cAstore1 = initialClientStore {clientStoreAddedItems = is}
-- Client B is empty
let cBstore1 = initialClientStore :: ClientStore (UUID) Int
-- The server is empty
let sstore1 = initialServerStore
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
let (rest, items) = mergeAddedItems is (syncResponseClientAdded resp1)
lift $ do
rest `shouldBe` M.empty
sstore2 `shouldBe` (ServerStore {serverStoreItems = items})
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1
lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2
lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})
-- Client A and Client B now have the same store
lift $ cAstore2 `shouldBe` cBstore2
it "succesfully syncs deletions across to a second client" $
forAllValid $ \items ->
forAllValid $ \time1 ->
evalDM $ do
let syncedItems = M.map (\i -> Timed i time1) (items :: Map (UUID) Int)
itemTimes = M.map (const time1) items
itemIds = M.keysSet items
let cAstore1 = initialClientStore {clientStoreSyncedItems = syncedItems}
-- Client A has synced items
-- Client B had synced the same items, but has since deleted them.
let cBstore1 = initialClientStore {clientStoreDeletedItems = itemTimes}
-- The server still has the undeleted item
let sstore1 = ServerStore {serverStoreItems = syncedItems}
-- Client B makes sync request 1
let req1 = makeSyncRequest cBstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
lift $ do
resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}
sstore2 `shouldBe` initialServerStore
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1
lift $ cBstore2 `shouldBe` initialClientStore
-- Client A makes sync request 2
let req2 = makeSyncRequest cAstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}
sstore3 `shouldBe` sstore2
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2
lift $ cAstore2 `shouldBe` initialClientStore
-- Client A and Client B now have the same store
lift $ cAstore2 `shouldBe` cBstore2
it "does not run into a conflict if two clients both try to sync a deletion" $
forAllValid $ \items ->
forAllValid $ \time1 ->
evalDM $ do
let cAstore1 =
initialClientStore
{clientStoreDeletedItems = M.map (const time1) (items :: Map (UUID) Int)}
-- Both client a and client b delete their items.
let cBstore1 =
initialClientStore {clientStoreDeletedItems = M.map (const time1) items}
-- The server still has the undeleted items
let sstore1 = ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items}
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
lift $ do
resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})
sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) -- TODO will probably need some sort of tombstoning.
-- Client A merges the response
let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1
lift $ cAstore2 `shouldBe` initialClientStore
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
lift $ do
resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2
lift $ do
cBstore2 `shouldBe` initialClientStore
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
describe "processServerSync with mergeSyncResponseFromServer" $ do
describe "Multiple clients" $ do
describe "Single-item" $ do
it "does not diverge after a conflict occurs" $
forAllValid $ \uuid ->
forAllValid $ \time1 ->
forAllValid $ \i1 ->
forAllValid $ \i2 ->
forAllValid $ \i3 ->
evalDM $ do
let sstore1 =
ServerStore
{ serverStoreItems =
M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)
}
-- The server has an item
-- The first client has synced it, and modified it.
let cAstore1 =
initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}
-- The second client has synced it too, and modified it too.
let cBstore1 =
initialClientStore
{clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}
-- Client A makes sync request 1
let req1 = makeSyncRequest cAstore1
-- The server processes sync request 1
(resp1, sstore2) <- processServerSync genD sstore1 req1
let time2 = incrementServerTime time1
-- The server updates the item accordingly
lift $ do
resp1 `shouldBe`
(emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})
sstore2 `shouldBe`
(ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})
-- Client A merges the response
let cAstore2 = mergeSyncResponseFromServer cAstore1 resp1
lift $
cAstore2 `shouldBe`
(initialClientStore
{clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})
-- Client B makes sync request 2
let req2 = makeSyncRequest cBstore1
-- The server processes sync request 2
(resp2, sstore3) <- processServerSync genD sstore2 req2
-- The server reports a conflict and does not change its store
lift $ do
resp2 `shouldBe`
(emptySyncResponse
{syncResponseConflicts = M.singleton uuid (Timed i2 time2)})
sstore3 `shouldBe` sstore2
-- Client B merges the response
let cBstore2 = mergeSyncResponseFromServer cBstore1 resp2
-- Client does not update, but keeps its conflict
lift $ do
cBstore2 `shouldBe`
(initialClientStore
{clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})
-- Client A and Client B now have the same store
cBstore2 `shouldBe` cAstore2
newtype D m a =
D
{ unD :: StateT StdGen m a
}
deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO)
evalD :: D Identity a -> a
evalD = runIdentity . evalDM
-- runD :: D Identity a -> StdGen -> (a, StdGen)
-- runD = runState . unD
evalDM :: Functor m => D m a -> m a
evalDM d = fst <$> runDM d (mkStdGen 42)
runDM :: D m a -> StdGen -> m (a, StdGen)
runDM = runStateT . unD
genD :: Monad m => D m UUID
genD = do
r <- get
let (u, r') = random r
put r'
pure u