From f36e5e6431344273c47642b0cb874a42d9f96d1b Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 22 Aug 2024 12:52:03 +0300 Subject: [PATCH] wip, basic refchan commands to cli --- hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs | 42 ++++++++++++++++----- hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs | 30 ++++++++++++++- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 42 ++++++++++++++------- 3 files changed, 90 insertions(+), 24 deletions(-) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 85f0ef0c..52fe9b15 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -32,6 +32,7 @@ import Codec.Serialise groupKeyEntries :: forall c m . ( MonadUnliftIO m , IsContext c + , Exception (BadFormException c) , HasClientAPI StorageAPI UNIX m , HasStorage m ) => MakeDictM c m () @@ -48,17 +49,40 @@ groupKeyEntries = do _ -> throwIO $ BadFormException @C nil - entry $ bindMatch "hbs2:groupkey:store" $ \case - [LitStrVal s] -> do - let lbs = LBS8.pack (Text.unpack s) - gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) - `orDie` "invalid group key" - sto <- getStorage - ha <- writeAsMerkle sto (serialise gk) - pure $ mkStr (show $ pretty ha) + brief "stores groupkey to the peer's storage" $ + args [arg "string" "groupkey"] $ + returns "string" "hash" $ + entry $ bindMatch "hbs2:groupkey:store" $ \case + [LitStrVal s] -> do + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" - _ -> throwIO $ BadFormException @C nil + sto <- getStorage + ha <- writeAsMerkle sto (serialise gk) + pure $ mkStr (show $ pretty ha) + + _ -> throwIO $ BadFormException @c nil + + + brief "publish groupkey to the given refchan" $ + args [arg "string" "refchan", arg "string" "groupkey-blob|groupkey-hash"] $ + desc "groupkey may be also hash of te stored groupkey" $ + entry $ bindMatch "hbs2:groupkey:publish" $ nil_ $ \case + + [SignPubKeyLike rchan, LitStrVal gk] -> do + -- get + -- check + -- store + -- find refchan + -- post tx as metadata + notice $ red "not implemented yet" + + [SignPubKeyLike rchan, HashLike gkh] -> do + notice $ red "not implemented yet" + + _ -> throwIO $ BadFormException @c nil -- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \ diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index e864bc5e..878ba42e 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -43,6 +43,10 @@ import Data.HashSet qualified as HS import Data.Coerce import Control.Monad.Trans.Cont import Control.Monad.Except +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text qualified as Text +import Codec.Serialise import Text.InterpolatedString.Perl6 (qc) @@ -293,5 +297,29 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr <> pretty rch - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) + + + brief "creates RefChanUpdate/AnnotatedHashRef transaction for refchan" $ + args [arg "string" "sign-key", arg "string" "payload-tree-hash"] $ + entry $ bindMatch "hbs2:refchan:tx:annref:create" $ \case + [SignPubKeyLike signpk, HashLike hash] -> do + sto <- getStorage + void $ hasBlock sto (fromHashRef hash) `orDie` "no block found" + let lbs = AnnotatedHashRef Nothing hash & serialise + creds <- runKeymanClient $ loadCredentials signpk >>= orThrowUser "can't find credentials" + let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise + pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)] + + _ -> throwIO (BadFormException @c nil) + + brief "posts Propose transaction to the refchan" $ + args [arg "string" "refchan", arg "blob" "signed-box"] $ + entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \case + [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do + api <- getClientAPI @RefChanAPI @UNIX + bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction" + void $ callService @RpcRefChanPropose api (rchan, bbox) + + _ -> throwIO (BadFormException @c nil) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 9ef4f3f3..5cf5faea 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -107,9 +107,10 @@ data instance GroupKey 'Symm s = { recipients :: Recipients s } | GroupKeySymmFancy - { recipients :: Recipients s - , groupKeyIdScheme :: Maybe GroupKeyIdScheme - , groupKeyId :: Maybe GroupKeyId + { recipients :: Recipients s + , groupKeyIdScheme :: Maybe GroupKeyIdScheme + , groupKeyId :: Maybe GroupKeyId + , groupKeyTimestamp :: Maybe Word64 } deriving stock (Generic) @@ -123,14 +124,19 @@ getGroupKeyId = \case GroupKeySymmPlain{} -> Nothing GroupKeySymmFancy{..} -> groupKeyId +getGroupKeyTimestamp :: GroupKey 'Symm s -> Maybe Word64 +getGroupKeyTimestamp = \case + GroupKeySymmPlain{} -> Nothing + GroupKeySymmFancy{..} -> groupKeyTimestamp + instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where - mempty = GroupKeySymmFancy mempty mzero mzero + mempty = GroupKeySymmFancy mempty mzero mzero mzero instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where - (<>) (GroupKeySymmPlain a) (GroupKeySymmPlain b) = GroupKeySymmFancy (a <> b) mzero mzero - (<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k) = GroupKeySymmFancy (r0 <> r) s k - (<>) (GroupKeySymmFancy r s k) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k - (<>) (GroupKeySymmFancy r0 s0 k0) (GroupKeySymmFancy r1 s1 k1) = GroupKeySymmFancy (r0 <> r1) (s1 <|> s0) (k1 <|> k0) + (<>) (GroupKeySymmPlain a) (GroupKeySymmPlain b) = GroupKeySymmFancy (a <> b) mzero mzero mzero + (<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k t) = GroupKeySymmFancy (r0 <> r) s k t + (<>) (GroupKeySymmFancy r s k t) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k t + (<>) (GroupKeySymmFancy r0 s0 k0 t0) (GroupKeySymmFancy r1 s1 k1 t1) = GroupKeySymmFancy (r0 <> r1) (s1 <|> s0) (k1 <|> k0) (max t0 t1) instance Serialise GroupKeyIdScheme instance Serialise GroupKeyId @@ -179,7 +185,7 @@ instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where let compat = GroupKeySymmV1 @s (recipients x) let compatEncoded = Serialise.encode compat let version = 2 - let ext = (getGroupKeyIdScheme x, getGroupKeyId x) + let ext = (getGroupKeyIdScheme x, getGroupKeyId x, getGroupKeyTimestamp x) compatEncoded <> Serialise.encode version <> Serialise.encode ext decode = do @@ -194,8 +200,8 @@ instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where case version of 2 -> do - (s,kid) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId) - pure $ GroupKeySymmFancy recipientsV1 s kid + (s,kid, t) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId, Maybe Word64) + pure $ GroupKeySymmFancy recipientsV1 s kid t _ -> pure $ GroupKeySymmPlain recipientsV1 @@ -257,15 +263,23 @@ generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Enc -> [PubKey 'Encrypt s] -> m (GroupKey 'Symm s) -generateGroupKeyFancy mbk pks = create -- GroupKeySymmFancy <$> create <*> pure schema <*> pure keyId +generateGroupKeyFancy mbk pks = create where create = do + now <- liftIO getPOSIXTime <&> Just . round sk <- maybe1 mbk (liftIO SK.newKey) pure rcpt <- forM pks $ \pk -> do box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox pure (pk, box) - let ha = hashObject @HbSync (serialise sk) - pure $ GroupKeySymmFancy (HashMap.fromList rcpt) (Just GroupKeyIdJustHash) (Just (GroupKeyId (coerce ha))) + -- TODO: GroupKeyIdJustHash-implies-timestamp + -- теперь просто хэш = хэш (ключ, таймстемп) + -- так лучше + let ha = hashObject @HbSync (serialise (sk,now)) + pure $ GroupKeySymmFancy + (HashMap.fromList rcpt) + (Just GroupKeyIdJustHash) + (Just (GroupKeyId (coerce ha))) + now lookupGroupKey :: forall s . ( ForGroupKeySymm s , PubKey 'Encrypt s ~ AK.PublicKey