wip

hbs2-core/lib/HBS2/Net/Proto/Service.hs

@@ -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)

hbs2-git/hbs2-git-oracle/app/Main.hs

@@ -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
+  runWithOracleEnv runOracle
-  --   pLww :: ReadM (LWWRefKey HBS2Basic)
+
-  --   pLww = maybeReader fromStringMay
+  `finally` do
+      setLoggingOff @DEBUG
+      setLoggingOff @WARN
+      setLoggingOff @ERROR
+      setLoggingOff @NOTICE
 
 
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs

@@ -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,40 +33,35 @@ newtype Oracle m a =
                    , MonadUnliftIO
                    )
 
-newOracleEnv :: MonadUnliftIO m => m OracleEnv
+runWithOracleEnv ::  MonadUnliftIO m => Oracle m () -> m ()
-newOracleEnv = do
+runWithOracleEnv m = do
 
   soname <- detectRPC
                `orDie` "can't locate rpc"
 
-  flip runContT pure do
+  client <- race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+              >>= orThrowUser ("can't connect to" <+> pretty soname)
 
-    client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+  peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
-                >>= orThrowUser ("can't connect to" <+> pretty soname)
+  reflogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+  lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+  storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+
+  env <- pure $ OracleEnv  peerAPI
+                           reflogAPI
+                           lwwAPI
+
+  let endpoints = [ Endpoint @UNIX  peerAPI
+                  , Endpoint @UNIX  reflogAPI
+                  , Endpoint @UNIX  lwwAPI
+                  , Endpoint @UNIX  storageAPI
+                  ]
+
+  flip runContT pure do
 
     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)
-
-    let sto = AnyStorage (StorageClient storageAPI)
-
-    let endpoints = [ Endpoint @UNIX  peerAPI
-                    , Endpoint @UNIX  reflogAPI
-                    , Endpoint @UNIX  lwwAPI
-                    , Endpoint @UNIX  storageAPI
-                    ]
-
     void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
 
-    pure $ OracleEnv  peerAPI
+    lift $ runReaderT (fromOracle m) env
-                      reflogAPI
-                      lwwAPI
-
-withOracleEnv ::  MonadIO m => OracleEnv -> Oracle m a -> m a
-withOracleEnv env m = runReaderT (fromOracle m) env
-
-
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs

@@ -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

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -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
+
+

hbs2-git/hbs2-git.cabal

@@ -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