From 49c67a49dcef5281adc5b06ec32bcfc3db80bb77 Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Sat, 2 Nov 2024 17:26:04 +0300
Subject: [PATCH] wip

---
 hbs2-core/lib/HBS2/Net/Messaging/TCP.hs        |  2 +-
 hbs2-core/lib/HBS2/Net/Messaging/Unix.hs       |  2 +-
 hbs2-peer/app/PeerMain.hs                      | 11 ++++-------
 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs  |  3 ++-
 hbs2-storage-simple/lib/HBS2/Storage/Simple.hs | 11 ++++++++++-
 5 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
index d42f8d73..406aab2b 100644
--- a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
+++ b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
@@ -296,7 +296,7 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
         let (L4Address _ (IPAddrPort (i,p))) = own
         let myCookie = view tcpCookie env
 
-        pause @'Seconds 30
+        pause @'Seconds 10
 
         forever $ void $ runMaybeT do
             -- client sockets
diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
index f6fd7f79..b2cf49bb 100644
--- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
+++ b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
@@ -234,7 +234,7 @@ runMessagingUnix env = do
           void $ ContT $ bracket ( debug $ "Client thread started" <+> pretty that )
                                  ( \_ -> debug $ "Client thread finished" <+> pretty that  )
 
-          void $ ContT $ bracket writer (\x -> pause @'Seconds 0.1 >> cancel x)
+          void $ ContT $ bracket writer (\x -> pause @'Seconds 0.25 >> cancel x)
 
           fix \next -> do
 
diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs
index 6b12d0ff..e5b82d20 100644
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@@ -313,13 +313,10 @@ runCLI = do
     pPoke = do
       rpc <- pRpcCommon
       pure $ withMyRPC @PeerAPI rpc $ \caller -> do
-        e <- race ( pause @'Seconds 0.25) do
-          r <- callService @RpcPoke caller ()
-          case r of
-            Left e -> die (show e)
-            Right txt -> putStrLn txt >> exitSuccess
-
-        liftIO $ either (const $ exitFailure) (const $ exitSuccess) e
+        r <- callRpcWaitRetry @RpcPoke (TimeoutSec 0.5) 2 caller ()
+        case r of
+          Nothing -> exitFailure
+          Just s -> putStrLn s >> exitSuccess
 
     pAnnounce = do
       rpc <- pRpcCommon
diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
index 720d0020..99eb24dc 100644
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
@@ -55,6 +55,7 @@ instance Monad m => HasOwnPeer UNIX (ReaderT RPC2Context m) where
 
 instance (MonadUnliftIO m, HasProtocol UNIX (ServiceProto (api :: [Type]) UNIX))
   => HasDeferred (ServiceProto api UNIX) UNIX  m where
-  deferred m = void $ asyncLinked m
+  deferred m = void $ async m
+
 
 
diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
index 50690231..dd212c73 100644
--- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
+++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
@@ -220,6 +220,15 @@ simpleStorageWorker ss@SimpleStorage{..} = do
         atomically do
           modifyTVar lru (HashMap.filter notExpired)
 
+    ContT $ withAsync $ do
+      forever $ do
+        pause ( 10 :: Timeout 'Seconds ) -- FIXME: setting
+        purgeExpired _storageSizeCache
+        -- now <- getTimeCoarse
+        -- let notExpired t0 = not (expired timeout (now - t0))
+        -- atomically do
+        --   modifyTVar lru (HashMap.filter notExpired)
+
     liftIO do
       fix \next -> do
         s <- atomically $ do TBMQ.readTBMQueue ( ss ^. storageOpQ )
@@ -364,7 +373,7 @@ simpleBlockExists ss hash = runMaybeT $ do
     _ -> do
         exists <- liftIO $ doesFileExist fn
         unless exists mzero
-        s <- liftIO $ getFileSize fn
+        s <- liftIO $! getFileSize fn
         liftIO $ Cache.insert cache hash (Just s)
         pure s