From 625c55609ca6924bb24da585cbce8e70fe3f694e Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 9 Feb 2023 03:07:17 +0400 Subject: [PATCH] Draft merkle wrapper for encryption --- hbs2-core/lib/HBS2/Data/Detect.hs | 5 +- hbs2-core/lib/HBS2/Merkle.hs | 28 +++++++++- hbs2-peer/app/BlockDownload.hs | 53 +++++++++++-------- .../lib/HBS2/Storage/Simple/Extra.hs | 15 ++++++ hbs2/Main.hs | 25 ++++++++- 5 files changed, 101 insertions(+), 25 deletions(-) diff --git a/hbs2-core/lib/HBS2/Data/Detect.hs b/hbs2-core/lib/HBS2/Data/Detect.hs index 5e463cf8..c2e0edeb 100644 --- a/hbs2-core/lib/HBS2/Data/Detect.hs +++ b/hbs2-core/lib/HBS2/Data/Detect.hs @@ -9,18 +9,21 @@ import Codec.Serialise (deserialiseOrFail) import Data.ByteString.Lazy (ByteString) import Data.Either import Data.Function +import Data.Functor data BlobType = Merkle (Hash HbSync) + | MerkleWrap (MWrap [HashRef]) | AnnRef (Hash HbSync) | Blob (Hash HbSync) deriving (Show,Data) tryDetect :: Hash HbSync -> ByteString -> BlobType -tryDetect hash obj = rights [mbLink, mbMerkle] & headDef orBlob +tryDetect hash obj = rights [mbWrap, mbLink, mbMerkle] & headDef orBlob where mbLink = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef hash) mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle hash) + mbWrap = deserialiseOrFail obj <&> MerkleWrap orBlob = Blob hash diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index a9692dbb..6662e3cf 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -10,7 +10,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS import Data.Data -import Data.Foldable (traverse_) +import Data.Foldable (forM_, traverse_) import Data.List qualified as List import GHC.Generics import Lens.Micro.Platform @@ -76,6 +76,22 @@ makeLenses ''MNodeData instance Serialise MNodeData +data MWrap a = MWrap + { _mwCrypt :: !CryptScheme + , _mwTree :: !(MTree a) + } + deriving stock (Generic,Data,Show) + +instance Serialise a => Serialise (MWrap a) + +data CryptScheme + = NullCrypt + | GroupKeyCrypt (Hash HbSync) + -- FIXME more crypt schemes + deriving stock (Generic,Data,Show) + +instance Serialise CryptScheme + data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a deriving stock (Generic,Data,Show) @@ -159,3 +175,13 @@ walkMerkle root flookup sink = walkMerkle' root flookup withTree (Right (MNode _ _)) -> pure () Left hx -> sink (Left hx) + +walkMerkleTree :: (Serialise (MTree a), Monad m) + => MTree a + -> ( Hash HbSync -> m (Maybe LBS.ByteString) ) + -> ( Either (Hash HbSync) a -> m () ) + -> m () + +walkMerkleTree tree flookup sink = case tree of + (MLeaf s) -> sink (Right s) + (MNode _ hashes) -> forM_ hashes \h -> walkMerkle h flookup sink diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 269c70ac..49e64f22 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -160,35 +160,44 @@ processBlock h = do when (isJust bt) (removeFromWip h) + let handleHrr = \(hrr :: Either (Hash HbSync) [HashRef]) -> do + + case hrr of + Left hx -> addDownload hx + Right hr -> do + + for_ hr $ \(HashRef blk) -> do + + -- debug $ pretty blk + + here <- liftIO (hasBlock sto blk) <&> isJust + + if here then do + pure () + -- debug $ "block" <+> pretty blk <+> "is already here" + -- unless (h == blk) do + -- processBlock blk -- NOTE: хуже не стало + -- FIXME: fugure out if it's really required + + else do + addDownload blk + case bt of Nothing -> addDownload h Just (AnnRef{}) -> pure () + Just (MerkleWrap (MWrap sch t)) -> do + case sch of + NullCrypt -> pure () + GroupKeyCrypt hk -> addDownload hk + + debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h + walkMerkleTree t (liftIO . getBlock sto) handleHrr + Just (Merkle{}) -> do debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h - walkMerkle h (liftIO . getBlock sto) $ \(hrr :: Either (Hash HbSync) [HashRef]) -> do - - case hrr of - Left hx -> addDownload hx - Right hr -> do - - for_ hr $ \(HashRef blk) -> do - - -- debug $ pretty blk - - here <- liftIO (hasBlock sto blk) <&> isJust - - if here then do - pure () - -- debug $ "block" <+> pretty blk <+> "is already here" - -- unless (h == blk) do - -- processBlock blk -- NOTE: хуже не стало - -- FIXME: fugure out if it's really required - - else do - addDownload blk - + walkMerkle h (liftIO . getBlock sto) handleHrr Just (Blob{}) -> do pure () diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs index 75ad3127..b09b9204 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs @@ -43,6 +43,21 @@ instance SimpleStorageExtra Handle where & S.map (HashRef . hashObject) & S.toList_ + putAsMerkle ss hashes + +instance SimpleStorageExtra (S.Stream (S.Of ByteString) IO ()) where + putAsMerkle ss streamChunks = do + + hashes <- streamChunks + & S.mapM (\blk -> enqueueBlock ss blk >> pure blk) + & S.map (HashRef . hashObject) + & S.toList_ + + putAsMerkle ss hashes + +instance SimpleStorageExtra [HashRef] where + putAsMerkle ss hashes = do + let pt = toPTree (MaxSize pieces) (MaxNum pieces) hashes -- FIXME: settings root <- makeMerkle 0 pt $ \(_,_,bs) -> void $ putBlock ss bs diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 38daee2f..9317c260 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -65,6 +65,7 @@ data StoreOpts = StoreOpts { storeInit :: Maybe OptInit , storeInputFile :: Maybe OptInputFile + -- FIXME store option to encrypt } deriving stock (Data) @@ -122,9 +123,25 @@ runCat opts ss = do Nothing -> die $ show $ "missed block: " <+> pretty hx Just blk -> LBS.putStr blk + let walkWrap :: CryptScheme -> MTree [HashRef] -> IO () + walkWrap sch t = walkMerkleTree t (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do + case hr of + Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx + Right (hrr :: [HashRef]) -> do + forM_ hrr $ \(HashRef hx) -> do + if honly then do + print $ pretty hx + else do + mblk <- getBlock ss hx + case mblk of + Nothing -> die $ show $ "missed block: " <+> pretty hx + -- FIXME apply crypto scheme `sch` to stream of blk's + Just blk -> LBS.putStr blk + case q of Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr Merkle h -> walk h + MerkleWrap (MWrap sch hs) -> walkWrap sch hs AnnRef h -> do let lnk = deserialise @AnnotatedHashRef obj let mbHead = headMay [ h @@ -148,7 +165,12 @@ runStore opts ss = do handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname - root <- putAsMerkle ss handle + root <- case (undefined opts) of -- FIXME + Nothing -> putAsMerkle ss handle + Just encOpts -> do + encryptedChunks :: S.Stream (S.Of ByteString) IO () + <- undefined encOpts handle -- FIXME readChunked then encrypt ? + putAsMerkle ss encryptedChunks print $ "merkle-root: " <+> pretty root @@ -250,6 +272,7 @@ main = join . customExecParser (prefs showHelpOnError) $ o <- common file <- optional $ strArgument ( metavar "FILE" ) init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit + -- FIXME option to encrypt pure $ withStore o (runStore ( StoreOpts init file )) pCat = do