diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index c737bfe6..fe7f7a18 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -103,6 +103,7 @@ library HBS2.CLI.Bind HBS2.CLI.Run HBS2.CLI.Run.Internal + HBS2.CLI.Run.Internal.GroupKey HBS2.CLI.Run.GroupKey HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 1c1a8c53..ee6fa374 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -1,12 +1,16 @@ module HBS2.CLI.Run.GroupKey where - import HBS2.CLI.Prelude hiding (mapMaybe) + +import HBS2.Data.Types.Refs import HBS2.System.Logger.Simple.ANSI as All +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString import HBS2.Base58 import Data.List qualified as L import Data.Maybe import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Net.Auth.Credentials @@ -14,21 +18,43 @@ import HBS2.Net.Auth.Credentials import Data.Text qualified as Text import Data.ByteString.Lazy.Char8 as LBS8 import Data.HashMap.Strict qualified as HM +import Control.Monad.Trans.Cont +import Control.Monad.Except +import Codec.Serialise import Lens.Micro.Platform {- HLINT ignore "Functor law" -} -groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic) -groupKeyFromKeyList ks = do - let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks - Symm.generateGroupKey @'HBS2Basic Nothing members groupKeyEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () groupKeyEntries = do + entry $ bindMatch "hbs2:groupkey:load" $ \case + [StringLike s] -> do + flip runContT pure do + sto <- ContT withPeerStorage + + gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s))) + >>= orThrowUser "can't load group key" + <&> deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) + >>= orThrowUser "invalid group key" + + pure $ mkStr (show $ pretty $ AsGroupKeyFile gk) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:groupkey:store" $ \case [LitStrVal s] -> do - error "FUCK" + flip runContT pure do + + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" + + sto <- ContT withPeerStorage + ha <- writeAsMerkle sto (serialise gk) + pure $ mkStr (show $ pretty ha) _ -> throwIO $ BadFormException @C nil diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index cb8f9938..3a1b867d 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -279,6 +279,14 @@ runExpr syn = handle (handleForm syn) $ case syn of (BadFormException _ :: BadFormException c) -> do throwIO (BadFormException syn) +runM :: forall c m a. ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Dict c m -> RunM c m a -> m a +runM d m = do + tvd <- newTVarIO d + runReaderT (fromRunM m) tvd + run :: forall c m . ( IsContext c , MonadUnliftIO m , Exception (BadFormException c) @@ -379,6 +387,10 @@ internalEntries = do [ sy ] -> display sy ss -> mapM_ display ss + entry $ bindMatch "println" $ nil_ $ \case + [ sy ] -> display sy >> liftIO (putStrLn "") + ss -> mapM_ display ss >> liftIO (putStrLn "") + entry $ bindMatch "str:read-stdin" $ \case [] -> liftIO getContents <&> mkStr @c diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs new file mode 100644 index 00000000..fb7cf82d --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs @@ -0,0 +1,36 @@ +module HBS2.CLI.Run.Internal.GroupKey where + +import HBS2.CLI.Prelude hiding (mapMaybe) + +import HBS2.Data.Types.Refs +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString +import Data.Maybe +import HBS2.CLI.Run.Internal +import HBS2.Net.Auth.GroupKeySymm as Symm + +import Control.Monad.Trans.Cont +import Control.Monad.Except +import Codec.Serialise + +groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic) +groupKeyFromKeyList ks = do + let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks + Symm.generateGroupKey @'HBS2Basic Nothing members + + +loadGroupKey :: (IsContext c, MonadUnliftIO m) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic)) +loadGroupKey h = do + + flip runContT pure do + sto <- ContT withPeerStorage + + raw <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h))) + <&> either (const Nothing) Just + + bs <- ContT (maybe1 raw (pure Nothing)) + + let gk = deserialiseOrFail bs + & either (const Nothing) Just + + pure gk diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 6cbeaba1..582830a9 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -4,6 +4,7 @@ module HBS2.CLI.Run.MetaData (metaDataEntries) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey import HBS2.Data.Types.Refs import HBS2.Merkle @@ -53,10 +54,11 @@ metaFromSyntax syn = t x = Text.pack (show $ pretty x) createTreeWithMetadata :: (MonadUnliftIO m) - => HashMap Text Text + => Maybe (GroupKey 'Symm 'HBS2Basic) + -> HashMap Text Text -> LBS.ByteString -> m HashRef -createTreeWithMetadata meta lbs = do +createTreeWithMetadata mgk meta lbs = do debug "create fucking metadata" -- TODO: set-hbs2-peer so <- detectRPC `orDie` "hbs2-peer not found" @@ -169,12 +171,17 @@ metaDataEntries = do let meta1 = HM.fromList [ (txt n, txt e) | MetaDataEntry n e <- universeBi opts ] - let enc = headMay [ x | x@(Encrypted _) <- universeBi opts ] + let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ] - when (isJust enc) do - error "ENCRYPTION" + gk <- runMaybeT do + s <- toMPlus enc + g <- lift $ loadGroupKey (fromString s) + toMPlus g - href <- createTreeWithMetadata (meta0 <> meta1) lbs + when (isJust enc && isNothing gk) do + error $ show $ "Can't load group key" <+> pretty enc + + href <- createTreeWithMetadata gk (meta0 <> meta1) lbs pure $ mkStr (show $ pretty href) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 5b536f25..f23d11ac 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs @@ -53,6 +53,8 @@ peerEntries = do pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)] + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "hbs2:peer:has-block" $ \case [StringLike s] -> do flip runContT pure do