wip

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 stock (Generic,Data,Eq)
-                     deriving newtype (ToField,FromField)
+                     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
+    GitRepoFacts
-  { gitLwwRef       :: GitLwwRef
+    { gitLwwRef       :: GitLwwRef
-  , gitLwwSeq       :: GitLwwSeq
+    , gitLwwSeq       :: GitLwwSeq
-  , gitRefLog       :: GitRefLog
+    , gitRefLog       :: GitRefLog
-  , gitTx           :: GitTx
+    , gitTx           :: GitTx
-  , gitRepoHead     :: GitRepoHeadRef
+    , gitRepoHead     :: GitRepoHeadRef
-  , gitRepoHeadSeq  :: GitRepoHeadSeq
+    , gitRepoHeadSeq  :: GitRepoHeadSeq
-  , gitName         :: GitName
+    , gitName         :: GitName
-  , gitBrief        :: GitBrief
+    , gitBrief        :: GitBrief
-  , gitEncrypted    :: GitEncrypted
+    , gitEncrypted    :: GitEncrypted
-  , gitExtended     :: [GitRepoExtended]
+    , 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"
+

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

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

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

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"))
                            )