wip

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

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
 

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
 

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

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)
 

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