diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 5b986a57..a3de23e6 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 422d42a4..97567526 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/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 diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs index c06d6a1a..753b6e9f 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs +++ b/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 + + + diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs index 1b4bb330..8fa8e3a2 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs +++ b/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) + + + +