{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.MergelessSpec
( spec
) where
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Time
import qualified Data.UUID.Typed as Typed
import GHC.Generics (Generic)
import System.Random
import Control.Monad.State
import Test.Hspec
import Test.QuickCheck
import Test.Validity
import Test.Validity.Aeson
import Data.GenValidity.Mergeless ()
import Data.GenValidity.UUID.Typed ()
import Data.Mergeless
import Data.UUID.Typed
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
spec :: Spec
spec = do
eqSpecOnValid @(Store Double Double)
ordSpecOnValid @(Store Double Double)
genValiditySpec @(Store Double Double)
jsonSpecOnValid @(Store Double Double)
eqSpecOnValid @(StoreItem Double Double)
ordSpecOnValid @(StoreItem Double Double)
genValiditySpec @(StoreItem Double Double)
jsonSpecOnValid @(StoreItem Double Double)
eqSpecOnValid @(Added Double)
ordSpecOnValid @(Added Double)
genValiditySpec @(Added Double)
jsonSpecOnValid @(Added Double)
eqSpecOnValid @(Synced Double Double)
ordSpecOnValid @(Synced Double Double)
genValiditySpec @(Synced Double Double)
jsonSpecOnValid @(Synced Double Double)
eqSpecOnValid @(SyncRequest Double Double)
ordSpecOnValid @(SyncRequest Double Double)
genValiditySpec @(SyncRequest Double Double)
jsonSpecOnValid @(SyncRequest Double Double)
eqSpecOnValid @(SyncResponse Double Double)
ordSpecOnValid @(SyncResponse Double Double)
genValiditySpec @(SyncResponse Double Double)
jsonSpecOnValid @(SyncResponse Double Double)
eqSpecOnValid @(CentralItem Double)
ordSpecOnValid @(CentralItem Double)
genValiditySpec @(CentralItem Double)
jsonSpecOnValid @(CentralItem Double)
eqSpecOnValid @(CentralStore Double Double)
ordSpecOnValid @(CentralStore Double Double)
genValiditySpec @(CentralStore Double Double)
jsonSpecOnValid @(CentralStore Double Double)
describe "makeSyncRequest" $
it "produces valid sync requests" $
producesValidsOnValids (makeSyncRequest @Double @Double)
describe "mergeSyncResponse" $
it "produces valid sync stores" $
producesValidsOnValids2 (mergeSyncResponse @Double @Double)
describe "processSyncWith" $ do
it
"makes no change if the sync request reflects the same local state with an empty sync response" $
forAllValid $ \synct ->
forAllValid $ \sis -> do
let cs = CentralStore sis
let (sr, cs') =
evalD $
processSyncWith @(UUID Double) @Double genD synct cs $
SyncRequest S.empty (M.keysSet sis) S.empty
cs' `shouldBe` cs
sr `shouldBe` SyncResponse S.empty S.empty S.empty
it "deletes the deleted items" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sreq -> do
let (_, cs') =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
sreq
syncRequestUndeletedItems sreq `shouldSatisfy`
(not .
any
(`S.member` (M.keysSet $ centralStoreItems cs')))
it "returns the items that were added in the sync response" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sreq -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
sreq
S.map syncedValue (syncResponseAddedItems sresp) `shouldBe`
S.map addedValue (syncRequestAddedItems sreq)
it "returns the single added item" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \ai -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
SyncRequest
{ syncRequestAddedItems = S.singleton ai
, syncRequestSyncedItems = S.empty
, syncRequestUndeletedItems = S.empty
}
S.map syncedValue (syncResponseAddedItems sresp) `shouldBe`
S.singleton (addedValue ai)
it "adds the items that were added" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sreq -> do
let (_, cs') =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
sreq
S.map addedValue (syncRequestAddedItems sreq) `shouldSatisfy`
all
(`elem` (M.elems $
M.map centralValue $
centralStoreItems cs'))
it
"returns the single remotely added item if the sync request is empty and the central store has one item" $
forAllValid $ \synct ->
forAllValid $ \(uuid, ci) -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
(CentralStore $ M.singleton uuid ci)
SyncRequest
{ syncRequestAddedItems = S.empty
, syncRequestSyncedItems = S.empty
, syncRequestUndeletedItems = S.empty
}
S.map syncedValue (syncResponseNewRemoteItems sresp) `shouldBe`
S.singleton (centralValue ci)
it
"returns all remotely added items when no items are locally added or deleted" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sis -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
SyncRequest
{ syncRequestAddedItems = S.empty
, syncRequestSyncedItems = sis
, syncRequestUndeletedItems = S.empty
}
S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe`
S.difference (M.keysSet $ centralStoreItems cs) sis
it "returns all remotely added items when no items are locally deleted " $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sis ->
forAllValid $ \ais -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
SyncRequest
{ syncRequestAddedItems = ais
, syncRequestSyncedItems = sis
, syncRequestUndeletedItems = S.empty
}
S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe`
S.difference
(M.keysSet $ centralStoreItems cs)
sis
it
"returns all remotely added items that weren't deleted when no items are locally added " $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sis ->
forAllValid $ \dis -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
SyncRequest
{ syncRequestAddedItems = S.empty
, syncRequestSyncedItems = sis
, syncRequestUndeletedItems = dis
}
S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe`
S.difference
(S.difference
(M.keysSet $ centralStoreItems cs)
dis)
sis
it "returns all remotely added items that weren't deleted" $
forAllValid $ \synct ->
forAllValid $ \cs ->
forAllValid $ \sreq -> do
let (sresp, _) =
evalD $
processSyncWith
@(UUID Double)
@Double
genD
synct
cs
sreq
S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe`
S.difference
(S.difference
(M.keysSet $ centralStoreItems cs)
(syncRequestUndeletedItems sreq))
(syncRequestSyncedItems sreq)
it
"successfully syncs two clients using a central store when using incrementing words" $
forAllValid $ \store1 ->
forAllValid $ \(synct1, synct2, synct3) -> do
let (s1, s2) =
evalI $ do
let central = CentralStore M.empty
let store2 = Store S.empty
let sreq1 = makeSyncRequest @Word @Double store1
(sresp1, central') <-
processSyncWith genI synct1 central sreq1
let store1' = mergeSyncResponse store1 sresp1
let sreq2 = makeSyncRequest store2
(sresp2, central'') <-
processSyncWith genI synct2 central' sreq2
let store2' = mergeSyncResponse store2 sresp2
let sreq3 = makeSyncRequest store1'
(sresp3, _) <-
processSyncWith genI synct3 central'' sreq3
let store1'' = mergeSyncResponse store1' sresp3
pure (store1'', store2')
s1 `shouldBe` s2
it
"successfully syncs two clients using a central store when using deterministic UUIDs" $
forAllValid $ \store1 ->
forAllValid $ \(synct1, synct2, synct3) -> do
let (s1, s2) =
evalD $ do
let central = CentralStore M.empty
let store2 = Store S.empty
let sreq1 =
makeSyncRequest
@(UUID Double)
@Double
store1
(sresp1, central') <-
processSyncWith genD synct1 central sreq1
let store1' = mergeSyncResponse store1 sresp1
let sreq2 = makeSyncRequest store2
(sresp2, central'') <-
processSyncWith genD synct2 central' sreq2
let store2' = mergeSyncResponse store2 sresp2
let sreq3 = makeSyncRequest store1'
(sresp3, _) <-
processSyncWith genD synct3 central'' sreq3
let store1'' = mergeSyncResponse store1' sresp3
pure (store1'', store2')
s1 `shouldBe` s2
it
"produces valid results when building up a central store from nothing using incrementing words" $
forAllValid $ \tups ->
shouldBeValid $
evalI $ do
let initCentralStore = CentralStore M.empty
let go cs (store, synct) = do
let sreq = makeSyncRequest @Word @Double store
(_, central') <- processSyncWith genI synct cs sreq
pure central'
foldM
go
initCentralStore
(tups :: [(Store Word Double, UTCTime)])
it
"produces valid results when building up a central store from nothing using deterministic UUIDs" $
forAllValid $ \tups ->
shouldBeValid $
evalD $ do
let initCentralStore = CentralStore M.empty
let go cs (store, synct) = do
let sreq =
makeSyncRequest @(UUID Double) @Double store
(_, central') <- processSyncWith genD synct cs sreq
pure central'
foldM
go
initCentralStore
(tups :: [(Store (UUID Double) Double, UTCTime)])
-- This property does not hold.
xit "produces valid results when using incrementing words" $
producesValidsOnValids3 $ \synct cs sr ->
evalI $ processSyncWith @Word @Double genI synct cs sr
it "produces valid results when using determinisitic UUIDs" $
producesValidsOnValids3 $ \synct cs sr ->
evalD $ processSyncWith @(UUID Double) @Double genD synct cs sr
it "makes syncing idempotent with incrementing words" $
forAllValid $ \synct1 ->
forAll (genValid `suchThat` (>= synct1)) $ \synct2 ->
forAllValid $ \central1 ->
forAllValid $ \local1 -> do
let d1 = 0
let sreq1 = makeSyncRequest @Word @Double local1
let ((sresp1, central2), d2) =
runI
(processSyncWith
genI
synct1
central1
sreq1)
d1
let local2 = mergeSyncResponse local1 sresp1
let sreq2 = makeSyncRequest local2
let ((sresp2, central3), _) =
runI
(processSyncWith
genI
synct2
central2
sreq2)
d2
let local3 = mergeSyncResponse local2 sresp2
local2 `shouldBe` local3
central2 `shouldBe` central3
it "makes syncing idempotent with deterministic UUIDs" $
forAllValid $ \synct1 ->
forAll (genValid `suchThat` (>= synct1)) $ \synct2 ->
forAllValid $ \central1 ->
forAllValid $ \local1 -> do
let d1 = mkStdGen 42
let sreq1 =
makeSyncRequest
@(UUID Double)
@Double
local1
let ((sresp1, central2), d2) =
runD
(processSyncWith
genD
synct1
central1
sreq1)
d1
let local2 = mergeSyncResponse local1 sresp1
let sreq2 = makeSyncRequest local2
let ((sresp2, central3), _) =
runD
(processSyncWith
genD
synct2
central2
sreq2)
d2
let local3 = mergeSyncResponse local2 sresp2
local2 `shouldBe` local3
central2 `shouldBe` central3
it "makes syncing idempotent with random UUIDs" $
forAllValid $ \synct1 ->
forAll (genValid `suchThat` (>= synct1)) $ \synct2 ->
forAllValid $ \central1 ->
forAllValid $ \local1 -> do
let sreq1 =
makeSyncRequest
@(UUID Double)
@Double
local1
(sresp1, central2) <-
processSyncWith
nextRandomUUID
synct1
central1
sreq1
let local2 = mergeSyncResponse local1 sresp1
let sreq2 = makeSyncRequest local2
(sresp2, central3) <-
processSyncWith
nextRandomUUID
synct2
central2
sreq2
let local3 = mergeSyncResponse local2 sresp2
local2 `shouldBe` local3
central2 `shouldBe` central3
describe "processSync" $
it "makes syncing idempotent when using random UUIDs" $
forAllValid $ \central1 ->
forAllValid $ \local1 -> do
let sreq1 = makeSyncRequest @(UUID Double) @Double local1
(sresp1, central2) <- processSync nextRandomUUID central1 sreq1
let local2 = mergeSyncResponse local1 sresp1
let sreq2 = makeSyncRequest local2
(sresp2, central3) <- processSync nextRandomUUID central2 sreq2
let local3 = mergeSyncResponse local2 sresp2
local2 `shouldBe` local3
central2 `shouldBe` central3
newtype D a = D
{ unD :: State StdGen a
} deriving (Generic, Functor, Applicative, Monad, MonadState StdGen)
evalD :: D a -> a
evalD d = fst $ runD d $ mkStdGen 42
runD :: D a -> StdGen -> (a, StdGen)
runD = runState . unD
genD :: D (Typed.UUID a)
genD = do
r <- get
let (u, r') = random r
put r'
pure u
newtype I a = I
{ unI :: State Word a
} deriving (Generic, Functor, Applicative, Monad, MonadState Word)
evalI :: I a -> a
evalI i = fst $ runI i 0
runI :: I a -> Word -> (a, Word)
runI = runState . unI
genI :: I Word
genI = do
i <- get
modify succ
pure i