wip

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

@@ -10,13 +10,15 @@ 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.CLI.Run.Internal.GroupKey as G
 import HBS2.Net.Auth.GroupKeySymm as Symm
 
 import HBS2.Net.Auth.Credentials
 
 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 Control.Monad.Trans.Cont
 import Control.Monad.Except
@@ -92,4 +94,30 @@ groupKeyEntries = do
       _ -> throwIO $ BadFormException @C nil
 
 
+  entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
+    [BlobLike bs] -> flip runContT pure do
+
+      sto <- ContT withPeerStorage
+
+      let lbs = LBS.fromStrict bs
+
+      seb <- pure (deserialiseOrFail lbs)
+               `orDie` "invalid SmallEncryptedBlock"
+
+      decrypted <- lift $ G.decryptBlock sto seb
+
+      pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)]
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case
+    [StringLike gkh, BlobLike what] -> do
+      flip runContT pure do
+        sto <- ContT withPeerStorage
+        gk <- lift $ loadGroupKey (fromString gkh)
+                `orDie` "can't load group key"
+        seb <- lift $ G.encryptBlock sto gk what
+        pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))]
+
+    _ -> throwIO $ BadFormException @C nil
 

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

@@ -21,6 +21,7 @@ import Data.Text qualified as Text
 import Data.Text.IO qualified as TIO
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString (ByteString)
 import Control.Monad.Identity
 import Control.Monad.Writer
 
@@ -32,6 +33,8 @@ pattern StringLike e <- (stringLike -> Just e)
 pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
 pattern StringLikeList e <- (stringLikeList -> e)
 
+pattern BlobLike :: forall {c} . ByteString -> Syntax c
+pattern BlobLike s <- (blobLike -> Just s)
 
 class Display a where
   display :: MonadIO m => a -> m ()
@@ -39,9 +42,12 @@ class Display a where
 instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
   display = liftIO . print . pretty
 
-instance Display (Syntax c) where
+instance IsContext c => Display (Syntax c) where
   display = \case
     LitStrVal s -> liftIO $ TIO.putStr s
+    ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do
+      let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+      liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)
     ListVal [SymbolVal "blob", LitStrVal txt] -> do
       let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
       liftIO $ print $ parens $ "blob:base58" <+> dquotes s
@@ -112,6 +118,12 @@ stringLike = \case
 stringLikeList :: [Syntax c] -> [String]
 stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
 
+blobLike :: Syntax c -> Maybe ByteString
+blobLike = \case
+  LitStrVal s -> Just $ BS8.pack (Text.unpack s)
+  ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)
+  _ -> Nothing
+
 pattern PairList :: [Syntax c] -> [Syntax c]
 pattern PairList es <- (pairList -> es)
 
@@ -471,6 +483,7 @@ internalEntries = do
       e -> throwIO (BadFormException @c nil)
 
     entry $ bindMatch "base58:decode" $ \case
+
       [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
         s <- decodeB58 t <&> BS8.unpack
         pure $ mkForm "blob" [mkStr @c s]

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

@@ -1,15 +1,20 @@
-module HBS2.CLI.Run.Internal.GroupKey where
+module HBS2.CLI.Run.Internal.GroupKey
+  ( module HBS2.CLI.Run.Internal.GroupKey
+  , SmallEncryptedBlock(..)
+  ) where
 
 import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
 
+import HBS2.Storage
 import HBS2.Data.Types.Refs
 import HBS2.Data.Types.SmallEncryptedBlock
 import HBS2.Storage.Operations.Class
 import HBS2.Storage.Operations.ByteString
-import Data.Maybe
+import HBS2.KeyMan.Keys.Direct
-import HBS2.CLI.Run.Internal
 import HBS2.Net.Auth.GroupKeySymm as Symm
 
+import Data.Maybe
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
 import Codec.Serialise
@@ -22,11 +27,27 @@ groupKeyFromKeyList ks = do
 
 
 encryptBlock :: MonadUnliftIO m
-             => GroupKey 'Symm 'HBS2Basic
+             => AnyStorage
+             -> GroupKey 'Symm 'HBS2Basic
              -> ByteString
              -> m (SmallEncryptedBlock ByteString)
 
-encryptBlock gk bs = undefined
+encryptBlock sto gk bs = do
+  gks <- runKeymanClient (extractGroupKeySecret gk)
+           >>= orThrowUser "can't extract group key secret"
+
+  Symm.encryptBlock sto gks (Right gk) Nothing bs
+
+decryptBlock :: MonadUnliftIO m
+             => AnyStorage
+             -> SmallEncryptedBlock ByteString
+             -> m ByteString
+decryptBlock sto seb = do
+  let find gk = runKeymanClient (extractGroupKeySecret gk)
+
+  -- FIXME: improve-error-diagnostics
+  runExceptT (Symm.decryptBlock sto find seb)
+     >>= orThrowUser "can't decrypt block"
 
 loadGroupKey :: (IsContext c, MonadUnliftIO m) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic))
 loadGroupKey h = do

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

@@ -403,16 +403,17 @@ decryptBlock :: forall t s sto h m . ( MonadIO m
                                      )
 
              => sto
-             -> [KeyringEntry s]
+             -> (GroupKey 'Symm s -> m (Maybe GroupSecret))
              -> SmallEncryptedBlock t
              -> m t
 
-decryptBlock sto keys (SmallEncryptedBlock{..}) = do
+decryptBlock sto findKey (SmallEncryptedBlock{..}) = do
 
   gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0))
   gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs)
 
-  let gksec' = [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
+  gksec' <- findKey gk
+  -- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
 
   gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure