hbs2-peer fetch -p to exit on Ctrl-c or q keys

hbs2-git3/app/GitRemoteHelper.hs

@@ -136,30 +136,30 @@ main =  flip runContT pure do
 
   setupLogger
 
-  origStderr <- liftIO $ dup stdError
+  -- origStderr <- liftIO $ dup stdError
-  (readEnd, writeEnd) <- liftIO createPipe
+  -- (readEnd, writeEnd) <- liftIO createPipe
-  liftIO $ dupTo writeEnd stdError
+  -- liftIO $ dupTo writeEnd stdError
-  liftIO $ closeFd writeEnd
+  -- liftIO $ closeFd writeEnd
 
-  rStderr <- liftIO $ fdToHandle readEnd
+  -- rStderr <- liftIO $ fdToHandle readEnd
-  origHandle <- liftIO $ fdToHandle origStderr
+  -- origHandle <- liftIO $ fdToHandle origStderr
 
-  liftIO $ hSetBuffering origHandle NoBuffering
+  -- liftIO $ hSetBuffering origHandle NoBuffering
 
-  -- liftIO $ IO.hPutStr origHandle "\n"
+  -- -- liftIO $ IO.hPutStr origHandle "\n"
-  ContT $ withAsync $ liftIO $ forever do
+  -- ContT $ withAsync $ liftIO $ forever do
-    -- pause @'Seconds 0.25
+  --   -- pause @'Seconds 0.25
-    wut <- IO.hGetContents rStderr <&> lines
+  --   wut <- IO.hGetContents rStderr <&> lines
-    for_ wut $ \s -> do
+  --   for_ wut $ \s -> do
-      IO.hPutStr origHandle (replicate 100 ' ')
+  --     IO.hPutStr origHandle (replicate 100 ' ')
-      IO.hPutStr origHandle "\r"
+  --     IO.hPutStr origHandle "\r"
-      IO.hPutStr origHandle s
+  --     IO.hPutStr origHandle s
-      IO.hPutStr origHandle "\r"
+  --     IO.hPutStr origHandle "\r"
-      pause @'Seconds 0.05
+  --     pause @'Seconds 0.05
 
   ContT $ bracket none $ const do
-    IO.hPutStr origHandle (replicate 100 ' ')
+    -- IO.hPutStr origHandle (replicate 100 ' ')
-    IO.hPutStr origHandle "\rdone\n"
+    -- IO.hPutStr origHandle "\rdone\n"
     silence
 
   lift $ void $ installHandler sigPIPE Ignore Nothing

hbs2-peer/app/PeerMain.hs

@@ -85,6 +85,7 @@ import HBS2.Peer.Proto.LWWRef.Internal
 import RPC2(RPC2Context(..))
 
 import Data.Config.Suckless.Script hiding (optional)
+import Data.Config.Suckless.Almost.RPC
 
 import Codec.Serialise as Serialise
 import Control.Concurrent (myThreadId)
@@ -122,8 +123,10 @@ import System.IO
 import System.Mem
 import System.Metrics
 import System.Posix.Process
+import System.Posix.Signals
 import Control.Monad.Trans.Cont
 
+
 import UnliftIO (MonadUnliftIO(..))
 import UnliftIO.Exception qualified as U
 -- import UnliftIO.STM
@@ -133,6 +136,9 @@ import UnliftIO.Concurrent (getNumCapabilities)
 import Streaming.Prelude qualified as S
 
 import Graphics.Vty qualified as Vty
+import Graphics.Vty.Input qualified as Vty
+import Graphics.Vty.Input hiding (Event)
+import Graphics.Vty (Mode(..),setMode,outputIface,inputIface)
 import Graphics.Vty.Platform.Unix qualified as Vty
 
 import Control.Concurrent.Async (ExceptionInLinkedThread(..))
@@ -202,7 +208,6 @@ data PeerOpts =
 
 makeLenses 'PeerOpts
 
-
 main :: IO ()
 main = do
 
@@ -336,6 +341,7 @@ runCLI = do
 
       pure $ flip runContT pure do
 
+
         client <- ContT $ withRPCMessaging rpc
 
         self <- runReaderT (ownPeer @UNIX) client
@@ -355,11 +361,14 @@ runCLI = do
         void $ callService @RpcFetch peerAPI h
 
         liftIO do
+
           when pro $ flip runContT pure do
             cfg <- pure $ Vty.defaultConfig
             vty <- ContT $ bracket (Vty.mkVty cfg) Vty.shutdown
 
-            fix \next -> do
+            let input  = inputIface vty & Vty.eventChannel
+
+            poller <- ContT $ withAsync $ fix \next -> do
               miss <- findMissedBlocks sto h
 
               let l = length miss
@@ -378,10 +387,20 @@ runCLI = do
               let pic = Vty.picForImage $ Vty.string Vty.defAttr msg
               liftIO $ Vty.update vty pic
 
-              unless (l == 0) do
+              when (l > 0) do
                 pause @'Seconds 2
                 next
 
+            let exitNicely = cancel poller
+
+            inp <- ContT $ withAsync $ forever do
+              atomically (readTChan input) >>= \case
+                InputEvent (EvKey (KChar 'c') [MCtrl]) -> exitNicely
+                InputEvent (EvKey (KChar 'q') [])      -> exitNicely
+                _ -> none
+
+            void $ waitAnyCatchCancel [poller, inp]
+            liftIO $ Vty.shutdown vty
 
     pPing = do
       rpc <- pRpcCommon