From 37cf24c61d49c7b88819960f493999db82c813fe Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Fri, 8 Mar 2024 08:12:50 +0300
Subject: [PATCH] tuned error message on tx apply fail

---
 hbs21-git/git-remote-hbs21/Main.hs            | 10 +++++++
 .../HBS2/Git/Client/App.hs                    |  4 +++
 .../HBS2/Git/Client/Import.hs                 | 28 ++++++++++++++++++-
 .../HBS2/Git/Client/Progress.hs               |  1 +
 4 files changed, 42 insertions(+), 1 deletion(-)

diff --git a/hbs21-git/git-remote-hbs21/Main.hs b/hbs21-git/git-remote-hbs21/Main.hs
index 744904ed..04c2fc4b 100644
--- a/hbs21-git/git-remote-hbs21/Main.hs
+++ b/hbs21-git/git-remote-hbs21/Main.hs
@@ -123,6 +123,16 @@ main = do
                                   <> "If it's not a new reflog --- just wait until it became available"
                       liftIO exitFailure
                   )
+          `catch` ( \(ImportTxApplyError h) -> do
+                      onProgress ip ImportAllDone
+                      pause @'Seconds 0.25
+                      liftIO $ hFlush stderr
+                      liftIO $ hPutDoc stderr $ red "Can not apply tx" <+>  pretty h <> line <> line
+                                      <> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
+                                      <> line
+
+                      liftIO exitFailure
+                  )
 
         void $ runExceptT do
 
diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs
index d2c18aae..7ecdddb8 100644
--- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs
+++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs
@@ -90,6 +90,10 @@ drawProgress (ProgressQ q) = do
               put ("apply tx" <+> pretty h)
               next quiet
 
+            ImportApplyTxError h s -> do
+              limit 0.25 $ put $ red ("failed" <+> pretty s) <+> pretty h
+              next quiet
+
             ImportReadBundleChunk meta (Progress s _) -> do
               let h = bundleHash meta
               let e = if bundleEncrypted meta then yellow "@" else ""
diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
index 2004dd9b..16a48e67 100644
--- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
+++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
@@ -14,9 +14,12 @@ import HBS2.Git.Data.Tx
 
 import Data.ByteString.Lazy qualified as LBS
 
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
 import Text.InterpolatedString.Perl6 (qc)
 import Streaming.Prelude qualified as S
 import System.IO (hPrint)
+import Data.Maybe
 import System.Environment
 import System.Exit
 
@@ -26,6 +29,14 @@ data ImportRefLogNotFound = ImportRefLogNotFound
 
 instance Exception ImportRefLogNotFound
 
+
+data ImportTxApplyError = ImportTxApplyError HashRef
+                          deriving stock (Typeable,Show)
+
+
+instance Exception ImportTxApplyError
+
+
 data ImportTxError =
     ImportTxReadError HashRef
   | ImportOpError OperationError
@@ -59,6 +70,8 @@ importRepoWait  puk = do
 
   ip <- asks _progress
 
+  meet <- newTVarIO (mempty :: HashMap HashRef Int)
+
   flip fix (IWaitRefLog 20) $ \next -> \case
     IWaitRefLog w | w <= 0 -> do
       throwIO ImportRefLogNotFound
@@ -99,13 +112,26 @@ importRepoWait  puk = do
 
     IApplyTx h -> do
       onProgress ip (ImportApplyTx h)
+
       r <- runExceptT (applyTx h)
+             `catch` \case
+               ImportUnbundleError{}  -> pure (Left IncompleteData)
+               _ -> throwIO (userError "tx apply / state read error")
+
+
       case r of
 
         Left MissedBlockError -> do
           next =<< repeatOrExit
 
         Left IncompleteData -> do
+          atomically $ modifyTVar meet (HM.insertWith (+) h 1)
+          onProgress ip (ImportApplyTxError h (Just "read/decrypt"))
+          attempts <- readTVarIO meet <&> fromMaybe 0 . HM.lookup h
+
+          when (attempts >= 10 ) do
+            throwIO (ImportTxApplyError h)
+
           next =<< repeatOrExit
 
         Left e  -> do
@@ -220,7 +246,7 @@ applyTx h = do
         unless here do
 
           BundleWithMeta meta bytes <- lift (runExceptT $ readBundle sto r bu)
-                                          >>= orThrow (ImportUnbundleError bu)
+                                          >>=  orThrow (ImportUnbundleError bu)
 
           (_,_,idx,lbs) <- unpackPackMay bytes
                              &  orThrow (ImportUnbundleError bu)
diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs
index e736ed27..8e3a7c70 100644
--- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs
+++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs
@@ -26,6 +26,7 @@ data ProgressEvent =
   | ImportWaitTx HashRef
   | ImportScanTx HashRef
   | ImportApplyTx HashRef
+  | ImportApplyTxError HashRef (Maybe String)
   | ImportReadBundleChunk BundleMeta (Progress Int)
   | ImportSetQuiet Bool
   | ImportAllDone