-
Notifications
You must be signed in to change notification settings - Fork 217
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
[3] Adding ticking function test and downloading block logic [3] Block syncer working ok plus additional tests [3] Cleaning the code [3] cabal fix [3] Complete refactoring to the review [3] Final refactoring [3] cabal fix [3] hlint and weeding [3] add killing thread at the end of test [3] Replace IORef with MVar refactoring #1 | inline intermediate functions to see more clearly + remove debug console prints refactoring #2 | review indentation of 'where' clause refactoring #3 | inline loop and remove test intrumentation from test logic refactoring #4 | define generator for ticking args in a declarative manner refactoring #5 | purify tickingFunctionTest and make it a monadic property refactoring #6 | review naming in Arbitrary TickingArgs refactoring #7 | use guards in mkConsecutiveTestBlocks refactoring #8 | define single block generator from previous block refactoring #9 | use 'fromPreviousBlock' and start loop with an already initialize list refactoring #10 | purify mkConsecutiveTestBlocks by defining a test hash function refactoring #11 | switch argument positions in mkConsecutiveTestBlocks refactoring #12 | replace loop with built-in list 'iterate' refactoring #13 | define Arbitrary instance for creating consecutive blocks refactoring #14 | replace mkConsecutiveBlocks with a property parameter refactoring #15 | use 'newMVar' instead or 'newEmptyMVar' + 'putMVar' refactoring #16 | remove unecessary IO in 'writeToIORefAction' refactoring #17 | replace takeMVar + putMVar with modifyMVar refactoring #18 | review naming for 'writeToIORefAction' --> 'reader' refactoring #19 | use a 'Map.lookup' instead of 'List.filter' + pattern-match refactoring #20 | remove 'BlocksConsumed' wrapper refactoring #21 | generalize reader with polymorphic parametrism refactoring #22 | review pushNextBlocks indentation refactoring #23 | group case pattern matches using tuple refactoring #24 | remove 'Hash BlockHeader' from the block to inject refactoring #25 | use synchronization lock instead of computed times refactoring #26 | Move generation of duplicated blocks onto 'Arbitrary Blocks' refactoring #27 | remove 'chunkSizes' in a favor of inline random selection refactoring #28 | remove 'DeliveryMode' in favor of the most general case refactoring #29 | cleanup wrapper types refactoring #30 | generalize pushNextBlocks with parametric polymorphism refactoring #31 | rename pushNextBlocks to 'writer' refactoring #32 | define reader on Block instead of BlockHeaderHash refactoring #33 | replace old reader with reader' refactoring #34 | move creation of writer MVar inside writer action refactoring #35 | remove header hash from 'Blocks' refactoring #36 | rename 'consecutiveBlocks' into 'blocks' refactoring #37 | re-organize module to separate effectful logic from declarations refactoring #38 | move waiting logic into dedicated function refactoring #39 | move 'done' and 'readerChan' initialization into reader and writer refactoring #40 | use Millisecond instead of Second for shorter tests refactoring #41 | Move creation of blocks from writer to 'Arbitrary Blocks' [3] fix line width [3] aligning the code with other code changes [3] hlint suggestion
- Loading branch information
1 parent
1fc6bd6
commit a423b02
Showing
5 changed files
with
272 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,69 @@ | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
|
|
||
| -- | | ||
| -- Copyright: © 2018-2019 IOHK | ||
| -- License: MIT | ||
| -- | ||
| -- This module contains the ticking function that is responsible for invoking | ||
| -- block acquisition functionality and executing it in periodic fashion. | ||
| -- | ||
| -- Known limitations: the ticking function makes sure action is not executed on | ||
| -- already consumed block, but does not check and handle block gaps (aka | ||
| -- catching up). | ||
|
|
||
| module Cardano.Wallet.BlockSyncer | ||
| ( | ||
| BlockHeadersConsumed(..) | ||
| , tickingFunction | ||
| ) where | ||
|
|
||
|
|
||
| import Prelude | ||
|
|
||
| import Cardano.Wallet.Primitive | ||
| ( Block (..), BlockHeader ) | ||
| import Control.Concurrent | ||
| ( threadDelay ) | ||
| import Data.Time.Units | ||
| ( Millisecond, toMicroseconds ) | ||
|
|
||
| import qualified Data.List as L | ||
|
|
||
|
|
||
| newtype BlockHeadersConsumed = | ||
| BlockHeadersConsumed [BlockHeader] | ||
| deriving (Show, Eq) | ||
|
|
||
| storingLimit :: Int | ||
| storingLimit = 2160 | ||
|
|
||
| tickingFunction | ||
| :: IO [Block] | ||
| -- ^ a way to get a new block | ||
| -> (Block -> IO ()) | ||
| -- ^ action taken on a new block | ||
| -> Millisecond | ||
| -- ^ tick time | ||
| -> BlockHeadersConsumed | ||
| -> IO () | ||
| tickingFunction getNextBlocks action tickTime = go | ||
| where | ||
| go | ||
| :: BlockHeadersConsumed | ||
| -> IO () | ||
| go (BlockHeadersConsumed headersConsumed) = do | ||
| blocksDownloaded <- getNextBlocks | ||
| let blocksToProcess = | ||
| filter (checkIfAlreadyConsumed headersConsumed) (L.nub blocksDownloaded) | ||
| mapM_ action blocksToProcess | ||
| threadDelay $ (fromIntegral . toMicroseconds) tickTime | ||
| go $ BlockHeadersConsumed | ||
| $ take storingLimit | ||
| $ map header blocksToProcess ++ headersConsumed | ||
|
|
||
| checkIfAlreadyConsumed | ||
| :: [BlockHeader] | ||
| -> Block | ||
| -> Bool | ||
| checkIfAlreadyConsumed consumedHeaders (Block theHeader _) = | ||
| theHeader `L.notElem` consumedHeaders |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,191 @@ | ||
| {-# OPTIONS_GHC -fno-warn-unused-imports #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
|
|
||
| module Cardano.Wallet.BlockSyncerSpec | ||
| ( spec | ||
| , groups | ||
| , duplicateMaybe | ||
| ) where | ||
|
|
||
|
|
||
| import Prelude | ||
|
|
||
| import Cardano.Wallet.BlockSyncer | ||
| ( BlockHeadersConsumed (..), tickingFunction ) | ||
| import Cardano.Wallet.Primitive | ||
| ( Block (..), BlockHeader (..), EpochId (..), Hash (..), SlotId (..) ) | ||
| import Control.Concurrent | ||
| ( ThreadId, forkIO, killThread, threadDelay ) | ||
| import Control.Concurrent.MVar | ||
| ( MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar ) | ||
| import Control.Monad | ||
| ( foldM, forM_, (>=>) ) | ||
| import Control.Monad.IO.Class | ||
| ( liftIO ) | ||
| import Data.ByteString | ||
| ( ByteString, pack ) | ||
| import Data.Functor | ||
| ( ($>) ) | ||
| import Data.Map.Strict | ||
| ( Map ) | ||
| import Data.Time.Units | ||
| ( Millisecond, fromMicroseconds ) | ||
| import Data.Tuple | ||
| ( swap ) | ||
| import Test.Hspec | ||
| ( Arg, Spec, SpecWith, describe, it, shouldReturn ) | ||
| import Test.QuickCheck | ||
| ( Arbitrary (..) | ||
| , Property | ||
| , elements | ||
| , generate | ||
| , property | ||
| , vector | ||
| , withMaxSuccess | ||
| ) | ||
| import Test.QuickCheck.Gen | ||
| ( Gen, choose, vectorOf ) | ||
| import Test.QuickCheck.Monadic | ||
| ( monadicIO ) | ||
|
|
||
| import qualified Codec.CBOR.Encoding as CBOR | ||
| import qualified Codec.CBOR.Write as CBOR | ||
| import qualified Data.List as L | ||
| import qualified Data.Map.Strict as Map | ||
| import qualified Data.Set as Set | ||
|
|
||
|
|
||
| spec :: Spec | ||
| spec = do | ||
| describe "Block syncer downloads blocks properly" $ do | ||
| it "Check ticking function when blocks are sent" | ||
| (withMaxSuccess 10 $ property tickingFunctionTest) | ||
|
|
||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Test Logic | ||
| -------------------------------------------------------------------------------} | ||
|
|
||
| tickingFunctionTest | ||
| :: (TickingTime, Blocks) | ||
| -> Property | ||
| tickingFunctionTest (TickingTime tickTime, Blocks blocks) = monadicIO $ liftIO $ do | ||
| (readerChan, reader) <- mkReader | ||
| (writerChan, writer) <- mkWriter blocks | ||
| waitFor writerChan $ tickingFunction writer reader tickTime (BlockHeadersConsumed []) | ||
| takeMVar readerChan `shouldReturn` L.nub (reverse $ mconcat blocks) | ||
|
|
||
| waitFor | ||
| :: MVar () | ||
| -> IO () | ||
| -> IO () | ||
| waitFor done action = do | ||
| threadId <- forkIO action | ||
| _ <- takeMVar done | ||
| killThread threadId | ||
|
|
||
| mkWriter | ||
| :: [[a]] | ||
| -> IO (MVar (), IO [a]) | ||
| mkWriter xs0 = do | ||
| ref <- newMVar xs0 | ||
| done <- newEmptyMVar | ||
| return | ||
| ( done | ||
| , takeMVar ref >>= \case | ||
| [] -> putMVar done () $> [] | ||
| h:q -> putMVar ref q $> h | ||
| ) | ||
|
|
||
| mkReader | ||
| :: IO (MVar [a], a -> IO ()) | ||
| mkReader = do | ||
| ref <- newMVar [] | ||
| return | ||
| ( ref | ||
| , \x -> modifyMVar_ ref $ return . (x :) | ||
| ) | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Arbitrary Instances | ||
| -------------------------------------------------------------------------------} | ||
|
|
||
|
|
||
| newtype TickingTime = TickingTime Millisecond | ||
| deriving (Show) | ||
|
|
||
| instance Arbitrary TickingTime where | ||
| -- No shrinking | ||
| arbitrary = do | ||
| tickTime <- fromMicroseconds . (* 1000) <$> choose (50, 100) | ||
| return $ TickingTime tickTime | ||
|
|
||
|
|
||
| newtype Blocks = Blocks [[Block]] | ||
| deriving Show | ||
|
|
||
| instance Arbitrary Blocks where | ||
| -- No Shrinking | ||
| arbitrary = do | ||
| n <- arbitrary | ||
| let h0 = BlockHeader 1 0 (Hash "initial block") | ||
| let blocks = map snd $ take n $ iterate next | ||
| ( blockHeaderHash h0 | ||
| , Block h0 mempty | ||
| ) | ||
| mapM duplicateMaybe blocks >>= fmap Blocks . groups . mconcat | ||
| where | ||
| next :: (Hash "BlockHeader", Block) -> (Hash "BlockHeader", Block) | ||
| next (prev, b) = | ||
| let | ||
| epoch = epochIndex (header b) | ||
| slot = slotNumber (header b) + 1 | ||
| h = BlockHeader epoch slot prev | ||
| in | ||
| (blockHeaderHash h, Block h mempty) | ||
|
|
||
| blockHeaderHash :: BlockHeader -> Hash "BlockHeader" | ||
| blockHeaderHash = | ||
| Hash . CBOR.toStrictByteString . encodeBlockHeader | ||
| where | ||
| encodeBlockHeader (BlockHeader (EpochId epoch) (SlotId slot) prev) = mempty | ||
| <> CBOR.encodeListLen 3 | ||
| <> CBOR.encodeWord64 epoch | ||
| <> CBOR.encodeWord16 slot | ||
| <> CBOR.encodeBytes (getHash prev) | ||
|
|
||
|
|
||
| -- | Construct arbitrary groups of elements from a given list. | ||
| -- | ||
| -- >>> generate $ groups [0,1,2,3,4,5,6,7,8,9] | ||
| -- [[0,1],[2,3],[4,5,6],[7,8,9]] | ||
| -- | ||
| -- | ||
| -- >>> generate $ groups [0,1,2,3,4,5,6,7,8,9] | ||
| -- [[],[0],[1,2,3,4,5,6,7,8],[9]] | ||
| -- | ||
| groups :: [a] -> Gen [[a]] | ||
| groups = fmap reverse . foldM arbitraryGroup [[]] | ||
| where | ||
| arbitraryGroup :: [[a]] -> a -> Gen [[a]] | ||
| arbitraryGroup [] _ = return [] -- Can't happen with the given initial value | ||
| arbitraryGroup (grp:rest) a = do | ||
| choose (1 :: Int, 3) >>= \case | ||
| 1 -> return $ [a]:grp:rest | ||
| _ -> return $ (grp ++ [a]):rest | ||
|
|
||
| -- | Generate a singleton or a pair from a given element. | ||
| -- | ||
| -- >>> generate $ duplicateMaybe 14 | ||
| -- [14] | ||
| -- | ||
| -- >>> generate $ duplicateMaybe 14 | ||
| -- [14, 14] | ||
| -- | ||
| duplicateMaybe :: a -> Gen [a] | ||
| duplicateMaybe a = do | ||
| predicate <- arbitrary | ||
| if predicate then return [a, a] else return [a] |