fsck

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

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

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

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
 

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