From 8eae06b2af4ac419329ea6d8b93187e2541d85f6 Mon Sep 17 00:00:00 2001 From: Snail <> Date: Wed, 20 Nov 2024 00:42:40 +0400 Subject: [PATCH] fsck --- hbs2-core/lib/HBS2/Merkle/Walk.hs | 9 ++ hbs2-git/git-hbs2/Main.hs | 14 ++ .../HBS2/Git/Client/Import.hs | 148 ++++++++++++++++++ .../HBS2/Git/Data/RepoHead.hs | 6 +- hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs | 5 + 5 files changed, 179 insertions(+), 3 deletions(-) diff --git a/hbs2-core/lib/HBS2/Merkle/Walk.hs b/hbs2-core/lib/HBS2/Merkle/Walk.hs index fd566066..28b11d82 100644 --- a/hbs2-core/lib/HBS2/Merkle/Walk.hs +++ b/hbs2-core/lib/HBS2/Merkle/Walk.hs @@ -147,6 +147,15 @@ catFromMerkle getB = . Q.fromChunks . (S.map cs . streamCatFromMerkle getB) +streamToListEither + :: (Monad m) + => Stream (Of a) m (Either e ()) + -> m (Either e [a]) +streamToListEither = fmap runStreamOfA . S.toList + +runStreamOfA :: (Functor m) => Of a (m ()) -> m a +runStreamOfA (a S.:> e) = a <$ e + --- streamMerkle1 diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index e6e9a916..4631069b 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -64,6 +64,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 "fsck" (info pFsck (progDesc "check objects from a last reflog transaction")) <> command "key" (info pKey (progDesc "key management")) <> command "manifest" (info pManifest (progDesc "manifest commands")) <> command "track" (info pTrack (progDesc "track tools")) @@ -130,6 +131,13 @@ pImport = do git <- Git.gitDir >>= orThrowUser "not a git dir" importRepoWait puk +pFsck :: GitPerks m => Parser (GitCLI m ()) +pFsck = do + lww <- argument pLwwKey (metavar "LWWREF") + pure do + git <- Git.gitDir >>= orThrowUser "not a git dir" + fsckRepo lww + 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")) @@ -467,6 +475,12 @@ theDict = do myEntries = do + entry $ bindMatch "lww:fsck" $ nil_ $ \case + [StringLike puk] -> lift do + lww <- orThrowUser "bad lwwref key" (fromStringMay puk) + git <- Git.gitDir >>= orThrowUser "not a git dir" + fsckRepo lww + entry $ bindMatch "remote:hbs2:show" $ nil_ $ \case _ -> do -- TODO: move-to-HBS2.Local.CLI diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs index 3d61e28e..1165970b 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs @@ -11,8 +11,20 @@ import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.RepoHead +import HBS2.Data.Detect (readLogThrow) +import HBS2.Merkle.Walk +import HBS2.Peer.Proto.LWWRef +import HBS2.Storage +import HBS2.Storage.Operations.Missed +import HBS2.Storage.Operations.ByteString +-- import HBS2.Git.Data.GK +-- import HBS2.Git.Data.RepoHead +import HBS2.Storage.Operations.Class + import Data.ByteString.Lazy qualified as LBS +import Control.Arrow ((>>>)) +import Control.Concurrent (threadDelay) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Text.InterpolatedString.Perl6 (qc) @@ -232,6 +244,142 @@ importRepoWait lwwKey = do pause @'Seconds 2 pure (IWaitLWWBlock 5) +newtype CanNotReadLWWBlock = CanNotReadLWWBlock (LWWRefKey HBS2Basic) + deriving (Show) via (AsBase58 (LWWRefKey HBS2Basic)) +instance Exception CanNotReadLWWBlock + +newtype CanNotReadLWWHashRef = CanNotReadLWWHashRef (PubKey Sign HBS2Basic) + deriving (Show) +instance Exception CanNotReadLWWHashRef + +newtype NoBlocksInMerkle = NoBlocksInMerkle HashRef + deriving (Show) +instance Exception NoBlocksInMerkle + +newtype GetBlockError = GetBlockError HashRef + deriving (Show) +instance Exception GetBlockError + +newtype GetOrFetchBlockError = GetOrFetchBlockError (Hash HbSync) + deriving (Show) +instance Exception GetOrFetchBlockError + +newtype FsckError = FsckError Text + deriving (Show) +instance Exception FsckError + +fsckRepo :: ( GitPerks m + , MonadReader GitEnv m + , HasAPI PeerAPI UNIX m + , HasAPI LWWRefAPI UNIX m + , HasAPI RefLogAPI UNIX m + ) + => LWWRefKey 'HBS2Basic + -> m () + +fsckRepo lwwKey = do + env <- ask + sto' <- asks _storage + peerAPI <- getAPI @PeerAPI @UNIX + + let + getBF = getBlockOrFetch callBlockFetch (getBlock sto') + getBJ = fmap Just . getBF + + let + getBJ' :: Hash HbSync -> IO (Maybe LBS.ByteString) + getBJ' = fmap Just . getBlockOrFetch (callBlockFetchIO peerAPI) (getBlock sto') + sto = AnyStorage (AdHocStorage @IO sto' getBJ') + + (LWWRef{..}, LWWBlockData{..}) <- maybe (throwIO (CanNotReadLWWBlock lwwKey)) pure + =<< readLWWBlock sto lwwKey + + hr <- maybe (throwIO (CanNotReadLWWHashRef lwwRefLogPubKey)) pure + =<< getRefLogMerkle lwwRefLogPubKey + liftIO . print $ "Reflog merkle hash:" <+> pretty hr + + -- mapM_ (liftIO . print . pretty) =<< readLogThrow getBJ hr + + -- readLogThrow getBJ hr >>= mapM_ \txh -> do + + txh <- maybe (throwIO (NoBlocksInMerkle hr)) pure + =<< S.last_ do + (orThrowPassIO <=< streamMerkle @HashRef getBJ) + (fromHashRef hr) + do + + liftIO . print $ "tx:" <+> pretty txh + + txbs <- getBF (fromHashRef txh) + <&> deserialiseOrFail @(RefLogUpdate L4Proto) + >>= orThrow UnsupportedFormat + + (n, rhh, blkh) <- unpackTx txbs + + rh <- catFromMerkle + (fmap Just . getBF) + (fromHashRef rhh) + >>= orThrowPassIO + >>= (deserialiseOrFail @RepoHead >>> orThrow UnsupportedFormat) + + findMissedBlocks2 sto blkh + & S.mapM_ (getBF . fromHashRef) + + liftIO . print $ "All blocks fetched for tx" <+> pretty txh + + -- Double check. Ensure readTx has everything needed + _ <- (orThrowPassIO <=< runExceptT) do + readTx sto txh + + bundlesCount <- (orThrowPassIO . runStreamOfA <=< S.length) do + streamMerkle @HashRef getBJ (fromHashRef blkh) + & S.mapM (\bh -> bh <$ getBF (fromHashRef blkh)) + & S.mapM (orThrowPassIO <=< runExceptT . readBundle sto rh) + + liftIO . print $ "All bundles (" <+> pretty bundlesCount + <+> ") fetched and checked for tx" <+> pretty txh + + where + callBlockFetch + :: ( MonadUnliftIO m + , HasAPI PeerAPI UNIX m + ) + => Hash HbSync -> m () + callBlockFetch h = do + peerAPI <- getAPI @PeerAPI @UNIX + liftIO $ callBlockFetchIO peerAPI h + + callBlockFetchIO :: ServiceCaller PeerAPI UNIX -> Hash HbSync -> IO () + callBlockFetchIO peerAPI h = do + race (pause @'Seconds 1) + (callService @RpcFetch peerAPI (HashRef h)) + >>= orThrow BlockFetchRequestTimeout + >>= orThrow BlockFetchRequestError + +data BlockFetchRequestTimeout = BlockFetchRequestTimeout deriving (Show) +instance Exception BlockFetchRequestTimeout + +data BlockFetchRequestError = BlockFetchRequestError deriving (Show) +instance Exception BlockFetchRequestError + +getBlockOrFetch + :: (MonadIO m) + => (Hash HbSync -> m ()) + -> (Hash HbSync -> m (Maybe LBS.ByteString)) + -> Hash HbSync -> m LBS.ByteString +getBlockOrFetch fetch getB h = do + getB h >>= flip maybe pure do + fetch h + liftIO . print $ "Fetch block:" <+> pretty h + flip fix 1 \go attempt -> do + liftIO $ threadDelay (attempt * 10^6) + getB h >>= flip maybe pure do + if attempt < numAttempts + then go (attempt + 1) + else throwIO (GetOrFetchBlockError h) + where + numAttempts = 12 + scanRefLog :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> HashRef diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs index 1d9a4bf4..9304e9cc 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs @@ -17,10 +17,10 @@ import Data.Maybe import Data.Set qualified as Set data RepoHeadType = RepoHeadType1 - deriving stock (Enum,Generic) + deriving stock (Enum,Generic,Show) data RepoHeadExt = RepoHeadExt - deriving stock Generic + deriving stock (Generic,Show) data RepoHead = RepoHeadSimple @@ -33,7 +33,7 @@ data RepoHead = , repoHeadRefs' :: [(GitRef, GitHash)] , _repoHeadExt :: [RepoHeadExt] } - deriving stock (Generic) + deriving stock (Generic,Show) makeLenses ''RepoHead diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index cd7fe769..2517710a 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs @@ -79,6 +79,11 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (AsBase58 (LWWRefKey s)) instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (LWWRefKey s) where pretty (LWWRefKey k) = pretty (AsBase58 k) +instance Pretty (AsBase58 (PubKey 'Sign s )) => Show (AsBase58 (LWWRefKey s)) where + -- show = show . pretty + -- show (AsBase58 (LWWRefKey k)) = show $ pretty (AsBase58 k) + show (AsBase58 lww) = show $ pretty lww + instance Pretty (LWWRef e) where pretty (LWWRef{..}) = parens ( "lwwref" <> line