diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index d5544848..36120eb6 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -41,8 +41,10 @@ common shared-properties , ConstraintKinds , DataKinds , DeriveDataTypeable + , DeriveFoldable , DeriveFunctor , DeriveGeneric + , DeriveTraversable , DerivingStrategies , DerivingVia , ExtendedDefaultRules diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index 468920a7..dcd7af7b 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -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 "" diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 4c399f38..1ca455d4 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -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) diff --git a/hbs2-core/lib/HBS2/Merkle/Walk.hs b/hbs2-core/lib/HBS2/Merkle/Walk.hs index 6d8b133b..004c2acc 100644 --- a/hbs2-core/lib/HBS2/Merkle/Walk.hs +++ b/hbs2-core/lib/HBS2/Merkle/Walk.hs @@ -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) diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 30f0aac8..8ee4bf42 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -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 diff --git a/hbs2-tests/lib/HBS2/Tests/MapStore.hs b/hbs2-tests/lib/HBS2/Tests/MapStore.hs new file mode 100644 index 00000000..60c3bb70 --- /dev/null +++ b/hbs2-tests/lib/HBS2/Tests/MapStore.hs @@ -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) diff --git a/hbs2-tests/lib/HBS2/Tests/StoreAsMerkle.hs b/hbs2-tests/lib/HBS2/Tests/StoreAsMerkle.hs new file mode 100644 index 00000000..b2cd6d63 --- /dev/null +++ b/hbs2-tests/lib/HBS2/Tests/StoreAsMerkle.hs @@ -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 diff --git a/hbs2-tests/test/TestWalkMerkleConditional.hs b/hbs2-tests/test/TestWalkMerkleConditional.hs new file mode 100644 index 00000000..1b2e25be --- /dev/null +++ b/hbs2-tests/test/TestWalkMerkleConditional.hs @@ -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 diff --git a/hbs2-tests/test/TestWalkMerkleTreeCorner.hs b/hbs2-tests/test/TestWalkMerkleTreeCorner.hs index 737e1d89..29f654f2 100644 --- a/hbs2-tests/test/TestWalkMerkleTreeCorner.hs +++ b/hbs2-tests/test/TestWalkMerkleTreeCorner.hs @@ -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