genvalidity-appendful (empty) → 0.0.0.0
raw patch · 6 files changed
+481/−0 lines, 6 filesdep +QuickCheckdep +appendfuldep +base
Dependencies added: QuickCheck, appendful, base, containers, criterion, genvalidity, genvalidity-appendful, genvalidity-containers, genvalidity-criterion, genvalidity-hspec, genvalidity-hspec-aeson, genvalidity-time, genvalidity-uuid, hspec, mtl, pretty-show, random, time, uuid
Files
- bench/Bench.hs +20/−0
- genvalidity-appendful.cabal +80/−0
- src/Data/GenValidity/Appendful.hs +8/−0
- src/Data/GenValidity/Appendful/Collection.hs +82/−0
- test/Data/Appendful/CollectionSpec.hs +290/−0
- test/Spec.hs +1/−0
+ bench/Bench.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Criterion.Main as Criterion+import Data.Appendful.Collection+import Data.GenValidity.Appendful ()+import Data.GenValidity.Criterion++main :: IO ()+main =+ Criterion.defaultMain+ [ genValidBench @ClientId,+ genValidBench @(ClientStore ClientId Int Bool),+ genValidBench @(SyncRequest ClientId Int Bool),+ genValidBench @(SyncResponse ClientId Int Bool),+ genValidBench @(ServerStore Int Bool)+ ]
+ genvalidity-appendful.cabal view
@@ -0,0 +1,80 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name: genvalidity-appendful+version: 0.0.0.0+description: Generators for ppend-only cooperative agreement+homepage: https://github.com/NorfairKing/appendful#readme+bug-reports: https://github.com/NorfairKing/appendful/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright: (c) 2020-2022 Tom Sydney Kerckhove+license: MIT+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/appendful++library+ exposed-modules:+ Data.GenValidity.Appendful+ Data.GenValidity.Appendful.Collection+ other-modules:+ Paths_genvalidity_appendful+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , appendful+ , base >=4.7 && <5+ , containers+ , genvalidity+ , genvalidity-containers+ , genvalidity-time+ default-language: Haskell2010++test-suite appendful-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Appendful.CollectionSpec+ Paths_genvalidity_appendful+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , appendful+ , base >=4.7 && <5+ , containers+ , genvalidity-appendful+ , genvalidity-hspec+ , genvalidity-hspec-aeson+ , genvalidity-uuid+ , hspec+ , mtl+ , pretty-show+ , random+ , time+ , uuid+ default-language: Haskell2010++benchmark genvalidity-appendful-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ other-modules:+ Paths_genvalidity_appendful+ hs-source-dirs:+ bench+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ appendful+ , base >=4.7 && <5+ , criterion+ , genvalidity-appendful+ , genvalidity-criterion+ default-language: Haskell2010
+ src/Data/GenValidity/Appendful.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Appendful+ ( module Data.GenValidity.Appendful.Collection,+ )+where++import Data.GenValidity.Appendful.Collection
+ src/Data/GenValidity/Appendful/Collection.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Appendful.Collection where++import Control.Monad+import Data.Appendful+import Data.GenValidity+import Data.GenValidity.Containers ()+import Data.GenValidity.Time ()+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Test.QuickCheck++instance GenValid ClientId where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (ClientStore ci si a) where+ genValid =+ sized $ \n -> do+ (a, b) <- genSplit n+ s <- resize a genValid+ clientStoreAdded <- resize b genValid+ clientStoreSynced <- mapWithIds s+ pure ClientStore {..}+ shrinkValid = shrinkValidStructurally++instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (SyncRequest ci si a) where+ genValid = do+ syncRequestAdded <- genValid+ syncRequestMaximumSynced <- genValid+ pure SyncRequest {..}+ shrinkValid = shrinkValidStructurally++instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (SyncResponse ci si a) where+ genValid = do+ (s1, s2) <- genValid >>= splitSet+ syncResponseClientAdded <-+ fmap M.fromList $+ forM (S.toList s1) $+ \i -> do+ cid <- genValid -- TODO maybe we can find a way to not generate duplicate client ids and speed up this generator, but it's fine for now.+ pure (cid, i)+ syncResponseServerAdded <- mapWithIds s2+ pure SyncResponse {..}+ shrinkValid = shrinkValidStructurally++splitSet :: Ord i => Set i -> Gen (Set i, Set i)+splitSet s =+ if S.null s+ then pure (S.empty, S.empty)+ else do+ a <- elements $ S.toList s+ pure $ S.split a s++mapWithIds :: (Ord i, GenValid a) => Set i -> Gen (Map i a)+mapWithIds = sequenceA . M.fromSet (const genValid)++instance (GenValid si, GenValid a, Show si, Show a, Ord si, Ord a) => GenValid (ServerStore si a) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++genServerStoreFromSet :: (Ord si, GenValid v) => Set si -> Gen (ServerStore si v)+genServerStoreFromSet s = ServerStore <$> mapWithIds s++genUnsyncedStore ::+ forall ci si a.+ (Show ci, Ord ci, Ord si, Ord a, GenValid ci, GenValid si, GenValid a) =>+ Gen (ClientStore ci si a)+genUnsyncedStore = do+ as <- genValid+ pure $ emptyClientStore {clientStoreAdded = as}++genClientStoreFromSet :: (Show ci, Ord ci, Ord si, GenValid ci, GenValid v) => Set si -> Gen (ClientStore ci si v)+genClientStoreFromSet s = do+ clientStoreAdded <- genValid+ clientStoreSynced <- mapWithIds s+ pure ClientStore {..}
+ test/Data/Appendful/CollectionSpec.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Appendful.CollectionSpec+ ( spec,+ )+where++import Control.Monad.State+import Data.Appendful.Collection+import Data.GenValidity.Appendful.Collection ()+import Data.GenValidity.UUID ()+import Data.List+import qualified Data.Map.Strict as M+import Data.UUID+import GHC.Generics (Generic)+import System.Random+import Test.Hspec+import Test.Validity+import Test.Validity.Aeson++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++spec :: Spec+spec = do+ genValidSpec @(ClientStore ClientId Int Int)+ jsonSpec @(ClientStore ClientId Int Int)+ genValidSpec @(SyncRequest ClientId Int Int)+ jsonSpec @(SyncRequest ClientId Int Int)+ genValidSpec @(SyncResponse ClientId Int Int)+ jsonSpec @(SyncResponse ClientId Int Int)+ genValidSpec @(ServerStore Int Int)+ jsonSpec @(ServerStore Int Int)+ describe "emptyStore" $ it "is valid" $ shouldBeValid (emptyClientStore @Int @Int @Int)+ describe "storeSize" $ do+ it "does not crash" $ producesValid (storeSize @Int @Int @Int)+ specify "adding an item makes the store bigger" $+ forAllValid $+ \store ->+ forAllValid $ \added -> do+ let size1 = storeSize (store :: ClientStore Int Int Int)+ let store' = addItemToClientStore added store+ let size2 = storeSize store'+ size2 `shouldBe` (size1 + 1)+ describe "addItemToClientStore" $+ it "produces valid stores" $+ producesValid2 (addItemToClientStore @Int @Int @Int)+ describe "emptySyncRequest" $+ it "is valid" $+ shouldBeValid (emptySyncRequest @Int @Int @Int)+ describe "makeSyncRequest" $+ it "produces valid sync requests" $+ producesValid (makeSyncRequest @Int @Int @Int)+ describe "mergeSyncResponse" $ do+ it "produces valid sync stores" $ producesValid2 (mergeSyncResponse @Int @Int @Int)+ it "adds the single item that the server tells it to add to an empty client store" $+ forAllValid $+ \cid ->+ forAllValid $ \a ->+ forAllValid $ \u -> do+ let cstore1 = emptyClientStore {clientStoreAdded = M.singleton (cid :: ClientId) (a :: Int)}+ resp = emptySyncResponse {syncResponseClientAdded = M.singleton cid (u :: Int)}+ cstore2 = mergeSyncResponse cstore1 resp+ clientStoreSynced cstore2 `shouldBe` M.singleton u a+ describe "processServerSync" $+ describe "deterministic UUIDs" $+ serverSyncSpec @Int evalDM $+ processServerSync genD++serverSyncSpec ::+ forall a si m.+ (Show si, Ord si, GenValid si, Show a, Ord a, GenValid a, MonadIO m) =>+ (forall r. m r -> IO r) ->+ (ServerStore si a -> SyncRequest ClientId si a -> m (SyncResponse ClientId si a, ServerStore si a)) ->+ Spec+serverSyncSpec eval func = do+ describe "Single client" $ do+ describe "Single-item" $ do+ it "succesfully downloads a single item from the server for an empty client" $+ forAllValid $+ \u ->+ forAllValid $ \i ->+ eval $ do+ let sstore1 = emptyServerStore {serverStoreItems = M.singleton u i}+ let cstore1 = emptyClientStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ sstore2 `shouldBe` sstore1+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads a single item to the server for an empty server" $+ forAllValid $+ \c ->+ forAllValid $ \i ->+ eval $ do+ let cstore1 = emptyClientStore {clientStoreAdded = M.singleton c i}+ let sstore1 = emptyServerStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ sort (M.elems (clientStoreSynced cstore2))+ `shouldBe` sort (M.elems $ M.singleton c i)+ describe "Multi-item" $ do+ it "succesfully downloads everything from the server for an empty client" $+ forAllValid $+ \sstore1 ->+ eval $ do+ let cstore1 = emptyClientStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ sstore2 `shouldBe` sstore1+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads everything to the server for an empty server" $+ forAllValid $+ \items ->+ eval $ do+ let cstore1 = emptyClientStore {clientStoreAdded = items}+ let sstore1 = emptyServerStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ sort (M.elems (clientStoreSynced cstore2)) `shouldBe` sort (M.elems items)+ it "is idempotent with one client" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 ->+ eval $ do+ let req1 = makeSyncRequest cstore1+ (resp1, sstore2) <- func sstore1 req1+ let cstore2 = mergeSyncResponse cstore1 resp1+ req2 = makeSyncRequest cstore2+ (resp2, sstore3) <- func sstore2 req2+ let cstore3 = mergeSyncResponse cstore2 resp2+ liftIO $ 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 ->+ eval $ do+ let cAstore1 = emptyClientStore {clientStoreAdded = M.singleton (ClientId 0) i}+ -- Client B is empty+ let cBstore1 = emptyClientStore+ -- The server is empty+ let sstore1 = emptyServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ let addedItems = syncResponseClientAdded resp1+ case M.toList addedItems of+ [(ClientId 0, clientAdditionId)] -> do+ let items = M.singleton clientAdditionId i+ liftIO $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- func sstore2 req2+ liftIO $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- pPrint cBstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client A and Client B now have the same store+ liftIO $ cAstore2 `shouldBe` cBstore2+ _ -> liftIO $ expectationFailure "Should have found exactly one added item."+ describe "Multiple items" $ do+ it+ "makes no change if the sync request reflects the same local state with an empty sync response"+ $ forAllValid $+ \sis -> do+ let cs = ServerStore sis+ (sr, cs') <-+ eval $+ func cs $+ SyncRequest+ { syncRequestAdded = M.empty,+ syncRequestMaximumSynced = fst <$> M.lookupMax sis+ }+ cs' `shouldBe` cs+ sr+ `shouldBe` SyncResponse+ { syncResponseClientAdded = M.empty,+ syncResponseServerAdded = M.empty+ }+ it "successfully syncs additions accross to a second client" $+ forAllValid $+ \is ->+ eval $ do+ let cAstore1 = emptyClientStore {clientStoreAdded = is}+ -- Client B is empty+ let cBstore1 = emptyClientStore+ -- The server is empty+ let sstore1 = emptyServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ let items = clientStoreSynced cAstore2+ liftIO $ do+ clientStoreAdded cAstore2 `shouldBe` M.empty+ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- func sstore2 req2+ liftIO $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client A and Client B now have the same store+ liftIO $ cAstore2 `shouldBe` cBstore2+ describe "General properties" $ do+ it "produces valid results" $+ forAllValid $+ \cs ->+ forAllValid $ \sr -> do+ res <- eval $ func cs sr+ shouldBeValid res+ it "successfully syncs two clients using a central store" $+ forAllValid $+ \addedItems ->+ eval $ do+ let central = ServerStore M.empty+ let store1 = emptyClientStore {clientStoreAdded = addedItems}+ let store2 = emptyClientStore+ let sreq1 = makeSyncRequest store1+ (sresp1, central') <- func central sreq1+ let store1' = mergeSyncResponse store1 sresp1+ let sreq2 = makeSyncRequest store2+ (sresp2, central'') <- func central' sreq2+ let store2' = mergeSyncResponse store2 sresp2+ let sreq3 = makeSyncRequest store1'+ (sresp3, _) <- func central'' sreq3+ let store1'' = mergeSyncResponse store1' sresp3+ liftIO $ store1'' `shouldBe` store2'+ it "ensures that syncing is idempotent" $+ forAllValid $+ \central1 ->+ forAllValid $ \local1 ->+ eval $ do+ let sreq1 = makeSyncRequest local1+ (sresp1, central2) <- func central1 sreq1+ let local2 = mergeSyncResponse local1 sresp1+ let sreq2 = makeSyncRequest local2+ (sresp2, central3) <- func central2 sreq2+ let local3 = mergeSyncResponse local2 sresp2+ liftIO $ do+ local2 `shouldBe` local3+ central2 `shouldBe` central3++newtype D m a = D+ { unD :: StateT StdGen m a+ }+ deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO)++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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}