diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index e9d964f1..abcc8872 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -622,20 +622,6 @@ theDict = do BS.hPutStr fh ghs - entry $ bindMatch "test:sqlite" $ nil_ $ \case - [ StringLike fn ] -> lift do - db <- newDBPipeEnv dbPipeOptsDef fn - withDB db do - all <- select_ @_ @(Only Text) [qc|select hash from githash|] - for_ all $ \x -> do - n <- select @(Only Int) [qc|select 1 from githash where hash = ?|] (Only (fromOnly x)) - <&> L.null - unless n do - liftIO $ print $ pretty (fromOnly x) - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do sto <- getStorage let (_, argz) = splitOpts [] syn @@ -1036,12 +1022,12 @@ theDict = do entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do - let (opts, _) = splitOpts [ ("--tree",0) - , ("--checkpoints",0) + let (opts, _) = splitOpts [ ("--checkpoints",0) + , ("--segments",0) ] syn - let optTree = or [ True | ListVal [StringLike "--tree"] <- opts ] let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ] + let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ] sto <- getStorage @@ -1059,20 +1045,17 @@ theDict = do liftIO $ forM_ hxs $ \h -> do - if not optTree && not cpOnly then - print $ pretty h - else do - decoded <- readTxMay sto h - <&> \case - Just (TxSegment x) | not cpOnly -> - Just (fill 44 (pretty h) <+> fill 44 (pretty x)) + decoded <- readTxMay sto h + <&> \case + Just (TxSegment x) | not cpOnly -> + Just ("S" <+> fill 44 (pretty h) <+> fill 44 (pretty x)) - Just (TxCheckpoint n x) -> - Just (fill 44 (pretty h) <+> fill 8 (pretty n) <+> pretty x) + Just (TxCheckpoint n x) | not sOnly -> + Just ("C" <+> fill 44 (pretty h) <+> pretty x <+> fill 8 (pretty n)) - _ -> Nothing + _ -> Nothing - forM_ decoded print + forM_ decoded print entry $ bindMatch "test:git:import" $ nil_ $ \syn -> lift $ connectedDo do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index 16149fcf..19fd8cfa 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -4,6 +4,7 @@ import HBS2.Git3.Prelude import HBS2.System.Dir import HBS2.CLI.Run.Internal.Merkle (getTreeContents) import HBS2.Git3.State.Types +import HBS2.Git3.Git import HBS2.Data.Log.Structured @@ -25,19 +26,9 @@ import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Data.Word -import Data.Vector (Vector) -import Data.Vector qualified as V -import Data.Kind +import Data.Config.Suckless -import Data.BloomFilter qualified as Bloom -import Data.BloomFilter (Bloom(..)) -import Data.BloomFilter.Mutable qualified as MBloom - -import Control.Monad.ST - -import Control.Concurrent.STM qualified as STM -import Codec.Compression.Zstd.Lazy qualified as ZstdL import Codec.Compression.Zstd.Streaming as ZStdS import Codec.Serialise import Streaming.Prelude qualified as S @@ -384,8 +375,17 @@ updateReflogIndex = do pieces <- S.toList_ $ do void $ runConsumeLBS what $ readLogFileLBS () $ \o _ lbs -> do - let (t, _) = LBS.splitAt 1 lbs - notice $ pretty (LBS8.unpack t) <+> pretty o + let (t, llbs) = LBS.splitAt 1 lbs + -- notice $ pretty (LBS8.unpack t) <+> pretty o + + -- FIXME: do-something + when (t == "R") do + let refs = [ (t,h,x) + | ListVal [LitIntVal t, GitHashLike h, StringLike x] + <- parseTop (LBS8.unpack llbs) & fromRight mempty + ] + liftIO $ mapM_ (print . pretty) refs + lift $ S.yield o lift $ S.yield (h, pieces)