wip, group key update works

hbs2-cli/hbs2-cli.cabal

@@ -110,6 +110,7 @@ library
       HBS2.CLI.Run.Keyring
       HBS2.CLI.Run.MetaData
       HBS2.CLI.Run.Peer
+      HBS2.CLI.Run.RefLog
       HBS2.CLI.Run.Sigil
 
       HBS2.CLI.Run.Help

hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs

@@ -14,12 +14,14 @@ import HBS2.CLI.Run.Internal.GroupKey as G
 import HBS2.Net.Auth.GroupKeySymm as Symm
 
 import HBS2.Net.Auth.Credentials
+import HBS2.KeyMan.Keys.Direct
 
 import Data.Text qualified as Text
 import Data.ByteString.Lazy.Char8 as LBS8
 import Data.ByteString.Lazy as LBS
 import Data.ByteString.Char8 as BS8
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
 import Codec.Serialise
@@ -45,7 +47,6 @@ groupKeyEntries = do
 
       _ -> throwIO $ BadFormException @C nil
 
-
   entry $ bindMatch "hbs2:groupkey:store" $ \case
       [LitStrVal s] -> do
         flip runContT pure do
@@ -60,6 +61,28 @@ groupKeyEntries = do
 
       _ -> throwIO $ BadFormException @C nil
 
+
+-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
+--             [list [remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8] \
+--                   [add . 5sJXsw7qhmq521hwhE67jYvrD6ZNVazc89rFwfWaQPyY]] ]
+--
+  entry $ bindMatch "hbs2:groupkey:update" $ \case
+    [LitStrVal s, ListVal ins] -> do
+
+      flip runContT pure do
+
+        sto <- ContT withPeerStorage
+
+        let lbs = LBS8.pack (Text.unpack s)
+        gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                `orDie` "invalid group key"
+
+        gk1 <- lift $ modifyGroupKey gk ins
+
+        pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)
+
+    _ -> throwIO $ BadFormException @C nil
+
   entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
     case syn of
       [ListVal (StringLikeList keys)] -> do

hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs

@@ -6,6 +6,7 @@ module HBS2.CLI.Run.Internal.GroupKey
 import HBS2.CLI.Prelude hiding (mapMaybe)
 import HBS2.CLI.Run.Internal
 
+import HBS2.Base58
 import HBS2.Hash
 import HBS2.Storage
 import HBS2.Data.Types.Refs
@@ -15,6 +16,8 @@ import HBS2.Storage.Operations.ByteString
 import HBS2.KeyMan.Keys.Direct
 import HBS2.Net.Auth.GroupKeySymm as Symm
 
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Data.Maybe
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
@@ -68,3 +71,29 @@ loadGroupKey h = do
               & either (const Nothing) Just
 
     pure gk
+
+modifyGroupKey :: (IsContext c, MonadUnliftIO m)
+               => GroupKey 'Symm 'HBS2Basic
+               -> [Syntax c]
+               -> m (GroupKey 'Symm HBS2Basic)
+modifyGroupKey gk ins = do
+
+  gks <- runKeymanClient do
+          extractGroupKeySecret gk
+         `orDie` "can't extract group key secret"
+
+  let r = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "remove", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let a = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "add", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let x = recipients gk & HM.keysSet
+
+  let new = x `HS.difference` r `mappend` a & HS.toList
+
+  generateGroupKey @'HBS2Basic (Just gks) new
+
+

hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs

@@ -21,8 +21,26 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.HashMap.Strict qualified as HM
 import Data.Text qualified as Text
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
 import Control.Monad.Except
 
+getGroupKeyHash :: (IsContext c, MonadUnliftIO m)
+                => HashRef
+                -> RunM c m (Maybe HashRef, MTreeAnn [HashRef])
+getGroupKeyHash h = do
+  flip runContT pure do
+    sto <- ContT withPeerStorage
+
+    headBlock <- getBlock sto (fromHashRef h)
+                   >>= orThrowUser  "no-block"
+                   <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                   >>= orThrowUser  "invalid block format"
+
+    case _mtaCrypt headBlock of
+      (EncryptGroupNaClSymm hash _) ->
+        pure $ (Just $ HashRef hash, headBlock)
+      _ -> pure (Nothing, headBlock)
+
 -- TODO: client-api-candidate
 createTreeWithMetadata :: (MonadUnliftIO m)
                        => AnyStorage

hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs

@@ -59,14 +59,55 @@ metaFromSyntax syn =
 metaDataEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
 metaDataEntries = do
 
+  entry $ bindMatch "hbs2:tree:metadata:update-gk" $ \case
+    [StringLike tree, ListVal ins] -> do
+
+      ha <- orThrowUser "invalid hash" (fromStringMay tree)
+
+      -- 1. load-group-key
+      (gkh', headBlk) <- getGroupKeyHash ha
+
+      gkh <- orThrowUser "not encrypted" gkh'
+
+      gk <- loadGroupKey gkh
+              >>= orThrowUser "can't load gk"
+
+      gk1 <- modifyGroupKey gk ins
+
+      flip runContT pure do
+        sto <- ContT withPeerStorage
+        gk1h <- writeAsMerkle sto (serialise gk1)
+
+        case headBlk of
+          w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do
+            let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce }
+
+            h <- putBlock sto (serialise w1)
+                   >>= orThrowUser "can't put block"
+
+            pure $ mkStr (show $ pretty h)
+
+          _ -> pure nil
+
+    _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:tree:metadata:get-gk" $ \case
+    [ StringLike hash ] -> flip runContT pure do
+
+      (gk,_) <- lift $ getGroupKeyHash (fromString hash)
+
+      case gk of
+        Just h -> pure $ mkStr (show $ pretty h)
+        _      -> pure nil
+
+    _ -> throwIO (BadFormException @c nil)
+
   entry $ bindMatch "hbs2:tree:metadata:get" $ \case
     [ SymbolVal how, StringLike hash ] -> do
 
-      -- FIXME: put-to-the-state
-      so <- detectRPC `orDie` "hbs2-peer not found"
+      r <- flip runContT pure do
 
-      r <- withRPC2 @StorageAPI  @UNIX so $ \caller -> do
-        let sto = AnyStorage (StorageClient caller)
+        sto <- ContT withPeerStorage
 
         runMaybeT do
 
@@ -91,7 +132,7 @@ metaDataEntries = do
                  >>= toMPlus
                  <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
                  >>= toMPlus
-                 >>= lift . G.decryptBlock sto
+                 >>= lift . lift . G.decryptBlock sto
                  <&> \case
                   ShortMetadata s -> mkStr s
                   _ -> nil

hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs

@@ -0,0 +1,6 @@
+module HBS2.CLI.Run.RefLog where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+

hbs2/Main.hs

@@ -651,7 +651,6 @@ main = join . customExecParser (prefs showHelpOnError) $
                                <> command "update" (info pGroupKeySymmUpdate (progDesc "update") )
                                )
 
-
     pGroupKeyFromSigils = do
       fns <- many $ strArgument ( metavar "SIGIL-FILES" <> help "sigil file list" )
       pure $ do