diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 6d29d0c7..f9e3e2d7 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 907ed538..0f9cbeb2 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs index 515a67eb..f7af2a33 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs +++ b/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 + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs index 7122f3ce..a10cd76c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index c81e315e..4003fc6f 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs new file mode 100644 index 00000000..4c7fe603 --- /dev/null +++ b/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 + + diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 5abd81fd..98873d3f 100644 --- a/hbs2/Main.hs +++ b/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