diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index b6f4e8f3..94f5e7e3 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -13,8 +13,8 @@ import Fixme.GK import HBS2.Git.Local.CLI import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents,getGroupKeyHash) +import HBS2.Merkle.MetaData -import HBS2.Polling import HBS2.OrDie import HBS2.Base58 import HBS2.Net.Auth.GroupKeySymm @@ -38,6 +38,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString qualified as BS import Data.Either +import Data.Map qualified as Map import Data.Maybe import Data.HashSet qualified as HS import Data.HashMap.Strict (HashMap) @@ -612,33 +613,66 @@ refchanImport = do else do - what <- liftIO (runExceptT $ getTreeContents sto href) - <&> either (const Nothing) Just - >>= toMPlus + -- check if metadata tx + meta <- runExceptT (extractMetaData @'HBS2Basic (const $ pure Nothing) sto href) + <&> fromRight mempty - exported <- deserialiseOrFail @[FixmeExported] what - & toMPlus + let parsed = parseTop meta & fromRight mempty - for_ exported $ \e -> do - atomically $ writeTQueue tq (txh, orig, href, e) + let isGk = not $ L.null [ True | ListVal [SymbolVal "GK:", _] <- parsed ] + + notice $ "metadata:" <+> pretty isGk <+> pretty parsed + + if isGk then do + + -- TODO: check-error-type + what <- liftIO (runExceptT $ getTreeContents sto href) + <&> either (const Nothing) Just + >>= toMPlus + + gkz <- deserialiseOrFail @[GroupKey 'Symm 'HBS2Basic] what + & toMPlus + + for_ gkz $ \gk -> do + atomically $ writeTQueue tq (Left (txh, orig, href, gk)) + + + else do + what <- liftIO (runExceptT $ getTreeContents sto href) + <&> either (const Nothing) Just + >>= toMPlus + + exported <- deserialiseOrFail @[FixmeExported] what + & toMPlus + + for_ exported $ \e -> do + atomically $ writeTQueue tq (Right (txh, orig, href, e)) imported <- atomically $ flushTQueue tq withState $ transactional do - for_ imported $ \(txh, h, href, i) -> do - w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h - let item = i { exportedWeight = w } + for_ imported $ \case + Left (txh, orig, href, gk) -> do + hx <- writeAsMerkle sto (serialise gk) + notice $ "import GK" <+> pretty hx <+> "from" <+> pretty href + insertScanned txh + -- TODO: ASAP-notify-hbs2-keyman + pure () - if exportedWeight item /= 0 then do - notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) - insertFixmeExported (localNonce (href,i)) item - else do - debug $ "SKIP TX!" <+> pretty txh + Right (txh, h, href, i) -> do + w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h + let item = i { exportedWeight = w } - atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h - insertScanned txh - insertScanned href - for_ atx insertScanned + if exportedWeight item /= 0 then do + notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) + insertFixmeExported (localNonce (href,i)) item + else do + debug $ "SKIP TX!" <+> pretty txh + + atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h + insertScanned txh + insertScanned href + for_ atx insertScanned fixmeRefChanInit :: FixmePerks m => FixmeM m () @@ -844,7 +878,17 @@ refchanExportGroupKeys = do rch <- RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan) >>= orThrowUser "can't request refchan head" - hashes <- L.sort <$> S.toList_ do + au <- asks fixmeEnvAuthor + >>= readTVarIO + >>= orThrowUser "author's key not set" + + creds <- runKeymanClientRO $ loadCredentials au + >>= orThrowUser "can't read credentials" + + + let (pk,sk) = (view peerSignPk creds, view peerSignSk creds) + + keyz <- Map.fromList <$> S.toList_ do for_ r $ \gkh -> void $ runMaybeT do gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk) @@ -854,31 +898,36 @@ refchanExportGroupKeys = do warn $ "unaccessible group key" <+> pretty gkh mzero - debug $ red "prepare new gk0" <+> pretty gkh <+> pretty (groupKeyId gk) - gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch) - gkh1 <- writeAsMerkle sto (serialise gk1) <&> HashRef - lift $ S.yield gkh1 + let lbs = serialise gk1 + -- gkh1 <- writeAsMerkle sto lbs <&> HashRef + debug $ red "prepare new gk0" <+> pretty (LBS.length lbs) <+> pretty gkh <+> pretty (groupKeyId gk) + lift $ S.yield (groupKeyId gk, gk1) - notice $ yellow $ "new gk:" <+> pretty (L.length hashes) + notice $ yellow $ "new gk:" <+> pretty (Map.size keyz) - -- scanned <- lift $ selectIsAlreadyScanned href + let nitems = 262144 `div` (125 * HS.size (view refChanHeadReaders rch) ) + let chunks = Map.elems keyz & chunksOf nitems - -- -- notice $ yellow "SCANNED" <+> pretty scanned + for_ chunks $ \x -> do - -- if scanned then do - -- atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh - -- lift $ withState $ transactional do - -- insertScanned txh - -- for_ atx insertScanned + let gktreemeta = HM.fromList [ ("GK", Text.pack (show $ pretty $ L.length x)) ] + -- group keys are public (and already encrypted) + -- therefore, no encryption + href <- liftIO $ createTreeWithMetadata sto mzero gktreemeta (serialise x) + >>= orThrowPassIO - -- else do + let tx = AnnotatedHashRef Nothing href - -- -- FIXME: decrypt-tree - -- what <- liftIO (runExceptT $ getTreeContents sto href) - -- <&> either (const Nothing) Just - -- >>= toMPlus + let lbs = serialise tx + + let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs) + + warn $ "POST GK TX" <+> pretty (length x) <+> "tree" <+> pretty href + + result <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (chan, box) + + when (isNothing result) do + err $ red "hbs2-peer rpc calling timeout" - -- exported <- deserialiseOrFail @[FixmeExported] what - -- & toMPlus