mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
89400efefa
commit
11f0c27e40
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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|
|
||||
|
|
|
|||
Loading…
Reference in New Issue