diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs index 3c55a814..ca217686 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs index ebca824c..9bf0fb89 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs +++ b/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 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 c9bd5622..67a107a1 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 @@ -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 + 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 - - - for_ polls $ \(p, s, _) -> do - debug $ "found poll" <+> pretty (AsBase58 p) <+> pretty s + <&> fmap (LWWRefKey @HBS2Basic . view _1) + + repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do + (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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index ecf55583..8d4113c5 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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 diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 2348788a..2f32003e 100644 --- a/hbs2-peer/app/Brains.hs +++ b/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) diff --git a/hbs2-peer/app/RPC2/Poll.hs b/hbs2-peer/app/RPC2/Poll.hs index 2d0082b2..a10ff85a 100644 --- a/hbs2-peer/app/RPC2/Poll.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Brains.hs b/hbs2-peer/lib/HBS2/Peer/Brains.hs index 49a1caa2..8c16d230 100644 --- a/hbs2-peer/lib/HBS2/Peer/Brains.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs index 3a012a30..e47310ef 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs +++ b/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 = ()