voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

TestWalkMerkleConditional

This commit is contained in:
Snail 2024-11-23 20:17:18 +04:00 committed by voidlizard
parent d88ca1a449
commit 016bf48b24
9 changed files with 234 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-core/hbs2-core.cabal
View File

@ -41,8 +41,10 @@ common shared-properties
, ConstraintKinds
, DataKinds
, DeriveDataTypeable
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, DerivingVia
, ExtendedDefaultRules

3
hbs2-core/lib/HBS2/Base58.hs
View File

@ -39,6 +39,9 @@ instance Pretty (AsBase58 LBS.ByteString) where
instance Show (AsBase58 ByteString) where
show (AsBase58 bs) = BS8.unpack $ toBase58 bs
instance Show (AsBase58 LBS.ByteString) where
show (AsBase58 bs) = BS8.unpack . toBase58 . LBS.toStrict $ bs
byteToHex :: Word8 -> String
byteToHex byte = pad $ showHex byte ""

5
hbs2-core/lib/HBS2/Data/Types/Refs.hs
View File

@ -26,7 +26,10 @@ class RefMetaData a where
newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync)
deriving stock (Data,Generic,Show)
deriving stock (Data,Generic)
instance Show HashRef where
show (HashRef h) = show . pretty $ h
newtype TaggedHashRef t = TaggedHashRef { fromTaggedHashRef :: HashRef }
deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync)

28
hbs2-core/lib/HBS2/Merkle/Walk.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HBS2.Merkle.Walk where
import Codec.Serialise
@ -7,10 +9,13 @@ import Control.Monad.Except
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Data.Bool
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable
import Data.Functor
import Data.Functor.Identity
import Data.String.Conversions (cs)
import Data.Text (Text)
import GHC.Generics (Generic)
import Prettyprinter
import Streaming (Of (..), Stream)
@ -54,10 +59,25 @@ walkMerkleV2 flookup sink =
<> (deserialiseOrFail bs <&> \(MTreeAnn {_mtaTree = t}) -> t)
)
data WalkStep a
type WalkStep a = WalkStep' (Hash HbSync) a
data WalkStep' h a
= WalkLeaf a
| WalkProcessedTree (Hash HbSync)
| WalkSkippedTree (Hash HbSync)
| WalkProcessedTree h
| WalkSkipTree h
deriving (Generic, Functor, Foldable, Traversable)
withWalkProcessedTree :: (Applicative m) => (h -> m ()) -> WalkStep' h a -> m ()
withWalkProcessedTree f = \case
WalkLeaf _ -> pure ()
WalkProcessedTree h -> f h
WalkSkipTree _ -> pure ()
deriving instance (Show b) => Show (WalkStep' (AsBase58 (Hash HbSync)) b)
deriving via (WalkStep' (AsBase58 (Hash HbSync)) [a]) instance (Show a) => Show (WalkStep [a])
deriving via (WalkStep' (AsBase58 (Hash HbSync)) (AsBase58 BSL.ByteString)) instance Show (WalkStep BSL.ByteString)
deriving via (WalkStep' (AsBase58 (Hash HbSync)) (AsBase58 BS.ByteString)) instance Show (WalkStep BS.ByteString)
deriving via (WalkStep' (AsBase58 (Hash HbSync)) String) instance Show (WalkStep String)
deriving via (WalkStep' (AsBase58 (Hash HbSync)) Text) instance Show (WalkStep Text)
walkMerkleConditional
:: forall a m
@ -72,7 +92,7 @@ walkMerkleConditional getB p sink =
where
go :: Hash HbSync -> ExceptT WalkMerkleError m ()
go = fix \go' h ->
(lift . p) h >>= bool (sinkRight (WalkSkippedTree h)) do
(lift . p) h >>= bool (sinkRight (WalkSkipTree h)) do
bs <- maybe (throwError $ MerkleHashNotFound h) pure =<< (lift . getB) h
either
(throwError . MerkleDeserialiseFailure h)

36
hbs2-tests/hbs2-tests.cabal
View File

@ -45,6 +45,7 @@ common common-deps
, suckless-conf
, tasty
, tasty-hunit
, tasty-quickcheck
, temporary
, timeit
, transformers
@ -53,6 +54,7 @@ common common-deps
, vector
, prettyprinter-ansi-terminal
, interpolatedstring-perl6
, string-conversions
, unliftio
common shared-properties
@ -99,6 +101,13 @@ common shared-properties
, TypeOperators
, TypeFamilies
library
import: shared-properties
import: common-deps
hs-source-dirs: lib
exposed-modules:
HBS2.Tests.MapStore
HBS2.Tests.StoreAsMerkle
test-suite test-skey
import: shared-properties
@ -1124,23 +1133,14 @@ executable test-refchan-notify
executable test-walk-merkletree-cornercase
import: shared-properties
import: common-deps
default-language: Haskell2010
ghc-options:
-- other-extensions:
import: shared-properties, common-deps
hs-source-dirs: test
main-is: TestWalkMerkleTreeCorner.hs
build-depends:
base, hbs2-core
, bytestring
, containers
, string-conversions
, interpolatedstring-perl6
-- , mtl
-- , mwc-random
-- , random
, safe
, serialise
, streaming
, text
build-depends: hbs2-tests
test-suite test-walk-merkle-conditional
import: shared-properties, common-deps
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: TestWalkMerkleConditional.hs
build-depends: hbs2-tests

34
hbs2-tests/lib/HBS2/Tests/MapStore.hs Normal file
View File

@ -0,0 +1,34 @@
module HBS2.Tests.MapStore where
import Control.Monad.State as State
import Data.ByteString.Lazy (ByteString)
import Data.Functor.Identity
import Data.Map (Map)
import Data.Map qualified as Map
import HBS2.Hash
type MapStore = Map (Hash HbSync) ByteString
type MapStoreM a = MapStoreT Identity a
newtype MapStoreT m a = MapStoreT {unMapStoreT :: StateT MapStore m a}
deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadState MapStore)
runMapStoreM :: MapStoreM a -> a
runMapStoreM = runIdentity . runMapStoreT
runMapStoreT :: (Monad m) => MapStoreT m a -> m a
runMapStoreT = flip evalStateT mempty . unMapStoreT
mapStorePutBlock :: (Monad m) => ByteString -> MapStoreT m (Hash HbSync)
mapStorePutBlock bs =
h <$ State.modify (Map.insert h bs)
where
h = hashObject bs
mapStoreReadBlock :: (Monad m) => (Hash HbSync) -> MapStoreT m (Maybe ByteString)
mapStoreReadBlock h =
State.gets (Map.lookup h)
mapStoreDeleteBlock :: (Monad m) => (Hash HbSync) -> MapStoreT m ()
mapStoreDeleteBlock h =
State.modify (Map.delete h)

38
hbs2-tests/lib/HBS2/Tests/StoreAsMerkle.hs Normal file
View File

@ -0,0 +1,38 @@
module HBS2.Tests.StoreAsMerkle where
import Control.Monad
import Data.ByteString.Lazy qualified as LBS
import HBS2.Data.Types.Refs
import HBS2.Hash
import HBS2.Merkle
import HBS2.Tests.MapStore
class (Monad m) => StoreAsMerkle m h b a where
storeAsMerkle :: (b -> m h) -> a -> m MerkleHash
instance
(Monad m, Serialise a)
=> StoreAsMerkle m (Hash HbSync) LBS.ByteString (PTree a)
where
storeAsMerkle putB ptree = fmap MerkleHash do
makeMerkle 0 ptree \(_, _, bs) -> (void . putB) bs
-- (Monad m, Serialise a)
-- => StoreAsMerkle m (Hash HbSync) LBS.ByteString [a]
instance
(Monad m)
=> StoreAsMerkle m (Hash HbSync) LBS.ByteString [HashRef]
where
storeAsMerkle putB hrs = storeAsMerkle putB do
toPTree (MaxSize hashListChunk) (MaxNum treeChildNum) hrs
where
treeChildNum = 3
hashListChunk = 2
instance
(Monad m)
=> StoreAsMerkle m (Hash HbSync) LBS.ByteString [LBS.ByteString]
where
storeAsMerkle putB =
storeAsMerkle putB . fmap HashRef <=< mapM putB

109
hbs2-tests/test/TestWalkMerkleConditional.hs Normal file
View File

@ -0,0 +1,109 @@
module Main where
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import Data.ByteString.Lazy qualified as LBS
import Data.Foldable as F
import Data.Function
import Data.List qualified as List
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as Set
import Prettyprinter
import Test.Tasty
import Test.Tasty.HUnit as HU
import Test.Tasty.QuickCheck as QC
import HBS2.Data.Types.Refs
import HBS2.Hash
import HBS2.Merkle
import HBS2.Merkle.Walk
import HBS2.Tests.MapStore
import HBS2.Tests.StoreAsMerkle
mapStoreAsMerkle
:: (Monad m, StoreAsMerkle (MapStoreT m) (Hash HbSync) LBS.ByteString a)
=> a
-> MapStoreT m MerkleHash
mapStoreAsMerkle = storeAsMerkle mapStorePutBlock
li :: (Monoid (t a), Applicative t) => a -> Writer (t a) ()
li = tell . pure
fromRightOrM :: (Applicative m) => m b -> Either a b -> m b
fromRightOrM ml = either (const ml) pure
main :: IO ()
main = defaultMain $ testGroup "walk conditional" $ execWriter do
li $ HU.testCaseSteps "streamMerkleConditional simple" \step' -> do
flip evalStateT (mempty :: Set (Hash HbSync)) $ runMapStoreT do
let step = lift . lift . step'
step "Reading elems:"
MerkleHash h <- mapStoreAsMerkle $ [payload]
(either pure (lift . lift . assertFailure . const "Expected `Left`") <=< streamToListEither) do
streamMerkleConditionalEither @String mapStoreReadBlock (pure . const True) h
ws <-
onLeft' (\a -> assertFailure ("Expected `Right` but got " <> show a))
=<< streamToListEither do
streamMerkleConditionalEither @[HashRef] mapStoreReadBlock (pure . const True) h
step . show $ ws
r <- mapM (mapStoreReadBlock . fromHashRef) $ foldWalkSteps ws
step . show $ r
lift . lift $ payload @=? (mconcat . catMaybes) r
li $ HU.testCaseSteps "streamMerkleConditional with caching" \step' -> do
flip evalStateT (mempty :: Set (Hash HbSync)) $ runMapStoreT do
let step = lift . lift . step'
MerkleHash h1 <- mapStoreAsMerkle $ L (batch1 :: [Int])
MerkleHash h2 <- mapStoreAsMerkle $ T [L (batch1 :: [Int]), L batch2, L batch3]
step "Reading single branch:"
ws1 <-
onLeft' (\a -> assertFailure ("Expected `Right` but got " <> show a))
=<< streamToListEither do
streamMerkleConditionalEither @[Int] mapStoreReadBlock (pure . const True) h1
step . show $ ws1
let
isKnownHash :: Hash HbSync -> MapStoreT (StateT (Set (Hash HbSync)) IO) Bool
isKnownHash = lift . gets . Set.member
let
markHashAsKnown :: Hash HbSync -> MapStoreT (StateT (Set (Hash HbSync)) IO) ()
markHashAsKnown = lift . modify' . Set.insert
step "Mark known hashes:"
mapM_ (withWalkProcessedTree markHashAsKnown) ws1
step "Skipping known:"
wsPartial <-
onLeft' (\a -> assertFailure ("Expected `Right` but got " <> show a))
=<< streamToListEither do
streamMerkleConditionalEither @[Int] mapStoreReadBlock (fmap not . isKnownHash) h2
step . show $ wsPartial
step . show $ foldWalkSteps wsPartial
lift . lift $ foldWalkSteps wsPartial @?= mconcat [batch2, batch3]
step "Reading everything:"
wsFull <-
onLeft' (\a -> assertFailure ("Expected `Right` but got " <> show a))
=<< streamToListEither do
streamMerkleConditionalEither @[Int] mapStoreReadBlock (pure . const True) h2
step . show $ wsFull
step . show $ foldWalkSteps wsFull
lift . lift $ foldWalkSteps wsFull @?= mconcat [batch1, batch2, batch3]
where
onLeft' f ea = fromRightOrM (lift . lift . f $ ea) ea
batch1 = [1 .. 4]
batch2 = [5 .. 8]
batch3 = [9 .. 12]
payload :: LBS.ByteString
payload = "payload"
foldWalkSteps :: [WalkStep' (Hash HbSync) [a]] -> [a]
foldWalkSteps = mconcat . mconcat . fmap F.toList

42
hbs2-tests/test/TestWalkMerkleTreeCorner.hs
View File

@ -13,6 +13,8 @@ import HBS2.Data.Types.Refs
import HBS2.Hash
import HBS2.Merkle
import HBS2.Merkle.Walk
import HBS2.Tests.MapStore
import HBS2.Tests.StoreAsMerkle
main :: IO ()
main = do
@ -41,43 +43,3 @@ main = do
r2 <- (,) <$> catFromMerkle mapStoreReadBlock h <*> catFromMerkle1 mapStoreReadBlock h
pure [r1, r2]
type MapStore = Map (Hash HbSync) ByteString
newtype MapStoreM a = MapStoreM {unMapStoreM :: State MapStore a}
deriving newtype (Functor, Applicative, Monad, MonadState MapStore)
runMapStoreM :: MapStoreM a -> a
runMapStoreM = flip evalState mempty . unMapStoreM
mapStorePutBlock :: ByteString -> MapStoreM (Hash HbSync)
mapStorePutBlock bs =
h <$ State.modify (Map.insert h bs)
where
h = hashObject bs
mapStoreReadBlock :: (Hash HbSync) -> MapStoreM (Maybe ByteString)
mapStoreReadBlock h =
State.gets (Map.lookup h)
mapStoreDeleteBlock :: (Hash HbSync) -> MapStoreM ()
mapStoreDeleteBlock h =
State.modify (Map.delete h)
---
class (Monad m) => StoreAsMerkle m h b a where
storeAsMerkle :: (b -> m h) -> a -> m MerkleHash
instance StoreAsMerkle MapStoreM (Hash HbSync) ByteString [ByteString] where
storeAsMerkle = \putB bs -> do
hashes <- mapM putB bs
storeAsMerkle putB (HashRef <$> hashes)
instance StoreAsMerkle MapStoreM (Hash HbSync) ByteString [HashRef] where
storeAsMerkle = \putB hrs -> do
let
treeChildNum = 3
hashListChunk = 2
ptree = toPTree (MaxSize hashListChunk) (MaxNum treeChildNum) hrs
MerkleHash <$> do
makeMerkle 0 ptree \(_, _, bs) -> (void . putB) bs