wip

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

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
+
+
+

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
 

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
+
+
+

hbs2-git3/test/Spec.hs

@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+