wip

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)
+          -- check if metadata tx
-                    <&> either (const Nothing) Just
+          meta <- runExceptT (extractMetaData @'HBS2Basic (const $ pure Nothing) sto href)
-                    >>= toMPlus
+                     <&> fromRight mempty
 
-          exported <- deserialiseOrFail @[FixmeExported] what
+          let parsed = parseTop meta & fromRight mempty
-                        & toMPlus
 
-          for_ exported $ \e -> do
+          let isGk = not $ L.null [ True | ListVal [SymbolVal "GK:", _] <- parsed ]
-              atomically $ writeTQueue tq (txh, orig, href, e)
+
+          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
+    for_ imported $ \case
-      w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
+      Left (txh, orig, href, gk) -> do
-      let item = i { exportedWeight = w }
+        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
+      Right (txh, h, href, i) -> do
-        notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item)
+        w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
-        insertFixmeExported (localNonce (href,i)) item
+        let item = i { exportedWeight = w }
-      else do
-        debug $ "SKIP TX!" <+> pretty txh
 
-      atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h
+        if exportedWeight item /= 0 then do
-      insertScanned txh
+          notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item)
-      insertScanned href
+          insertFixmeExported (localNonce (href,i)) item
-      for_ atx insertScanned
+        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
+      let lbs = serialise gk1
-      lift $ S.yield gkh1
+      -- 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
+      let gktreemeta = HM.fromList [ ("GK", Text.pack (show $ pretty $ L.length x)) ]
-        --   atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh
+      -- group keys are public (and already encrypted)
-        --   lift $ withState $ transactional do
+      -- therefore, no encryption
-        --     insertScanned txh
+      href <- liftIO $ createTreeWithMetadata sto mzero gktreemeta (serialise x)
-        --     for_ atx insertScanned
+                >>= orThrowPassIO
 
-        -- else do
+      let tx = AnnotatedHashRef Nothing href
 
-        --   -- FIXME: decrypt-tree
+      let lbs = serialise tx
-        --   what <- liftIO (runExceptT $ getTreeContents sto href)
+
-        --             <&> either (const Nothing) Just
+      let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
-        --             >>= toMPlus
+
+      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