wip, basic refchan commands to cli

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
+  brief "stores groupkey to the peer's storage" $
-        ha <- writeAsMerkle sto (serialise gk)
+   args [arg "string" "groupkey"] $
-        pure $ mkStr (show $ pretty ha)
+   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] \

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)
 

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

@@ -107,9 +107,10 @@ data instance GroupKey 'Symm s =
     { recipients :: Recipients s
     }
   | GroupKeySymmFancy
-    { recipients       :: Recipients s
+    { recipients         :: Recipients s
-    , groupKeyIdScheme :: Maybe GroupKeyIdScheme
+    , groupKeyIdScheme   :: Maybe GroupKeyIdScheme
-    , groupKeyId       :: Maybe GroupKeyId
+    , groupKeyId         :: Maybe GroupKeyId
+    , groupKeyTimestamp  :: Maybe Word64
     }
   deriving stock (Generic)
 
@@ -119,14 +120,19 @@ deriving instance
     )
     => Eq (GroupKey 'Symm s)
 
+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 a) (GroupKeySymmPlain b) = GroupKeySymmFancy (a <> b) mzero mzero mzero
-  (<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k) = GroupKeySymmFancy (r0 <> r) s k
+  (<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k t) = GroupKeySymmFancy (r0 <> r) s k t
-  (<>) (GroupKeySymmFancy r s k) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k
+  (<>) (GroupKeySymmFancy r s k t) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k t
-  (<>) (GroupKeySymmFancy r0 s0 k0) (GroupKeySymmFancy r1 s1 k1) = GroupKeySymmFancy (r0 <> r1) (s1 <|> s0) (k1 <|> k0)
+  (<>) (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
@@ -175,7 +181,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
@@ -190,8 +196,8 @@ instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where
 
       case version of
         2 -> do
-          (s,kid) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId)
+          (s,kid, t) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId, Maybe Word64)
-          pure $ GroupKeySymmFancy recipientsV1 s kid
+          pure $ GroupKeySymmFancy recipientsV1 s kid t
 
         _ -> pure $ GroupKeySymmPlain recipientsV1
 
@@ -253,15 +259,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)
+      -- TODO: GroupKeyIdJustHash-implies-timestamp
-      pure $ GroupKeySymmFancy (HashMap.fromList rcpt) (Just GroupKeyIdJustHash) (Just (GroupKeyId (coerce ha)))
+      --   теперь просто хэш = хэш (ключ, таймстемп)
+      --   так лучше
+      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