mirror of https://github.com/voidlizard/hbs2
wip, fixed regression
This commit is contained in:
Dmitry Zuikov
parent
77fa0bfefb
commit
f8a461406c
|
|
@ -871,307 +871,3 @@ refchanExportGroupKeys = do
|
||||||
err $ red "hbs2-peer rpc calling timeout"
|
err $ red "hbs2-peer rpc calling timeout"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
fixmeRefChanInit :: FixmePerks m => FixmeM m ()
|
|
||||||
fixmeRefChanInit = do
|
|
||||||
let rch0 = refChanHeadDefault @L4Proto
|
|
||||||
sto <- getStorage
|
|
||||||
peer <- getClientAPI @PeerAPI @UNIX
|
|
||||||
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
|
||||||
|
|
||||||
dir <- localConfigDir
|
|
||||||
confFile <- localConfig
|
|
||||||
|
|
||||||
rchan <- asks fixmeEnvRefChan
|
|
||||||
>>= readTVarIO
|
|
||||||
|
|
||||||
flip runContT pure $ callCC \done -> do
|
|
||||||
|
|
||||||
when (isJust rchan) do
|
|
||||||
warn $ red "refchan is already set" <+> pretty (fmap AsBase58 rchan)
|
|
||||||
warn $ "done" <+> pretty (fmap AsBase58 rchan)
|
|
||||||
done ()
|
|
||||||
|
|
||||||
poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
|
|
||||||
>>= orThrowUser "hbs2-peer not connected"
|
|
||||||
<&> parseTop
|
|
||||||
<&> fromRight mempty
|
|
||||||
|
|
||||||
pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x
|
|
||||||
| ListVal [SymbolVal "peer-key:", StringLike x ] <- poked
|
|
||||||
] & headMay . catMaybes & orThrowUser "hbs2-peer key not set"
|
|
||||||
|
|
||||||
|
|
||||||
notice $ green "default peer" <+> pretty (AsBase58 pkey)
|
|
||||||
|
|
||||||
|
|
||||||
signK' <- lift $ runKeymanClientRO $ listCredentials
|
|
||||||
<&> headMay
|
|
||||||
|
|
||||||
signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman")
|
|
||||||
|
|
||||||
notice $ green "default author" <+> pretty (AsBase58 signK)
|
|
||||||
|
|
||||||
-- TODO: use-hbs2-git-api?
|
|
||||||
(_, gkh', _) <- readProcess (shell [qc|git hbs2 key|])
|
|
||||||
<&> over _2 ( (fromStringMay @HashRef) <=< (notEmpty . headDef "" . lines . LBS8.unpack) )
|
|
||||||
<&> \x -> case view _1 x of
|
|
||||||
ExitFailure _ -> set _2 Nothing x
|
|
||||||
ExitSuccess -> x
|
|
||||||
|
|
||||||
notice $ green "group key" <+> maybe "none" pretty gkh'
|
|
||||||
|
|
||||||
readers <- fromMaybe mempty <$> runMaybeT do
|
|
||||||
gh <- toMPlus gkh'
|
|
||||||
gk <- loadGroupKeyMaybe @'HBS2Basic sto gh
|
|
||||||
>>= toMPlus
|
|
||||||
pure $ HM.keys (recipients gk)
|
|
||||||
|
|
||||||
notice $ green "readers" <+> pretty (length readers)
|
|
||||||
|
|
||||||
rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers
|
|
||||||
<&> fmap snd . headMay
|
|
||||||
|
|
||||||
|
|
||||||
let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
|
|
||||||
& set refChanHeadAuthors (HS.singleton signK)
|
|
||||||
& set refChanHeadPeers (HM.singleton pkey 1)
|
|
||||||
|
|
||||||
|
|
||||||
let unlucky = HM.null (view refChanHeadPeers rch1)
|
|
||||||
|| HS.null (view refChanHeadAuthors rch1)
|
|
||||||
|
|
||||||
|
|
||||||
liftIO $ print $ pretty rch1
|
|
||||||
|
|
||||||
if unlucky then do
|
|
||||||
warn $ red $ "refchan definition is not complete;" <+>
|
|
||||||
"you may add missed keys, edit the" <+>
|
|
||||||
"defition and add if manually or repeat init attempt"
|
|
||||||
<> line
|
|
||||||
else do
|
|
||||||
notice "refchan definition seems okay, adding new refchan"
|
|
||||||
|
|
||||||
refchan <- lift $ keymanNewCredentials (Just "refchan") 0
|
|
||||||
|
|
||||||
creds <- lift $ runKeymanClientRO $ loadCredentials refchan
|
|
||||||
>>= orThrowUser "can't load credentials"
|
|
||||||
|
|
||||||
let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1
|
|
||||||
|
|
||||||
href <- writeAsMerkle sto (serialise box)
|
|
||||||
|
|
||||||
callService @RpcPollAdd peer (refchan, "refchan", 17)
|
|
||||||
>>= orThrowUser "can't subscribe to refchan"
|
|
||||||
|
|
||||||
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
|
||||||
>>= orThrowUser "can't post refchan head"
|
|
||||||
|
|
||||||
|
|
||||||
let nonce = take 6 $ show $ pretty (AsBase58 refchan)
|
|
||||||
let rchanFile = "refchan-" <> nonce <> ".local"
|
|
||||||
let rchanFilePath = dir </> rchanFile
|
|
||||||
|
|
||||||
let note = ";; author and reader are inferred automatically" <> line
|
|
||||||
<> ";; from hbs2-keyman data" <> line
|
|
||||||
<> ";; edit them if needed" <> line
|
|
||||||
<> ";; reader is *your* reading public key." <> line
|
|
||||||
<> ";; author is *your* signing public key." <> line
|
|
||||||
|
|
||||||
let refChanClause = mkList @C [ mkSym "refchan"
|
|
||||||
, mkSym (show $ pretty (AsBase58 refchan))
|
|
||||||
]
|
|
||||||
|
|
||||||
let theirReaderKeyClause = maybe1 rk ";; reader ..."$ \(KeyringEntry pk _ _) -> do
|
|
||||||
pretty $ mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) ) ]
|
|
||||||
|
|
||||||
let theirAuthorClause = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ]
|
|
||||||
|
|
||||||
let content = line
|
|
||||||
<> note
|
|
||||||
<> line
|
|
||||||
<> vcat [ theirReaderKeyClause
|
|
||||||
, pretty theirAuthorClause
|
|
||||||
]
|
|
||||||
|
|
||||||
liftIO do
|
|
||||||
writeFile rchanFilePath $
|
|
||||||
show content
|
|
||||||
|
|
||||||
appendFile confFile $ show $
|
|
||||||
line
|
|
||||||
<> vcat [ pretty refChanClause ]
|
|
||||||
<> line <>
|
|
||||||
pretty (mkList @C [ mkSym "source", mkSym ( "." </> rchanFile ) ])
|
|
||||||
|
|
||||||
notice $ green "refchan added" <+> pretty (AsBase58 refchan)
|
|
||||||
|
|
||||||
|
|
||||||
refchanExportGroupKeys :: FixmePerks m => FixmeM m ()
|
|
||||||
refchanExportGroupKeys = do
|
|
||||||
|
|
||||||
let gkHash x = hashObject @HbSync ("GKSCAN" <> serialise x) & HashRef
|
|
||||||
|
|
||||||
sto <- getStorage
|
|
||||||
|
|
||||||
chan <- asks fixmeEnvRefChan
|
|
||||||
>>= readTVarIO
|
|
||||||
>>= orThrowUser "refchan not set"
|
|
||||||
|
|
||||||
ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
|
|
||||||
|
|
||||||
let goodToGo x | ignCached = pure True
|
|
||||||
| otherwise = do
|
|
||||||
here <- selectIsAlreadyScanned (gkHash x)
|
|
||||||
pure $ not here
|
|
||||||
|
|
||||||
debug "refchanExportGroupKeys"
|
|
||||||
|
|
||||||
skip <- newTVarIO HS.empty
|
|
||||||
gkz <- newTVarIO HS.empty
|
|
||||||
|
|
||||||
fixmeSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
|
|
||||||
|
|
||||||
walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
|
|
||||||
|
|
||||||
case u of
|
|
||||||
P orig (ProposeTran _ box) -> void $ runMaybeT do
|
|
||||||
(_, bs) <- unboxSignedBox0 box & toMPlus
|
|
||||||
|
|
||||||
AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
|
|
||||||
& toMPlus . either (const Nothing) Just
|
|
||||||
|
|
||||||
result <- lift $ try @_ @OperationError (getGroupKeyHash href)
|
|
||||||
|
|
||||||
case result of
|
|
||||||
Right (Just gk,_) -> do
|
|
||||||
atomically do
|
|
||||||
modifyTVar gkz (HS.insert gk)
|
|
||||||
modifyTVar skip (HS.insert txh)
|
|
||||||
|
|
||||||
Right (Nothing,_) -> do
|
|
||||||
atomically $ modifyTVar skip (HS.insert txh)
|
|
||||||
|
|
||||||
Left UnsupportedFormat -> do
|
|
||||||
debug $ "unsupported" <+> pretty href
|
|
||||||
atomically $ modifyTVar skip (HS.insert txh)
|
|
||||||
|
|
||||||
Left e -> do
|
|
||||||
debug $ "other error" <+> viaShow e
|
|
||||||
|
|
||||||
_ -> none
|
|
||||||
|
|
||||||
l <- readTVarIO skip <&> HS.toList
|
|
||||||
r <- readTVarIO gkz <&> HS.toList
|
|
||||||
|
|
||||||
withState $ transactional do
|
|
||||||
for_ l (insertScanned . gkHash)
|
|
||||||
|
|
||||||
rchan <- asks fixmeEnvRefChan
|
|
||||||
>>= readTVarIO
|
|
||||||
>>= orThrowUser "refchan not set"
|
|
||||||
|
|
||||||
api <- getClientAPI @RefChanAPI @UNIX
|
|
||||||
|
|
||||||
rch <- RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
|
|
||||||
>>= orThrowUser "can't request refchan head"
|
|
||||||
|
|
||||||
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 <- Set.fromList <$> S.toList_ do
|
|
||||||
for_ r $ \gkh -> void $ runMaybeT do
|
|
||||||
|
|
||||||
debug $ red $ "FOR GK" <+> pretty gkh
|
|
||||||
|
|
||||||
gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus
|
|
||||||
|
|
||||||
-- the original groupkey should be indexed as well
|
|
||||||
lift $ S.yield gkh
|
|
||||||
|
|
||||||
gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk)
|
|
||||||
|
|
||||||
when (isNothing gks) do
|
|
||||||
-- lift $ withState (insertScanned (gkHash txh))
|
|
||||||
warn $ "unaccessible group key" <+> pretty gkh
|
|
||||||
mzero
|
|
||||||
|
|
||||||
gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch)
|
|
||||||
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 gkh1
|
|
||||||
|
|
||||||
notice $ yellow $ "new gk:" <+> pretty (Set.size keyz)
|
|
||||||
|
|
||||||
-- let nitems = 262144 `div` (125 * HS.size (view refChanHeadReaders rch) )
|
|
||||||
-- let chunks = Map.elems keyz & chunksOf nitems
|
|
||||||
|
|
||||||
-- TODO: gk:performance-vs-reliability
|
|
||||||
-- ситуация такова: групповой ключ это меркл-дерево
|
|
||||||
-- для одного и того же блоба могут быть разные меркл-деревья,
|
|
||||||
-- так как могут быть разные настройки.
|
|
||||||
--
|
|
||||||
-- если распространять ключи по-одному, то хотя бы тот же ключ,
|
|
||||||
-- который мы создали изначально -- будет доступен по своему хэшу,
|
|
||||||
-- как отдельный артефакт.
|
|
||||||
--
|
|
||||||
-- Если писать их пачками, где каждый ключ представлен непосредственно,
|
|
||||||
-- то на принимающей стороне нет гарантии, что меркл дерево будет писаться
|
|
||||||
-- с таким же параметрами, хотя и может.
|
|
||||||
--
|
|
||||||
-- Решение: делать групповой ключ БЛОКОМ. тогда его размер будет ограничен,
|
|
||||||
-- но он хотя бы будет всегда однозначно определён хэшем.
|
|
||||||
--
|
|
||||||
-- Решение: ссылаться не на групповой ключ, а на хэш его секрета
|
|
||||||
-- что ломает текущую схему и обратная совместимость будет морокой.
|
|
||||||
--
|
|
||||||
-- Решение: добавить в hbs2-keyman возможно индексации единичного
|
|
||||||
-- ключа, и индексировать таким образом *исходные* ключи.
|
|
||||||
--
|
|
||||||
-- Тогда можно эти вот ключи писать пачками, их хэши не имеют особого значения,
|
|
||||||
-- если мы проиндексируем оригинальный ключ и будем знать, на какой секрет он
|
|
||||||
-- ссылается.
|
|
||||||
--
|
|
||||||
-- Заметим, что в один блок поместится аж >2000 читателей, что должно быть
|
|
||||||
-- более, чем достаточно => при таких группах вероятность утечки секрета
|
|
||||||
-- стремится к 1.0, так как большинство клало болт на меры безопасности.
|
|
||||||
--
|
|
||||||
-- Кстати говоря, проблема недостаточного количества авторов в ключе легко
|
|
||||||
-- решается полем ORIGIN, т.к мы можем эти самые ключи разделять.
|
|
||||||
--
|
|
||||||
-- Что бы не стоять перед такой проблемой, мы всегда можем распостранять эти ключи
|
|
||||||
-- по-одному, ЛИБО добавить в производный ключ поле
|
|
||||||
-- ORIGIN: где будет хэш изначального ключа.
|
|
||||||
--
|
|
||||||
-- Это нормально, так как мы сможем проверить, что у этих ключей
|
|
||||||
-- (текущий и ORIGIN) одинаковые хэши секретов.
|
|
||||||
--
|
|
||||||
-- Это всё равно оставляет возможность еще одной DoS атаки на сервис,
|
|
||||||
-- с распространением кривых ключей, но это хотя бы выяснимо, ну и атака
|
|
||||||
-- может быть только в рамках рефчана, т.е лечится выкидыванием пиров /
|
|
||||||
-- исключением зловредных авторов.
|
|
||||||
|
|
||||||
for_ (Set.toList keyz) $ \href -> do
|
|
||||||
|
|
||||||
let tx = AnnotatedHashRef fixmeSign href
|
|
||||||
|
|
||||||
let lbs = serialise tx
|
|
||||||
|
|
||||||
let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
|
|
||||||
|
|
||||||
warn $ "post gk tx" <+> "tree" <+> pretty href
|
|
||||||
|
|
||||||
result <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (chan, box)
|
|
||||||
|
|
||||||
when (isNothing result) do
|
|
||||||
err $ red "hbs2-peer rpc calling timeout"
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -78,13 +78,13 @@ runInFixme repo m = do
|
||||||
listFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m, HasPredicate q) => RepoLww -> q -> m [Fixme]
|
listFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m, HasPredicate q) => RepoLww -> q -> m [Fixme]
|
||||||
listFixme repo q = do
|
listFixme repo q = do
|
||||||
runInFixme repo $ F.listFixme q
|
runInFixme repo $ F.listFixme q
|
||||||
& try @_ @RunInFixmeError
|
& try @_ @SomeException
|
||||||
<&> fromRight mempty
|
<&> fromRight mempty
|
||||||
|
|
||||||
countFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> m (Maybe Int)
|
countFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> m (Maybe Int)
|
||||||
countFixme repo = do
|
countFixme repo = do
|
||||||
runInFixme repo $ F.countFixme
|
runInFixme repo $ F.countFixme
|
||||||
& try @_ @RunInFixmeError
|
& try @_ @SomeException
|
||||||
<&> either (const Nothing) Just
|
<&> either (const Nothing) Just
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -738,6 +738,8 @@ repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||||
repoCommits lww predicate' = do
|
repoCommits lww predicate' = do
|
||||||
now <- getEpoch
|
now <- getEpoch
|
||||||
|
|
||||||
|
debug $ red "repoCommits"
|
||||||
|
|
||||||
let predicate = either id id predicate'
|
let predicate = either id id predicate'
|
||||||
|
|
||||||
co <- lift $ selectCommits lww predicate
|
co <- lift $ selectCommits lww predicate
|
||||||
|
|
@ -1018,6 +1020,8 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
|
||||||
|
|
||||||
getTopInfoBlock lww = do
|
getTopInfoBlock lww = do
|
||||||
|
|
||||||
|
debug $ red "getTopInfoBlock"
|
||||||
|
|
||||||
it@RepoListItem{..} <- lift (selectRepoList ( mempty
|
it@RepoListItem{..} <- lift (selectRepoList ( mempty
|
||||||
& set repoListByLww (Just lww)
|
& set repoListByLww (Just lww)
|
||||||
& set repoListLimit (Just 1))
|
& set repoListLimit (Just 1))
|
||||||
|
|
@ -1038,8 +1042,11 @@ getTopInfoBlock lww = do
|
||||||
allowed <- lift $ checkFixmeAllowed (RepoLww lww)
|
allowed <- lift $ checkFixmeAllowed (RepoLww lww)
|
||||||
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
|
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
|
||||||
|
|
||||||
fixmeCnt <- lift (Fixme.countFixme (RepoLww lww))
|
fixmeCnt <- if allowed then
|
||||||
<&> fromMaybe 0
|
lift (Fixme.countFixme (RepoLww lww))
|
||||||
|
<&> fromMaybe 0
|
||||||
|
else
|
||||||
|
pure 0
|
||||||
|
|
||||||
let forksNum = rlRepoForks
|
let forksNum = rlRepoForks
|
||||||
let commitsNum = rlRepoCommits
|
let commitsNum = rlRepoCommits
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue