voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

fixme-new

This commit is contained in:
Dmitry Zuikov 2024-09-25 11:19:41 +03:00
parent c66cb4a8ee
commit c240b8ad9e
22 changed files with 1077 additions and 1027 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.fixme-new/config
View File

@ -13,7 +13,7 @@ fixme-attribs assigned workflow :class
fixme-attribs class
fixme-value-set workflow new backlog wip test fixed done
fixme-value-set :workflow :new :backlog :wip :test :fixed :done
fixme-value-set class hardcode performance boilerplate
@ -65,7 +65,6 @@ fixme-comments ";" "--"
(define (backlog s) (modify s workflow :backlog))
;; refchan settings
source ./config.local
refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42
source ./refchan.local

29
docs/todo/hbs2-peer-queues.txt Normal file
View File

@ -0,0 +1,29 @@
TODO: hbs2-peer-queues
$workflow: backlog
Сделать механизм очередей ( циклических FIFO буферов )
с управлением ( put/get ) по RPC
hbs2-peer постоянно в памяти;
Тогда мы решаем проблемы блокировок в sqlite:
Процесс продюсер -- пишет в очередь через hbs2-peer ( на диск )
Процесс консьюмер -- читает оттуда и обновляет БД, когда к этому
готов.
Таким образом, мы избегаем проблем с блокировками и
получаем понятный асинхронный механизм взаимодействия
между разными программами из hbs2.
Технически их можно сделать на основе компактов, в каждый
compact пишутся сообщения в формате (n, bytestring), после
чтения консьюмером -- сообщения удаляются.
По превышению файлом компакта некоего размера --
производим компактизацию, т.е начинаем писать в новый
файл, а старый удаляем, как только в нём не останется
ничего для чтения... Ну или как-то так.

2
fixme-new/fixme.cabal
View File

@ -107,6 +107,7 @@ library
other-modules:
Fixme.Run.Internal
Fixme.Run.Internal.RefChan
exposed-modules:
Fixme
@ -117,6 +118,7 @@ library
Fixme.State
Fixme.Scan
Fixme.Scan.Git.Local
Fixme.GK
build-depends: base
, base16-bytestring

96
fixme-new/lib/Fixme/GK.hs Normal file
View File

@ -0,0 +1,96 @@
{-# Language MultiWayIf #-}
module Fixme.GK where
import Fixme.Prelude
import Fixme.Config
import Fixme.Types
import HBS2.OrDie
-- import HBS2.System.Dir
import HBS2.Storage.Operations.ByteString
import HBS2.Storage.Operations.Class
import HBS2.Net.Auth.GroupKeySymm
import HBS2.Peer.Proto.RefChan as RefChan
import HBS2.System.Dir
-- import HBS2.Net.Auth.Credentials
import Control.Monad.Trans.Maybe
import Data.HashSet qualified as HS
import Data.HashMap.Strict qualified as HM
import Data.Maybe
import Lens.Micro.Platform
data GroupKeyOpError =
NoRefChanHead
| NoReadersSet
| GKLoadFailed
deriving (Eq,Ord,Show,Typeable)
instance Exception GroupKeyOpError
groupKeyFile :: forall m . FixmePerks m => m FilePath
groupKeyFile = do
dir <- localConfigDir
pure $ dir </> "gk0"
-- TODO: rotate-group-key
loadGroupKey :: forall s m . (s ~ 'HBS2Basic, FixmePerks m) => FixmeM m (Maybe (HashRef, GroupKey 'Symm s))
loadGroupKey = do
sto <- getStorage
gkF <- groupKeyFile
runMaybeT do
rchan <- lift (asks fixmeEnvRefChan >>= readTVarIO) >>= toMPlus
rch <- getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
>>= orThrow NoRefChanHead
guard ( not $ HS.null (view refChanHeadReaders rch) )
flip fix 0 $ \next -> \case
attempt | attempt > 2 -> throwIO GKLoadFailed
attempt -> do
let readers = view refChanHeadReaders rch
gkHash <- liftIO (try @_ @IOError $ readFile gkF)
<&> either (const Nothing) ( (=<<) (fromStringMay @HashRef) . headMay . lines )
debug $ "GK0" <+> pretty gkHash
case gkHash of
Nothing -> do
debug "generate new group key"
gknew <- generateGroupKey @'HBS2Basic Nothing (HS.toList readers)
ha <- writeAsMerkle sto (serialise gknew)
liftIO $ writeFile gkF (show $ pretty ha)
next (succ attempt)
Just h -> do
now <- liftIO $ getPOSIXTime <&> round
gk' <- loadGroupKeyMaybe @s sto h
(_,gk) <- maybe1 gk' (rm gkF >> next (succ attempt)) (pure . (h,))
let ts = getGroupKeyTimestamp gk & fromMaybe 0
-- FIXME: timeout-hardcode
-- $class: hardcode
if | now - ts > 2592000 -> do
rm gkF
next (succ attempt)
| HM.keysSet (recipients gk) /= readers -> do
rm gkF
next (succ attempt)
| otherwise -> do
pure (h,gk)

126
fixme-new/lib/Fixme/Run.hs
View File

@ -6,8 +6,10 @@ import Fixme.Types
import Fixme.Config
import Fixme.State
import Fixme.Run.Internal
import Fixme.Run.Internal.RefChan
import Fixme.Scan.Git.Local as Git
import Fixme.Scan as Scan
import Fixme.GK as GK
import Data.Config.Suckless.Script.File
@ -138,6 +140,7 @@ runFixmeCLI m = do
<*> newTVarIO mzero
<*> newTVarIO mzero
<*> newTVarIO mzero
<*> newTVarIO mempty
-- FIXME: defer-evolve
-- не все действия требуют БД,
@ -196,10 +199,6 @@ runCLI = do
runTop forms
notEmpty :: [a] -> Maybe [a]
notEmpty = \case
[] -> Nothing
x -> Just x
runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m ()
runTop forms = do
@ -360,6 +359,14 @@ runTop forms = do
magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
liftIO $ print $ pretty magic
entry $ bindMatch "fixme:gk:show" $ nil_ $ const do
w <- lift loadGroupKey
case w of
Just (h,_) -> do
liftIO $ print $ pretty h
_ -> do
liftIO $ print $ pretty "none"
entry $ bindMatch "fixme:path" $ nil_ $ const do
path <- lift fixmeWorkDir
liftIO $ print $ pretty path
@ -434,6 +441,12 @@ runTop forms = do
_ -> void $ lift $ refchanExport ()
entry $ bindMatch "fixme:refchan:import" $ nil_ $ \case
_ -> void $ lift $ refchanImport
entry $ bindMatch "fixme:gk:export" $ nil_ $ \case
_ -> void $ lift $ refchanExportGroupKeys
entry $ bindMatch "source" $ nil_ $ \case
[StringLike path] -> do
@ -467,6 +480,11 @@ runTop forms = do
entry $ bindMatch "fixme:refchan:update" $ nil_ $ const $ lift do
refchanUpdate
entry $ bindMatch "cache:ignore" $ nil_ $ const $ lift do
tf <- asks fixmeEnvFlags
atomically $ modifyTVar tf (HS.insert FixmeIgnoreCached)
entry $ bindMatch "git:blobs" $ \_ -> do
blobs <- lift (listBlobs Nothing)
@ -487,102 +505,10 @@ runTop forms = do
) $
args [] $
returns "string" "refchan-key" $ do
entry $ bindMatch "refchan:init" $ nil_ $ const $ do
let rch0 = refChanHeadDefault @L4Proto
sto <- lift getStorage
peer <- lift $ getClientAPI @PeerAPI @UNIX
rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX
confFile <- localConfig
conf <- liftIO (readFile confFile)
<&> parseTop
<&> either (error.show) (fmap (fixContext @_ @C))
let already = headMay [ x
| ListVal [StringLike "refchan", SignPubKeyLike x] <- conf
]
flip runContT pure $ callCC \done -> do
when (isJust already) do
warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already)
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)
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"
liftIO $ appendFile confFile $
show $ pretty ( mkList @C [ mkSym "refchan"
, mkSym (show $ pretty (AsBase58 refchan)) ]
)
entry $ bindMatch "fixme:refchan:init" $ nil_ $ \case
[] -> lift $ fixmeRefChanInit Nothing
[SignPubKeyLike rc] -> lift $ fixmeRefChanInit (Just rc)
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "set-template" $ nil_ \case
[SymbolVal who, SymbolVal w] -> do

411
fixme-new/lib/Fixme/Run/Internal.hs
View File

@ -9,31 +9,37 @@ import Fixme.Config
import Fixme.State
import Fixme.Scan.Git.Local as Git
import Fixme.Scan as Scan
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
import HBS2.Data.Types.SignedBox
import HBS2.Peer.Proto.RefChan
import HBS2.Peer.Proto.RefChan as RefChan
import HBS2.Peer.RPC.Client.RefChan
import HBS2.Storage.Operations.ByteString
import HBS2.System.Dir
import HBS2.Net.Auth.Credentials
import DBPipe.SQLite hiding (field)
import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
import HBS2.KeyMan.Keys.Direct
import Data.Config.Suckless.Script.File
import Data.List qualified as L
import Data.List.Split (chunksOf)
import Data.Aeson.Encode.Pretty as Aeson
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.Set qualified as Set
import Data.Maybe
import Data.HashSet qualified as HS
import Data.HashMap.Strict (HashMap)
@ -52,6 +58,7 @@ import Control.Concurrent.STM (flushTQueue)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import System.Directory (getModificationTime)
import System.IO as IO
import Streaming.Prelude qualified as S
@ -60,6 +67,7 @@ pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs)
{- HLINT ignore "Functor law" -}
defaultTemplate :: HashMap Id FixmeTemplate
defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
where
@ -72,6 +80,37 @@ defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
|]
templateExample :: String
templateExample = [qc|
; this is an optional template example
; for nicer fixme list
;(define-template short
; (quot
; (simple
; (trim 10 $fixme-key) " "
;
; (if (~ FIXME $fixme-tag)
; (then (fgd red (align 6 $fixme-tag)) )
; (else (if (~ TODO $fixme-tag)
; (then (fgd green (align 6 $fixme-tag)))
; (else (align 6 $fixme-tag)) ) )
; )
;
;
; (align 10 ("[" $workflow "]")) " "
; (align 8 $class) " "
; (align 12 $assigned) " "
; (align 20 (trim 20 $committer-name)) " "
; (trim 50 ($fixme-title)) " "
; (nl))
; )
;)
; (set-template default short)
|]
init :: FixmePerks m => FixmeM m ()
init = do
@ -85,14 +124,62 @@ init = do
let gitignore = lo </> ".gitignore"
here <- doesPathExist gitignore
confPath <- localConfig
unless here do
liftIO $ appendFile confPath $ show $ vcat
[ mempty
, ";; this is a default fixme config"
, ";;"
, "fixme-prefix" <+> "FIXME:"
, "fixme-prefix" <+> "TODO:"
, "fixme-value-set" <+> hsep [":workflow", ":new",":wip",":backlog",":done"]
, "fixme-file-comments" <+> dquotes "*.scm" <+> dquotes ";"
, "fixme-comments" <+> dquotes ";" <+> dquotes "--" <+> dquotes "#"
, mempty
]
exts <- listBlobs Nothing
<&> fmap (takeExtension . fst)
<&> HS.toList . HS.fromList
for_ exts $ \e -> do
unless (e `elem` [".gitignore",".local"] ) do
liftIO $ appendFile confPath $
show $ ( "fixme-files" <+> dquotes ("**/*" <> pretty e) <> line )
liftIO $ appendFile confPath $ show $ vcat
[ "fixme-exclude" <+> dquotes "**/.**"
]
liftIO $ appendFile confPath $ show $ vcat
[ mempty
, pretty templateExample
, ";; uncomment to source any other local settings file"
, ";; source ./my.local"
, mempty
]
unless here do
liftIO $ writeFile gitignore $ show $
vcat [ pretty ("." </> localDBName)
]
notice $ yellow "run" <> line <> vcat [
"git add" <+> pretty (lo0 </> ".gitignore")
notice $ green "default config created:" <+> ".fixme-new/config" <> line
<> "edit it for your project" <> line
<> "typically you need to add it to git"
<> line
<> "use (source ./some.local) form to add your personal settings" <> line
<> "which should not be shared amongst the whole project" <> line
<> "and add " <> yellow ".fixme-new/some.local" <+> "file to .gitignore"
<> line
notice $ "run" <> line <> vcat [
mempty
, "git add" <+> pretty (lo0 </> ".gitignore")
, "git add" <+> pretty (lo0 </> "config")
, mempty
]
@ -312,7 +399,11 @@ cat_ hash = do
let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0
let bbefore = if start > before then before + 1 else 1
debug $ red "start" <+> pretty start
debug $ red "before" <+> pretty before
let bbefore = if start == 0 then before else before + 1
let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
let lno = max 1 $ origLen + after + before
@ -371,18 +462,20 @@ refchanExport opts = do
let (pk,sk) = (view peerSignPk creds, view peerSignSk creds)
gk0 <- loadGroupKey
-- TODO: this-may-cause-to-tx-flood
-- сделать какой-то период релакса,
-- что ли
now <- liftIO $ getPOSIXTime <&> round
withState do
-- FIXME: select-only-really-missed-records
-- сейчас всегда фуллскан. будет всё дольше и дольше
-- с ростом количества записей. Нужно отбирать
-- только такие элементы, которые реально отсутствуют
-- в рефчане
what <- select_ @_ @FixmeExported [qc|
select distinct o,w,k,cast (v as text)
what <- select @FixmeExported [qc|
select distinct o,?,k,cast (v as text)
from object obj
where not exists (select null from scanned where hash = obj.nonce)
order by o, k, v, w
|]
|] (Only now)
let chu = chunksOf 10000 what
@ -391,17 +484,19 @@ refchanExport opts = do
for_ chu $ \x -> callCC \next -> do
-- FIXME: encrypt-tree
-- 1. откуда ключ взять
-- 2. куда его положить
-- 3. один на всех?
-- 4. по одному на каждого?
-- 5. как будет устроена ротация
-- 6. как делать доступ к историческим данным
-- 6.1 новые ключи в этот же рефчан
-- 6.2 или новые ключи в какой-то еще рефчан
h <- writeAsMerkle sto (serialise x)
let tx = AnnotatedHashRef Nothing (HashRef h)
let s = maybe "[ ]" (const $ yellow "[@]") gk0
let gk = snd <$> gk0
href <- liftIO $ createTreeWithMetadata sto gk mempty (serialise x)
>>= orThrowPassIO
let tx = AnnotatedHashRef Nothing href
lift do
@ -409,7 +504,7 @@ refchanExport opts = do
let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
warn $ "POST" <+> red "unencrypted!" <+> pretty (length x) <+> pretty (hashObject @HbSync (serialise box))
warn $ "POST" <+> pretty (length x) <+> s <> "tree" <+> pretty href <+> pretty (hashObject @HbSync (serialise box))
unless dry do
r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box)
@ -419,18 +514,30 @@ refchanExport opts = do
pure $ length what
refchanUpdate :: FixmePerks m => FixmeM m ()
refchanUpdate = do
refchanImport
rchan <- asks fixmeEnvRefChan
>>= readTVarIO
>>= orThrowUser "refchan not set"
api <- getClientAPI @RefChanAPI @UNIX
sto <- getStorage
h0 <- callService @RpcRefChanGet api rchan
>>= orThrowUser "can't request refchan head"
rch <- RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
>>= orThrowUser "can't request refchan head"
let w = view refChanHeadWaitAccept rch
refchanExportGroupKeys
txn <- refchanExport ()
unless (txn == 0) do
@ -443,7 +550,7 @@ refchanUpdate = do
-- TODO: fix-this-lame-polling
flip fix 0 $ \next -> \case
n | n >= 3 -> pure ()
n | n >= w -> pure ()
n -> do
h <- callService @RpcRefChanGet api rchan
@ -453,6 +560,7 @@ refchanUpdate = do
pure ()
else do
pause @'Seconds 1
liftIO $ hPutStr stderr (show $ pretty (w - n) <> " \r")
next (succ n)
none
@ -474,12 +582,16 @@ refchanImport = do
tq <- newTQueueIO
-- TODO: assume-huge-list
-- scanned <- listAllScanned
let goodToGo x = do
ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
let goodToGo x | ignCached = pure True
| otherwise = do
here <- selectIsAlreadyScanned x
pure $ not here
fixmeGkSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
>>= orThrowUser "hbs2 storage error. aborted"
walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
case u of
@ -489,41 +601,87 @@ refchanImport = do
atomically $ modifyTVar ttsmap (HM.insertWith max what (coerce @_ @Word64 ts))
atomically $ modifyTVar accepts (HM.insertWith (<>) what (HS.singleton txh))
scanned <- selectIsAlreadyScanned what
when scanned do
withState $ insertScanned txh
A _ -> none
P orig (ProposeTran _ box) -> void $ runMaybeT do
(_, bs) <- unboxSignedBox0 box & toMPlus
AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
AnnotatedHashRef sn href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
& toMPlus . either (const Nothing) Just
scanned <- lift $ selectIsAlreadyScanned href
-- notice $ yellow "SCANNED" <+> pretty scanned
when (not scanned || ignCached) do
if scanned then do
atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh
lift $ withState $ transactional do
insertScanned txh
for_ atx insertScanned
let isGk = sn == Just fixmeGkSign
if isGk then do
atomically $ writeTQueue tq (Left (txh, orig, href, href))
else do
-- FIXME: decrypt-tree
what <- runExceptT (readFromMerkle sto (SimpleKey (coerce href)))
what <- liftIO (runExceptT $ getTreeContents sto href)
<&> either (const Nothing) Just
>>= toMPlus
exported <- deserialiseOrFail @[FixmeExported] what
& toMPlus
let exported = deserialiseOrFail @[FixmeExported] what
& either (const Nothing) Just
for_ exported $ \e -> do
atomically $ writeTQueue tq (txh, orig, href, e)
case exported of
Just e -> do
for_ e $ \x -> do
atomically $ writeTQueue tq (Right (txh, orig, href, x))
Nothing -> do
lift $ withState $ insertScanned txh
imported <- atomically $ flushTQueue tq
withState $ transactional do
for_ imported $ \(txh, h, href, i) -> do
for_ imported $ \case
Left (txh, orig, href, gk) -> do
-- hx <- writeAsMerkle sto (serialise gk)
-- notice $ "import GK" <+> pretty hx <+> "from" <+> pretty href
-- let tx = AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
-- & toMPlus . either (const Nothing) Just
insertScanned txh
-- TODO: ASAP-notify-hbs2-keyman
-- у нас два варианта:
-- 1. звать runKeymanClient и в нём записывать в БД
-- с возможностью блокировок
-- 2. каким-то образом делать отложенную запись,
-- например, писать лог групповых ключей
-- куда-то, откуда hbs2-keyman сможет
-- обновить их при запуске
--
-- лог групповых ключей мы можем писать:
-- 1. в рефлог, на который подписан и кейман
-- 2. в рефчан, на который подписан и кейман
-- неожиданные плюсы:
-- + у нас уже есть такой рефчан!
-- всё, что надо сделать -- это записать ключи туда
-- с одной стороны туповато: перекладывать транзы из
-- рефчана в рефчан. с другой стороны -- не нужны никакие
-- новые механизмы. рефчан, в общем-то, локальный(?),
-- блоки никуда за пределы хоста не поедут (?) и сеть
-- грузить не будут (?)
--
-- 3. в рефчан, используя notify
-- 4. в еще какую переменную, которая будет
-- локальна
-- 5. в какой-то лог. который кейман будет
-- процессировать при hbs2-keyman update
--
-- поскольку БД кеймана блокируется целиком при апдейтах,
-- единственное, куда писать проблематично -- это сама БД.
--
pure ()
Right (txh, h, href, i) -> do
w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
let item = i { exportedWeight = w }
@ -538,3 +696,174 @@ refchanImport = do
insertScanned href
for_ atx insertScanned
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"

284
fixme-new/lib/Fixme/Run/Internal/RefChan.hs Normal file
View File

@ -0,0 +1,284 @@
{-# Language MultiWayIf #-}
module Fixme.Run.Internal.RefChan (fixmeRefChanInit) where
import Prelude hiding (init)
import Fixme.Prelude hiding (indent)
import Fixme.Types
import Fixme.Config
import HBS2.OrDie
import HBS2.Base58
import HBS2.Net.Auth.GroupKeySymm
import HBS2.Data.Types.SignedBox
import HBS2.Peer.Proto.RefChan as RefChan
import HBS2.Storage.Operations.ByteString
import HBS2.System.Dir
import HBS2.Net.Auth.Credentials
import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
import HBS2.KeyMan.Keys.Direct
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.Either
import Data.Maybe
import Data.List qualified as List
import Data.HashSet qualified as HS
import Data.HashMap.Strict qualified as HM
import Text.InterpolatedString.Perl6 (qc)
import Lens.Micro.Platform
import System.Process.Typed
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.Word
import System.IO qualified as IO
{- HLINT ignore "Functor law"-}
notEmpty :: [a] -> Maybe [a]
notEmpty = \case
[] -> Nothing
x -> Just x
data RefChanInitFSM =
InitInit
| SetupNewRefChan
| SetupExitFailure
| CheckRefChan (PubKey 'Sign 'HBS2Basic)
| RefChanHeadFound (PubKey 'Sign 'HBS2Basic) (RefChanHeadBlock L4Proto)
| WaitRefChanHeadStart (PubKey 'Sign 'HBS2Basic) Word64
| WaitRefChanHead (PubKey 'Sign 'HBS2Basic) Word64
fixmeRefChanInit :: FixmePerks m => Maybe (PubKey 'Sign 'HBS2Basic) -> FixmeM m ()
fixmeRefChanInit mbRc = do
let rch0 = refChanHeadDefault @L4Proto
sto <- getStorage
peer <- getClientAPI @PeerAPI @UNIX
rchanApi <- getClientAPI @RefChanAPI @UNIX
dir <- localConfigDir
confFile <- localConfig
rchan <- asks fixmeEnvRefChan
>>= readTVarIO
poked <- 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"
let refChanClause r = mkList @C [ mkSym "refchan"
, mkSym (show $ pretty (AsBase58 r))
]
flip runContT pure $ callCC \done -> do
flip fix InitInit $ \next -> \case
InitInit -> do
case (rchan, mbRc) of
(Nothing, Nothing) -> next SetupNewRefChan
(_, Just r2) -> next (CheckRefChan r2)
(Just r1, Nothing) -> next (CheckRefChan r1)
CheckRefChan rc -> do
notice $ "check refchan:" <+> pretty (AsBase58 rc)
notice $ "subscribe to refchan" <+> pretty (AsBase58 rc)
-- FIXME: poll-time-hardcode
-- $class: hardcode
void $ callService @RpcPollAdd peer (rc, "refchan", 17)
notice $ "fetch refchan head" <+> pretty (AsBase58 rc)
void $ lift $ callRpcWaitMay @RpcRefChanHeadFetch (TimeoutSec 1) rchanApi rc
now <- liftIO $ getPOSIXTime <&> round
pause @'Seconds 1
next $ WaitRefChanHead rc now
WaitRefChanHeadStart rc t -> do
notice $ "wait for refchan head" <+> pretty (AsBase58 rc)
next (WaitRefChanHead rc t)
WaitRefChanHead rc t -> do
now <- liftIO $ getPOSIXTime <&> round
let s = 60 - (now -t)
hd <- getRefChanHead @L4Proto sto (RefChanHeadKey rc)
liftIO $ IO.hPutStr stderr $ show $ "waiting" <+> pretty s <+> " \r"
if | now - t < 60 && isNothing hd -> do
pause @'Seconds 1
next $ WaitRefChanHead rc t
| now - t > 60 && isNothing hd -> do
err "refchan wait timeout"
next $ SetupExitFailure
| isJust hd -> do
next $ RefChanHeadFound rc (fromJust hd)
| otherwise -> next $ SetupExitFailure
RefChanHeadFound rc hd -> do
notice $ "found refchan head for" <+> pretty (AsBase58 rc)
void $ lift $ callRpcWaitMay @RpcRefChanFetch (TimeoutSec 1) rchanApi rc
author <- lift $ asks fixmeEnvAuthor >>= readTVarIO
let readers = view refChanHeadReaders hd
let authors = view refChanHeadAuthors hd
-- hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs
rs <- liftIO (runKeymanClientRO $ loadKeyRingEntries (HS.toList readers))
let isReader = case rs of
[] -> False
_ -> True
let canRead = if isReader then
green "yes"
else
red "no"
notice $ "reader:" <+> canRead
let isAuthor = maybe1 author False (`HS.member` authors)
let canWrite = if isAuthor
then green "yes"
else red "no"
notice $ "author:" <+> canWrite
unless isReader do
warn $ yellow "no reader key found" <> line
<> "it's may be ok, if this refchan is not encrypted" <> line
<> "otherwise, make your encryption key a member of this refchan head"
<> line
unless isAuthor do
warn $ red "no author key found" <> line
<> "it's may be ok if you have only read-only access to this refchan" <> line
<> "otherwise, use" <+> yellow "author KEY" <+> "settings in the .fixme-new/config" <> line
<> "and make sure it is added to the refchan head"
<> line
unless (isJust rchan) do
notice $ "adding refchan to" <+> pretty confFile
liftIO do
appendFile confFile $ show $
line
<> vcat [ pretty (refChanClause rc) ]
SetupExitFailure -> do
err "refchan init failed"
SetupNewRefChan -> do
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 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
notice $ "adding refchan to" <+> pretty confFile
liftIO do
appendFile confFile $ show $
line
<> vcat [ pretty (refChanClause refchan) ]
next $ CheckRefChan refchan

791
fixme-new/lib/Fixme/RunOld.hs
View File

@ -1,791 +0,0 @@
{-# Language MultiWayIf #-}
{-# Language PatternSynonyms #-}
{-# Language ViewPatterns #-}
module Fixme.RunOld where
import Prelude hiding (init)
import Fixme.Prelude hiding (indent)
import Fixme.Types
import Fixme.Config
import Fixme.State
import Fixme.Scan.Git.Local as Git
import Fixme.Scan as Scan
import HBS2.Git.Local.CLI
import HBS2.Base58
import HBS2.Merkle
import HBS2.Data.Types.Refs
import HBS2.Storage
import HBS2.Storage.Compact
import HBS2.System.Dir
import DBPipe.SQLite hiding (field)
import Data.Config.Suckless
import Data.Aeson.Encode.Pretty as Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.Either
import Data.Maybe
import Data.HashSet qualified as HS
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.HashSet (HashSet)
import Data.Set qualified as Set
import Data.Generics.Product.Fields (field)
import Data.List qualified as List
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Text.InterpolatedString.Perl6 (qc)
import Data.Coerce
import Control.Monad.Identity
import Lens.Micro.Platform
import System.Process.Typed
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import System.IO.Temp as Temp
import System.IO qualified as IO
import Streaming.Prelude qualified as S
{- HLINT ignore "Functor law" -}
pattern Init :: forall {c}. Syntax c
pattern Init <- ListVal [SymbolVal "init"]
pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c
pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e))
pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c
pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e))
pattern ReadFixmeStdin :: forall {c}. Syntax c
pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"]
pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c
pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e))
pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c
pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s]
pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
logRootKey :: SomeRefKey ByteString
logRootKey = SomeRefKey "ROOT"
scanGitArgs :: [Syntax c] -> [ScanGitArgs]
scanGitArgs syn = [ w | ScanGitArgs w <- syn ]
fileMasks :: [Syntax c] -> [FilePattern]
fileMasks what = [ show (pretty s) | s <- what ]
fixmePrefix :: Syntax c -> Maybe FixmeTag
fixmePrefix = \case
SymbolVal s -> Just (FixmeTag (coerce s))
_ -> Nothing
defaultTemplate :: HashMap Id FixmeTemplate
defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
where
short = parseTop s & fromRight mempty
s = [qc|
(trim 10 $fixme-key) " "
(align 6 $fixme-tag) " "
(trim 50 ($fixme-title))
(nl)
|]
runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
runFixmeCLI m = do
dbPath <- localDBPath
git <- findGitDir
env <- FixmeEnv
<$> newMVar ()
<*> newTVarIO mempty
<*> newTVarIO dbPath
<*> newTVarIO Nothing
<*> newTVarIO git
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO defCommentMap
<*> newTVarIO Nothing
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO defaultCatAction
<*> newTVarIO defaultTemplate
<*> newTVarIO mempty
<*> newTVarIO (1,3)
-- FIXME: defer-evolve
-- не все действия требуют БД,
-- хорошо бы, что бы она не создавалась,
-- если не требуется
runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
`finally` flushLoggers
where
setupLogger = do
setLogging @ERROR $ toStderr . logPrefix "[error] "
setLogging @WARN $ toStderr . logPrefix "[warn] "
setLogging @NOTICE $ toStdout . logPrefix ""
pure ()
flushLoggers = do
silence
-- FIXME: tied-fucking-context
defaultCatAction = CatAction $ \dict lbs -> do
LBS.putStr lbs
pure ()
silence :: FixmePerks m => m ()
silence = do
setLoggingOff @DEBUG
setLoggingOff @ERROR
setLoggingOff @WARN
setLoggingOff @NOTICE
readConfig :: FixmePerks m => FixmeM m [Syntax C]
readConfig = do
user <- userConfigs
lo <- localConfig
w <- for (lo : user) $ \conf -> do
try @_ @IOException (liftIO $ readFile conf)
<&> fromRight mempty
<&> parseTop
<&> fromRight mempty
pure $ mconcat w
init :: FixmePerks m => FixmeM m ()
init = do
lo <- localConfigDir
let lo0 = takeFileName lo
mkdir lo
touch (lo </> "config")
let gitignore = lo </> ".gitignore"
here <- doesPathExist gitignore
unless here do
liftIO $ writeFile gitignore $ show $
vcat [ pretty ("." </> localDBName)
]
notice $ yellow "run" <> line <> vcat [
"git add" <+> pretty (lo0 </> ".gitignore")
, "git add" <+> pretty (lo0 </> "config")
]
readFixmeStdin :: FixmePerks m => FixmeM m ()
readFixmeStdin = do
what <- liftIO LBS8.getContents
fixmies <- Scan.scanBlob Nothing what
liftIO $ print $ vcat (fmap pretty fixmies)
list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m ()
list_ tpl a = do
tpl <- asks fixmeEnvTemplates >>= readTVarIO
<&> HM.lookup (fromMaybe "default" tpl)
fixmies <- selectFixmeThin a
case tpl of
Nothing-> do
liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
Just (Simple (SimpleTemplate simple)) -> do
for_ fixmies $ \(FixmeThin attr) -> do
let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList attr ]
let what = render (SimpleTemplate (inject subst simple))
& fromRight "render error"
liftIO $ hPutDoc stdout what
catFixmeMetadata :: FixmePerks m => Text -> FixmeM m ()
catFixmeMetadata = cat_ True
catFixme :: FixmePerks m => Text -> FixmeM m ()
catFixme = cat_ False
cat_ :: FixmePerks m => Bool -> Text -> FixmeM m ()
cat_ metaOnly hash = do
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
gd <- fixmeGetGitDirCLIOpt
CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
void $ flip runContT pure do
callCC \exit -> do
mha <- lift $ selectFixmeHash hash
ha <- ContT $ maybe1 mha (pure ())
fme' <- lift $ selectFixme ha
Fixme{..} <- ContT $ maybe1 fme' (pure ())
when metaOnly do
for_ (HM.toList fixmeAttr) $ \(k,v) -> do
liftIO $ print $ (pretty k <+> pretty v)
exit ()
let gh' = HM.lookup "blob" fixmeAttr
-- FIXME: define-fallback-action
gh <- ContT $ maybe1 gh' none
let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0
let bbefore = if start > before then before + 1 else 1
let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
let lno = max 1 $ origLen + after + before
let dict = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList fixmeAttr ]
<>
[ (mkId (FixmeAttrName "before"), mkStr @C (FixmeAttrVal $ Text.pack $ show bbefore))
]
debug (pretty cmd)
w <- gitRunCommand cmd
<&> either (LBS8.pack . show) id
<&> LBS8.lines
<&> drop start
<&> take lno
liftIO $ action dict (LBS8.unlines w)
delete :: FixmePerks m => Text -> FixmeM m ()
delete txt = do
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
hashes <- selectFixmeHashes txt
for_ hashes $ \ha -> do
insertFixmeDelStaged ha
modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
modify_ txt a b = do
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
void $ runMaybeT do
ha <- toMPlus =<< lift (selectFixmeHash txt)
lift $ insertFixmeModStaged ha (fromString a) (fromString b)
importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m ()
importFromLog sto = do
fset <- listAllFixmeHashes
-- sto <- compactStorageOpen @HbSync readonly fn
ks <- keys sto
toImport <- S.toList_ do
for_ ks $ \k -> runMaybeT do
v <- get sto k & MaybeT
what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus
case what of
Added _ fx -> do
let ha = hashObject @HbSync (serialise fx) & HashRef
unless (HS.member ha fset) do
warn $ red "import" <+> viaShow (pretty ha)
lift $ S.yield (Right fx)
w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w))
withState $ transactional do
for_ (rights toImport) insertFixme
let w = lefts toImport
eval (mconcat w)
unless (List.null toImport) do
updateIndexes
-- compactStorageClose sto
printEnv :: FixmePerks m => FixmeM m ()
printEnv = do
g <- asks fixmeEnvGitDir >>= readTVarIO
masks <- asks fixmeEnvFileMask >>= readTVarIO
tags <- asks fixmeEnvTags >>= readTVarIO
days <- asks fixmeEnvGitScanDays >>= readTVarIO
comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
comments2 <- asks fixmeEnvFileComments >>= readTVarIO
<&> HM.toList
<&> fmap (over _2 HS.toList)
attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
for_ tags $ \m -> do
liftIO $ print $ "fixme-prefix" <+> pretty m
for_ masks $ \m -> do
liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
for_ days $ \d -> do
liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
for_ comments1 $ \d -> do
liftIO $ print $ "fixme-comments" <+> dquotes (pretty d)
for_ comments2 $ \(ft, comm') -> do
for_ comm' $ \comm -> do
liftIO $ print $ "fixme-file-comments"
<+> dquotes (pretty ft) <+> dquotes (pretty comm)
for_ attr $ \a -> do
liftIO $ print $ "fixme-attribs"
<+> pretty a
for_ vals$ \(v, vs) -> do
liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs))
for_ g $ \git -> do
liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
dbPath <- asks fixmeEnvDbPath >>= readTVarIO
liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
for_ ma $ \(n, syn) -> do
liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
help :: FixmePerks m => m ()
help = do
notice "this is help message"
-- splitForms :: [String] -> [[String]]
-- splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
-- where
-- go acc ( "then" : rest ) = emit acc >> go mempty rest
-- go acc ( "and" : rest ) = emit acc >> go mempty rest
-- go acc ( x : rest ) = go ( x : acc ) rest
-- go acc [] = emit acc
-- emit = S.yield . reverse
sanitizeLog :: [Syntax c] -> [Syntax c]
sanitizeLog lls = flip filter lls $ \case
ListVal (SymbolVal "deleted" : _) -> True
ListVal (SymbolVal "modified" : _) -> True
_ -> False
pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c]
pattern Template w syn <- (mbTemplate -> (w, syn))
mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c])
mbTemplate = \case
( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest)
other -> (Nothing, other)
pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> [Syntax c]
pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)]
run :: FixmePerks m => [String] -> FixmeM m ()
run what = do
sc <- readConfig
let s0 = fmap (parseTop . unwords) (splitForms what)
& rights
& mconcat
runForms (sc <> s0)
runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
=> [Syntax c]
-> FixmeM m ()
runForms ss = for_ ss $ \s -> do
macros <- asks fixmeEnvMacro >>= readTVarIO
debug $ pretty s
case s of
(ListVal (SymbolVal name : rest)) | HM.member name macros -> do
let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ]
maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do
debug $ yellow "run macro" <+> pretty macro
runForms [macro]
FixmeFiles xs -> do
t <- asks fixmeEnvFileMask
atomically (modifyTVar t (<> xs))
FixmePrefix tag -> do
t <- asks fixmeEnvTags
atomically (modifyTVar t (HS.insert tag))
FixmeGitScanFilterDays d -> do
t <- asks fixmeEnvGitScanDays
atomically (writeTVar t (Just d))
ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
let co = Text.pack b & HS.singleton
t <- asks fixmeEnvFileComments
atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
t <- asks fixmeEnvDefComments
let co = fmap Text.pack xs & HS.fromList
atomically $ modifyTVar t (<> co)
ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do
ta <- asks fixmeEnvAttribs
atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
ListVal [SymbolVal "fixme-git-dir", StringLike g] -> do
ta <- asks fixmeEnvGitDir
atomically $ writeTVar ta (Just g)
ListVal [SymbolVal "fixme-state-path", StringLike g] -> do
p <- asks fixmeEnvDbPath
db <- asks fixmeEnvDb
atomically do
writeTVar p g
writeTVar db Nothing
evolve
ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do
t <- asks fixmeEnvCatContext
atomically $ writeTVar t (fromIntegral a, fromIntegral b)
ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do
t <- asks fixmeEnvCatAction
let action = CatAction $ \dict lbs -> do
let ccmd = case inject dict cmd0 of
(StringLike p : StringLikeList xs) -> Just (p, xs)
_ -> Nothing
debug $ pretty ccmd
maybe1 ccmd none $ \(p, args) -> do
let input = byteStringInput lbs
let cmd = setStdin input $ setStderr closed
$ proc p args
void $ runProcess cmd
atomically $ writeTVar t action
ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do
t <- asks fixmeEnvAttribValues
let name = fromString n
let vals = fmap fromString xs & HS.fromList
atomically $ modifyTVar t (HM.insertWith (<>) name vals)
Init -> init
ScanGitLocal args -> scanGitLocal args Nothing
Update args -> scanGitLocal args Nothing
ListVal (SymbolVal "list" : (Template n [])) -> do
debug $ "list" <+> pretty n
list_ n ()
ListVal (SymbolVal "list" : (Template n whatever)) -> do
debug $ "list" <+> pretty n
list_ n whatever
ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do
catFixmeMetadata hash
ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
catFixme hash
ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
delete hash
ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do
modify_ hash a b
ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do
debug $ green $ pretty s
updateFixme (Just t) hash (fromString a) (fromString b)
ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do
debug $ green $ pretty s
updateFixme Nothing hash (fromString a) (fromString b)
ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do
deleteFixme hash
ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
deleteFixme hash
ListVal [SymbolVal "added", FixmeHashLike _] -> do
-- we don't add fixmies at this stage
-- but in fixme-import
none
ReadFixmeStdin -> readFixmeStdin
ListVal [SymbolVal "print-env"] -> printEnv
ListVal (SymbolVal "hello" : xs) -> do
notice $ "hello" <+> pretty xs
ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do
debug $ yellow "define-macro" <+> pretty name <+> pretty macro
macros <- asks fixmeEnvMacro
atomically $ modifyTVar macros (HM.insert name (fixContext macro))
ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do
trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs)
t <- asks fixmeEnvTemplates
atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs)))
ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do
templates <- asks fixmeEnvTemplates
t <- readTVarIO templates
for_ (HM.lookup w t) $ \tpl -> do
atomically $ modifyTVar templates (HM.insert who tpl)
-- FIXME: maybe-rename-fixme-update-action
ListVal (SymbolVal "fixme-update-action" : xs) -> do
debug $ "fixme-update-action" <+> pretty xs
env <- ask
t <- asks fixmeEnvUpdateActions
let repl syn = [ ( "$1", syn ) ]
let action = UpdateAction @c $ \syn -> do
liftIO (withFixmeEnv env (runForms (inject (repl syn) xs)))
atomically $ modifyTVar t (<> [action])
ListVal (SymbolVal "update-action" : xs) -> do
debug $ "update-action" <+> pretty xs
env <- ask
t <- asks fixmeEnvReadLogActions
let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs))
atomically $ modifyTVar t (<> [action])
ListVal [SymbolVal "import-git-logs", StringLike fn] -> do
warn $ red "import-git-logs" <+> pretty fn
scanGitLogLocal fn importFromLog
ListVal [SymbolVal "import", StringLike fn] -> do
warn $ red "IMPORT" <+> pretty fn
sto <- compactStorageOpen readonly fn
importFromLog sto
compactStorageClose sto
ListVal [SymbolVal "export", StringLike fn] -> do
warn $ red "EXPORT" <+> pretty fn
exportToLog fn
ListVal [SymbolVal "git:list-refs"] -> do
refs <- listRefs False
for_ refs $ \(h,r) -> do
liftIO $ print $ pretty h <+> pretty r
ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do
debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b
temp <- liftIO $ emptyTempFile "." "merge-result"
sa <- compactStorageOpen @HbSync readonly o
sb <- compactStorageOpen @HbSync readonly b
r <- compactStorageOpen @HbSync mempty temp
for_ [sa,sb] $ \sto -> do
ks <- keys sto
for_ ks $ \k -> runMaybeT do
v <- get sto k & MaybeT
put r k v
compactStorageClose r
compactStorageClose sa
compactStorageClose sb
mv temp target
ListVal [SymbolVal "no-debug"] -> do
setLoggingOff @DEBUG
ListVal [SymbolVal "silence"] -> do
silence
ListVal [SymbolVal "builtin:run-stdin"] -> do
let ini = mempty :: [Text]
flip fix ini $ \next acc -> do
eof <- liftIO IO.isEOF
s <- if eof then pure "" else liftIO Text.getLine <&> Text.strip
if Text.null s then do
let code = parseTop (Text.unlines acc) & fromRight mempty
runForms code
unless eof do
next mempty
else do
next (acc <> [s])
ListVal [SymbolVal "builtin:evolve"] -> do
evolve
ListVal [SymbolVal "builtin:list-commits"] -> do
co <- listCommits
liftIO $ print $ vcat (fmap (pretty . view _1) co)
ListVal [SymbolVal "builtin:cleanup-state"] -> do
cleanupDatabase
ListVal [SymbolVal "builtin:clean-stage"] -> do
cleanStage
ListVal [SymbolVal "builtin:drop-stage"] -> do
cleanStage
ListVal [SymbolVal "builtin:show-stage"] -> do
stage <- selectStage
liftIO $ print $ vcat (fmap pretty stage)
ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
sto <- compactStorageOpen @HbSync readonly fn
ks <- keys sto
entries <- mapM (get sto) ks
<&> catMaybes
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
<&> rights
liftIO $ print $ vcat (fmap pretty entries)
compactStorageClose sto
ListVal [SymbolVal "builtin:update-indexes"] -> do
updateIndexes
ListVal [SymbolVal "builtin:scan-magic"] -> do
magic <- scanMagic
liftIO $ print $ pretty magic
ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do
w <- selectFixmeHash x
liftIO $ print $ pretty w
ListVal [SymbolVal "builtin:git:list-stage"] -> do
stage <- gitListStage
for_ stage $ \case
Left (fn,h) -> liftIO $ print $ "N" <+> pretty h <+> pretty fn
Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn
ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do
fxm <- gitExtractFileMetaData fs <&> HM.toList
liftIO $ print $ vcat (fmap (pretty.snd) fxm)
ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do
env <- ask
gitStage <- gitListStage
let dry = or [ True | StringLike "dry" <- opts ]
let verbose = or [ True | StringLike "verbose" <- opts ]
blobs <- for gitStage $ \case
Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash))
let fns = fmap (view _1) blobs
-- TODO: extract-metadata-from-git-blame
-- subj
stageFile <- localConfigDir <&> (</> "current-stage.log")
fmeStage <- compactStorageOpen mempty stageFile
for_ blobs $ \(fn, bhash, readBlob) -> do
nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
lbs <- readBlob
fxs <- scanBlob (Just fn) lbs
>>= \e -> do
for e $ \fx0 -> do
n <- atomically $ stateTVar nno (\m -> do
let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0
(what, HM.insert (fixmeTitle fx0) (succ what) m)
)
let ls = fixmePlain fx0
meta <- getMetaDataFromGitBlame fn fx0
let tit = fixmeTitle fx0 & coerce @_ @Text
-- FIXME: fix-this-copypaste
let ks = [qc|{fn}#{tit}:{n}|] :: Text
let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
let kh = HM.singleton "fixme-key" ksh
let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta)
& set (field @"fixmePlain") ls
& over (field @"fixmeAttr")
(HM.insert "blob" (fromString $ show $ pretty bhash))
& over (field @"fixmeAttr")
(mappend (kh<>kv))
unless dry do
for_ fxs $ \fx -> void $ runMaybeT do
e <- getEpoch
let what = Added e fx
let k = mkKey (FromFixmeKey fx)
get fmeStage k >>= guard . isNothing
put fmeStage k (LBS.toStrict $ serialise what)
when verbose do
liftIO $ print (pretty fx)
when dry do
warn $ red "FUCKING DRY!"
compactStorageClose fmeStage
ListVal [SymbolVal "trace"] -> do
setLogging @TRACE (logPrefix "[trace] " . toStderr)
trace "trace on"
ListVal [SymbolVal "no-trace"] -> do
trace "trace off"
setLoggingOff @TRACE
ListVal [SymbolVal "debug"] -> do
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
w -> err (pretty w)

2
fixme-new/lib/Fixme/Scan/Git/Local.hs
View File

@ -365,3 +365,5 @@ startGitCatFile = do
-- ssin <- getStdin config
startProcess config

2
fixme-new/lib/Fixme/State.hs
View File

@ -404,7 +404,7 @@ insertFixme fme = do
when excluded.w > object.w and (excluded.v <> object.v) then excluded.w
else object.w
end,
nonce = case when excluded.w > object.w and (excluded.v <> object.v) then null
nonce = case when excluded.w > object.w and (excluded.v <> object.v) then excluded.nonce
else object.nonce
end
|]

10
fixme-new/lib/Fixme/Types.hs
View File

@ -332,6 +332,14 @@ data PeerNotConnected = PeerNotConnected
instance Exception PeerNotConnected
data FixmeFlags =
FixmeIgnoreCached
deriving stock (Eq,Ord,Enum,Show,Generic)
instance Hashable FixmeFlags
-- hashWithSalt s e = undefined
data FixmeEnv =
FixmeEnv
{ fixmeLock :: MVar ()
@ -358,6 +366,7 @@ data FixmeEnv =
, fixmeEnvRefChan :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
, fixmeEnvAuthor :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
, fixmeEnvReader :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic))
, fixmeEnvFlags :: TVar (HashSet FixmeFlags)
}
@ -428,6 +437,7 @@ fixmeEnvBare =
<*> newTVarIO mzero
<*> newTVarIO mzero
<*> newTVarIO mzero
<*> newTVarIO mempty
withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
withFixmeEnv env what = runReaderT ( fromFixmeM what) env

50
hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs
View File

@ -8,6 +8,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G
import HBS2.Hash
import HBS2.Net.Auth.GroupKeySymm as Symm
import HBS2.Data.Types.Refs
import HBS2.Data.Detect
import HBS2.Merkle
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
@ -19,6 +20,7 @@ import HBS2.KeyMan.Keys.Direct
import HBS2.Net.Auth.Schema()
import Codec.Serialise
import Data.Coerce
import Data.ByteString.Lazy qualified as LBS
import Data.HashMap.Strict qualified as HM
import Data.Text qualified as Text
@ -26,22 +28,22 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Cont
import Control.Monad.Except
--FIXME: move-somewhere-else
getGroupKeyHash :: ( IsContext c
, MonadUnliftIO m
getGroupKeyHash :: ( MonadUnliftIO m
, HasStorage m
, HasClientAPI StorageAPI UNIX m
)
=> HashRef
-> RunM c m (Maybe HashRef, MTreeAnn [HashRef])
-> m (Maybe HashRef, MTreeAnn [HashRef])
getGroupKeyHash h = do
flip runContT pure do
sto <- getStorage
sto <- lift getStorage
headBlock <- getBlock sto (fromHashRef h)
>>= orThrowUser "no-block"
>>= orThrow MissedBlockError
<&> deserialiseOrFail @(MTreeAnn [HashRef])
>>= orThrowUser "invalid block format"
>>= orThrow UnsupportedFormat
case _mtaCrypt headBlock of
(EncryptGroupNaClSymm hash _) ->
@ -115,3 +117,39 @@ createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do
runExceptT $ writeAsMerkle sto source <&> HashRef
getTreeContents :: forall m . ( MonadUnliftIO m
, MonadIO m
, MonadError OperationError m
)
=> AnyStorage
-> HashRef
-> m LBS.ByteString
getTreeContents sto href = do
blk <- getBlock sto (coerce href)
>>= orThrowError MissedBlockError
let q = tryDetect (coerce href) blk
case q of
Merkle _ -> do
readFromMerkle sto (SimpleKey (coerce href))
MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
readFromMerkle sto (SimpleKey (coerce href))
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh)
>>= orThrowError (GroupKeyNotFound 11)
<&> HM.keys . Symm.recipients
let findStuff g = do
runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
_ -> throwError UnsupportedFormat

2
hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs
View File

@ -3,6 +3,8 @@
module HBS2.CLI.Run.MetaData
( metaDataEntries
, createTreeWithMetadata
, getTreeContents
, getGroupKeyHash
) where
import HBS2.CLI.Prelude

12
hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
View File

@ -63,6 +63,18 @@ data MessagingUnixOpts =
| MUKeepAlive Int
deriving (Eq,Ord,Show,Generic,Data)
-- TODO: counters-to-detect-zombies
-- $class: leak
-- добавить счётчики для обнаружения
-- мёртвых соединений, а так же их отстрел.
-- есть основания полагать, что Messaging
-- может течь.
--
-- Шаг 1. добавить счётчики
-- Шаг 2. убедиться, что ресурсы текут
-- Шаг 3. устранить течь
-- Шаг 4. убедиться, что течь устранена
-- FIXME: use-bounded-queues
data MessagingUnix =
MessagingUnix

7
hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs
View File

@ -157,6 +157,13 @@ extractGroupKeySecret gk = do
pure $ headMay r
trackGK :: forall s m . (MonadIO m, s ~ HBS2Basic)
=> AnyStorage
-> HashRef
-> m ()
trackGK sto href = do
-- gk <- loadGroupKeyMaybe @s sto href
pure ()
type TrackGroupKeyView = ( SomeHash GroupKeyId
, SomeHash HashRef

11
hbs2-keyman/hbs2-keyman/Main.hs
View File

@ -136,8 +136,11 @@ updateKeys = do
conf <- getConf
let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
-- FIXME: assume-huge-list
seen <- withState selectAllSeenGKTx
trace $ "SEEN" <+> pretty (List.length seen)
flip runContT pure $ callCC \exit -> do
when (List.null rchans) $ exit ()
so' <- detectRPC
@ -152,6 +155,8 @@ updateKeys = do
for_ rchans $ \r -> do
notice $ "scan refchan" <+> pretty (AsBase58 r)
walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case
P _ (ProposeTran _ box) -> do
@ -174,7 +179,10 @@ updateKeys = do
-- будет болтаться, если она не AnnotatedHashRef
lift $ lift $ S.yield (Left tx0)
gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs & toMPlus
let gkz1 = deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs
& either mempty List.singleton
for_ gkz1 $ \gk -> do
gkId <- getGroupKeyId gk & toMPlus
@ -183,6 +191,7 @@ updateKeys = do
notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh
lift $ lift $ S.yield (Right (gkId, gkh, gk) )
lift $ lift $ S.yield ( Left tx0 )
_ -> do
lift $ S.yield (Left tx0)

3
hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs
View File

@ -267,6 +267,9 @@ refChanUpdateProto self pc adapter msg = do
guard =<< lift (refChanSubscribed adapter (getRefChanId msg))
let h0 = hashObject @HbSync (serialise msg)
debug $ "RefchanUpdate: ALREADY" <+> pretty h0
guard =<< liftIO (hasBlock sto h0 <&> isNothing)
case msg of

2
hbs2-sync/src/HBS2/Sync/Internal.hs
View File

@ -11,6 +11,8 @@ import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client.Unix (UNIX)
import HBS2.Peer.RPC.Client
import HBS2.CLI.Run.MetaData (getTreeContents)
import HBS2.CLI.Run.Internal hiding (PeerNotConnectedException)
import Control.Monad.Trans.Maybe

35
hbs2-sync/src/HBS2/Sync/State.hs
View File

@ -24,7 +24,7 @@ import HBS2.Peer.RPC.Client.RefChan as Client
import HBS2.KeyMan.Keys.Direct
import HBS2.CLI.Run.MetaData (createTreeWithMetadata)
import HBS2.CLI.Run.MetaData (createTreeWithMetadata, getTreeContents)
import DBPipe.SQLite
import Data.Config.Suckless.Script.File
@ -599,39 +599,6 @@ mergeState seed orig = do
else
new
getTreeContents :: forall m . ( MonadUnliftIO m
, MonadIO m
, MonadError OperationError m
)
=> AnyStorage
-> HashRef
-> m LBS.ByteString
getTreeContents sto href = do
blk <- getBlock sto (coerce href)
>>= orThrowError MissedBlockError
let q = tryDetect (coerce href) blk
case q of
MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
readFromMerkle sto (SimpleKey (coerce href))
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh)
>>= orThrowError (GroupKeyNotFound 11)
<&> HM.keys . Symm.recipients
let findStuff g = do
runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
_ -> throwError UnsupportedFormat
runDirectory :: ( IsContext c
, SyncAppPerks m

2
hbs2-tests/test/TestRefChanNotify.hs
View File

@ -117,7 +117,7 @@ work = do
--
-- так лучше
--
let o = [MUWatchdog 10,MUDontRetry]
let o = [MUWatchdog 10]
soname <- detectRPC
>>= orThrowUser "hbs2-peer not found"

180
nix/peer/flake.lock
View File

@ -9,15 +9,16 @@
]
},
"locked": {
"lastModified": 1708680396,
"narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=",
"ref": "refs/heads/master",
"rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827",
"revCount": 7,
"lastModified": 1713359411,
"narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=",
"ref": "generic-sql",
"rev": "03635c54b2e2bd809ec1196bc9082447279f6f24",
"revCount": 9,
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
},
"original": {
"ref": "generic-sql",
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
}
@ -82,6 +83,21 @@
"type": "github"
}
},
"flake-utils_10": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_2": {
"locked": {
"lastModified": 1644229661,
@ -187,6 +203,62 @@
"type": "github"
}
},
"flake-utils_9": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"fuzzy": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_4",
"nixpkgs": [
"hbs2",
"nixpkgs"
]
},
"locked": {
"lastModified": 1715919110,
"narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
"ref": "refs/heads/master",
"rev": "5a55c22750589b357e50b759d2a754df058446d6",
"revCount": 40,
"type": "git",
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
},
"original": {
"type": "git",
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
}
},
"fuzzy_2": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_8",
"nixpkgs": "nixpkgs_2"
},
"locked": {
"lastModified": 1715918584,
"narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
"rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
"revCount": 63,
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
},
"original": {
"rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
}
},
"haskell-flake-utils": {
"inputs": {
"flake-utils": "flake-utils_2"
@ -245,6 +317,24 @@
"inputs": {
"flake-utils": "flake-utils_5"
},
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_5": {
"inputs": {
"flake-utils": "flake-utils_6"
},
"locked": {
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
@ -260,9 +350,9 @@
"type": "github"
}
},
"haskell-flake-utils_5": {
"haskell-flake-utils_6": {
"inputs": {
"flake-utils": "flake-utils_6"
"flake-utils": "flake-utils_7"
},
"locked": {
"lastModified": 1672412555,
@ -279,9 +369,9 @@
"type": "github"
}
},
"haskell-flake-utils_6": {
"haskell-flake-utils_7": {
"inputs": {
"flake-utils": "flake-utils_7"
"flake-utils": "flake-utils_8"
},
"locked": {
"lastModified": 1698938553,
@ -297,9 +387,27 @@
"type": "github"
}
},
"haskell-flake-utils_7": {
"haskell-flake-utils_8": {
"inputs": {
"flake-utils": "flake-utils_8"
"flake-utils": "flake-utils_9"
},
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_9": {
"inputs": {
"flake-utils": "flake-utils_10"
},
"locked": {
"lastModified": 1672412555,
@ -319,7 +427,8 @@
"inputs": {
"db-pipe": "db-pipe",
"fixme": "fixme",
"haskell-flake-utils": "haskell-flake-utils_4",
"fuzzy": "fuzzy",
"haskell-flake-utils": "haskell-flake-utils_5",
"hspup": "hspup",
"lsm": "lsm",
"nixpkgs": [
@ -329,17 +438,15 @@
"suckless-conf": "suckless-conf_2"
},
"locked": {
"lastModified": 1713159635,
"narHash": "sha256-iXf8qcJxePLM65E0fsAK2kj69/YIyQdNMrZ5yULzVGc=",
"ref": "hbs2-git-index",
"rev": "2289845078ba839bade83a1daf5234435e6e631e",
"revCount": 997,
"lastModified": 1726739166,
"narHash": "sha256-8IXnyZnKZY2kaKNgdYHDzDcMOxxmtSvkQ9HRctSM4xk=",
"rev": "627a3e0911d470b0f06d986d8bc663f934269d0e",
"revCount": 1022,
"type": "git",
"url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
},
"original": {
"ref": "hbs2-git-index",
"rev": "2289845078ba839bade83a1daf5234435e6e631e",
"rev": "627a3e0911d470b0f06d986d8bc663f934269d0e",
"type": "git",
"url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
}
@ -366,7 +473,7 @@
},
"hspup": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_5",
"haskell-flake-utils": "haskell-flake-utils_6",
"nixpkgs": [
"hbs2",
"nixpkgs"
@ -388,7 +495,7 @@
},
"lsm": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_6",
"haskell-flake-utils": "haskell-flake-utils_7",
"nixpkgs": [
"hbs2",
"nixpkgs"
@ -425,6 +532,22 @@
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
}
},
"nixpkgs_3": {
"locked": {
"lastModified": 1709200309,
"narHash": "sha256-lKdtMbhnBNU1lr978T+wEYet3sfIXXgyiDZNEgx8CV8=",
@ -445,7 +568,7 @@
"extra-container": "extra-container",
"hbs2": "hbs2",
"home-manager": "home-manager",
"nixpkgs": "nixpkgs_2"
"nixpkgs": "nixpkgs_3"
}
},
"saltine": {
@ -490,22 +613,23 @@
},
"suckless-conf_2": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_7",
"fuzzy": "fuzzy_2",
"haskell-flake-utils": "haskell-flake-utils_9",
"nixpkgs": [
"hbs2",
"nixpkgs"
]
},
"locked": {
"lastModified": 1704001322,
"narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=",
"ref": "refs/heads/master",
"rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196",
"revCount": 28,
"lastModified": 1724740155,
"narHash": "sha256-dHAWLoQ0uZ2FckV/93qbXo6aYCTY+jARXiiTgUt6fcA=",
"rev": "b6c5087312e6c09e5c27082da47846f377f73756",
"revCount": 38,
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
},
"original": {
"rev": "b6c5087312e6c09e5c27082da47846f377f73756",
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
}

2
nix/peer/flake.nix
View File

@ -7,7 +7,7 @@
extra-container.url = "github:erikarvstedt/extra-container";
nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
hbs2.url =
"git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=3b8f3d48f486043c7fa2df5990e5ab96b71996e1";
"git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=627a3e0911d470b0f06d986d8bc663f934269d0e";
hbs2.inputs.nixpkgs.follows = "nixpkgs";
home-manager.url = "github:nix-community/home-manager";