diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index d25c4957..0fe956ac 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/Detect.hs b/hbs2-core/lib/HBS2/Data/Detect.hs index c2e0edeb..ce0c8f95 100644 --- a/hbs2-core/lib/HBS2/Data/Detect.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index 6662e3cf..2a8da3ba 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -76,21 +76,24 @@ makeLenses ''MNodeData instance Serialise MNodeData -data MWrap a = MWrap - { _mwCrypt :: !CryptScheme - , _mwTree :: !(MTree a) +data MTreeAnn a = MTreeAnn + { _mtaAnn :: !Ann + , _mtaTree :: !(MTree a) } deriving stock (Generic,Data,Show) -instance Serialise a => Serialise (MWrap a) +instance Serialise a => Serialise (MTreeAnn a) -data CryptScheme - = NullCrypt +data MerkleEncryptionType + 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) diff --git a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs new file mode 100644 index 00000000..7af126ed --- /dev/null +++ b/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) diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 49e64f22..d7a82c99 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -187,9 +187,9 @@ processBlock h = do Just (AnnRef{}) -> pure () - Just (MerkleWrap (MWrap sch t)) -> do - case sch of - NullCrypt -> pure () + Just (MerkleAnn (MTreeAnn ann t)) -> do + case ann of + NullAnn -> pure () GroupKeyCrypt hk -> addDownload hk debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 9317c260..f1195e7b 100644 --- a/hbs2/Main.hs +++ b/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 () - 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 + let walkAnn :: Ann -> MTree [HashRef] -> IO () + 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 -> lift $ void $ hPrint stderr $ "missed block:" <+> pretty hx + Right (hrr :: [HashRef]) -> do + forM_ hrr $ \(HashRef hx) -> do + if honly then do + lift $ print $ pretty hx + else do + mblk <- lift $ getBlock ss hx + case mblk of + Nothing -> lift $ die $ show $ "missed block: " <+> pretty hx + Just blk -> do + 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 - Nothing -> putAsMerkle ss handle + case (uniLastMay @(OptEncryption MerkleEncryptionType) opts) of + Nothing -> do + root <- putAsMerkle ss handle + print $ "merkle-root: " <+> pretty root 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 + -- 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