From cea1b2418b7c83ebc81737ae55d69048e012fce9 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sat, 16 Mar 2024 05:37:45 +0300
Subject: [PATCH] lww repo subscribe only

---
 hbs2-peer/app/HttpWorker.hs                   |  7 +++
 hbs21-git/git-hbs21/Main.hs                   |  9 +++
 .../HBS2/Git/Client/Import.hs                 | 57 +++++++++++++++++++
 3 files changed, 73 insertions(+)

diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs
index 9395a4d4..0cef0224 100644
--- a/hbs2-peer/app/HttpWorker.hs
+++ b/hbs2-peer/app/HttpWorker.hs
@@ -29,6 +29,7 @@ import Web.Scotty
 
 import Data.ByteString.Builder (byteString, Builder)
 
+import Control.Concurrent
 import Data.Either
 import Codec.Serialise (deserialiseOrFail)
 import Data.Aeson (object, (.=))
@@ -39,6 +40,8 @@ import System.FilePath
 import Control.Monad.Except
 import Control.Monad.Trans.Cont
 
+import UnliftIO (async)
+
 {- HLINT ignore "Functor law" -}
 
 -- TODO: introduce-http-of-off-feature
@@ -73,7 +76,11 @@ httpWorker (PeerConfig syn) pmeta e = do
     scotty port $ do
       middleware logStdout
 
+      defaultHandler $ const do
+        status status500
+
       get "/size/:hash" do
+
         what <- param @String "hash" <&> fromString
         size <- liftIO $ hasBlock sto what
         case size of
diff --git a/hbs21-git/git-hbs21/Main.hs b/hbs21-git/git-hbs21/Main.hs
index fc6bc349..fa4d7b07 100644
--- a/hbs21-git/git-hbs21/Main.hs
+++ b/hbs21-git/git-hbs21/Main.hs
@@ -38,6 +38,7 @@ commands :: GitPerks m => Parser (GitCLI m ())
 commands =
   hsubparser ( command "export"  (info pExport  (progDesc "export repo to hbs2-git"))
              <> command "import" (info pImport  (progDesc "import repo from reflog"))
+             <> command "subscribe" (info pSubscribe (progDesc "subscribe to repo"))
              <> command "key"    (info pKey     (progDesc "key management"))
              <> command "tools"  (info pTools   (progDesc "misc tools"))
              )
@@ -96,6 +97,14 @@ pImport = do
     git <- Git.findGitDir >>= orThrowUser "not a git dir"
     importRepoWait puk
 
+pSubscribe :: GitPerks m => Parser (GitCLI m ())
+pSubscribe = do
+  lww <- argument pLwwKey (metavar "LWWREF")
+  pure do
+    merelySubscribeRepo lww >>= liftIO . \case
+      Just x -> print $ "subscribed" <+> pretty x
+      Nothing -> exitFailure
+
 pTools :: GitPerks m => Parser (GitCLI m ())
 pTools = hsubparser (  command "dump-pack" (info pDumpPack (progDesc "dump hbs2 git pack"))
                     <> command "show-ref" (info pShowRef (progDesc "show current references"))
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 eadb6c1c..655aaa6c 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
@@ -59,6 +59,63 @@ data IState =
   | IApplyTx HashRef
   | IExit
 
+
+merelySubscribeRepo :: (GitPerks m, MonadReader GitEnv m)
+                    => LWWRefKey HBS2Basic
+                    -> m (Maybe HashRef)
+merelySubscribeRepo lwwKey = do
+
+  ip  <- asks _progress
+  sto <- asks _storage
+
+  subscribeLWWRef lwwKey
+
+  fetchLWWRef lwwKey
+
+  flip fix (IWaitLWWBlock 10) $ \next -> \case
+
+    IWaitLWWBlock w | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitLWWBlock w -> do
+      onProgress ip (ImportWaitLWW w lwwKey)
+      lww <- readLWWBlock sto lwwKey
+
+      case lww of
+        Nothing -> do
+          pause @'Seconds 2
+          fetchLWWRef lwwKey
+          next (IWaitLWWBlock (pred w))
+
+        Just (_, LWWBlockData{..}) -> do
+          void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
+          subscribeRefLog lwwRefLogPubKey
+          pause @'Seconds 0.25
+          getRefLogMerkle lwwRefLogPubKey
+          next (IWaitRefLog 10 lwwRefLogPubKey)
+
+    IWaitRefLog w _ | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitRefLog w puk -> do
+      onProgress ip (ImportRefLogStart puk)
+      try @_ @SomeException (getRefLogMerkle puk) >>= \case
+        Left _ -> do
+          onProgress ip (ImportRefLogDone puk Nothing)
+          pause @'Seconds 2
+          next (IWaitRefLog (pred w) puk)
+
+        Right Nothing -> do
+          onProgress ip (ImportRefLogDone puk Nothing)
+          pause @'Seconds 2
+          next (IWaitRefLog (pred w) puk)
+
+        Right (Just h) -> do
+          pure (Just h)
+
+    _ -> pure Nothing
+
+
 importRepoWait :: (GitPerks m, MonadReader GitEnv m)
                => LWWRefKey HBS2Basic
                -> m ()