wip

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

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 chan  = _refchanId env
-    let rchanAPI = _refchanAPI env
+    -- let rchanAPI = _refchanAPI env
-    let sto = _storage 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 rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ]
+    withOracleEnv env do
-                & HM.fromList
+      items <- withState $ select_ @_ @(HashVal, Text, Text) [qc|
-
+                SELECT
-      items <- S.toList_ $ for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do
+                  g.ref,
-        let d = HM.lookup k rhf
+                  gn.name,
-        let nm    = maybe "" gitRepoName d
+                  gb.brief
-        let brief = maybe "" gitRepoBrief d
+                FROM
-
+                  gitrepo AS g
-        S.yield $ Aeson.toJSON [ show (pretty gitLwwRef)
+                INNER JOIN
-                               , show (pretty nm)
+                  gitreponame AS gn ON g.ref = gn.ref
-                               , show (pretty brief)
+                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

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|