diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 78cf00f2..d1199c71 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -190,10 +190,9 @@ main = flip runContT pure do cli <- parseCLI - case cli of [ ListVal [_, RepoURL url ] ] -> do - debug $ "FUCKING REMOTE" <+> pretty (AsBase58 url) + notice $ "FUCKING REMOTE" <+> pretty (AsBase58 url) setGitRepoKey url _ -> none @@ -202,8 +201,6 @@ main = flip runContT pure do recover $ connectedDo do - waitRepo - flip fix Plain $ \next -> \case Plain -> do diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index cb38b408..23990bfa 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -43,78 +43,6 @@ data CInit = | CreateRepoDefBlock GitRepoKey -data ReflogWaitTimeout = - ReflogWaitTimeout - deriving stock (Show,Typeable) - -instance Exception ReflogWaitTimeout - -waitRepo :: forall m . HBS2GitPerks m => Git3 m () -waitRepo = do - repoKey <- getGitRepoKey >>= orThrow GitRepoRefNotSet - - lwwAPI <- getClientAPI @LWWRefAPI @UNIX - peerAPI <- getClientAPI @PeerAPI @UNIX - reflogAPI <- getClientAPI @RefLogAPI @UNIX - - env <- ask - - callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey) - >>= orThrowUser "rpc timeout while subscribing to LWWRef" - - let maxTimeout = ceiling 30e9 -- Максимальное время ожидания (30 секунд) - startTime <- getTimeCoarse - - flip runContT pure do - - let periodicFetch reflog = forever $ do - callRpcWaitMay @RpcRefLogFetch (TimeoutSec 1) reflogAPI reflog - >>= orThrowUser "rpc timeout while fetching reflog" - pause @'Seconds 10 -- Засыпаем на 10 секунд - - let waitForReflog till reflog = do - now <- getTimeCoarse - - if now > till - then throwIO ReflogWaitTimeout - else do - mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI (coerce reflog) - case mhead of - Just headVal -> do - debug $ "waitRepo: Reflog data arrived" <+> pretty headVal - - Nothing -> pause @'Seconds 1 >> waitForReflog till reflog - - let waitForLWWRef till = liftIO $ withGit3Env env do - now <- getTimeCoarse - - if now > till - then throwIO RpcTimeout - else do - rv <- getRepoRefMaybe - maybe1 rv (pause @'Seconds 1 >> waitForLWWRef till) $ \LWWRef{..} -> do - debug $ "waitRepo: LWWRef arrived" <+> pretty lwwValue - - -- Парсим манифест репозитория - repo <- getRepoManifest - - -- Достаём `reflog` - reflog <- [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- repo ] - & headMay - & orThrowUser "malformed repo manifest" - - -- Подписываемся на `reflog` - callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) - >>= orThrowUser "rpc timeout while subscribing to reflog" - - debug $ "waitRepo: Subscribed to reflog" <+> pretty (AsBase58 reflog) - - -- Запускаем асинхронную задачу для периодического вызова RpcRefLogFetch - withAsync (periodicFetch reflog) $ \_ -> do - -- Ждём появления значений в `reflog` - waitForReflog till reflog - - liftIO $ withGit3Env env $ waitForLWWRef (startTime + fromNanoSecs maxTimeout) initRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m () initRepo syn = do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index 5a3e5bc1..112eabbd 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -346,14 +346,17 @@ recover m = fix \again -> do notice $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) connected <- Git3Connected soname sto peer refLogAPI lwwAPI - <$> newTVarIO Nothing + <$> newTVarIO (Just rk) <*> newTVarIO Nothing <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel <*> newTVarIO defIndexBlockSize + liftIO $ withGit3Env connected do + waitRepo + updateRepoKey rk ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed @@ -365,3 +368,80 @@ recover m = fix \again -> do e -> throwIO e +data ReflogWaitTimeout = + ReflogWaitTimeout + deriving stock (Show,Typeable) + +instance Exception ReflogWaitTimeout + +waitRepo :: forall m . HBS2GitPerks m => Git3 m () +waitRepo = do + repoKey <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + peerAPI <- getClientAPI @PeerAPI @UNIX + reflogAPI <- getClientAPI @RefLogAPI @UNIX + + env <- ask + + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (repoKey, "lwwref", 31) + >>= orThrowUser "rpc timeout while subscribing to reflog" + + callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey) + >>= orThrowUser "rpc timeout while subscribing to LWWRef" + + let maxTimeout = ceiling 30e9 -- Максимальное время ожидания (30 секунд) + startTime <- getTimeCoarse + + flip runContT pure do + + let periodicFetch reflog = forever $ do + callRpcWaitMay @RpcRefLogFetch (TimeoutSec 1) reflogAPI reflog + >>= orThrowUser "rpc timeout while fetching reflog" + pause @'Seconds 10 -- Засыпаем на 10 секунд + + let waitForReflog till reflog = do + now <- getTimeCoarse + + if now > till + then throwIO ReflogWaitTimeout + else do + mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI (coerce reflog) + case mhead of + Just headVal -> do + debug $ "waitRepo: Reflog data arrived" <+> pretty headVal + + Nothing -> pause @'Seconds 1 >> waitForReflog till reflog + + let waitForLWWRef till = liftIO $ withGit3Env env do + now <- getTimeCoarse + + if now > till + then throwIO RpcTimeout + else do + rv <- getRepoRefMaybe + maybe1 rv (pause @'Seconds 1 >> waitForLWWRef till) $ \LWWRef{..} -> do + debug $ "waitRepo: LWWRef arrived" <+> pretty lwwValue + + -- Парсим манифест репозитория + repo <- getRepoManifest + + -- Достаём `reflog` + reflog <- [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- repo ] + & headMay + & orThrowUser "malformed repo manifest" + + -- Подписываемся на `reflog` + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) + >>= orThrowUser "rpc timeout while subscribing to reflog" + + debug $ "waitRepo: Subscribed to reflog" <+> pretty (AsBase58 reflog) + + -- Запускаем асинхронную задачу для периодического вызова RpcRefLogFetch + withAsync (periodicFetch reflog) $ \_ -> do + -- Ждём появления значений в `reflog` + waitForReflog till reflog + + liftIO $ withGit3Env env $ waitForLWWRef (startTime + fromNanoSecs maxTimeout) + +