From 009440895c87c8d81944c46dfe96cd3765d996aa Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 6 Apr 2024 10:23:50 +0300 Subject: [PATCH] wip --- .../lib/HBS2/Git/Oracle/Facts.hs | 75 +++++++++++++++---- .../lib/HBS2/Git/Oracle/Run.hs | 41 +++++++++- .../lib/HBS2/Git/Oracle/State.hs | 51 ++++++++++++- hbs2-peer/app/PeerMain.hs | 13 +++- hbs2/Main.hs | 2 +- 5 files changed, 157 insertions(+), 25 deletions(-) diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs index ea21029e..352c255f 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs @@ -8,10 +8,10 @@ import HBS2.Git.Oracle.Prelude import HBS2.Hash import DBPipe.SQLite -import DBPipe.SQLite.Generic +import DBPipe.SQLite.Generic as G +import Data.HashSet (HashSet) import Data.Aeson -import GHC.Generics import Data.Word type PKS = PubKey 'Sign HBS2Basic @@ -25,8 +25,13 @@ data GitRepoExtended = deriving stock (Generic,Data) newtype GitLwwRef = GitLwwRef (LWWRefKey HBS2Basic) - deriving stock (Generic,Data) - deriving newtype (ToField,FromField) + deriving stock (Generic,Data,Eq) + deriving newtype (ToField,FromField,Hashable) + + +newtype GitLwwRefRel = GitLwwRefRel (LWWRefKey HBS2Basic) + deriving stock (Generic,Data,Eq) + deriving newtype (ToField,FromField,Hashable) newtype GitLwwSeq = GitLwwSeq Word64 deriving stock (Generic,Data) @@ -65,6 +70,10 @@ newtype GitEncrypted = GitEncrypted (Maybe HashRef) deriving stock (Generic,Data) deriving newtype (ToField, FromField) +newtype GitBundle = GitBundle HashRef + deriving stock (Generic,Data) + deriving newtype (ToField,FromField) + instance ToJSON GitLwwRef where toJSON (GitLwwRef k) = toJSON $ show $ pretty k @@ -84,17 +93,33 @@ instance ToJSON GitName where data Facts data GitRepoFacts = - GitRepoFacts - { gitLwwRef :: GitLwwRef - , gitLwwSeq :: GitLwwSeq - , gitRefLog :: GitRefLog - , gitTx :: GitTx - , gitRepoHead :: GitRepoHeadRef - , gitRepoHeadSeq :: GitRepoHeadSeq - , gitName :: GitName - , gitBrief :: GitBrief - , gitEncrypted :: GitEncrypted - , gitExtended :: [GitRepoExtended] + GitRepoFacts + { gitLwwRef :: GitLwwRef + , gitLwwSeq :: GitLwwSeq + , gitRefLog :: GitRefLog + , gitTx :: GitTx + , gitRepoHead :: GitRepoHeadRef + , gitRepoHeadSeq :: GitRepoHeadSeq + , gitName :: GitName + , gitBrief :: GitBrief + , gitEncrypted :: GitEncrypted + , gitExtended :: [GitRepoExtended] + } + | GitRepoRelatedFact + { gitLwwRef :: GitLwwRef + , gitRelated :: HashSet GitLwwRef + } + + deriving stock (Generic,Data) + +data GitRepoRelatedFactTable = + GitRepoRelatedFactTable + deriving stock (Data,Generic) + +data GitRepoBundle = + GitRepoBundle + { gitRepo :: GitLwwRef + , gitRepoBundle :: GitBundle } deriving stock (Generic,Data) @@ -110,6 +135,7 @@ instance Serialise GitManifest instance Serialise GitRepoExtended instance Serialise GitEncrypted instance Serialise GitRepoHeadSeq +instance Serialise GitBundle instance ToField HashRef where toField = toField @String . show . pretty @@ -132,9 +158,22 @@ instance (FromField (RefLogKey HBS2Basic)) where instance HasTableName GitRepoFacts where tableName = "gitrepofact" +instance HasTableName GitRepoRelatedFactTable where + tableName = "gitreporelatedfact" + +instance HasPrimaryKey GitRepoRelatedFactTable where + primaryKey = [G.columnName @GitLwwRef, G.columnName @GitLwwRefRel] + instance HasTableName GitManifest where tableName = "gitrepomanifest" +instance HasTableName GitRepoBundle where + tableName = "gitrepobundle" + +instance HasPrimaryKey GitRepoBundle where + primaryKey = [G.columnName @GitLwwRef, G.columnName @GitBundle] + + instance HasColumnName GitManifest where columnName = "manifest" @@ -147,6 +186,9 @@ instance HasPrimaryKey GitRepoFacts where instance HasColumnName GitLwwRef where columnName = "lwwref" +instance HasColumnName GitLwwRefRel where + columnName = "lwwrefrel" + instance HasColumnName GitLwwSeq where columnName = "lwwseq" @@ -171,3 +213,6 @@ instance HasColumnName GitEncrypted where instance HasColumnName GitRepoHeadSeq where columnName = "repoheadseq" +instance HasColumnName GitBundle where + columnName = "bundle" + diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index 7ba8d1fc..96742f48 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs @@ -46,6 +46,7 @@ import Data.Ord import Data.Text qualified as Text import Data.List qualified as List import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS import Data.ByteString.Lazy qualified as LBS import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) @@ -114,14 +115,28 @@ runOracleIndex auPk = do <&> deserialiseOrFail @(RefLogUpdate L4Proto) >>= toMPlus >>= unpackTx - >>= \(n,h,_) -> lift (S.yield (n,htx)) + >>= \(n,h,blk) -> lift (S.yield (n,htx,blk)) - let tx' = maximumByMay (comparing fst) txs + relAlready <- lift $ withDB db do + -- FIXME: uncomment-for-speedup + done <- isGitRepoBundleProcessed mh >> pure False + unless done do + transactional do + for_ txs $ \(n,_,bu) -> do + refs <- fromRight mempty <$> readBundleRefs sto bu + for_ refs $ \r -> do + debug $ red "bundle-fact" <+> pretty lw <+> pretty r + insertRepoBundleFact (GitRepoBundle (GitLwwRef lw) (GitBundle r)) - for_ tx' $ \(n,tx) -> void $ runMaybeT do + insertGitRepoBundleProcessed mh + pure done + + -- let tx' = maximumByMay (comparing (view _1)) txs + + for_ txs $ \(n,tx,blk) -> void $ runMaybeT do liftIO $ withDB db do transactional do - for_ [ t | (i,t) <- txs, i < n ] $ \tran -> do + for_ [ t | (i,t,_) <- txs, i < n ] $ \tran -> do insertTxProcessed (HashVal tran) (rhh,RepoHeadSimple{..}) <- readRepoHeadFromTx sto tx @@ -143,6 +158,24 @@ runOracleIndex auPk = do (GitEncrypted _repoHeadGK0) [GitRepoExtendedManifest (GitManifest manifest)] + -- yield repo relation facts by common bundles + unless relAlready do + + what <- withDB db do + select_ @_ @(GitLwwRef, GitLwwRef) [qc| + select distinct + b1.lwwref + , b2.lwwref + from gitrepobundle b1 join gitrepobundle b2 on b1.bundle = b2.bundle + where b1.lwwref <> b2.lwwref + |] + + let r = HM.fromListWith (<>) [ (a, HS.singleton b) | (a,b) <- what ] + & HM.toList + + for_ r $ \(lww, rel) -> do + lift $ S.yield $ GitRepoRelatedFact lww rel + -- liftIO $ withDB db (insertTxProcessed (HashVal tx)) rchanAPI <- asks _refchanAPI diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs index 0ba1612d..09721475 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs @@ -12,11 +12,10 @@ import DBPipe.SQLite hiding (insert,columnName) import DBPipe.SQLite qualified as SQL import DBPipe.SQLite.Generic -import GHC.Generics +import Data.HashSet qualified as HS import Data.Aeson import Text.InterpolatedString.Perl6 (qc) import Data.Coerce -import Data.Word import Data.Text qualified as Text data GitRepoPage = @@ -55,7 +54,9 @@ evolveDB :: MonadUnliftIO m => DBPipeM m () evolveDB = do debug $ yellow "evolveDB" gitRepoFactTable + gitRepoRelatedFactTable gitRepoManifestTable + gitRepoBundleTable gitRepoFactView txProcessedTable @@ -86,6 +87,16 @@ gitRepoFactTable = do |] +gitRepoRelatedFactTable :: MonadUnliftIO m => DBPipeM m () +gitRepoRelatedFactTable = do + ddl [qc| + create table if not exists gitreporelatedfact + ( lwwref text not null + , lwwrefrel text not null + , primary key (lwwref,lwwrefrel) + ) + |] + gitRepoManifestTable :: MonadUnliftIO m => DBPipeM m () gitRepoManifestTable = do ddl [qc| @@ -97,6 +108,16 @@ gitRepoManifestTable = do |] +gitRepoBundleTable :: MonadUnliftIO m => DBPipeM m () +gitRepoBundleTable = do + ddl [qc| + create table if not exists gitrepobundle + ( lwwref text not null + , bundle text not null + , primary key (lwwref,bundle) + ) + |] + gitRepoFactView :: MonadUnliftIO m => DBPipeM m () gitRepoFactView = do ddl [qc|DROP VIEW IF EXISTS vrepofact|] @@ -159,7 +180,33 @@ isTxProcessed hash = do pure $ not $ null (results :: [Only Int]) +gitRepoBundleProcessedKey :: HashRef -> HashVal +gitRepoBundleProcessedKey mhead = + hashObject @HbSync (serialise ("GitRepoBundle", mhead)) & HashRef & HashVal + +isGitRepoBundleProcessed :: MonadUnliftIO m => HashRef -> DBPipeM m Bool +isGitRepoBundleProcessed mhead = do + isTxProcessed (gitRepoBundleProcessedKey mhead) + +insertGitRepoBundleProcessed :: MonadUnliftIO m => HashRef -> DBPipeM m () +insertGitRepoBundleProcessed mhead = do + insertTxProcessed (gitRepoBundleProcessedKey mhead) + +insertRepoBundleFact :: MonadUnliftIO m => GitRepoBundle -> DBPipeM m () +insertRepoBundleFact rb = do + insert @GitRepoBundle $ + onConflictIgnore @GitRepoBundle rb + insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m () + +insertRepoFacts GitRepoRelatedFact{..} = do + for_ (HS.toList gitRelated) $ \rel -> do + insert @GitRepoRelatedFactTable $ + onConflictIgnore @GitRepoRelatedFactTable + ( gitLwwRef + , GitLwwRefRel (coerce rel) + ) + insertRepoFacts facts@GitRepoFacts{..} = do insert @GitRepoFacts $ onConflictIgnore @GitRepoFacts diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 01e8fe5b..0fd83408 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -31,6 +31,8 @@ import HBS2.Storage.Simple import HBS2.Storage.Operations.Missed import HBS2.Data.Detect +import HBS2.KeyMan.Keys.Direct + import HBS2.Version import Paths_hbs2_peer qualified as Pkg @@ -281,6 +283,8 @@ runCLI = do pVersion = pure do LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version) + pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) + pRun = do runPeer <$> common @@ -417,10 +421,13 @@ runCLI = do pRefLogSend = do rpc <- pRpcCommon - kr <- strOption (long "keyring" <> short 'k' <> help "reflog keyring" <> metavar "FILE") + pk <- argument pPubKeySign (metavar "REFLOG-KEY") + pure $ withMyRPC @RefLogAPI rpc $ \caller -> do - s <- BS.readFile kr - creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile s)) `orDie` "bad keyring file" + + creds <- runKeymanClient $ loadCredentials pk + >>= orThrowUser "can't find credentials" + bs <- BS.take defChunkSize <$> BS.hGetContents stdin let pubk = view peerSignPk creds let privk = view peerSignSk creds diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 416dbc25..19390e95 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -553,7 +553,7 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw - pMetadata = hsubparser ( command "dump" (info pMetadataDump (progDesc "dump metadata")) + pMetadata = hsubparser ( command "dump" (info pMetadataDump (progDesc "dump metadata")) <> command "create" (info pMetadataCreate (progDesc "create tree with metadata")) )