From 9985ec68de78a7a605ce20b43e11cba1f70c8bb7 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 22 Jan 2023 20:40:53 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Data/Types/Refs.hs | 10 +- .../lib/HBS2/Storage/Simple.hs | 3 - hbs2-tests/test/Peer2Main.hs | 1 + hbs2/Main.hs | 125 ++++++++++++------ 4 files changed, 94 insertions(+), 45 deletions(-) diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 9387bd13..9b1435d6 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -17,25 +17,25 @@ newtype HashRef = HashRef (Hash HbSync) data HashRefObject = HashRefObject HashRef (Maybe HashRefMetadata) - deriving stock (Data,Generic) + deriving stock (Data,Show,Generic) newtype HashRefMetadata = HashRefMetadata HashRef deriving newtype (Eq,Ord,Pretty) - deriving stock (Data,Generic) + deriving stock (Data,Show,Generic) newtype HashRefPrevState = HashRefPrevState HashRef deriving newtype (Eq,Ord,Pretty,IsString) - deriving stock (Data,Generic) + deriving stock (Data,Show,Generic) data HashRefType = HashRefMerkle HashRefObject | HashRefBlob HashRefObject - deriving stock (Data,Generic) + deriving stock (Data,Show,Generic) data AnnotatedHashRef = AnnotatedHashRef (Maybe HashRefPrevState) HashRefType - deriving stock (Data,Generic) + deriving stock (Data,Show,Generic) instance Serialise AnnotatedHashRef diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 197a3e59..c8bc85f9 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -200,9 +200,6 @@ simpleGetBlockLazy :: (IsKey h, Pretty (Key h)) -> IO (Maybe LBS.ByteString) simpleGetBlockLazy s key = do - - liftIO $ print $ "simpleGetBlockLazy" <+> pretty key - resQ <- TBMQ.newTBMQueueIO 1 :: IO (TBMQueue (Maybe LBS.ByteString)) let fn = simpleBlockFileName s key let action = do diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index 3a753ea2..8607fd71 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -254,6 +254,7 @@ blockDownloadLoop = do processBlock h processBlock h = do + sto <- getStorage debug $ "GOT BLOCK!" <+> pretty h diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 01409276..450467b1 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -1,25 +1,5 @@ module Main where -import Control.Concurrent.Async -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Data.ByteString.Lazy qualified as LBS -import Data.Function -import Data.Functor -import Options.Applicative -import Prettyprinter -import System.Directory --- import System.FilePath.Posix -import System.IO -import Data.UUID.V4 qualified as UUID -import Data.UUID qualified as UUID - -import Codec.Serialise - -import Streaming.Prelude qualified as S --- import Streaming qualified as S - import HBS2.Storage import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra @@ -29,6 +9,37 @@ import HBS2.Merkle import HBS2.Data.Types import HBS2.Defaults + +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy qualified as LBS +import Data.Either +import Data.Function +import Data.Functor +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUID +import Options.Applicative +import Prettyprinter +import System.Directory +import Data.Maybe +-- import System.FilePath.Posix +import System.IO +import System.Exit + +import Codec.Serialise + +import Streaming.Prelude qualified as S +-- import Streaming qualified as S + + +newtype CommonOpts = + CommonOpts + { _coPref :: Maybe StoragePrefix + } + deriving stock (Data) + newtype OptInputFile = OptInputFile { unOptFile :: FilePath } deriving newtype (Eq,Ord,IsString) deriving stock (Data) @@ -63,6 +74,10 @@ newtype NewRefOpts = } deriving stock (Data) +data BlobType = Merkle (Hash HbSync) + | AnnRef (Hash HbSync) + | Blob (Hash HbSync) + deriving (Show,Data) runCat :: Data opts => opts -> SimpleStorage HbSync -> IO () runCat opts ss = do @@ -75,24 +90,59 @@ runCat opts ss = do obj <- MaybeT $ getBlock ss mhash - let mbLink = deserialiseOrFail @AnnotatedHashRef obj + let mbLink = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef mhash) + let mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle mhash) + let orBlob = Blob mhash - realHash <- MaybeT $ case mbLink of - Left _ -> pure $ Just mhash - Right lnk -> do - pure $ headMay [ h - | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk - ] + let q = rights [mbLink, mbMerkle] & headDef orBlob - liftIO $ walkMerkle realHash (getBlock ss) $ \(hr :: [HashRef]) -> do - forM_ hr $ \(HashRef h) -> do - if honly then do - print $ pretty h - else do - mblk <- getBlock ss h - case mblk of - Nothing -> error $ show $ "missed block: " <+> pretty h - Just blk -> LBS.putStr blk + liftIO $ do + + let walk h = walkMerkle h (getBlock ss) $ \(hr :: [HashRef]) -> do + forM_ hr $ \(HashRef h) -> do + if honly then do + print $ pretty h + else do + mblk <- getBlock ss h + case mblk of + Nothing -> die $ show $ "missed block: " <+> pretty h + Just blk -> LBS.putStr blk + + + case q of + Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr + Merkle h -> walk h + AnnRef h -> do + let lnk = deserialise @AnnotatedHashRef obj + let mbHead = headMay [ h + | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk + ] + maybe (error "empty ref") walk mbHead + + + -- case q of + -- Merkle h -> liftIO do + -- walkMerkle h (getBlock ss) $ \(hr :: [HashRef]) -> do + -- forM_ hr $ \(HashRef h) -> do + -- if honly then do + -- print $ pretty h + -- else do + -- mblk <- getBlock ss h + -- case mblk of + -- Nothing -> error $ show $ "missed block: " <+> pretty h + -- Just blk -> LBS.putStr blk + + + -- case q of + + -- realHash <- MaybeT $ case mbLink of + -- Left _ -> pure $ Just mhash + -- Right lnk -> do + -- pure $ headMay [ h + -- | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk + -- ] + + -- -- FIXME: if merkle? runStore :: Data opts => opts -> SimpleStorage HbSync -> IO () @@ -155,7 +205,8 @@ main = join . customExecParser (prefs showHelpOnError) $ ) common = do - pure () + pref <- optional $ strOption ( short 'p' <> long "prefix" <> help "storage prefix" ) + pure $ CommonOpts pref pNewRef = do o <- common