diff --git a/.fixme-new/config b/.fixme-new/config index 6a3abfa5..fa093caa 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -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 diff --git a/docs/todo/hbs2-peer-queues.txt b/docs/todo/hbs2-peer-queues.txt new file mode 100644 index 00000000..bb454b02 --- /dev/null +++ b/docs/todo/hbs2-peer-queues.txt @@ -0,0 +1,29 @@ +TODO: hbs2-peer-queues + $workflow: backlog + + Сделать механизм очередей ( циклических FIFO буферов ) + с управлением ( put/get ) по RPC + + hbs2-peer постоянно в памяти; + + Тогда мы решаем проблемы блокировок в sqlite: + + Процесс продюсер -- пишет в очередь через hbs2-peer ( на диск ) + + Процесс консьюмер -- читает оттуда и обновляет БД, когда к этому + готов. + + Таким образом, мы избегаем проблем с блокировками и + получаем понятный асинхронный механизм взаимодействия + между разными программами из hbs2. + + Технически их можно сделать на основе компактов, в каждый + compact пишутся сообщения в формате (n, bytestring), после + чтения консьюмером -- сообщения удаляются. + + По превышению файлом компакта некоего размера -- + производим компактизацию, т.е начинаем писать в новый + файл, а старый удаляем, как только в нём не останется + ничего для чтения... Ну или как-то так. + + diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 66e23c71..3fc39f97 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -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 diff --git a/fixme-new/lib/Fixme/GK.hs b/fixme-new/lib/Fixme/GK.hs new file mode 100644 index 00000000..58baf1f9 --- /dev/null +++ b/fixme-new/lib/Fixme/GK.hs @@ -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) + diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index b8a54d8d..7ca139d8 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -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 diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index f459cde7..684fa0d4 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -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,52 +601,269 @@ 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 sn href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + scanned <- lift $ selectIsAlreadyScanned href + + when (not scanned || ignCached) do + + let isGk = sn == Just fixmeGkSign + + if isGk then do + + atomically $ writeTQueue tq (Left (txh, orig, href, href)) + + else do + what <- liftIO (runExceptT $ getTreeContents sto href) + <&> either (const Nothing) Just + >>= toMPlus + + let exported = deserialiseOrFail @[FixmeExported] what + & either (const Nothing) Just + + 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 $ \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 } + + if exportedWeight item /= 0 then do + notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) + insertFixmeExported (localNonce (href,i)) item + else do + debug $ "SKIP TX!" <+> pretty txh + + atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h + insertScanned txh + insertScanned href + for_ atx insertScanned + + + + +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 - scanned <- lift $ selectIsAlreadyScanned href + result <- lift $ try @_ @OperationError (getGroupKeyHash href) - -- notice $ yellow "SCANNED" <+> pretty scanned + case result of + Right (Just gk,_) -> do + atomically do + modifyTVar gkz (HS.insert gk) + modifyTVar skip (HS.insert txh) - if scanned then do - atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh - lift $ withState $ transactional do - insertScanned txh - for_ atx insertScanned + Right (Nothing,_) -> do + atomically $ modifyTVar skip (HS.insert txh) - else do + Left UnsupportedFormat -> do + debug $ "unsupported" <+> pretty href + atomically $ modifyTVar skip (HS.insert txh) - -- FIXME: decrypt-tree - what <- runExceptT (readFromMerkle sto (SimpleKey (coerce href))) - <&> either (const Nothing) Just - >>= toMPlus + Left e -> do + debug $ "other error" <+> viaShow e - exported <- deserialiseOrFail @[FixmeExported] what - & toMPlus + _ -> none - for_ exported $ \e -> do - atomically $ writeTQueue tq (txh, orig, href, e) - - imported <- atomically $ flushTQueue tq + l <- readTVarIO skip <&> HS.toList + r <- readTVarIO gkz <&> HS.toList withState $ transactional do - for_ imported $ \(txh, h, href, i) -> do - w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h - let item = i { exportedWeight = w } + for_ l (insertScanned . gkHash) - if exportedWeight item /= 0 then do - notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) - insertFixmeExported (localNonce (href,i)) item - else do - debug $ "SKIP TX!" <+> pretty txh + 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" - atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h - insertScanned txh - insertScanned href - for_ atx insertScanned diff --git a/fixme-new/lib/Fixme/Run/Internal/RefChan.hs b/fixme-new/lib/Fixme/Run/Internal/RefChan.hs new file mode 100644 index 00000000..9011de3f --- /dev/null +++ b/fixme-new/lib/Fixme/Run/Internal/RefChan.hs @@ -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 + + diff --git a/fixme-new/lib/Fixme/RunOld.hs b/fixme-new/lib/Fixme/RunOld.hs deleted file mode 100644 index 14e5db1f..00000000 --- a/fixme-new/lib/Fixme/RunOld.hs +++ /dev/null @@ -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) - - diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 5d2910d5..2741d462 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -365,3 +365,5 @@ startGitCatFile = do -- ssin <- getStdin config startProcess config + + diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index ead1514e..b5719fd1 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -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 |] diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 5caaabb6..6c507343 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs index 8217dbb9..6edd1bfb 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -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 + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 599f6759..5b21c82c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -3,6 +3,8 @@ module HBS2.CLI.Run.MetaData ( metaDataEntries , createTreeWithMetadata + , getTreeContents + , getGroupKeyHash ) where import HBS2.CLI.Prelude diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs index ea67083e..7895f509 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs @@ -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 diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs index d8081eb5..9208e542 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs @@ -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 diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs index 47e7aa2a..bacad32b 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -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,15 +179,19 @@ 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 - gkId <- getGroupKeyId gk & toMPlus + for_ gkz1 $ \gk -> do - --TODO: verify-group-key-id-if-possible + gkId <- getGroupKeyId gk & toMPlus - notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh + --TODO: verify-group-key-id-if-possible - lift $ lift $ S.yield (Right (gkId, gkh, gk) ) + 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) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs index 2801b941..b6d8cfb6 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs @@ -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 diff --git a/hbs2-sync/src/HBS2/Sync/Internal.hs b/hbs2-sync/src/HBS2/Sync/Internal.hs index 4b0a62f0..4d518f5c 100644 --- a/hbs2-sync/src/HBS2/Sync/Internal.hs +++ b/hbs2-sync/src/HBS2/Sync/Internal.hs @@ -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 diff --git a/hbs2-sync/src/HBS2/Sync/State.hs b/hbs2-sync/src/HBS2/Sync/State.hs index b05b5cbf..137e2128 100644 --- a/hbs2-sync/src/HBS2/Sync/State.hs +++ b/hbs2-sync/src/HBS2/Sync/State.hs @@ -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 diff --git a/hbs2-tests/test/TestRefChanNotify.hs b/hbs2-tests/test/TestRefChanNotify.hs index 3a98eaca..9458c33b 100644 --- a/hbs2-tests/test/TestRefChanNotify.hs +++ b/hbs2-tests/test/TestRefChanNotify.hs @@ -117,7 +117,7 @@ work = do -- -- так лучше -- - let o = [MUWatchdog 10,MUDontRetry] + let o = [MUWatchdog 10] soname <- detectRPC >>= orThrowUser "hbs2-peer not found" diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index 663c7a50..b5e8a73b 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -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" } diff --git a/nix/peer/flake.nix b/nix/peer/flake.nix index 32a67549..dd988bce 100644 --- a/nix/peer/flake.nix +++ b/nix/peer/flake.nix @@ -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";