diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index d3a51b1e..2cc1db74 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -871,307 +871,3 @@ refchanExportGroupKeys = do 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" - - diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs index ff73363e..e6c6c862 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs @@ -78,13 +78,13 @@ runInFixme repo m = do listFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m, HasPredicate q) => RepoLww -> q -> m [Fixme] listFixme repo q = do runInFixme repo $ F.listFixme q - & try @_ @RunInFixmeError + & try @_ @SomeException <&> fromRight mempty countFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> m (Maybe Int) countFixme repo = do runInFixme repo $ F.countFixme - & try @_ @RunInFixmeError + & try @_ @SomeException <&> either (const Nothing) Just diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs index 06fb1485..024cbb6b 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs @@ -738,6 +738,8 @@ repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) repoCommits lww predicate' = do now <- getEpoch + debug $ red "repoCommits" + let predicate = either id id predicate' co <- lift $ selectCommits lww predicate @@ -1018,6 +1020,8 @@ repoTopInfoBlock lww TopInfoBlock{..} = do getTopInfoBlock lww = do + debug $ red "getTopInfoBlock" + it@RepoListItem{..} <- lift (selectRepoList ( mempty & set repoListByLww (Just lww) & set repoListLimit (Just 1)) @@ -1038,8 +1042,11 @@ getTopInfoBlock lww = do allowed <- lift $ checkFixmeAllowed (RepoLww lww) let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ] - fixmeCnt <- lift (Fixme.countFixme (RepoLww lww)) - <&> fromMaybe 0 + fixmeCnt <- if allowed then + lift (Fixme.countFixme (RepoLww lww)) + <&> fromMaybe 0 + else + pure 0 let forksNum = rlRepoForks let commitsNum = rlRepoCommits