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 5980948b..0816c14a 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 @@ -5,6 +5,7 @@ module HBS2.Git.Oracle.App ( OracleEnv(..) , Oracle(..) , runWithOracleEnv + , withOracleEnv , withState ) where @@ -99,7 +100,11 @@ runWithOracleEnv rchan m = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - lift $ runReaderT (fromOracle (withState evolveDB >> m)) env + lift $ withOracleEnv env m + +withOracleEnv :: MonadUnliftIO m => OracleEnv -> Oracle m a -> m a +withOracleEnv env action = do + runReaderT (fromOracle (withState evolveDB >> action)) env class Monad m => HasDB m where getDB :: m DBPipeEnv 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 002993e4..c0ee5696 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 @@ -36,7 +36,7 @@ import Data.Text qualified as Text import Data.HashMap.Strict qualified as HM import Data.ByteString.Lazy qualified as LBS import System.Process.Typed - +import Text.InterpolatedString.Perl6 (qc) import System.Environment (getProgName, getArgs) {- HLINT ignore "Functor law" -} @@ -195,60 +195,34 @@ class HasOracleEnv m where instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery where handleMethod _ = do env <- getOracleEnv - let chan = _refchanId env - let rchanAPI = _refchanAPI env - let sto = _storage env - - runMaybeT do - - rv <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) rchanAPI chan) - >>= toMPlus >>= toMPlus - - facts <- S.toList_ do - walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case - Left{} -> pure () - Right txs -> do - for_ txs $ \htx -> void $ runMaybeT do - getBlock sto (fromHashRef htx) - >>= toMPlus - <&> deserialiseOrFail @(RefChanUpdate L4Proto) - >>= toMPlus - >>= \case - Propose _ box -> pure box - _ -> mzero - <&> unboxSignedBox0 - >>= toMPlus - <&> snd - >>= \(ProposeTran _ box) -> toMPlus (unboxSignedBox0 box) - <&> snd - <&> deserialiseOrFail @GitRepoFacts . LBS.fromStrict - >>= toMPlus - >>= lift . S.yield - - let rf = [ (HashRef (hashObject $ serialise f), f) - | f@GitRepoFact1{} <- universeBi facts - ] & HM.fromListWith (\v1 v2 -> if gitLwwSeq v1 > gitLwwSeq v2 then v1 else v2) + -- let chan = _refchanId env + -- let rchanAPI = _refchanAPI env + -- let sto = _storage env - let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ] - & HM.fromList - - items <- S.toList_ $ for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do - let d = HM.lookup k rhf - let nm = maybe "" gitRepoName d - let brief = maybe "" gitRepoBrief d - - S.yield $ Aeson.toJSON [ show (pretty gitLwwRef) - , show (pretty nm) - , show (pretty brief) - ] + withOracleEnv env do + items <- withState $ select_ @_ @(HashVal, Text, Text) [qc| + SELECT + g.ref, + gn.name, + gb.brief + FROM + gitrepo AS g + INNER JOIN + gitreponame AS gn ON g.ref = gn.ref + INNER JOIN + gitrepoheadversion AS ghv ON gn.hash = ghv.hash + LEFT JOIN + gitrepobrief AS gb ON g.ref = gb.ref AND ghv.hash = gb.hash + GROUP BY + g.ref, gn.name + |] let root = object [ "rows" .= items - , "state" .= show (pretty rv) , "desc" .= [ "entity", "name", "brief" ] ] - pure $ A.encodePretty root + pure $ Just $ A.encodePretty root -- Codec for protocol instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where @@ -280,6 +254,11 @@ runPipe = do void $ ContT $ withAsync $ runMessagingPipe server + void $ ContT $ withAsync $ forever do + debug $ yellow "updateState" + updateState + pause @'Seconds 60 + -- make server protocol responder -- void $ ContT $ withAsync $ flip lift $ flip runReaderT server do 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 62d74e3f..6a352793 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 @@ -2,9 +2,8 @@ module HBS2.Git.Oracle.State where import HBS2.Git.Oracle.Prelude import HBS2.Hash -import DBPipe.SQLite -import Data.Coerce +import Data.Aeson import Text.InterpolatedString.Perl6 (qc) import Data.Word @@ -75,12 +74,18 @@ newtype GitRepoKey = GitRepoKey (LWWRefKey HBS2Basic) newtype HashVal = HashVal HashRef deriving stock Generic +instance ToJSON HashVal where + toJSON (HashVal x) = toJSON (show $ pretty x) + instance ToField GitRepoKey where toField (GitRepoKey r) = toField $ show $ pretty $ AsBase58 r instance ToField HashVal where toField (HashVal r) = toField $ show $ pretty $ AsBase58 r +instance FromField HashVal where + fromField = fmap (HashVal . fromString @HashRef) . fromField @String + insertGitRepo :: MonadUnliftIO m => GitRepoKey -> DBPipeM m () insertGitRepo repo = do insert [qc|