{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
module Data.Mergeful.ItemSpec
( spec,
)
where
import Data.GenValidity.Mergeful.Item ()
import Data.Mergeful.Item
import Data.Mergeful.Timed
import Test.Hspec
import Test.QuickCheck
import Test.Validity
import Test.Validity.Aeson
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
forAllSubsequent :: Testable prop => ((ServerTime, ServerTime) -> prop) -> Property
forAllSubsequent func =
forAllValid $ \st ->
forAllShrink (genValid `suchThat` (> st)) (filter (> st) . shrinkValid) $ \st' -> func (st, st')
spec :: Spec
spec = do
genValidSpec @(ClientItem Int)
jsonSpecOnValid @(ClientItem Int)
genValidSpec @(ServerItem Int)
jsonSpecOnValid @(ServerItem Int)
genValidSpec @(ItemSyncRequest Int)
jsonSpecOnValid @(ItemSyncRequest Int)
genValidSpec @(ItemSyncResponse Int)
jsonSpecOnValid @(ItemSyncResponse Int)
describe "makeItemSyncRequest"
$ it "produces valid requests"
$ producesValidsOnValids (makeItemSyncRequest @Int)
describe "mergeItemSyncResponseRaw"
$ it "produces valid client stores"
$ producesValidsOnValids2 (mergeItemSyncResponseRaw @Int)
describe "mergeItemSyncResponseFromServer"
$ it "produces valid client stores"
$ producesValidsOnValids2 (mergeItemSyncResponseFromServer @Int)
describe "mergeItemSyncResponseFromClient"
$ it "produces valid client stores"
$ producesValidsOnValids2 (mergeItemSyncResponseFromClient @Int)
describe "mergeItemSyncResponseUsingCRDT"
$ it "produces valid client stores"
$ producesValidsOnValids2 (mergeItemSyncResponseUsingCRDT @Int max)
describe "processServerItemSync" $ do
it "produces valid responses and stores" $ producesValidsOnValids2 (processServerItemSync @Int)
it "makes no changes if the sync request reflects the state of the empty server" $ do
let store1 = ServerEmpty
req = ItemSyncRequestPoll
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseInSyncEmpty
it "makes no changes if the sync request reflects the state of the full server"
$ forAllValid
$ \i ->
forAllValid $ \st -> do
let store1 = ServerFull $ Timed i st
req = ItemSyncRequestKnown st
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseInSyncFull
describe "Client changes" $ do
it "adds the item that the client tells the server to add"
$ forAllValid
$ \i -> do
let store1 = ServerEmpty
req = ItemSyncRequestNew i
let (resp, store2) = processServerItemSync @Int store1 req
let time = initialServerTime
store2 `shouldBe` ServerFull (Timed i time)
resp `shouldBe` ItemSyncResponseClientAdded time
it "changes the item that the client tells the server to change"
$ forAllValid
$ \i ->
forAllValid $ \j ->
forAllValid $ \st -> do
let store1 = ServerFull (Timed i st)
req = ItemSyncRequestKnownButChanged (Timed j st)
let (resp, store2) = processServerItemSync @Int store1 req
let time = incrementServerTime st
store2 `shouldBe` ServerFull (Timed j time)
resp `shouldBe` ItemSyncResponseClientChanged time
it "deletes the item that the client tells the server to delete"
$ forAllValid
$ \i ->
forAllValid $ \st -> do
let store1 = ServerFull (Timed i st)
req = ItemSyncRequestDeletedLocally st
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` ServerEmpty
resp `shouldBe` ItemSyncResponseClientDeleted
describe "Server changes" $ do
it "tells the client that there is a new item at the server side"
$ forAllValid
$ \i ->
forAllValid $ \st -> do
let store1 = ServerFull (Timed i st)
req = ItemSyncRequestPoll
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseServerAdded (Timed i st)
it "tells the client that there is a modified item at the server side"
$ forAllValid
$ \i ->
forAllSubsequent $ \(st, st') -> do
let store1 = ServerFull (Timed i st')
req = ItemSyncRequestKnown st
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseServerChanged (Timed i st')
it "tells the client that there is a deleted item at the server side"
$ forAllValid
$ \st -> do
let store1 = ServerEmpty
req = ItemSyncRequestKnown st
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseServerDeleted
describe "Conflicts" $ do
it "notices a conflict if the client and server are trying to sync different items"
$ forAllValid
$ \i ->
forAllValid $ \j ->
forAllSubsequent $ \(st, st') -> do
let store1 = ServerFull (Timed i st')
req = ItemSyncRequestKnownButChanged (Timed j st)
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseConflict (Timed i st')
it
"notices a server-deleted-conflict if the client has a deleted item and server has a modified item"
$ forAllValid
$ \i ->
forAllSubsequent $ \(st, st') -> do
let store1 = ServerFull (Timed i st')
req = ItemSyncRequestDeletedLocally st
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseConflictClientDeleted (Timed i st')
it
"notices a server-deleted-conflict if the client has a modified item and server has no item"
$ forAllValid
$ \i ->
forAllValid $ \st -> do
let store1 = ServerEmpty
req = ItemSyncRequestKnownButChanged (Timed i st)
let (resp, store2) = processServerItemSync @Int store1 req
store2 `shouldBe` store1
resp `shouldBe` ItemSyncResponseConflictServerDeleted
describe "syncing" $ do
describe "fromServer" $ do
syncingSpec @Int mergeFromServer
emptyResponseSpec @Int mergeFromServer
describe "fromClient" $ do
syncingSpec @Int mergeFromClient
xdescribe "does not hold" $ emptyResponseSpec @Int mergeFromClient
describe "gadt" $ do
let merge = mergeUsingCRDT @Int max
syncingSpec merge
emptyResponseSpec merge
syncingSpec ::
forall a.
(Show a, Eq a, GenValid a) =>
(ClientItem a -> ItemMergeResult a -> ClientItem a) ->
Spec
syncingSpec mergeStrategy = do
let mergeSyncResponse ci = mergeStrategy ci . mergeItemSyncResponseRaw ci
it "it always possible to add an item from scratch"
$ forAllValid
$ \i -> do
let cstore1 = ClientAdded i
let sstore1 = ServerEmpty
let req1 = makeItemSyncRequest cstore1
(resp1, sstore2) = processServerItemSync sstore1 req1
cstore2 = mergeSyncResponse cstore1 resp1
let time = initialServerTime
resp1 `shouldBe` ItemSyncResponseClientAdded time
sstore2 `shouldBe` ServerFull (Timed i time)
cstore2 `shouldBe` ClientItemSynced (Timed i time)
it "succesfully syncs an addition across to a second client"
$ forAllValid
$ \i -> do
let cAstore1 = ClientAdded i
-- Client B is empty
let cBstore1 = ClientEmpty
-- The server is empty
let sstore1 = ServerEmpty
-- Client A makes sync request 1
let req1 = makeItemSyncRequest cAstore1
-- The server processes sync request 1
let (resp1, sstore2) = processServerItemSync sstore1 req1
let time = initialServerTime
resp1 `shouldBe` ItemSyncResponseClientAdded time
sstore2 `shouldBe` ServerFull (Timed i time)
-- Client A merges the response
let cAstore2 = mergeSyncResponse cAstore1 resp1
cAstore2 `shouldBe` ClientItemSynced (Timed i time)
-- Client B makes sync request 2
let req2 = makeItemSyncRequest cBstore1
-- The server processes sync request 2
let (resp2, sstore3) = processServerItemSync sstore2 req2
resp2 `shouldBe` ItemSyncResponseServerAdded (Timed i time)
sstore3 `shouldBe` ServerFull (Timed i time)
-- Client B merges the response
let cBstore2 = mergeSyncResponse cBstore1 resp2
cBstore2 `shouldBe` ClientItemSynced (Timed i time)
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
it "succesfully syncs a modification across to a second client"
$ forAllValid
$ \time1 ->
forAllValid $ \i ->
forAllValid $ \j -> do
let cAstore1 = ClientItemSynced (Timed i time1)
-- Client B had synced that same item, but has since modified it
let cBstore1 = ClientItemSyncedButChanged (Timed j time1)
-- The server is has the item that both clients had before
let sstore1 = ServerFull (Timed i time1)
-- Client B makes sync request 1
let req1 = makeItemSyncRequest cBstore1
-- The server processes sync request 1
let (resp1, sstore2) = processServerItemSync sstore1 req1
let time2 = incrementServerTime time1
resp1 `shouldBe` ItemSyncResponseClientChanged time2
sstore2 `shouldBe` ServerFull (Timed j time2)
-- Client B merges the response
let cBstore2 = mergeSyncResponse cBstore1 resp1
cBstore2 `shouldBe` ClientItemSynced (Timed j time2)
-- Client A makes sync request 2
let req2 = makeItemSyncRequest cAstore1
-- The server processes sync request 2
let (resp2, sstore3) = processServerItemSync sstore2 req2
resp2 `shouldBe` ItemSyncResponseServerChanged (Timed j time2)
sstore3 `shouldBe` ServerFull (Timed j time2)
-- Client A merges the response
let cAstore2 = mergeSyncResponse cAstore1 resp2
cAstore2 `shouldBe` ClientItemSynced (Timed j time2)
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
it "succesfully syncs a deletion across to a second client"
$ forAllValid
$ \time1 ->
forAllValid $ \i -> do
let cAstore1 = ClientItemSynced (Timed i time1)
-- Client B had synced that same item, but has since deleted it
let cBstore1 = ClientDeleted time1
-- The server still has the undeleted item
let sstore1 = ServerFull (Timed i time1)
-- Client B makes sync request 1
let req1 = makeItemSyncRequest cBstore1
-- The server processes sync request 1
let (resp1, sstore2) = processServerItemSync sstore1 req1
resp1 `shouldBe` ItemSyncResponseClientDeleted
sstore2 `shouldBe` ServerEmpty
-- Client B merges the response
let cBstore2 = mergeSyncResponse cBstore1 resp1
cBstore2 `shouldBe` ClientEmpty
-- Client A makes sync request 2
let req2 = makeItemSyncRequest cAstore1
-- The server processes sync request 2
let (resp2, sstore3) = processServerItemSync sstore2 req2
resp2 `shouldBe` ItemSyncResponseServerDeleted
sstore3 `shouldBe` ServerEmpty
-- Client A merges the response
let cAstore2 = mergeSyncResponse cAstore1 resp2
cAstore2 `shouldBe` ClientEmpty
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
it "does not run into a conflict if two clients both try to sync a deletion"
$ forAllValid
$ \time1 ->
forAllValid $ \i -> do
let cAstore1 = ClientDeleted time1
-- Both client a and client b delete an item.
let cBstore1 = ClientDeleted time1
-- The server still has the undeleted item
let sstore1 = ServerFull (Timed i time1)
-- Client A makes sync request 1
let req1 = makeItemSyncRequest cAstore1
-- The server processes sync request 1
let (resp1, sstore2) = processServerItemSync sstore1 req1
resp1 `shouldBe` ItemSyncResponseClientDeleted
sstore2 `shouldBe` ServerEmpty
-- Client A merges the response
let cAstore2 = mergeSyncResponse cAstore1 resp1
cAstore2 `shouldBe` ClientEmpty
-- Client B makes sync request 2
let req2 = makeItemSyncRequest cBstore1
-- The server processes sync request 2
let (resp2, sstore3) = processServerItemSync sstore2 req2
resp2 `shouldBe` ItemSyncResponseClientDeleted
sstore3 `shouldBe` ServerEmpty
-- Client B merges the response
let cBstore2 = mergeSyncResponse cBstore1 resp2
cBstore2 `shouldBe` ClientEmpty
-- Client A and Client B now have the same store
cAstore2 `shouldBe` cBstore2
it "is idempotent with one client"
$ forAllValid
$ \cstore1 ->
forAllValid $ \sstore1 -> do
let req1 = makeItemSyncRequest cstore1
(resp1, sstore2) = processServerItemSync sstore1 req1
cstore2 = mergeSyncResponse cstore1 resp1
req2 = makeItemSyncRequest cstore2
(resp2, sstore3) = processServerItemSync sstore2 req2
cstore3 = mergeSyncResponse cstore2 resp2
cstore3 `shouldBe` cstore2
sstore3 `shouldBe` sstore2
emptyResponseSpec ::
forall a.
(Show a, Eq a, GenValid a) =>
(ClientItem a -> ItemMergeResult a -> ClientItem a) ->
Spec
emptyResponseSpec mergeStrategy = do
let mergeSyncResponse ci = mergeStrategy ci . mergeItemSyncResponseRaw ci
it "is returns an empty response on the second sync with no modifications"
$ forAllValid
$ \cstore1 ->
forAllValid $ \sstore1 -> do
let req1 = makeItemSyncRequest cstore1
(resp1, sstore2) = processServerItemSync sstore1 req1
cstore2 = mergeSyncResponse cstore1 resp1
req2 = makeItemSyncRequest cstore2
(resp2, _) = processServerItemSync sstore2 req2
case resp2 of
ItemSyncResponseInSyncEmpty -> pure ()
ItemSyncResponseInSyncFull -> pure ()
_ -> expectationFailure $ "Sync response was not empty: " <> show resp2