TestWalkMerkleConditional

hbs2-core/hbs2-core.cabal

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

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 ""

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)

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)
+    | WalkProcessedTree h
-    | WalkSkippedTree (Hash HbSync)
+    | 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)

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:           shared-properties, common-deps
-    import:           common-deps
-    default-language: Haskell2010
-    ghc-options:
-    -- other-extensions:
     hs-source-dirs:   test
     main-is:          TestWalkMerkleTreeCorner.hs
-    build-depends:
+    build-depends:    hbs2-tests
-          base, hbs2-core
+
-        , bytestring
+test-suite test-walk-merkle-conditional
-        , containers
+    import:           shared-properties, common-deps
-        , string-conversions
+    type: exitcode-stdio-1.0
-        , interpolatedstring-perl6
+    hs-source-dirs:   test
-        -- , mtl
+    main-is:          TestWalkMerkleConditional.hs
-        -- , mwc-random
+    build-depends:    hbs2-tests
-        -- , random
-        , safe
-        , serialise
-        , streaming
-        , text

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)

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

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

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