wip

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs

@@ -19,6 +19,7 @@ data OracleEnv =
   { _peerAPI   :: ServiceCaller PeerAPI UNIX
   , _reflogAPI :: ServiceCaller RefLogAPI UNIX
   , _lwwAPI    :: ServiceCaller LWWRefAPI UNIX
+  , _storage   :: AnyStorage
   }
   deriving stock (Generic)
 
@@ -46,10 +47,12 @@ runWithOracleEnv m = do
   reflogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
   lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
   storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+  let sto = AnyStorage (StorageClient storageAPI)
 
   env <- pure $ OracleEnv  peerAPI
                            reflogAPI
                            lwwAPI
+                           sto
 
   let endpoints = [ Endpoint @UNIX  peerAPI
                   , Endpoint @UNIX  reflogAPI

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs

@@ -2,6 +2,7 @@ module HBS2.Git.Oracle.Prelude
   ( module HBS2.Prelude.Plated
   , module HBS2.Base58
   , module HBS2.OrDie
+  , module HBS2.Data.Types.Refs
   , module HBS2.Net.Auth.Schema
   , module HBS2.Storage
 
@@ -26,6 +27,7 @@ module HBS2.Git.Oracle.Prelude
 import HBS2.Prelude.Plated
 import HBS2.Base58
 import HBS2.OrDie
+import HBS2.Data.Types.Refs
 import HBS2.Net.Auth.Schema
 import HBS2.Net.Proto.Service
 import HBS2.Storage

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -3,22 +3,113 @@ module HBS2.Git.Oracle.Run where
 import HBS2.Git.Oracle.Prelude
 import HBS2.Git.Oracle.App
 
-import Data.Maybe
+import HBS2.Merkle
 
-runOracle :: MonadUnliftIO m => Oracle m ()
+import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.Tx
+
+import Data.Maybe
+import Lens.Micro.Platform
+
+import Data.Word
+import Streaming.Prelude qualified as S
+import Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Data.Coerce
+import Data.Ord
+import Control.Monad.Trans.Except
+import Data.List
+import Safe
+
+{- HLINT ignore "Functor law" -}
+
+data GitRepoFact =
+  GitRepoFact1
+  { gitLwwRef :: LWWRefKey HBS2Basic
+  , gitLwwSeq :: Word64
+  , gitRefLog :: RefLogKey HBS2Basic
+  }
+  deriving stock (Generic)
+
+data GitRepoHeadFact =
+  GitRepoHeadFact
+  {
+  }
+  deriving stock (Generic)
+
+
+instance Serialise GitRepoFact
+
+instance Pretty GitRepoFact where
+  pretty (GitRepoFact1{..}) =
+    parens ( "gitrepofact1" <+>  hsep [pretty gitLwwRef, pretty gitLwwSeq, pretty gitRefLog])
+
+
+makeGitRepoFactBlock :: MonadUnliftIO m => [GitRepoFact] -> Oracle m HashRef
+makeGitRepoFactBlock facts = do
+  undefined
+
+runOracle :: forall m  . MonadUnliftIO m => Oracle m ()
 runOracle = do
   debug "hbs2-git-oracle"
 
   debug "list all git references from peer"
-  -- TODO: introduce-paging
 
   peer   <- asks _peerAPI
+  reflog <- asks _reflogAPI
+  sto    <- asks _storage
 
-  polls <- callRpcWaitMay @RpcPollList (TimeoutSec 1) peer ()
+  polls <- callRpcWaitMay @RpcPollList2 (TimeoutSec 1) peer (Just "lwwref", Nothing)
             <&> join . maybeToList
-
+            <&> fmap (LWWRefKey @HBS2Basic . view _1)
-
+
-  for_ polls $ \(p, s, _) -> do
+  repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do
-    debug $ "found poll" <+> pretty (AsBase58 p) <+> pretty s
+            (lw,blk) <- readLWWBlock sto r >>= toMPlus
+            let rk = lwwRefLogPubKey blk
+
+            lift $ S.yield $
+              GitRepoFact1 r
+                           (lwwSeq lw)
+                           (RefLogKey rk)
+
+  for_ repos $ \what@GitRepoFact1{..} -> do
+
+    mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce gitRefLog)
+              <&> join
+
+    forM_ 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
+                      getBlock sto (fromHashRef htx) >>= toMPlus
+                         <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+                         >>= toMPlus
+                         >>= unpackTx
+                         >>= \(n,h,_) -> lift (S.yield (n,htx))
+
+      let tx' = maximumByMay (comparing fst) txs
+
+      forM_ tx' $ \(n,tx) -> void $ runMaybeT do
+        RepoHeadSimple{..} <- readRepoHeadFromTx sto tx >>= toMPlus
+
+        let enc = if isJust _repoHeadGK0 then "E" else "P"
+        let name  = _repoHeadName
+        let brief = _repoHeadBrief
+        let manifest = _repoManifest
+
+        debug $ "found head"
+          <+> pretty gitLwwRef
+          <+> pretty n
+          <+> pretty gitRefLog
+          <+> pretty name
+          <+> pretty brief
+          <+> pretty manifest
+          <+> pretty enc
+          <+> pretty tx
 
 

hbs2-git/hbs2-git.cabal

@@ -59,7 +59,6 @@ common shared-properties
       , hbs2-keyman
       , db-pipe
       , suckless-conf
-
       , attoparsec
       , atomic-write
       , bytestring
@@ -176,7 +175,7 @@ library hbs2-git-oracle-oracle-lib
       HBS2.Git.Oracle.App
       HBS2.Git.Oracle.Run
 
-    build-depends:    base
+    build-depends:    base, hbs2-git
                     , base16-bytestring
                     , binary
                     , unix

hbs2-peer/app/Brains.hs

@@ -256,6 +256,22 @@ instance ( Hashable (Peer e)
     where
       postprocess = mapMaybe (\(r,t,i) -> (,t,i) <$> fromStringMay r )
 
+  listPolledRefsFiltered brains (t, p)  = liftIO do
+    debug $ red "brains: listPolledRefsFiltered" <+> pretty (t,p)
+    let conn = view brainsDb brains
+    let sql = [qc|
+      select ref, type, interval
+      from {poll_table}
+      where coalesce(type = ?, true)
+      limit ?
+      offset ?
+    |]
+    query conn sql (t, lim, off ) <&> postprocess
+    where
+      postprocess = mapMaybe (\(r,t1,i) -> (,t1,i) <$> fromStringMay r )
+      off = maybe 0 fst p
+      lim = maybe 1000 snd p
+
   isPolledRef brains tp ref = do
 
     cached <- liftIO $ readTVarIO (_brainsPolled brains) <&> HashSet.member (ref,tp)

hbs2-peer/app/RPC2/Poll.hs

@@ -18,6 +18,12 @@ instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcP
     debug $ "rpc.pollList"
     listPolledRefs @L4Proto brains Nothing
 
+instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollList2 where
+
+  handleMethod filt = do
+    brains <- getRpcContext @PeerAPI <&> rpcBrains
+    debug $ "rpc.pollList2" <+> pretty filt
+    listPolledRefsFiltered @L4Proto brains filt
 
 instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollAdd where
 

hbs2-peer/lib/HBS2/Peer/Brains.hs

@@ -18,6 +18,13 @@ class HasBrains e a where
   listPolledRefs :: MonadIO m => a -> Maybe String -> m [(PubKey 'Sign (Encryption e), String, Int)]
   listPolledRefs _ _  = pure mempty
 
+  listPolledRefsFiltered :: MonadIO m
+                         => a
+                         -> (Maybe String, Maybe (Int, Int))
+                         -> m [(PubKey 'Sign (Encryption e), String, Int)]
+
+  listPolledRefsFiltered _ _  = pure mempty
+
   isPolledRef :: MonadIO m => a -> String -> PubKey 'Sign (Encryption e) -> m Bool
   isPolledRef _ _ _ = pure False
 
@@ -159,6 +166,7 @@ data SomeBrains e = forall a . HasBrains e a => SomeBrains a
 
 instance HasBrains e (SomeBrains e) where
   listPolledRefs (SomeBrains a) = listPolledRefs @e a
+  listPolledRefsFiltered (SomeBrains a) = listPolledRefsFiltered @e a
   isPolledRef (SomeBrains a) = isPolledRef @e a
   delPolledRef (SomeBrains a) = delPolledRef @e a
   addPolledRef (SomeBrains a) = addPolledRef @e a

hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs

@@ -25,6 +25,7 @@ data RpcLogLevel
 data RpcDie
 
 data RpcPollList
+data RpcPollList2
 data RpcPollAdd
 data RpcPollDel
 
@@ -50,6 +51,7 @@ type PeerAPI = '[ RpcPoke
                 , RpcDownloadDel
                 , RpcByPassInfo
                 , RpcPerformGC
+                , RpcPollList2
                 ]
 
 instance HasProtocol UNIX  (ServiceProto PeerAPI UNIX) where
@@ -84,15 +86,20 @@ type instance Output RpcPeers = [(PubKey 'Sign HBS2Basic, PeerAddr L4Proto)]
 type instance Input RpcFetch = HashRef
 type instance Output RpcFetch = ()
 
+
 type instance Input RpcPollList= ()
 type instance Output RpcPollList = [(PubKey 'Sign HBS2Basic, String, Int)]
 
+type instance Input RpcPollList2  = (Maybe String, Maybe (Int,Int))
+type instance Output RpcPollList2 = [(PubKey 'Sign HBS2Basic, String, Int)]
+
 type instance Input RpcDownloadList = ()
 type instance Output RpcDownloadList = [(HashRef, Integer)]
 
 type instance Input RpcDownloadDel = HashRef
 type instance Output RpcDownloadDel = ()
 
+
 type instance Input RpcPollAdd = (PubKey 'Sign HBS2Basic, String, Int)
 type instance Output RpcPollAdd = ()