wip

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

@@ -14,6 +14,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G
 import HBS2.Net.Auth.GroupKeySymm as Symm
 import HBS2.Storage
 
+import HBS2.KeyMan.Keys.Direct
 
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client
@@ -125,22 +126,14 @@ groupKeyEntries = do
 
   entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do
     case syn of
-
-      [StringLike "--file", StringLike fn] -> do
-        notice "READ-FROM-FILE"
-
+      -- TODO: from-file
+      -- TODO: from-stdin
+      -- TODO: base58 file
       [HashLike gkh] -> do
-        sto <- getStorage
-
-        lbs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh)))
-                 >>= orThrowUser "can't read merkle tree"
-
-        gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) lbs & orThrowUser "invalid group key"
-
+        gk <- loadGroupKey gkh
         liftIO $ print $ pretty gk
 
-      _ -> do
-        notice "READ-FROM-STDIN"
+      _ -> throwIO $ BadFormException @C nil
 
   entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
     case syn of
@@ -156,6 +149,25 @@ groupKeyEntries = do
 
       _ -> throwIO $ BadFormException @C nil
 
+  brief "find groupkey secret in hbs2-keyman" $
+    args [arg "string" "group-key-hash"] $
+    returns "secret-key-id" "string" $
+    entry $ bindMatch "hbs2:groupkey:find-secret" $ \case
+      [HashLike gkh] -> do
+
+        sto <- getStorage
+
+        gk <- loadGroupKey gkh >>= orThrowUser "can't load groupkey"
+
+        what <- runKeymanClient $ findMatchedGroupKeySecret sto gk
+                   >>= orThrowUser "groupkey secret not found"
+
+        let gid = generateGroupKeyId GroupKeyIdBasic1 what
+
+        pure $ mkStr (show $ pretty gid)
+
+      _ -> throwIO $ BadFormException @c nil
+
 
   entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
     [BlobLike bs] -> do

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

@@ -271,6 +271,12 @@ generateGroupKeyPlain mbk rcpt = do
 groupKeyCheckSeed :: N.ByteString
 groupKeyCheckSeed = BS.replicate 32 0
 
+generateGroupKeyId :: GroupKeyIdScheme -> GroupSecret -> GroupKeyId
+generateGroupKeyId _ sk = do
+    let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) groupKeyCheckSeed
+    let ha = hashObject @HbSync enc
+    GroupKeyId (coerce ha)
+
 generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
                  => Maybe GroupSecret
                  -> [PubKey 'Encrypt s]
@@ -278,18 +284,18 @@ generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Enc
 
 generateGroupKeyFancy mbk pks = create
   where
+    scheme = GroupKeyIdBasic1
     create = do
       now <- liftIO getPOSIXTime <&> Just . round
       sk <- maybe1 mbk (liftIO SK.newKey) pure
       rcpt <- forM pks $ \pk -> do
                 box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
                 pure (pk, box)
-      let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) groupKeyCheckSeed
-      let ha = hashObject @HbSync enc
+      let theId = generateGroupKeyId scheme sk
       pure $ GroupKeySymmFancy
                 (HashMap.fromList rcpt)
-                (Just GroupKeyIdBasic1)
-                (Just (GroupKeyId (coerce ha)))
+                (Just scheme)
+                (Just theId)
                 now
 
 lookupGroupKey :: forall s .  ( ForGroupKeySymm s

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs

@@ -5,6 +5,8 @@ import HBS2.KeyMan.Prelude
 import HBS2.KeyMan.State
 import HBS2.KeyMan.Config
 
+import HBS2.Storage
+import HBS2.Data.Types.Refs
 import HBS2.Prelude.Plated
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.GroupKeySymm as Symm
@@ -19,10 +21,12 @@ import DBPipe.SQLite
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Maybe
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Control.Monad.Trans.Maybe
 import Data.List qualified as List
 import Data.ByteString qualified as BS
 import Data.Ord
+import Data.Coerce
 import Streaming.Prelude qualified as S
 
 data KeyManClientError = KeyManClientSomeError
@@ -122,3 +126,70 @@ extractGroupKeySecret gk = do
 
     pure $ headMay r
 
+
+type TrackGroupKeyView = ( SomeHash GroupKeyId
+                         , SomeHash HashRef
+                         , String
+                         , FilePath
+                         , Int)
+
+findMatchedGroupKeySecret :: forall s m . ( MonadIO m
+                                          , SerialisedCredentials 'HBS2Basic
+                                          , s ~ 'HBS2Basic
+                                          )
+                        => AnyStorage
+                        -> GroupKey 'Symm s
+                        -> KeyManClient m (Maybe GroupSecret)
+
+findMatchedGroupKeySecret sto gk = do
+
+  let sql = [qc|
+      select t.secret
+           , t.gkhash
+           , f.key
+           , f.file
+           , kw.weight
+      from  gkaccess gka
+            join gktrack t on gka.gkhash = t.gkhash
+            join keyfile f on f.key = gka.key
+            left join keyweight kw on kw.key = f.key
+      where t.secret = ?
+      order by kw.weight desc nulls last
+          |]
+
+  let pks = recipients gk & HM.keysSet
+
+  flip runContT pure $ callCC $ \exit -> do
+
+    kre0 <- lift $ loadKeyRingEntries (HS.toList pks) <&> fmap snd
+
+    sec0 <- findSecretDefault kre0 gk
+
+    -- возвращаем первый, который нашли
+    maybe1 sec0 none (exit . Just)
+
+    -- если старый формат ключа -- то ничего не найдём
+    secId <- ContT $ maybe1 (getGroupKeyId gk) (pure Nothing)
+
+    rows <- lift $ KeyManClient $ select @TrackGroupKeyView sql (Only (SomeHash secId))
+
+    let gkss = HS.fromList (fmap (coerce @_ @HashRef . view _2) rows) & HS.toList
+
+    -- TODO: memoize
+
+    -- ищем такой же
+    --   если нашли -- хорошо бы проверить пруф, но как?
+    --   для исходного ключа -- мы оказались здесь потому,
+    --   что не смогли достать секрет из него и ищем такой же,
+    --   но доступный нам. соответственно, мы не можем убедиться,
+    --   что исходный ключ с правильным Id / правильным секретом.
+    --   можем только обломаться при расшифровке и записать этот факт
+    for_ gkss $ \gkh -> void $ runMaybeT do
+      gkx <- loadGroupKeyMaybe @s sto gkh >>= toMPlus
+      sec' <- lift $ lift $ extractGroupKeySecret gkx
+      maybe1 sec' none $ (lift . exit . Just)
+
+    pure Nothing
+
+
+

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs

@@ -10,8 +10,8 @@ module HBS2.KeyMan.State
 
 import HBS2.Prelude.Plated
 import HBS2.Base58
+import HBS2.Hash
 import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto.Types
 import HBS2.Data.Types.Refs
 import HBS2.Net.Auth.GroupKeySymm as Exported
 
@@ -23,7 +23,6 @@ import DBPipe.SQLite
 -- import Crypto.Saltine.Core.Box qualified as Encrypt
 import System.Directory
 import System.FilePath
-import Control.Monad.Trans.Maybe
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Maybe
 import Data.HashSet (HashSet)
@@ -46,11 +45,17 @@ instance FromField (SomeHash HashRef) where
 instance ToField (SomeHash GroupKeyId) where
   toField (SomeHash x) = toField $ show $ pretty x
 
+instance FromField (SomeHash GroupKeyId) where
+  fromField = do
+    fmap (SomeHash . convert . fromString @HashRef) . fromField @String
+    where
+      convert ha = GroupKeyId (coerce ha)
+
 -- newtype ToDB a = ToDB a
 class SomePubKeyType a where
   somePubKeyType :: a -> String
 
-type SomePubKeyPerks a = (Pretty (AsBase58 a))
+type SomePubKeyPerks a = (Pretty (AsBase58 a), FromStringMaybe a)
 
 data SomePubKey (c :: CryptoAction) = forall a . SomePubKeyPerks a => SomePubKey a
 
@@ -135,7 +140,6 @@ populateState = do
 instance ToField (SomePubKey a) where
   toField (SomePubKey s) = toField $ show $ pretty (AsBase58 s)
 
-
 updateKeyFile :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m)
               => SomePubKey a
               -> FilePath
@@ -285,3 +289,7 @@ insertGKAccess gkh gk = do
       on conflict (gkhash,key) do nothing
               |] (SomeHash gkh, SomePubKey k)
 
+
+
+
+