From bdc9fb80b371fbc25ea906332ed864a90492c911 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 21 Jan 2025 10:41:32 +0300 Subject: [PATCH] waitRepo --- hbs2-core/lib/HBS2/Data/Detect.hs | 7 +- hbs2-git3/lib/HBS2/Git3/Repo.hs | 5 +- hbs2-git3/lib/HBS2/Git3/Run.hs | 12 +- hbs2-git3/lib/HBS2/Git3/State.hs | 249 +++++++++++++++ .../lib/HBS2/Git3/State/Internal/Types.hs | 295 +----------------- 5 files changed, 269 insertions(+), 299 deletions(-) diff --git a/hbs2-core/lib/HBS2/Data/Detect.hs b/hbs2-core/lib/HBS2/Data/Detect.hs index 214e08cb..103bdd3e 100644 --- a/hbs2-core/lib/HBS2/Data/Detect.hs +++ b/hbs2-core/lib/HBS2/Data/Detect.hs @@ -1,4 +1,9 @@ -module HBS2.Data.Detect where +module HBS2.Data.Detect + ( module HBS2.Data.Detect + , module HBS2.Merkle.Walk + , module HBS2.Merkle + ) + where import HBS2.Prelude.Plated import HBS2.Hash diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index e20716e5..2e7c2f98 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -101,14 +101,13 @@ initRepo syn = do repo <- getRepoManifest - reflog <- [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- repo ] - & headMay & orThrowUser "malformed repo manifest" + reflog <- getRefLog repo & orThrow GitRepoManifestMalformed callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) >>= orThrowUser "rpc timeout" -- FIXME: remove-this - liftIO $ print $ pretty $ mkForm "manifest" repo + liftIO $ print $ pretty $ mkForm "manifest" (coerce repo) CreateRepoDefBlock pk -> do diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 0a836806..6810e56e 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -460,6 +460,11 @@ compression ; prints compression level -- for_ result $ \(n, (r, h, v)) -> do -- liftIO $ print $ "R" <+> pretty h <+> pretty r <+> pretty v <+> pretty n + entry $ bindMatch "reflog:wait" $ nil_ $ \syn -> lift $ connectedDo do + let (_,argz) = splitOpts [] syn + let t = headMay [ realToFrac x | LitIntVal x <- argz ] + waitRepo t + entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do p <- importedCheckpoint liftIO $ print $ pretty p @@ -470,16 +475,15 @@ compression ; prints compression level brief "shows repo manifest" $ entry $ bindMatch "repo:manifest" $ nil_ $ const $ lift $ connectedDo do manifest <- Repo.getRepoManifest - liftIO $ print $ pretty $ mkForm "manifest" manifest + liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest) brief "shows repo reflog" $ entry $ bindMatch "repo:reflog" $ nil_ $ const $ lift $ connectedDo do repo <- Repo.getRepoManifest - reflog <- [ x | x@(ListVal [SymbolVal "reflog", SignPubKeyLike _]) <- repo ] - & headMay & orThrow GitRepoManifestMalformed + reflog <- getRefLog repo & orThrow GitRepoManifestMalformed - liftIO $ print $ pretty reflog + liftIO $ print $ pretty (AsBase58 reflog) entry $ bindMatch "repo:credentials" $ nil_ $ const $ lift $ connectedDo do (p,_) <- getRepoRefLogCredentials diff --git a/hbs2-git3/lib/HBS2/Git3/State.hs b/hbs2-git3/lib/HBS2/Git3/State.hs index 88a4fac9..eee0d216 100644 --- a/hbs2-git3/lib/HBS2/Git3/State.hs +++ b/hbs2-git3/lib/HBS2/Git3/State.hs @@ -8,20 +8,269 @@ module HBS2.Git3.State import HBS2.Git3.Prelude +import HBS2.Merkle import HBS2.Git3.State.Internal.Types as Exported import HBS2.Git3.State.Internal.LWWBlock as Exported import HBS2.Git3.State.Internal.RefLog as Exported import HBS2.Git3.State.Internal.Segment as Exported import HBS2.Git3.State.Internal.Index as Exported +import HBS2.Storage.Operations.Missed +import HBS2.Net.Auth.Credentials +import HBS2.KeyMan.Keys.Direct +import HBS2.Data.Detect +import HBS2.CLI.Run.MetaData (getTreeContents) + +import Data.Config.Suckless + import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient import HBS2.System.Dir import HBS2.Peer.CLI.Detect +import Data.ByteString.Lazy qualified as LBS import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Data.Kind +import Data.Maybe +import Data.List qualified as L +import Data.Text.Encoding.Error qualified as TE +import Data.Text.Encoding qualified as TE +import Data.Word +import Lens.Micro.Platform import Codec.Compression.Zstd (maxCLevel) + +newtype RepoManifest = RepoManifest [Syntax C] + + +getRefLog :: RepoManifest -> Maybe GitRemoteKey +getRefLog mf = lastMay [ x + | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- coerce mf + ] + +updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m () +updateRepoKey key = do + + setGitRepoKey key + + reflog <- getRepoManifest <&> getRefLog + + ask >>= \case + Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog + _ -> none + +getRepoRefMaybe :: forall m . HBS2GitPerks m => Git3 m (Maybe (LWWRef 'HBS2Basic)) +getRepoRefMaybe = do + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + + pk <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey pk) + >>= orThrow RpcTimeout + +getRepoRefLogCredentials :: forall m . HBS2GitPerks m + => Git3 m (PubKey 'Sign 'HBS2Basic, PrivKey 'Sign HBS2Basic) + +getRepoRefLogCredentials = do + -- FIXME: memoize-this + mf <- getRepoManifest + rk <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet + + creds <- runKeymanClientRO (loadCredentials rk) + >>= orThrowUser ("not found credentials for" <+> pretty (AsBase58 rk)) + + seed <- [ x | ListVal [SymbolVal "seed", LitIntVal x ] <- coerce mf ] + & lastMay & orThrow GitRepoManifestMalformed + <&> fromIntegral @_ @Word64 + + let sk = view peerSignSk creds + + (p,s) <- derivedKey @'HBS2Basic @'Sign seed sk + + unless ( p == reflog ) do + throwIO RefLogCredentialsNotMatched + + pure (p,s) + +getRepoManifest :: forall m . HBS2GitPerks m => Git3 m RepoManifest +getRepoManifest = do + + sto <- getStorage + + LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty + + mfref <- readLogThrow (getBlock sto) lwwValue + <&> headMay + >>= orThrow GitRepoManifestMalformed + + runExceptT (getTreeContents sto mfref) + >>= orThrowPassIO + <&> TE.decodeUtf8With TE.lenientDecode . LBS.toStrict + <&> parseTop + >>= orThrow GitRepoManifestMalformed + <&> RepoManifest + +nullGit3Env :: MonadIO m => m Git3Env +nullGit3Env = Git3Disconnected + <$> newTVarIO defSegmentSize + <*> newTVarIO defCompressionLevel + <*> newTVarIO defIndexBlockSize + <*> newTVarIO Nothing + +connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a +connectedDo what = do + env <- ask + debug $ red "connectedDo" + case env of + Git3Disconnected{} -> do + throwIO Git3PeerNotConnected + + _ -> what + +withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a +withGit3Env env a = runReaderT (fromGit3 a) env + +runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b +runGit3 env action = withGit3Env env action + + +recover :: Git3 IO a -> Git3 IO a +recover m = fix \again -> do + catch m $ \case + Git3PeerNotConnected -> do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peer <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + + -- let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peer + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + let sto = AnyStorage (StorageClient storageAPI) + + rk <- lift $ getGitRepoKey >>= orThrow GitRepoRefNotSet + + notice $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) + + connected <- Git3Connected soname sto peer refLogAPI lwwAPI + <$> newTVarIO (Just rk) + <*> newTVarIO Nothing + <*> newTVarIO defSegmentSize + <*> newTVarIO defCompressionLevel + <*> newTVarIO defIndexBlockSize + + + liftIO $ withGit3Env connected do + + updateRepoKey rk + + ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed + + state <- getStatePath (AsBase58 ref) + mkdir state + + again + + e -> throwIO e + + +data ReflogWaitTimeout = + ReflogWaitTimeout + deriving stock (Show,Typeable) + +instance Exception ReflogWaitTimeout + + +data CWRepo = + CWaitLWW + | CCheckManifest (LWWRef HBS2Basic) + | CAborted + +waitRepo :: forall m . HBS2GitPerks m => Maybe (Timeout 'Seconds) -> Git3 m () +waitRepo timeout = do + repoKey <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + peerAPI <- getClientAPI @PeerAPI @UNIX + reflogAPI <- getClientAPI @RefLogAPI @UNIX + sto <- getStorage + + env <- ask + + flip runContT pure do + + let wait w what x = pause @'Seconds w >> what x + + callCC \forPeer -> do + + notice "wait for peer" + + lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (repoKey, "lwwref", 31)) + >>= maybe (wait 1 forPeer ()) (const none) + + pFetch <- ContT $ withAsync $ forever do + void (callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) + pause @'Seconds 10 + + lww <- flip fix () \next _ -> do + notice $ "wait for" <+> pretty (AsBase58 repoKey) + lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) + >>= \case + Just (Just x) -> pure x + _ -> wait 2 next () + + mf <- flip fix () $ \next _ -> do + notice $ "wait for manifest" + lift (try @_ @WalkMerkleError getRepoManifest) >>= \case + Left{} -> wait 1 next () + Right x -> pure x + + reflog <- getRefLog mf & orThrow GitRepoManifestMalformed + + lift $ setGitRepoKey reflog + + rv <- flip fix () \next _ -> do + notice $ "wait for data" <+> pretty (AsBase58 reflog) + lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI reflog) + >>= \case + Just (Just x) -> pure x + _ -> wait 2 next () + + okay <- newEmptyTMVarIO + + flip fix () $ \next _ -> do + notice $ "wait for data (2)" <+> pretty (AsBase58 reflog) + missed <- findMissedBlocks sto rv + unless (L.null missed) $ wait 2 next () + atomically $ writeTMVar okay True + + pWait <- ContT $ withAsync $ race ( pause (fromMaybe 300 timeout) ) do + void $ atomically $ takeTMVar okay + + waitAnyCatchCancel [pWait, pFetch] + + liftIO $ print $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv + + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index ec547437..a49756da 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -5,52 +5,13 @@ module HBS2.Git3.State.Internal.Types , pattern SignPubKeyLike ) where - import HBS2.Git3.Prelude import HBS2.Git3.Config.Local -import HBS2.Net.Auth.Credentials -import HBS2.KeyMan.Keys.Direct import HBS2.System.Dir -import HBS2.Data.Detect (readLogThrow) -import HBS2.CLI.Run.MetaData (getTreeContents) - -import Data.Config.Suckless - -import HBS2.Storage.Operations.Missed -import HBS2.Defaults as Exported -import HBS2.OrDie as Exported -import HBS2.Data.Types.Refs as Exported -import HBS2.Base58 as Exported -import HBS2.Merkle as Exported -import HBS2.Misc.PrettyStuff as Exported -import HBS2.Net.Auth.Credentials -import HBS2.Peer.Proto.LWWRef as Exported -import HBS2.Peer.Proto.RefLog as Exported -import HBS2.Peer.RPC.API.RefLog as Exported -import HBS2.Peer.RPC.API.Peer as Exported -import HBS2.Peer.RPC.API.LWWRef as Exported -import HBS2.Peer.RPC.API.Storage as Exported -import HBS2.Peer.RPC.Client hiding (encode,decode) -import HBS2.Peer.RPC.Client.Unix hiding (encode,decode) -import HBS2.Peer.RPC.Client.StorageClient -import HBS2.Peer.CLI.Detect (detectRPC) -import HBS2.Data.Types.SignedBox as Exported -import HBS2.Storage as Exported -import HBS2.Storage.Operations.Class as Exported -import HBS2.System.Logger.Simple.ANSI as Exported - -import Data.List qualified as L -import Data.Text.Encoding qualified as TE -import Data.Text.Encoding.Error qualified as TE -import Data.ByteString.Lazy qualified as LBS -import Data.Word import Data.Kind import Data.HashSet (HashSet) import Data.HashSet qualified as HS -import Lens.Micro.Platform - -import System.FilePath unit :: FilePath unit = "hbs2-git" @@ -182,77 +143,6 @@ instance (MonadIO m) => HasGitRemoteKey (Git3 m) where e <- ask liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k) -getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath -getStatePathM = do - k <- getGitRemoteKey >>= orThrow RefLogNotSet - getStatePath (AsBase58 k) - -updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m () -updateRepoKey key = do - - setGitRepoKey key - - mf <- getRepoManifest - - let reflog = lastMay [ x - | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf - ] - - ask >>= \case - Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog - _ -> none - -getRepoRefMaybe :: forall m . HBS2GitPerks m => Git3 m (Maybe (LWWRef 'HBS2Basic)) -getRepoRefMaybe = do - lwwAPI <- getClientAPI @LWWRefAPI @UNIX - - pk <- getGitRepoKey >>= orThrow GitRepoRefNotSet - - callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey pk) - >>= orThrow RpcTimeout - -getRepoRefLogCredentials :: forall m . HBS2GitPerks m - => Git3 m (PubKey 'Sign 'HBS2Basic, PrivKey 'Sign HBS2Basic) - -getRepoRefLogCredentials = do - -- FIXME: memoize-this - mf <- getRepoManifest - rk <- getGitRepoKey >>= orThrow GitRepoRefNotSet - - reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet - - creds <- runKeymanClientRO (loadCredentials rk) - >>= orThrowUser ("not found credentials for" <+> pretty (AsBase58 rk)) - - seed <- [ x | ListVal [SymbolVal "seed", LitIntVal x ] <- mf ] - & lastMay & orThrow GitRepoManifestMalformed - <&> fromIntegral @_ @Word64 - - let sk = view peerSignSk creds - - (p,s) <- derivedKey @'HBS2Basic @'Sign seed sk - - unless ( p == reflog ) do - throwIO RefLogCredentialsNotMatched - - pure (p,s) - -getRepoManifest :: forall m . HBS2GitPerks m => Git3 m [Syntax C] -getRepoManifest = do - - sto <- getStorage - - LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty - - mfref <- readLogThrow (getBlock sto) lwwValue - <&> headMay - >>= orThrow GitRepoManifestMalformed - - runExceptT (getTreeContents sto mfref) - >>= orThrowPassIO - <&> TE.decodeUtf8With TE.lenientDecode . LBS.toStrict - <&> parseTop - >>= orThrow GitRepoManifestMalformed newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a } deriving newtype ( Applicative @@ -288,186 +178,9 @@ instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure lwwAPI -nullGit3Env :: MonadIO m => m Git3Env -nullGit3Env = Git3Disconnected - <$> newTVarIO defSegmentSize - <*> newTVarIO defCompressionLevel - <*> newTVarIO defIndexBlockSize - <*> newTVarIO Nothing - -connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a -connectedDo what = do - env <- ask - debug $ red "connectedDo" - case env of - Git3Disconnected{} -> do - throwIO Git3PeerNotConnected - - _ -> what - -withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a -withGit3Env env a = runReaderT (fromGit3 a) env - -runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b -runGit3 env action = withGit3Env env action - - -recover :: Git3 IO a -> Git3 IO a -recover m = fix \again -> do - catch m $ \case - Git3PeerNotConnected -> do - - soname <- detectRPC - `orDie` "can't locate hbs2-peer rpc" - - flip runContT pure do - - client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) - >>= orThrowUser ("can't connect to" <+> pretty soname) - - void $ ContT $ withAsync $ runMessagingUnix client - - peer <- makeServiceCaller @PeerAPI (fromString soname) - refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) - storageAPI <- makeServiceCaller @StorageAPI (fromString soname) - lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) - - -- let sto = AnyStorage (StorageClient storageAPI) - - let endpoints = [ Endpoint @UNIX peer - , Endpoint @UNIX refLogAPI - , Endpoint @UNIX lwwAPI - , Endpoint @UNIX storageAPI - ] - - void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - - let sto = AnyStorage (StorageClient storageAPI) - - rk <- lift $ getGitRepoKey >>= orThrow GitRepoRefNotSet - - notice $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) - - connected <- Git3Connected soname sto peer refLogAPI lwwAPI - <$> newTVarIO (Just rk) - <*> newTVarIO Nothing - <*> newTVarIO defSegmentSize - <*> newTVarIO defCompressionLevel - <*> newTVarIO defIndexBlockSize - - - liftIO $ withGit3Env connected do - - waitRepo - - updateRepoKey rk - - ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed - - state <- getStatePath (AsBase58 ref) - mkdir state - - again - - e -> throwIO e - -data ReflogWaitTimeout = - ReflogWaitTimeout - deriving stock (Show,Typeable) - -instance Exception ReflogWaitTimeout - - -data CWRepo = - CWaitLWW - | CCheckManifest (LWWRef HBS2Basic) - | CAborted - -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 - sto <- getStorage - - env <- ask - - callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (repoKey, "lwwref", 31) - >>= orThrow RpcTimeout - - refLog1_ <- newEmptyTMVarIO - refLog2_ <- newEmptyTMVarIO - - void $ flip runContT pure do - - void $ ContT $ withAsync $ forever do - void $ callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey) - pause @'Seconds 10 - - p1 <- ContT $ withAsync $ do - r <- atomically $ takeTMVar refLog1_ - forever do - notice "FETCH REFLOG!" - void $ callRpcWaitMay @RpcRefLogFetch (TimeoutSec 1) reflogAPI r - pause @'Seconds 10 - - p2 <- ContT $ withAsync $ do - r <- atomically $ takeTMVar refLog2_ - void $ fix \again -> do - notice "AGAIN!" - rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI r - >>= \case - Nothing -> pause @'Seconds 3 >> again - Just Nothing -> pause @'Seconds 1.24 >> again - Just (Just x) -> pure x - - missed <- findMissedBlocks sto rv - - if L.null missed then do - pure rv - else do - notice "missed blocks in reflog" - pause @'Seconds 5 - again - - liftIO $ withGit3Env env do - - flip fix CWaitLWW $ \next -> \case - CWaitLWW -> do - notice $ "wait" <+> pretty (AsBase58 repoKey) - getRepoRefMaybe >>= \case - Nothing -> do - pause @'Seconds 1 - next CWaitLWW - - Just v -> next $ CCheckManifest v - - CCheckManifest LWWRef{} -> do - notice "check manifest" - r <- try @_ @HBS2GitExcepion getRepoManifest - case r of - Left GitRepoRefEmpty -> next CWaitLWW - - Left e -> next CAborted - - Right mf -> do - let reflog = lastMay [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf ] - case reflog of - Nothing -> next CAborted - Just rf -> do - - callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rf, "reflog", 17) - >>= orThrow RpcTimeout - - atomically do - writeTMVar refLog1_ rf - writeTMVar refLog2_ rf - - CAborted -> err "waitRepo aborted" >> none - - - waitAnyCatchCancel [p1,p2] +getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath +getStatePathM = do + k <- getGitRemoteKey >>= orThrow RefLogNotSet + getStatePath (AsBase58 k)