mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
bbf0d8ef62
commit
47a668d5ff
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue