wip

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -99,6 +99,12 @@ instance FromField HashRef where
 instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where
   toField x = toField $ show $ pretty (AsBase58 x)
 
+instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (RefLogKey s) where
+  toField x = toField $ show $ pretty (AsBase58 x)
+
+instance IsRefPubKey s => FromField (RefLogKey s) where
+  fromField = fmap (fromString @(RefLogKey s)) . fromField @String
+
 instance FromField (LWWRefKey HBS2Basic) where
   fromField = fmap fromString . fromField @String
 
@@ -124,6 +130,10 @@ newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
                   deriving stock (Generic)
                   deriving newtype (ToField,FromField,Pretty)
 
+newtype RepoLwwSeq = RepoLwwSeq Integer
+                     deriving stock (Generic)
+                     deriving newtype (ToField,FromField,Pretty)
+
 newtype RepoChannel = RepoChannel MyRefChan
 
 
@@ -136,6 +146,9 @@ newtype RepoHeadSeq = RepoHeadSeq Word64
                       deriving stock (Generic)
                       deriving newtype (ToField,FromField)
 
+newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
+                     deriving stock (Generic)
+                     deriving newtype (ToField,FromField)
 
 newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
                       deriving stock (Generic)
@@ -171,12 +184,18 @@ instance HasColumnName TxHash where
 instance HasColumnName RepoLww where
   columnName = "lww"
 
+instance HasColumnName RepoLwwSeq where
+  columnName = "lwwseq"
+
 instance HasColumnName RepoName where
   columnName = "name"
 
 instance HasColumnName RepoBrief where
   columnName = "brief"
 
+instance HasColumnName RepoRefLog where
+  columnName = "reflog"
+
 instance HasColumnName RepoChannel where
   columnName = "channel"
 
@@ -283,7 +302,9 @@ create view repolistview as
 with repolist as (
   select
     r.lww,
+    0 as lwwseq,
     0 as seq,
+    null as reflog,
     null as repohead,
     null as tx,
     coalesce(n.name, r.lww) as name,
@@ -295,6 +316,8 @@ with repolist as (
   union
   select
     lww,
+    lwwseq,
+    reflog,
     seq,
     repohead,
     tx,
@@ -306,18 +329,20 @@ with repolist as (
 ranked_repos as (
   select
     lww,
+    lwwseq,
+    reflog,
     seq,
     repohead,
     tx,
     name,
     brief,
     gk0,
-    row_number() over (partition by lww order by seq desc) as rn
+    row_number() over (partition by lww order by lwwseq desc, seq desc) as rn
   from repolist
   order by seq desc
 )
 
-select lww, seq, repohead, tx, name, brief, gk0
+select lww, lwwseq, reflog, seq, repohead, tx, name, brief, gk0
 from ranked_repos
 where rn = 1;
 
@@ -329,13 +354,15 @@ createRepoHeadTable = do
   ddl [qc|
     create table if not exists repohead
       (  lww        text not null
+      ,  lwwseq     integer not null
+      ,  reflog     text not null
       ,  repohead   text not null
       ,  tx         text not null
       ,  seq        integer not null
       ,  gk0        text null
       ,  name       text
       ,  brief      text
-      ,  primary key (lww,repohead)
+      ,  primary key (lww,lwwseq,repohead)
       )
   |]
 
@@ -345,7 +372,7 @@ instance HasTableName RepoHeadTable where
   tableName = "repohead"
 
 instance HasPrimaryKey RepoHeadTable where
-  primaryKey = ["lww", "repohead"]
+  primaryKey = ["lww", "lwwseq", "repohead"]
 
 instance HasColumnName RepoHeadRef where
   columnName = "repohead"
@@ -359,15 +386,20 @@ instance HasColumnName RepoHeadGK0 where
 instance HasColumnName RepoHeadTx where
   columnName = "tx"
 
+
 insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m)
                => LWWRefKey 'HBS2Basic
+               -> RepoLwwSeq
+               -> RepoRefLog
                -> RepoHeadTx
                -> RepoHeadRef
                -> RepoHead
                -> DBPipeM m ()
-insertRepoHead lww tx rf rh = do
+insertRepoHead lww lwwseq rlog tx rf rh = do
   insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable
     ( RepoLww lww
+    , lwwseq
+    , rlog
     , rf
     , tx
     , RepoHeadSeq      (_repoHeadTime rh)

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs

@@ -10,12 +10,15 @@ import Streaming.Prelude qualified as S
 
 {- HLINT ignore "Functor law" -}
 
+seconds = TimeoutSec
+
 updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
 updateIndexFromPeer = do
   debug "updateIndexFromPeer"
 
   peer   <- asks _peerAPI
   reflog <- asks _refLogAPI
+  lwwAPI <- asks _lwwRefAPI
   sto    <- asks _sto
 
 
@@ -24,12 +27,16 @@ updateIndexFromPeer = do
             <&> fmap (LWWRefKey @HBS2Basic . view _1)
 
   repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do
+
+            lwval <- liftIO (callRpcWaitMay @RpcLWWRefGet (seconds 1) lwwAPI r)
+                       >>= toMPlus >>= toMPlus
+
             (lw,blk) <- readLWWBlock sto r >>= toMPlus
             let rk = lwwRefLogPubKey blk
 
-            lift $ S.yield (r,RefLogKey @'HBS2Basic rk,blk)
+            lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk)
 
-  for_ repos $ \(lw,rk,LWWBlockData{..}) -> do
+  for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do
 
     mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk)
               <&> join
@@ -61,93 +68,6 @@ updateIndexFromPeer = do
 
       withState $ transactional do
         for_ headz $ \(l, tx, rh, rhead) -> do
-          insertRepoHead l tx rh rhead
+          let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
-
+          insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
-  -- db <- asks _db
-
-  -- facts <- S.toList_ do
-
-  --   for_ repos $ \(lw,rk,LWWBlockData{..}) -> do
-
-  --     mhead <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk)
-  --               <&> join
-
-  --     for_ mhead $ \mh -> do
-
-  --       txs <- S.toList_ $ do
-  --                 walkMerkle @[HashRef] (fromHashRef mh) (getBlock sto) $ \case
-  --                   Left{}   -> do
-  --                     pure ()
-
-  --                   Right hxs -> do
-  --                     for_ hxs $ \htx -> void $ runMaybeT do
-  --                       -- done  <- liftIO $ withDB db (isTxProcessed (HashVal htx))
-  --                       -- done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx)))
-  --                       -- guard (not done && not done1)
-  --                       getBlock sto (fromHashRef htx) >>= toMPlus
-  --                          <&> deserialiseOrFail @(RefLogUpdate L4Proto)
-  --                          >>= toMPlus
-  --                          >>= unpackTx
-  --                          >>= \(n,h,blk) -> lift (S.yield (n,htx,blk))
-
-  --       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))
-
-  --             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
-  --               insertTxProcessed (HashVal tran)
-
-  --         (rhh,RepoHeadSimple{..}) <- readRepoHeadFromTx sto tx
-  --                                        >>= toMPlus
-
-  --         let name  = Text.take 256 $  _repoHeadName
-  --         let brief = Text.take 1024 $ _repoHeadBrief
-  --         let manifest = _repoManifest
-
-  --         lift $ S.yield $ GitRepoFacts
-  --                            (GitLwwRef lw)
-  --                            (GitLwwSeq lwwRefSeed)
-  --                            (GitRefLog rk)
-  --                            (GitTx tx)
-  --                            (GitRepoHeadRef rhh)
-  --                            (GitRepoHeadSeq (fromIntegral n))
-  --                            (GitName (Just name))
-  --                            (GitBrief (Just brief))
-  --                            (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))