wip encryption

hbs2-core/hbs2-core.cabal

@@ -76,6 +76,7 @@ library
                     , HBS2.Events
                     , HBS2.Hash
                     , HBS2.Merkle
+                    , HBS2.Net.Auth.AccessKey
                     , HBS2.Net.Auth.Credentials
                     , HBS2.Net.IP.Addr
                     , HBS2.Net.Messaging

hbs2-core/lib/HBS2/Data/Detect.hs

@@ -12,18 +12,18 @@ import Data.Function
 import Data.Functor
 
 data BlobType =  Merkle (Hash HbSync)
-               | MerkleWrap (MWrap [HashRef])
+               | MerkleAnn (MTreeAnn [HashRef])
                | AnnRef (Hash HbSync)
                | Blob (Hash HbSync)
                deriving (Show,Data)
 
 
 tryDetect :: Hash HbSync -> ByteString -> BlobType
-tryDetect hash obj = rights [mbWrap, mbLink, mbMerkle] & headDef orBlob
+tryDetect hash obj = rights [mbAnn, mbLink, mbMerkle] & headDef orBlob
 
   where
     mbLink   = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef hash)
     mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle hash)
-    mbWrap   = deserialiseOrFail obj <&> MerkleWrap
+    mbAnn   = deserialiseOrFail obj <&> MerkleAnn
     orBlob   = Blob hash
 

hbs2-core/lib/HBS2/Merkle.hs

@@ -76,21 +76,24 @@ makeLenses ''MNodeData
 
 instance Serialise MNodeData
 
-data MWrap a = MWrap
+data MTreeAnn a = MTreeAnn
- { _mwCrypt :: !CryptScheme
+ { _mtaAnn :: !Ann
- , _mwTree :: !(MTree a)
+ , _mtaTree :: !(MTree a)
  }
   deriving stock (Generic,Data,Show)
 
-instance Serialise a => Serialise (MWrap a)
+instance Serialise a => Serialise (MTreeAnn a)
 
-data CryptScheme
+data MerkleEncryptionType
-  = NullCrypt
+  deriving stock (Data)
+
+data Ann
+  = NullAnn
   | GroupKeyCrypt (Hash HbSync)
-  -- FIXME more crypt schemes
+  -- FIXME more annotation schemes
   deriving stock (Generic,Data,Show)
 
-instance Serialise CryptScheme
+instance Serialise Ann
 
 data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a
                deriving stock (Generic,Data,Show)

hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs

@@ -0,0 +1,48 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language ConstraintKinds #-}
+module HBS2.Net.Auth.AccessKey where
+
+import HBS2.Base58
+import HBS2.Data.Detect
+import HBS2.Data.Types
+import HBS2.Defaults
+import HBS2.Merkle
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Messaging.UDP (UDP)
+import HBS2.Net.Proto.Definition()
+import HBS2.Net.Proto.Types
+import HBS2.OrDie
+import HBS2.Prelude.Plated
+
+import Codec.Serialise
+import Crypto.Saltine.Core.Sign (Keypair(..))
+import Crypto.Saltine.Core.Sign qualified as Sign
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Crypto.Saltine.Class qualified as Crypto
+import Crypto.Saltine.Class (IsEncoding)
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.ByteString.Char8 qualified as B8
+import Data.ByteString.Char8 (ByteString)
+import Data.Function
+import Data.List.Split (chunksOf)
+import Data.Text (Text)
+import Data.List qualified as List
+import Lens.Micro.Platform
+import Data.Kind
+import Prettyprinter
+
+
+newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
+  deriving stock (Generic)
+
+instance Serialise EncryptedBox
+
+newtype AccessKeyV1 e = AccessKeyV1
+  { permitted :: [(PubKey 'Encrypt e, EncryptedBox)]
+  }
+  deriving stock (Generic)
+
+instance Serialise (AccessKeyV1 e)

hbs2-peer/app/BlockDownload.hs

@@ -187,9 +187,9 @@ processBlock h = do
 
      Just (AnnRef{}) -> pure ()
 
-     Just (MerkleWrap (MWrap sch t)) -> do
+     Just (MerkleAnn (MTreeAnn ann t)) -> do
-       case sch of
+       case ann of
-            NullCrypt -> pure ()
+            NullAnn -> pure ()
             GroupKeyCrypt hk -> addDownload hk
 
        debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h

hbs2/Main.hs

@@ -5,6 +5,7 @@ import HBS2.Data.Detect
 import HBS2.Data.Types
 import HBS2.Defaults
 import HBS2.Merkle
+import HBS2.Net.Auth.AccessKey
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging.UDP (UDP)
 import HBS2.Net.Proto.Definition()
@@ -20,6 +21,7 @@ import Control.Concurrent.Async
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State.Strict
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Data.Either
@@ -61,11 +63,19 @@ newtype OptInit = OptInit { fromOptInit :: Bool }
                   deriving newtype (Eq,Ord,Pretty)
                   deriving stock (Data,Generic)
 
-data StoreOpts =
+data OptEncryption e = OptEncryption
+  { encryptFromSecKey :: Maybe (PrivKey 'Encrypt e)
+  , encryptToSecKey :: PrivKey 'Encrypt e
+  , encryptToPubKey :: PubKey 'Encrypt e
+  , encryptToGroup :: [PubKey 'Encrypt e]
+  }
+  deriving stock (Data)
+
+data StoreOpts e =
   StoreOpts
   {  storeInit      :: Maybe OptInit
   ,  storeInputFile :: Maybe OptInputFile
-      -- FIXME store option to encrypt
+  ,  storeEncryption :: Maybe (OptEncryption e)
   }
   deriving stock (Data)
 
@@ -73,6 +83,7 @@ data CatOpts =
   CatOpts
   { catMerkleHash :: Maybe MerkleHash
   , catHashesOnly :: Maybe CatHashesOnly
+  , catPathToKeyring :: Maybe FilePath
   }
   deriving stock (Data)
 
@@ -123,25 +134,46 @@ runCat opts ss = do
                        Nothing  -> die $ show $ "missed block: " <+> pretty hx
                        Just blk -> LBS.putStr blk
 
-      let walkWrap :: CryptScheme -> MTree [HashRef] -> IO ()
+      let walkAnn :: Ann -> MTree [HashRef] -> IO ()
-          walkWrap sch t = walkMerkleTree t (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+          walkAnn ann t = do
+            bprocess :: Int -> ByteString -> IO ByteString <- case ann of
+              NullAnn -> pure (\_ -> pure)
+              GroupKeyCrypt crypth -> do
+                  mblk <- getBlock ss crypth
+                  case mblk of
+                    Nothing  -> die $ show $ "missed block: " <+> pretty crypth
+                    Just blk -> do
+                        -- FIXME apply crypto scheme from `crypth` to stream of blk's
+                        -- extract AccessKeyV1 from blk
+                        -- find in it any pubkey known to us
+                        -- decrypt corresponding EncryptedBox
+                        -- get actual (PrivKey 'Encrypt e) to use for merkle decryption
+                        pure $ \blnum blk -> do
+                            -- convert blnum to Crypto.Saltine.Core.Box.Nonce
+                            -- decrypt blk with this nonce and priv key
+                            undefined
+
+            flip evalStateT firstNumOfBlock $
+             walkMerkleTree t (lift . getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
               case hr of
-              Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
+                Left hx -> lift $ void $ hPrint stderr $ "missed block:" <+> pretty hx
                 Right (hrr :: [HashRef]) -> do
                   forM_ hrr $ \(HashRef hx) -> do
                     if honly then do
-                     print $ pretty hx
+                      lift $ print $ pretty hx
                     else do
-                     mblk <- getBlock ss hx
+                      mblk <- lift $ getBlock ss hx
                       case mblk of
-                       Nothing  -> die $ show $ "missed block: " <+> pretty hx
+                        Nothing  -> lift $ die $ show $ "missed block: " <+> pretty hx
-                       -- FIXME apply crypto scheme `sch` to stream of blk's
+                        Just blk -> do
-                       Just blk -> LBS.putStr blk
+                            blnum <- get
+                            modify (+1)
+                            lift $ LBS.putStr =<< bprocess blnum 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
+        MerkleAnn (MTreeAnn ann hs) -> walkAnn ann hs
         AnnRef h -> do
           let lnk = deserialise @AnnotatedHashRef obj
           let mbHead =  headMay [ h
@@ -158,6 +190,8 @@ runStore opts ss | justInit = do
   where
     justInit = maybe False fromOptInit (uniLastMay @OptInit opts)
 
+firstNumOfBlock :: Int
+firstNumOfBlock = 1
 
 runStore opts ss = do
 
@@ -165,14 +199,36 @@ runStore opts ss = do
 
   handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
 
-  root <- case (undefined opts) of  -- FIXME
+  case (uniLastMay @(OptEncryption MerkleEncryptionType) opts) of
-    Nothing -> putAsMerkle ss handle
+    Nothing -> do
-    Just encOpts -> do
+        root <- putAsMerkle ss handle
-        encryptedChunks :: S.Stream (S.Of ByteString) IO ()
-            <- undefined encOpts handle  -- FIXME readChunked then encrypt ?
-        putAsMerkle ss encryptedChunks
-
         print $ "merkle-root: " <+> pretty root
+    Just encOpts -> do
+
+        -- FIXME generate AccessKeyV1, store it
+        accKeyh <- maybe (die "can not store access key") pure
+              =<< (putBlock ss . serialise) do
+            AccessKeyV1 (undefined :: [(PubKey 'Encrypt e, EncryptedBox)])
+
+        let rawChunks :: S.Stream (S.Of ByteString) IO ()
+            rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
+
+            encryptedChunks :: S.Stream (S.Of ByteString) IO ()
+            -- FIXME get keys to enrypt
+            encryptedChunks = rawChunks
+                & S.zip (S.enumFrom firstNumOfBlock)
+                & S.map (\(blnum, blk) -> do
+                      -- FIXME convert blnum to Crypto.Saltine.Core.Box.Nonce
+                      -- encrypt blk with this nonce and priv key
+                      undefined
+
+        mhash <- putAsMerkle ss encryptedChunks
+
+        mannh <- maybe (die "can not store MerkleAnn") pure
+              =<< (putBlock ss . serialise) do
+            MerkleAnn (MTreeAnn (GroupKeyCrypt accKeyh) (undefined mhash))
+
+        print $ "merkle-ann-root: " <+> pretty mannh
 
 runNewRef :: Data opts => opts -> MerkleHash -> SimpleStorage HbSync -> IO ()
 runNewRef opts mhash ss = do
@@ -273,13 +329,15 @@ main = join . customExecParser (prefs showHelpOnError) $
       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 ))
+      encOps :: Maybe (OptEncryption MerkleEncryptionType) <- optional $ undefined
+      pure $ withStore o (runStore ( StoreOpts init file encOps ))
 
     pCat = do
       o <- common
       hash  <- optional $ strArgument ( metavar "HASH" )
       onlyh <- optional $ flag' True ( short 'H' <> long "hashes-only" <> help "list only block hashes" )
-      pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh)
+      keyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" )
+      pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) keyringFile
 
     pHash = do
       o <- common