diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index d1570522..e1ba4963 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -139,6 +139,7 @@ runFixmeCLI m = do <*> newTVarIO mzero <*> newTVarIO mzero <*> newTVarIO mzero + <*> newTVarIO mempty -- FIXME: defer-evolve -- не все действия требуют БД, @@ -442,6 +443,8 @@ runTop forms = do 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 @@ -476,6 +479,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) diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index d053af2c..b6f4e8f3 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -12,7 +12,7 @@ import Fixme.Scan as Scan import Fixme.GK import HBS2.Git.Local.CLI -import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents) +import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents,getGroupKeyHash) import HBS2.Polling import HBS2.OrDie @@ -31,6 +31,7 @@ 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 @@ -530,6 +531,8 @@ refchanUpdate = do let w = view refChanHeadWaitAccept rch + refchanExportGroupKeys + txn <- refchanExport () unless (txn == 0) do @@ -609,7 +612,6 @@ refchanImport = do else do - -- FIXME: decrypt-tree what <- liftIO (runExceptT $ getTreeContents sto href) <&> either (const Nothing) Just >>= toMPlus @@ -773,3 +775,110 @@ fixmeRefChanInit = do notice $ green "refchan added" <+> pretty (AsBase58 refchan) + + +refchanExportGroupKeys :: FixmePerks m => FixmeM m () +refchanExportGroupKeys = do + + let gkHash x = hashObject @HbSync ("GKSCAN" <> serialise x) & HashRef + + sto <- getStorage + + chan <- asks fixmeEnvRefChan + >>= readTVarIO + >>= orThrowUser "refchan not set" + + ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached + + let goodToGo x | ignCached = pure True + | otherwise = do + here <- selectIsAlreadyScanned (gkHash x) + pure $ not here + + debug "refchanExportGroupKeys" + + skip <- newTVarIO HS.empty + gkz <- newTVarIO HS.empty + + 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" + + hashes <- L.sort <$> S.toList_ do + for_ r $ \gkh -> void $ runMaybeT do + gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus + gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk) + + when (isNothing gks) do + -- lift $ withState (insertScanned (gkHash txh)) + warn $ "unaccessible group key" <+> pretty gkh + mzero + + debug $ red "prepare new gk0" <+> pretty gkh <+> pretty (groupKeyId gk) + + gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch) + gkh1 <- writeAsMerkle sto (serialise gk1) <&> HashRef + lift $ S.yield gkh1 + + notice $ yellow $ "new gk:" <+> pretty (L.length hashes) + + -- scanned <- lift $ selectIsAlreadyScanned href + + -- -- notice $ yellow "SCANNED" <+> pretty scanned + + -- if scanned then do + -- atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh + -- lift $ withState $ transactional do + -- insertScanned txh + -- for_ atx insertScanned + + -- else do + + -- -- FIXME: decrypt-tree + -- what <- liftIO (runExceptT $ getTreeContents sto href) + -- <&> either (const Nothing) Just + -- >>= toMPlus + + -- exported <- deserialiseOrFail @[FixmeExported] what + -- & toMPlus + 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 dfc9dc14..6edd1bfb 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -28,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 _) -> diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 4a3a3d5b..5b21c82c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -4,6 +4,7 @@ module HBS2.CLI.Run.MetaData ( metaDataEntries , createTreeWithMetadata , getTreeContents + , getGroupKeyHash ) where import HBS2.CLI.Prelude 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..37a4ecf6 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -136,6 +136,7 @@ updateKeys = do conf <- getConf let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ] + -- FIXME: assume-huge-list seen <- withState selectAllSeenGKTx flip runContT pure $ callCC \exit -> do @@ -152,6 +153,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