Draft merkle wrapper for encryption

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
 

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

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
+       walkMerkle h (liftIO . getBlock sto) handleHrr
-
-        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
-
 
      Just (Blob{}) -> do
        pure ()

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

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