diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 63894dbb..36c5d9cd 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -19,7 +19,7 @@ import HBS2.Peer.RPC.Client.StorageClient import HBS2.CLI.Run.Internal.Merkle (getTreeContents) --- move to a sepatate library +-- move to Data.Config.Suckless.Script.Filea sepatate library import HBS2.Data.Log.Structured @@ -34,6 +34,7 @@ import HBS2.Git3.Config.Local import HBS2.Git3.Git import Data.Config.Suckless.Script +import Data.Config.Suckless.Script.File import DBPipe.SQLite import Codec.Compression.Zstd.Streaming qualified as ZstdS @@ -905,6 +906,56 @@ theDict = do LBS.hPutStr fh contents + entry $ bindMatch "reflog:index:count:missed" $ nil_ $ const $ lift $ flip runContT pure do + + hashes <- gitRunCommand [qc|git rev-list --all --objects|] + >>= orThrowPassIO + <&> LBS8.lines + <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack) + + for_ hashes $ \h -> do + liftIO $ print $ pretty h + + -- git <- findGitDir >>= orThrowUser ".git directory not found" + + -- ofiles <- S.toList_ $ glob ["**/*"] ["info/**", "pack/**"] (git "objects") $ \fn -> do + -- S.yield fn >> pure True + + -- idxFiles <- S.toList_ $ glob ["**/*.idx"] [] (git "objects/pack") $ \fn -> do + -- S.yield fn >> pure True + + -- liftIO $ for_ ofiles $ \f -> do + -- print f + + -- liftIO $ for_ idxFiles $ \f -> flip runContT pure do + -- p <- ContT withGitShowIndex + -- -- void $ ContT $ bracket (pure p) (hClose . getStdin) + -- liftIO do + -- LBS.hPutStr (getStdin p) =<< LBS.readFile f + -- hFlush (getStdin p) + -- wtf <- IO.hGetContents (getStdout p) <&> lines + -- for_ wtf $ IO.putStrLn + + -- _ <- gitRunCommand [qc|git show-index|] + -- print f + + -- gitCatCheck <- contWorkerPool 4 do + -- che <- ContT withGitCatCheck + -- pure $ gitCheckObjectFromHandle che + + -- idx <- lift openIndex + + -- missed_ <- newTVarIO ( mempty :: HashSet GitHash ) + -- lift $ enumEntries idx $ \bs -> do + -- let gh = GitHash (coerce (BS.take 20 bs)) + -- here <- gitCatCheck gh + -- unless (isJust here) do + -- atomically $ modifyTVar missed_ (HS.insert gh) + + -- missed <- readTVarIO missed_ <&> HS.size + + -- liftIO $ print $ "missed" <+> pretty missed + entry $ bindMatch "reflog:index:list:fast" $ nil_ $ const $ lift do files <- listObjectIndexFiles forConcurrently_ files $ \(f,_) -> do @@ -916,6 +967,13 @@ theDict = do notice $ pretty sha1 <+> pretty blake + + entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift do + idx <- openIndex + num_ <- newIORef 0 + enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x)) + readIORef num_ >>= liftIO . print . pretty + entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift do files <- listObjectIndexFiles for_ files $ \(ifn,_) -> do diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index d91477c2..2c6b267a 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -128,6 +128,7 @@ library HBS2.Git3.State.Index HBS2.Git3.Config.Local HBS2.Git3.Git + HBS2.Git3.Git.Pack HBS2.Data.Log.Structured @@ -170,3 +171,41 @@ executable hbs2-git-daemon +test-suite spec + import: shared-properties + type: exitcode-stdio-1.0 + main-is: Spec.hs + + other-modules: + HBS2.Git3.Git.PackSpec + -- Data.Config.Suckless.KeyValueSpec + -- Data.Config.Suckless.AesonSpec + + hs-source-dirs: + test + ghc-options: + -Wall + -threaded + -rtsopts + -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + + build-depends: base, hbs2-git3 + , hspec + , tasty-hunit + , tasty-quickcheck + , QuickCheck + + default-language: Haskell2010 + + -- default-extensions: + -- DerivingStrategies + -- , FlexibleInstances + -- , MultiParamTypeClasses + -- , OverloadedStrings + -- , ScopedTypeVariables + -- , TypeApplications + + + diff --git a/hbs2-git3/lib/HBS2/Git3/Git.hs b/hbs2-git3/lib/HBS2/Git3/Git.hs index 2306d960..abe0b020 100644 --- a/hbs2-git3/lib/HBS2/Git3/Git.hs +++ b/hbs2-git3/lib/HBS2/Git3/Git.hs @@ -33,6 +33,8 @@ import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) import UnliftIO +{-HLINT Ignore "Functor law"-} + pattern GitHashLike:: forall {c} . GitHash -> Syntax c pattern GitHashLike x <- ( \case @@ -162,6 +164,15 @@ withGitCatCheck action = do p <- startProcess config action p + +withGitShowIndex :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a +withGitShowIndex action = do + let cmd = "git" + let args = ["show-index"] + let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args + p <- startProcess config + action p + gitCheckObjectFromHandle :: MonadIO m => Process Handle Handle a -> GitHash -> m (Maybe (GitObjectType, Int)) gitCheckObjectFromHandle ph gh = liftIO do diff --git a/hbs2-git3/lib/HBS2/Git3/Git/Pack.hs b/hbs2-git3/lib/HBS2/Git3/Git/Pack.hs new file mode 100644 index 00000000..bbfc850f --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Git/Pack.hs @@ -0,0 +1,77 @@ +module HBS2.Git3.Git.Pack where + +import HBS2.Prelude +import HBS2.Git.Local + +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import Data.Bits +import Data.ByteString as BS +import Lens.Micro.Platform +import Data.Function +import Data.Word +import Network.ByteOrder qualified as N +import Numeric.Natural + +-- +-- Accordingly to https://git-scm.com/docs/pack-format +data PackFileObjectType = + OBJ_COMMIT -- (1) + | OBJ_TREE -- (2) + | OBJ_BLOB -- (3) + | OBJ_TAG -- (4) + | OBJ_RESERVED -- (5) + | OBJ_OFS_DELTA -- (6) + | OBJ_REF_DELTA -- (7) + deriving stock (Eq,Ord,Show) + +instance Enum PackFileObjectType where + fromEnum OBJ_COMMIT = 1 + fromEnum OBJ_TREE = 2 + fromEnum OBJ_BLOB = 3 + fromEnum OBJ_TAG = 4 + fromEnum OBJ_RESERVED = 5 + fromEnum OBJ_OFS_DELTA = 6 + fromEnum OBJ_REF_DELTA = 7 + + toEnum 1 = OBJ_COMMIT + toEnum 2 = OBJ_TREE + toEnum 3 = OBJ_BLOB + toEnum 4 = OBJ_TAG + toEnum 6 = OBJ_OFS_DELTA + toEnum 7 = OBJ_REF_DELTA + toEnum n = error $ "Invalid PackFileObjectType: " ++ show n + + +encodeObjectSize :: PackFileObjectType -> Natural -> ByteString +encodeObjectSize objType size = + BS.pack $ go (fromIntegral (fromEnum objType) `shiftL` 4 .|. fromIntegral (size .&. 0x0F)) (size `shiftR` 4) + where + go :: Word8 -> Natural -> [Word8] + go prefix 0 = [prefix] + go prefix sz = (prefix .|. 0x80) : go (fromIntegral (sz .&. 0x7F)) (sz `shiftR` 7) + +decodeObjectSize :: ByteString -> Maybe ((PackFileObjectType, Natural), ByteString ) +decodeObjectSize source = run $ flip fix (source,0,0,0) $ \next (bs, i, tp, num) -> do + case BS.uncons bs of + Nothing -> Nothing + Just (byte, rest) -> do + let val = clearBit byte 7 + + let acc = case i of + 0 -> (rest, succ i, fromIntegral (val `shiftR` 4), fromIntegral (val .&. 0x0F)) + 1 -> (rest, succ i, tp, num .|. fromIntegral val `shiftL` 4) + _ -> (rest, succ i, tp, num .|. fromIntegral val `shiftL` 7) + + if testBit byte 7 then + next acc + else + pure acc + + where + run loop = case loop of + Just (bs, _, tp, x) | tp > 0 && tp <= 7 -> Just ((toEnum tp, fromIntegral x), bs) + _ -> Nothing + + + diff --git a/hbs2-git3/test/Spec.hs b/hbs2-git3/test/Spec.hs new file mode 100644 index 00000000..038e7c8e --- /dev/null +++ b/hbs2-git3/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +