mirror of https://github.com/voidlizard/hbs2
wip, waitForRepo fixed
This commit is contained in:
voidlizard
parent
19fe110fee
commit
4b09dfc8a9
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue