Add poll and waiting for refchan when refchan not fetched

hbs2-sync/hbs2-sync.cabal

@@ -60,6 +60,7 @@ common shared-properties
       , db-pipe
       , suckless-conf
 
+      , ansi-terminal
       , atomic-write
       , bytestring
       , containers
@@ -110,4 +111,3 @@ executable hbs2-sync
 
     hs-source-dirs:   app
     default-language: GHC2021
-

hbs2-sync/src/HBS2/Sync/Internal.hs

@@ -132,10 +132,10 @@ syncInit keys = do
 
   href <- writeAsMerkle storage (serialise box)
 
-  callService @RpcPollAdd peerApi (refchan, "refchan", 17)
+  callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerApi (refchan, "refchan", 17)
     >>= orThrowUser "can't subscribe to refchan"
 
-  callService @RpcRefChanHeadPost rchanApi (HashRef href)
+  callRpcWaitMay @RpcRefChanHeadPost (TimeoutSec 1) rchanApi (HashRef href)
     >>= orThrowUser "can't post refchan head"
 
   let authorString = show $ pretty $ AsBase58 authorKey
@@ -204,6 +204,9 @@ hbs2-sync init --refchan 94GF31TtD38yWG6iZLRy1xZBb1dxcAC7BRBJTMyAq8VF
           fromStringMay @(PubKey 'Sign HBS2Basic) refchanString
             & orThrowUser "refchan not found"
 
+        waitForRefchan refchanKey (TimeoutMin 1)
+          >>= orThrowUser "waiting for refchan timed out"
+
         headBlock <-
           RefChanClient.getRefChanHead @UNIX refchanKey
             >>= orThrowUser "can't load refchan head"

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -9,7 +9,6 @@ module HBS2.Sync.Prelude
   , module Exported
   ) where
 
-
 import HBS2.Prelude.Plated as Exported
 import HBS2.Base58 as Exported
 import HBS2.OrDie as Exported
@@ -23,6 +22,7 @@ import HBS2.Storage.Compact as Compact
 import HBS2.Peer.CLI.Detect
 import HBS2.Peer.RPC.Client hiding (encode,decode) -- as Exported
 import HBS2.Peer.RPC.Client.Unix (UNIX)
+import HBS2.Peer.RPC.Client.RefChan (fetchRefChanHead, fetchRefChan, getRefChanValue)
 import HBS2.Peer.RPC.Client.StorageClient
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.API.RefChan
@@ -60,9 +60,12 @@ import Data.Maybe as Exported
 import Data.Time.Clock.POSIX
 import Data.Word
 import Lens.Micro.Platform
-import System.Exit qualified as Exit
+import System.Console.ANSI qualified as IO
 import System.Directory
+import System.Exit qualified as Exit
+import System.IO qualified as IO
 import UnliftIO as Exported
+import HBS2.CLI.Prelude (IsTimeout)
 
 {- HLINT ignore "Functor law" -}
 {- HLINT ignore "Eta reduce" -}
@@ -449,3 +452,49 @@ die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m ()
 die what = liftIO do
   hPutDoc stderr (pretty what)
   Exit.exitFailure
+
+animateSpinner =
+  async $ forM_ (cycle "|/-\\") $ \c -> do
+    IO.putChar c
+    IO.hFlush IO.stdout
+    IO.cursorBackward 1
+    pause (TimeoutSec 0.25)
+
+waitForRefchan ::
+  ( HasClientAPI PeerAPI UNIX m
+  , HasClientAPI RefChanAPI UNIX m
+  , MonadUnliftIO m
+  , IsTimeout t
+  )
+  => PubKey 'Sign 'HBS2Basic
+  -> Timeout t
+  -> m (Maybe HashRef)
+waitForRefchan refchan timeout = do
+  peerApi <- getClientAPI @PeerAPI @UNIX
+
+  callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerApi (refchan, "refchan", 17)
+    >>= orThrowUser "can't subscribe to refchan"
+
+  liftIO $ putStr "waiting for refchan "
+  spinner <- liftIO animateSpinner
+  res <- race (pause timeout) (wait 1)
+  cancel spinner
+  liftIO $ do
+    IO.setCursorColumn 0
+    IO.clearLine
+
+  case res of
+    Right x -> pure (Just x)
+    _ -> pure Nothing
+
+  where
+    wait seconds = do
+      fetchRefChanHead @UNIX refchan
+      fetchRefChan @UNIX refchan
+      getRefChanValue @UNIX refchan >>= \case
+        Just value ->
+          pure value
+
+        Nothing -> do
+          pause @'Seconds seconds
+          wait (seconds * 2)

hbs2-sync/src/HBS2/Sync/State.hs

@@ -13,6 +13,7 @@ import HBS2.Storage.Compact as Compact
 import HBS2.Storage.Operations.Class
 
 import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.RPC.API.Peer (PeerAPI)
 import HBS2.Peer.RPC.API.RefChan
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.Unix (UNIX)
@@ -690,6 +691,7 @@ mergeState seed orig = do
 
 runDirectory :: ( IsContext c
                 , SyncAppPerks m
+                , HasClientAPI PeerAPI UNIX m
                 , HasClientAPI RefChanAPI UNIX m
                 , HasClientAPI StorageAPI UNIX m
                 , HasStorage m
@@ -774,7 +776,8 @@ runDirectory = do
 
       refchan <- view dirSyncRefChan env & orThrow RefChanNotSetException
 
-      fetchRefChan @UNIX refchan
+      waitForRefchan refchan (TimeoutMin 1)
+        >>= orThrow RefChanHeadNotFoundException
 
       -- FIXME: multiple-directory-scans