lww repo subscribe only

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

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"))

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 ()