mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
e20bbcc551
commit
b1c75a43f0
|
|
@ -261,6 +261,26 @@ callService caller input = do
|
|||
_ -> pure (Left ErrorInvalidResponse)
|
||||
|
||||
|
||||
callRpcWaitMay :: forall method (api :: [Type]) m e proto t . ( MonadUnliftIO m
|
||||
, KnownNat (FromJust (FindMethodIndex 0 method api))
|
||||
, HasProtocol e (ServiceProto api e)
|
||||
, Serialise (Input method)
|
||||
, Serialise (Output method)
|
||||
, IsTimeout t
|
||||
, proto ~ ServiceProto api e
|
||||
)
|
||||
=> Timeout t
|
||||
-> ServiceCaller api e
|
||||
-> Input method
|
||||
-> m (Maybe (Output method))
|
||||
|
||||
callRpcWaitMay t caller args = do
|
||||
race (pause t) (callService @method @api @e @m caller args)
|
||||
>>= \case
|
||||
Right (Right x) -> pure (Just x)
|
||||
_ -> pure Nothing
|
||||
|
||||
|
||||
makeClient :: forall api e m . ( MonadIO m
|
||||
, HasProtocol e (ServiceProto api e)
|
||||
, Pretty (Peer e)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Git.Oracle.Prelude
|
||||
import HBS2.Git.Oracle.App
|
||||
import HBS2.Git.Oracle.Run
|
||||
|
||||
import Options.Applicative
|
||||
import Options.Applicative as O
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
|
@ -12,19 +14,26 @@ main = do
|
|||
<> help "serve"
|
||||
)
|
||||
|
||||
join $ execParser (info (parser <**> helper)
|
||||
join $ execParser (O.info (parser <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "hbs2-git oracle / distributed index builder"
|
||||
<> header "hbs2-git-oracle"))
|
||||
|
||||
runApp :: MonadUnliftIO m => Bool -> m ()
|
||||
runApp _ = do
|
||||
pure ()
|
||||
|
||||
setLogging @DEBUG (toStderr . logPrefix "[debug] ")
|
||||
setLogging @WARN (toStderr . logPrefix "[warn] ")
|
||||
setLogging @ERROR (toStderr . logPrefix "[error] ")
|
||||
setLogging @NOTICE (toStderr . logPrefix "[debug] ")
|
||||
|
||||
-- where
|
||||
-- pLww :: ReadM (LWWRefKey HBS2Basic)
|
||||
-- pLww = maybeReader fromStringMay
|
||||
runWithOracleEnv runOracle
|
||||
|
||||
`finally` do
|
||||
setLoggingOff @DEBUG
|
||||
setLoggingOff @WARN
|
||||
setLoggingOff @ERROR
|
||||
setLoggingOff @NOTICE
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,19 @@
|
|||
module HBS2.Git.Oracle.App where
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module HBS2.Git.Oracle.App
|
||||
( OracleEnv(..)
|
||||
, Oracle(..)
|
||||
, runWithOracleEnv
|
||||
) where
|
||||
|
||||
import HBS2.Git.Oracle.Prelude
|
||||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
||||
import GHC.TypeLits
|
||||
import Codec.Serialise
|
||||
|
||||
data OracleEnv =
|
||||
OracleEnv
|
||||
{ _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
|
|
@ -23,25 +33,23 @@ newtype Oracle m a =
|
|||
, MonadUnliftIO
|
||||
)
|
||||
|
||||
newOracleEnv :: MonadUnliftIO m => m OracleEnv
|
||||
newOracleEnv = do
|
||||
runWithOracleEnv :: MonadUnliftIO m => Oracle m () -> m ()
|
||||
runWithOracleEnv m = do
|
||||
|
||||
soname <- detectRPC
|
||||
`orDie` "can't locate rpc"
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||||
client <- race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||||
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||||
|
||||
void $ ContT $ withAsync $ runMessagingUnix client
|
||||
|
||||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||
reflogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
|
||||
let sto = AnyStorage (StorageClient storageAPI)
|
||||
env <- pure $ OracleEnv peerAPI
|
||||
reflogAPI
|
||||
lwwAPI
|
||||
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX reflogAPI
|
||||
|
|
@ -49,14 +57,11 @@ newOracleEnv = do
|
|||
, Endpoint @UNIX storageAPI
|
||||
]
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
void $ ContT $ withAsync $ runMessagingUnix client
|
||||
|
||||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
pure $ OracleEnv peerAPI
|
||||
reflogAPI
|
||||
lwwAPI
|
||||
|
||||
withOracleEnv :: MonadIO m => OracleEnv -> Oracle m a -> m a
|
||||
withOracleEnv env m = runReaderT (fromOracle m) env
|
||||
|
||||
|
||||
lift $ runReaderT (fromOracle m) env
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
module HBS2.Git.Oracle.Prelude
|
||||
( module HBS2.Prelude.Plated
|
||||
, module HBS2.Base58
|
||||
, module HBS2.OrDie
|
||||
, module HBS2.Net.Auth.Schema
|
||||
, module HBS2.Storage
|
||||
|
||||
, module HBS2.System.Logger.Simple.ANSI
|
||||
|
||||
, module HBS2.Peer.Proto.RefLog
|
||||
, module HBS2.Peer.Proto.LWWRef
|
||||
, module HBS2.Net.Proto.Service
|
||||
|
|
@ -13,17 +17,21 @@ module HBS2.Git.Oracle.Prelude
|
|||
, module HBS2.Peer.RPC.Client.StorageClient
|
||||
, module HBS2.Peer.RPC.Client.Unix
|
||||
|
||||
, module Data.Kind
|
||||
, module Control.Monad.Reader
|
||||
, module Control.Monad.Trans.Cont
|
||||
, module UnliftIO
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Base58
|
||||
import HBS2.OrDie
|
||||
import HBS2.Net.Auth.Schema
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Storage
|
||||
|
||||
import HBS2.System.Logger.Simple.ANSI
|
||||
|
||||
import HBS2.Peer.Proto.LWWRef
|
||||
import HBS2.Peer.Proto.RefLog
|
||||
import HBS2.Peer.RPC.API.Peer
|
||||
|
|
@ -33,6 +41,7 @@ import HBS2.Peer.RPC.API.Storage
|
|||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
import HBS2.Peer.RPC.Client.Unix
|
||||
|
||||
import Data.Kind
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Cont
|
||||
import UnliftIO
|
||||
|
|
|
|||
|
|
@ -0,0 +1,24 @@
|
|||
module HBS2.Git.Oracle.Run where
|
||||
|
||||
import HBS2.Git.Oracle.Prelude
|
||||
import HBS2.Git.Oracle.App
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
runOracle :: MonadUnliftIO m => Oracle m ()
|
||||
runOracle = do
|
||||
debug "hbs2-git-oracle"
|
||||
|
||||
debug "list all git references from peer"
|
||||
-- TODO: introduce-paging
|
||||
|
||||
peer <- asks _peerAPI
|
||||
|
||||
polls <- callRpcWaitMay @RpcPollList (TimeoutSec 1) peer ()
|
||||
<&> join . maybeToList
|
||||
|
||||
|
||||
for_ polls $ \(p, s, _) -> do
|
||||
debug $ "found poll" <+> pretty (AsBase58 p) <+> pretty s
|
||||
|
||||
|
||||
|
|
@ -174,6 +174,7 @@ library hbs2-git-oracle-oracle-lib
|
|||
exposed-modules:
|
||||
HBS2.Git.Oracle.Prelude
|
||||
HBS2.Git.Oracle.App
|
||||
HBS2.Git.Oracle.Run
|
||||
|
||||
build-depends: base
|
||||
, base16-bytestring
|
||||
|
|
|
|||
Loading…
Reference in New Issue