diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs index 80e86536..f60d1961 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs @@ -25,6 +25,7 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.Client.Unix +import Data.ByteString.Lazy qualified as LBS import Data.Coerce import Data.Text qualified as Text import Control.Monad.Except @@ -64,7 +65,22 @@ treeEntries = do _ -> throwIO (BadFormException @c nil) - brief "reads merkle tree data from storage" + brief "reads merkle tree data from storage to stdout" + $ args [arg "string" "tree"] + $ desc "hbs2:tree:read:stdout HASH" + $ returns "nil" "" + $ entry $ bindMatch "hbs2:tree:read:stdout" $ nil_ \case + [ HashLike h ] -> lift do + sto <- getStorage + + runExceptT (getTreeContents sto h) + >>= orThrowPassIO + >>= liftIO . LBS.putStr + + _ -> throwIO (BadFormException @c nil) + + + brief "creates a 'grove' -- an annotated hashref list" $ args [arg "list of hashes" "trees"] $ desc [qc|hbs2:grove creates a 'grove' - merkle tree of list of hashes of merkle trees It's just an easy way to create a such thing, you may browse it by hbs2 cat -H diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 8344ec6b..66ee718f 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -99,7 +99,6 @@ library , HBS2.Merkle.MetaData , HBS2.Merkle.Walk , HBS2.Net.Auth.Schema - , HBS2.Net.Auth.GroupKeyAsymm , HBS2.Net.Auth.GroupKeySymm , HBS2.Net.Auth.Credentials , HBS2.Net.Auth.Credentials.Sigil diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs deleted file mode 100644 index f1a23734..00000000 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language UndecidableInstances #-} -{-# Language AllowAmbiguousTypes #-} -{-# Language ConstraintKinds #-} -module HBS2.Net.Auth.GroupKeyAsymm where - -import HBS2.Base58 -import HBS2.Data.Types -import HBS2.Data.Types.EncryptedBox -import HBS2.Net.Auth.Credentials -import HBS2.Prelude.Plated - -import Codec.Serialise -import Control.Monad ((<=<)) -import Crypto.Saltine.Core.Box qualified as Encrypt -import Crypto.Saltine.Class qualified as Crypto -import Data.ByteString.Lazy.Char8 qualified as LBS -import Data.ByteString.Char8 qualified as B8 -import Data.ByteString.Char8 (ByteString) -import Data.List.Split (chunksOf) - - -type ForAccessKey (s :: CryptoScheme) = ( Crypto.IsEncoding (PubKey 'Encrypt s) - , Serialise (PubKey 'Encrypt s) - , Serialise (PubKey 'Sign s) - , Serialise (PrivKey 'Sign s) - , Serialise (PrivKey 'Encrypt s) - ) - - - -data family AccessKey ( s :: CryptoScheme ) - -newtype instance AccessKey (s :: CryptoScheme) = - AccessKeyNaClAsymm - { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] - } - deriving stock (Generic) - -instance ForAccessKey s => Serialise (AccessKey s) - ---- - - -data instance GroupKey 'Asymm s = - GroupKeyNaClAsymm - { recipientPk :: PubKey 'Encrypt s - , accessKey :: AccessKey s - } - deriving stock (Generic) - -instance ForAccessKey s => Serialise (GroupKey 'Asymm s) - ---- - - --- FIXME: integration-regression-test-for-groupkey --- Добавить тест: сгенерировали groupkey/распарсили groupkey - -parseGroupKey :: forall s . ForAccessKey s - => AsGroupKeyFile ByteString -> Maybe (GroupKey 'Asymm s) -parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs - -instance ( Serialise (GroupKey 'Asymm s) - ) - - => Pretty (AsBase58 (GroupKey 'Asymm s)) where - pretty (AsBase58 c) = - pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c - - -instance ForAccessKey s => Pretty (AsGroupKeyFile (AsBase58 (GroupKey 'Asymm s))) where - pretty (AsGroupKeyFile pc) = "# hbs2 groupkey file" <> line <> co - where - co = vcat $ fmap pretty - $ chunksOf 60 - $ show - $ pretty pc - - -parsePubKeys :: forall s . ForAccessKey s - => ByteString - -> Maybe [PubKey 'Encrypt s] - -parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines - - --- FIXME: public-key-type-hardcode --- Это нужно переместить в тайпкласс от s, аналогично Signatures -mkEncryptedKey :: forall s . (ForAccessKey s, PubKey 'Encrypt s ~ Encrypt.PublicKey) - => KeyringEntry s - -> PubKey 'Encrypt s - -> IO (EncryptedBox (KeyringEntry s)) - -mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr) - -openEncryptedKey :: forall s . ( ForAccessKey s - , PrivKey 'Encrypt s ~ Encrypt.SecretKey - , PubKey 'Encrypt s ~ Encrypt.PublicKey - ) - => EncryptedBox (KeyringEntry s) - -> KeyringEntry s - -> Maybe (KeyringEntry s) - -openEncryptedKey (EncryptedBox bs) kr = - either (const Nothing) Just . deserialiseOrFail . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs - diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 4027e5d7..a69d55ee 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -1,3 +1,4 @@ +{-# Language TypeOperators #-} module Main where import HBS2.Base58 @@ -12,7 +13,6 @@ import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient -import HBS2.Net.Auth.GroupKeyAsymm as Asymm import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.Net.Auth.GroupKeySymm import HBS2.Net.Auth.Credentials @@ -374,34 +374,7 @@ runStore opts ss = runResourceT do Left e -> die (show e) Right h -> hPrint stdout (pretty h) - Just (EncAsymm gk) -> liftIO $ IO.withFile inputFile IO.ReadMode $ \ha -> do - - accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk - `orDie` "can not store access key" - - let rawChunks = readChunked ha (fromIntegral defBlockSize) -- FIXME: to settings! - - let encryptedChunks = rawChunks - & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict) - - mhash <- putAsMerkle ss encryptedChunks - mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash)) - `orDie` "merkle tree was not stored properly with `putAsMerkle`" - - mannh <- maybe (die "can not store MerkleAnn") pure - =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do - MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree - - hPrint stdout $ "merkle-ann-root: " <+> pretty mannh - -runNewGroupKeyAsymm :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO () -runNewGroupKeyAsymm pubkeysFile = do - s <- BS.readFile pubkeysFile - pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file" - keypair <- newKeypair @s Nothing - accesskey <- AccessKeyNaClAsymm @s <$> do - List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk - print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey + _ -> die "Unsupported (obsolete) encryption scheme" runNewKey :: forall s . (s ~ 'HBS2Basic) => Int -> IO () runNewKey n = do