CollectionSpec.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Mergeful.CollectionSpec
  ( spec,
  )
where

import Control.Monad.State
import Data.Functor.Identity
import Data.GenValidity.Mergeful ()
import Data.GenValidity.Mergeful.Item ()
import Data.GenValidity.UUID ()
import Data.List
import qualified Data.Map as M
import Data.Mergeful
import qualified Data.Set as S
import Data.UUID
import GHC.Generics (Generic)
import System.Random
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Validity
import Test.Validity.Aeson
import Text.Show.Pretty

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

spec :: Spec
spec = modifyMaxShrinks (min 0) $ do
  genValidSpec @ClientId
  jsonSpecOnValid @ClientId
  genValidSpec @(ClientStore ClientId Int Int)
  jsonSpecOnValid @(ClientStore ClientId Int Int)
  genValidSpec @(ServerStore Int Int)
  jsonSpecOnValid @(ServerStore Int Int)
  genValidSpec @(SyncRequest ClientId Int Int)
  jsonSpecOnValid @(SyncRequest ClientId Int Int)
  genValidSpec @(ClientAddition Int)
  jsonSpecOnValid @(ClientAddition Int)
  genValidSpec @(SyncResponse ClientId Int Int)
  jsonSpecOnValid @(SyncResponse ClientId Int Int)
  describe "initialClientStore"
    $ it "is valid"
    $ shouldBeValid
    $ initialClientStore @ClientId @Int @Int
  describe "addItemToClientStore" $ do
    it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @ClientId @Int @Int)
    it "makes the client store one bigger"
      $ forAllValid
      $ \cs ->
        forAllValid $ \a ->
          clientStoreSize @ClientId @Int @Int (addItemToClientStore a cs)
            `shouldBe` (clientStoreSize cs + 1)
    it "ensures that the added item is in fact in the result"
      $ forAllValid
      $ \cs ->
        forAllValid $ \a ->
          let cs' = addItemToClientStore @ClientId @Int @Int a cs
           in a `elem` clientStoreAddedItems cs'
  describe "markItemDeletedInClientStore" $ do
    it "produces valid stores" $
      producesValidsOnValids2 (markItemDeletedInClientStore @ClientId @Int @Int)
    it "makes the client store one smaller" $
      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0
       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->
            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->
              (clientStoreSize @ClientId @Int @Int (markItemDeletedInClientStore i cs) + 1)
                `shouldBe` clientStoreSize cs
    it "ensures that the added item is in fact not in the result" $
      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0
       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->
            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->
              let cs' = markItemDeletedInClientStore @ClientId @Int @Int i cs
               in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Nothing
  describe "changeItemInClientStore" $ do
    it "produces valid stores" $
      producesValidsOnValids3 (changeItemInClientStore @ClientId @Int @Int)
    it "doesn't change the size of the client store" $
      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0
       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->
            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->
              forAllValid $ \a ->
                clientStoreSize @ClientId @Int @Int (changeItemInClientStore i a cs)
                  `shouldBe` clientStoreSize cs
    it "ensures that the changed item is in fact in the result" $
      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0
       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->
            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->
              forAllValid $ \a ->
                let cs' = changeItemInClientStore @ClientId @Int @Int i a cs
                 in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Just a
  describe "deleteItemFromClientStore" $ do
    it "produces valid stores" $
      producesValidsOnValids2 (deleteItemFromClientStore @ClientId @Int @Int)
    it "makes the client store one smaller" $
      let p cs = S.size (clientStoreClientIdSet cs) > 0
       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->
            forAll (elements $ S.toList $ clientStoreClientIdSet cs) $ \cid ->
              (clientStoreSize @ClientId @Int @Int (deleteItemFromClientStore cid cs) + 1)
                `shouldBe` clientStoreSize cs
  describe "initialServerStore" $ it "is valid" $ shouldBeValid $ initialServerStore @Int @Int
  describe "initialSyncRequest"
    $ it "is valid"
    $ shouldBeValid
    $ initialSyncRequest @ClientId @Int @Int
  describe "emptySyncResponse"
    $ it "is valid"
    $ shouldBeValid
    $ emptySyncResponse @ClientId @Int @Int
  describe "makeSyncRequest"
    $ it "produces valid requests"
    $ producesValidsOnValids (makeSyncRequest @ClientId @Int @Int)
  describe "mergeAddedItems"
    $ it "produces valid results"
    $ producesValidsOnValids2 (mergeAddedItems @ClientId @Int @Int)
  describe "mergeSyncedButChangedItems"
    $ it "produces valid results"
    $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)
  describe "mergeDeletedItems"
    $ it "produces valid results"
    $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)
  xdescribe "There must not be id conflicts" $ do
    describe "mergeSyncResponseFromServer"
      $ it "produces valid requests"
      $ forAllValid
      $ \store ->
        forAllValid $ \response ->
          let res = mergeSyncResponseFromServer @ClientId @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 "mergeSyncResponseFromClient"
      $ it "produces valid requests"
      $ forAllValid
      $ \store ->
        forAllValid $ \response ->
          let res = mergeSyncResponseFromClient @ClientId @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 "mergeSyncResponseUsingCRDT"
      $ it "produces valid requests"
      $ forAllValid
      $ \store ->
        forAllValid $ \response ->
          let res = mergeSyncResponseUsingCRDT @ClientId @Int @Int max 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 "processServerSync"
    $ it "produces valid tuples of a response and a store"
    $ producesValidsOnValids2
      ( \store request ->
          evalD $ processServerSync @ClientId @UUID genD (store :: ServerStore UUID Int) request
      )
  describe "Syncing with mergeSyncResponseFromClient" $ do
    let strat = mergeFromClientStrategy
    helperFunctionsSpec strat
    mergeFunctionSpec @Int strat
    noDataLossSpec @Int strat
    xdescribe "does not hold" $ do
      emptyResponseSpec @Int strat
      noDivergenceSpec @Int strat
  describe "Syncing with mergeSyncResponseFromServer" $ do
    let strat = mergeFromServerStrategy
    helperFunctionsSpec strat
    mergeFunctionSpec @Int strat
    noDivergenceSpec @Int strat
    emptyResponseSpec @Int strat
    noDifferentExceptForConflicts @Int strat mergeFromClientStrategy
    xdescribe "does not hold" $ noDataLossSpec @Int strat
  describe "Syncing with mergeSyncResponseUsingStrategy with a GCounter" $ do
    let strat = mergeUsingCRDTStrategy max
    helperFunctionsSpec strat
    mergeFunctionSpec strat
    noDataLossSpec strat
    noDivergenceSpec strat
    emptyResponseSpec strat
    noDifferentExceptForConflicts strat mergeFromClientStrategy
    noDifferentExceptForConflicts strat mergeFromServerStrategy

helperFunctionsSpec :: ItemMergeStrategy Int -> Spec
helperFunctionsSpec ItemMergeStrategy {..} = do
  describe "mergeSyncedButChangedConflicts"
    $ it "produces valid results"
    $ producesValidsOnValids2 (mergeSyncedButChangedConflicts @Int @Int itemMergeStrategyMergeChangeConflict)
  describe "mergeClientDeletedConflicts"
    $ it "produces valid results"
    $ producesValidsOnValids (mergeClientDeletedConflicts @Int @Int itemMergeStrategyMergeClientDeletedConflict)
  describe "mergeServerDeletedConflicts"
    $ it "produces valid results"
    $ producesValidsOnValids (mergeServerDeletedConflicts @Int @Int itemMergeStrategyMergeServerDeletedConflict)

mergeFunctionSpec ::
  forall a.
  (Show a, Ord a, GenValid a) =>
  ItemMergeStrategy a ->
  Spec
mergeFunctionSpec strat = do
  let mergeFunc = mergeSyncResponseUsingStrategy strat
  describe "Single client"
    $ describe "Multi-item"
    $ do
      it "succesfully downloads everything from the server for an empty client"
        $ forAllValid
        $ \sstore1 ->
          evalDM $ do
            let cstore1 = initialClientStore
            let req = makeSyncRequest cstore1
            (resp, sstore2) <- processServerSync genD sstore1 req
            let cstore2 = mergeFunc 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
            let req = makeSyncRequest cstore1
            (resp, sstore2) <- processServerSync genD sstore1 req
            let cstore2 = mergeFunc 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
              (resp1, sstore2) <- processServerSync genD sstore1 req1
              let cstore2 = mergeFunc cstore1 resp1
                  req2 = makeSyncRequest cstore2
              (resp2, sstore3) <- processServerSync genD sstore2 req2
              let cstore3 = mergeFunc 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
            -- 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, ClientAddition 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 = mergeFunc 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 = mergeFunc 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 (Timed i 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 = mergeFunc 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 = mergeFunc 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 (Timed i 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 = mergeFunc 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 = mergeFunc 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 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 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 = mergeFunc 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 = mergeFunc cBstore1 resp2
                lift $ do
                  cBstore2 `shouldBe` initialClientStore
                  -- Client A and Client B now have the same store
                  cAstore2 `shouldBe` cBstore2
    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
            -- 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 = mergeFunc 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 = mergeFunc 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
                  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 = mergeFunc 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 = mergeFunc 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}
              -- 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 = mergeFunc 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 = mergeFunc cBstore1 resp2
              lift $ do
                cBstore2 `shouldBe` initialClientStore
                -- Client A and Client B now have the same store
                cAstore2 `shouldBe` cBstore2

noDataLossSpec ::
  forall a.
  (Show a, Ord a, GenValid a) =>
  ItemMergeStrategy a ->
  Spec
noDataLossSpec strat = do
  let mergeFunc = mergeSyncResponseUsingStrategy strat
  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 (Timed i1 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 @ClientId @UUID 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 = mergeFunc 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 = mergeSyncResponseFromClient @ClientId @UUID cBstore1 resp2
                -- Client does not update, but keeps its conflict
                -- Client A and Client B now *do not* have the same store
                lift $
                  cBstore2
                    `shouldBe` ( initialClientStore
                                   { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)
                                   }
                               )

noDivergenceSpec ::
  forall a.
  (Show a, Ord a, GenValid a) =>
  ItemMergeStrategy a ->
  Spec
noDivergenceSpec strat = do
  let mergeFunc = mergeSyncResponseUsingStrategy strat
  it "does not diverge after a conflict occurs"
    $ forAllValid
    $ \uuid ->
      forAllValid $ \time1 ->
        forAllValid $ \iS ->
          forAllValid $ \iA ->
            forAllValid $ \iB ->
              evalDM $ do
                let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed iS time1)}
                -- The server has an item
                -- The first client has synced it, and modified it.
                let cAstore1 =
                      initialClientStore
                        { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iA time1)
                        }
                -- The second client has synced it too, and modified it too.
                let cBstore1 =
                      initialClientStore
                        { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)
                        }
                -- Client A makes sync request 1
                let req1 = makeSyncRequest @ClientId @UUID 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 iA time2)})
                -- Client A merges the response
                let cAstore2 = mergeFunc cAstore1 resp1
                -- Client A has the item from the server because there was no conflict.
                lift $
                  cAstore2
                    `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA 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 iA time2)})
                  sstore3 `shouldBe` sstore2
                -- Client B merges the response
                let cBstore2 = mergeFunc cBstore1 resp2
                lift $ do
                  let expected = case itemMergeStrategyMergeChangeConflict strat iB iA of
                        KeepLocal -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)}
                        TakeRemote -> initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA time2)}
                        Merged im -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed im time2)}
                  cBstore2
                    `shouldBe` expected
                -- In case of a previous merge, the synced item will still be changed, so we need to sync again with B and then with A
                let req3 = makeSyncRequest cBstore2
                (resp3, sstore4) <- processServerSync genD sstore3 req3
                let cBstore3 = mergeFunc cBstore2 resp3
                let req4 = makeSyncRequest cAstore2
                (resp4, _) <- processServerSync genD sstore4 req4
                let cAstore3 = mergeFunc cAstore2 resp4
                lift $
                  cBstore3 `shouldBe` cAstore3

emptyResponseSpec ::
  forall a.
  (Show a, Eq a, Ord a, GenValid a) =>
  ItemMergeStrategy a ->
  Spec
emptyResponseSpec strat = do
  let mergeFunc = mergeSyncResponseUsingStrategy strat
  it "is returns an empty response on the second sync with no modifications"
    $ forAllValid
    $ \cstore1 ->
      forAllValid $ \sstore1 ->
        evalDM $ do
          let req1 = makeSyncRequest @ClientId @UUID cstore1
          (resp1, sstore2) <- processServerSync genD sstore1 req1
          let cstore2 = mergeFunc cstore1 resp1
              req2 = makeSyncRequest cstore2
          (resp2, _) <- processServerSync genD sstore2 req2
          lift $ resp2 `shouldBe` emptySyncResponse

noDifferentExceptForConflicts ::
  forall a.
  (Show a, Eq a, Ord a, GenValid a) =>
  ItemMergeStrategy a ->
  ItemMergeStrategy a ->
  Spec
noDifferentExceptForConflicts strat1 strat2 = do
  let mergeFunc1 = mergeSyncResponseUsingStrategy strat1
      mergeFunc2 = mergeSyncResponseUsingStrategy strat2
  describe "mergeSyncResponseFromServer"
    $ it "only differs from mergeSyncResponseFromClient on conflicts"
    $ forAllValid
    $ \cstore ->
      forAllValid $ \sresp@SyncResponse {..} -> do
        let cstoreA = mergeFunc1 (cstore :: ClientStore ClientId UUID a) sresp
            cstoreB = mergeFunc2 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 mergeFunc1 and mergeFunc2 that was somehow unrelated to the conflicts:",
                  "syncResponseConflicts:",
                  ppShow syncResponseConflicts,
                  "syncResponseConflictsClientDeleted:",
                  ppShow syncResponseConflictsClientDeleted,
                  "syncResponseConflictsServerDeleted:",
                  ppShow syncResponseConflictsServerDeleted,
                  "client store after mergeFunc1:",
                  ppShow cstoreA,
                  "client store after mergeFunc2:",
                  ppShow cstoreB
                ]

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