genvalidity-mergeless (empty) → 0.0.0.0
raw patch · 7 files changed
+627/−0 lines, 7 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, genvalidity, genvalidity-containers, genvalidity-hspec, genvalidity-hspec-aeson, genvalidity-mergeless, genvalidity-time, genvalidity-typed-uuid, hspec, mergeless, mtl, random, time, typed-uuid, uuid
Files
- ChangeLog.md +3/−0
- README.md +1/−0
- Setup.hs +3/−0
- genvalidity-mergeless.cabal +66/−0
- src/Data/GenValidity/Mergeless.hs +82/−0
- test/Data/MergelessSpec.hs +471/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for mergeless++## Unreleased changes
+ README.md view
@@ -0,0 +1,1 @@+# mergeless
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ genvalidity-mergeless.cabal view
@@ -0,0 +1,66 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6e70257c58f9b084549d6af348ed63f6b22a88fc476bc7ccf0ccc1aa729f5891++name: genvalidity-mergeless+version: 0.0.0.0+description: Please see the README on GitHub at <https://github.com/NorfairKing/mergeless#readme>+homepage: https://github.com/NorfairKing/mergeless#readme+bug-reports: https://github.com/NorfairKing/mergeless/issues+author: Tom Sydney Kerckhove+maintainer: syd.kerckhove@gmail.com+copyright: Copyright: (c) 2018 Tom Sydney Kerckhove+license: MIT+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/mergeless++library+ exposed-modules:+ Data.GenValidity.Mergeless+ other-modules:+ Paths_genvalidity_mergeless+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , genvalidity+ , genvalidity-containers+ , genvalidity-time+ , mergeless+ default-language: Haskell2010++test-suite genvalidity-mergeless-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.MergelessSpec+ Paths_genvalidity_mergeless+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , containers+ , genvalidity-hspec+ , genvalidity-hspec-aeson+ , genvalidity-mergeless+ , genvalidity-typed-uuid+ , hspec+ , mergeless+ , mtl+ , random+ , time+ , typed-uuid+ , uuid+ default-language: Haskell2010
+ src/Data/GenValidity/Mergeless.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeless where++import Test.QuickCheck++import Data.GenValidity+import Data.GenValidity.Containers ()+import Data.GenValidity.Time ()++import Data.Mergeless++instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) =>+ GenUnchecked (Store i a)++instance (GenValid i, GenValid a, Ord i, Ord a) => GenValid (Store i a) where+ genValid = (Store <$> genValid) `suchThat` isValid++instance (GenInvalid i, GenInvalid a, Ord i, Ord a) =>+ GenInvalid (Store i a)++instance (GenUnchecked i, GenUnchecked a) => GenUnchecked (StoreItem i a)++instance (GenValid i, GenValid a) => GenValid (StoreItem i a)++instance (GenInvalid i, GenInvalid a) => GenInvalid (StoreItem i a)++instance GenUnchecked a => GenUnchecked (Added a)++instance GenValid a => GenValid (Added a) where+ genValid = (Added <$> genValid <*> genValid) `suchThat` isValid++instance GenInvalid a => GenInvalid (Added a)++instance (GenUnchecked i, GenUnchecked a) => GenUnchecked (Synced i a)++instance (GenValid i, GenValid a) => GenValid (Synced i a) where+ genValid =+ (Synced <$> genValid <*> genValid <*> genValid <*> genValid) `suchThat`+ isValid++instance (GenInvalid i, GenInvalid a) => GenInvalid (Synced i a)++instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) =>+ GenUnchecked (SyncRequest i a)++instance (GenValid i, GenValid a, Ord i, Ord a) =>+ GenValid (SyncRequest i a) where+ genValid =+ (SyncRequest <$> genValid <*> genValid <*> genValid) `suchThat` isValid++instance (GenInvalid i, GenInvalid a, Ord i, Ord a) =>+ GenInvalid (SyncRequest i a)++instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) =>+ GenUnchecked (SyncResponse i a)++instance (GenValid i, GenValid a, Ord i, Ord a) =>+ GenValid (SyncResponse i a) where+ genValid =+ (SyncResponse <$> genValid <*> genValid <*> genValid) `suchThat` isValid++instance (GenInvalid i, GenInvalid a, Ord i, Ord a) =>+ GenInvalid (SyncResponse i a)++instance GenUnchecked a => GenUnchecked (CentralItem a)++instance GenValid a => GenValid (CentralItem a) where+ genValid =+ (CentralItem <$> genValid <*> genValid <*> genValid) `suchThat` isValid++instance GenInvalid a => GenInvalid (CentralItem a)++instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) =>+ GenUnchecked (CentralStore i a)++instance (GenValid i, GenValid a, Ord i, Ord a) =>+ GenValid (CentralStore i a) where+ genValid = (CentralStore <$> genValid) `suchThat` isValid++instance (GenInvalid i, GenInvalid a, Ord i, Ord a) =>+ GenInvalid (CentralStore i a)
+ test/Data/MergelessSpec.hs view
@@ -0,0 +1,471 @@+{-# 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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}