{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Data.Mergeful.ItemSpec
( spec,
)
where
import Autodocodec
import Autodocodec.Yaml
import Data.Data
import Data.GenValidity.Mergeful.Item ()
import Data.Mergeful.Item
import Data.Mergeful.Timed
import Data.Word
import Test.QuickCheck
import Test.Syd hiding (Timed (..))
import Test.Syd.Validity
import Test.Syd.Validity.Aeson
import Test.Syd.Validity.Utils
import Text.Colour
{-# 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
let yamlSchemaSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
yamlSchemaSpec filePath = do
it ("outputs the same schema as before for " <> nameOf @a) $
pureGoldenTextFile
("test_resources/item/" <> filePath <> ".txt")
(renderChunksText With24BitColours $ schemaChunksViaCodec @a)
describe "ClientItem" $ do
genValidSpec @(ClientItem Word8)
jsonSpec @(ClientItem Word8)
yamlSchemaSpec @(ClientItem Word8) "client"
describe "ServerItem" $ do
genValidSpec @(ServerItem Word8)
jsonSpec @(ServerItem Word8)
yamlSchemaSpec @(ServerItem Word8) "server"
describe "ItemSyncRequest" $ do
genValidSpec @(ItemSyncRequest Word8)
jsonSpec @(ItemSyncRequest Word8)
yamlSchemaSpec @(ItemSyncRequest Word8) "request"
describe "ItemSyncResponse" $ do
genValidSpec @(ItemSyncResponse Word8)
jsonSpec @(ItemSyncResponse Word8)
yamlSchemaSpec @(ItemSyncResponse Word8) "response"
describe "makeItemSyncRequest" $
it "produces valid requests" $
producesValid (makeItemSyncRequest @Int)
describe "mergeItemSyncResponseRaw" $
it "produces valid client stores" $
producesValid2 (mergeItemSyncResponseRaw @Int)
describe "mergeItemSyncResponseFromServer" $
it "produces valid client stores" $
producesValid2 (mergeItemSyncResponseFromServer @Int)
describe "mergeItemSyncResponseFromClient" $
it "produces valid client stores" $
producesValid2 (mergeItemSyncResponseFromClient @Int)
describe "mergeItemSyncResponseUsingCRDT" $
it "produces valid client stores" $
producesValid2 (mergeItemSyncResponseUsingCRDT @Int max)
describe "processServerItemSync" $ do
it "produces valid responses and stores" $ producesValid2 (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