wip,compact kinda work

hbs2-git3/app/Main.hs

@@ -142,6 +142,7 @@ recover m = fix \again -> do
                         <$> newTVarIO (Just ref)
                         <*> newTVarIO defSegmentSize
                         <*> newTVarIO defCompressionLevel
+                        <*> newTVarIO defIndexBlockSize
 
         liftIO $ withGit3Env connected again
 
@@ -433,7 +434,11 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        entry $ bindValue "index-block-size"  (mkInt $ 32 * 1024 * 1024)
+        entry $ bindMatch "index-block-size" $ nil_ \case
+          [ LitIntVal size ]-> lift do
+            setIndexBlockSize (fromIntegral size)
+
+          _ -> throwIO (BadFormException @C nil)
 
         entry $ bindMatch "git:tree:ls" $ nil_ $ const do
           r <- gitReadTree "HEAD"
@@ -995,12 +1000,9 @@ theDict = do
                                       on conflict (sha1)
                                       do update set tx = excluded.tx|] (p,h)
 
-        entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> do
-          size <- lookupValue "index-block-size" >>= \case
-                    LitIntVal n  -> pure (fromIntegral n)
-                    _            -> pure 33554432
-
-          lift $ compactIndex size
+        entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift do
+          size <- getIndexBlockSize
+          compactIndex size
 
         entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift do
           indexPath >>= liftIO . print . pretty

hbs2-git3/lib/HBS2/Git3/Prelude.hs

@@ -31,6 +31,8 @@ import HBS2.Git3.Types as Exported
 -- TODO: about-to-remove
 import DBPipe.SQLite
 
+import Data.Config.Suckless.Script
+
 import Codec.Compression.Zstd (maxCLevel)
 import Codec.Serialise
 import Control.Monad.Except (runExceptT)
@@ -54,6 +56,9 @@ defSegmentSize = 50 * 1024 * 1024
 defCompressionLevel :: Int
 defCompressionLevel = maxCLevel
 
+defIndexBlockSize :: Natural
+defIndexBlockSize = 32 * 1024 * 1024
+
 type HBS2GitPerks m = (MonadUnliftIO  m)
 
 
@@ -89,6 +94,7 @@ data Git3Env =
     { gitRefLog            :: TVar (Maybe GitRemoteKey)
     , gitPackedSegmentSize :: TVar Int
     , gitCompressionLevel  :: TVar Int
+    , gitIndexBlockSize    :: TVar Natural
     }
   | Git3Connected
     { peerSocket  :: FilePath
@@ -98,6 +104,7 @@ data Git3Env =
     , gitRefLog   :: TVar (Maybe GitRemoteKey)
     , gitPackedSegmentSize :: TVar Int
     , gitCompressionLevel  :: TVar Int
+    , gitIndexBlockSize :: TVar Natural
     }
 
 class HasExportOpts m where
@@ -137,6 +144,17 @@ instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where
       Git3Disconnected{} -> throwIO Git3PeerNotConnected
       Git3Connected{..} -> pure peerStorage
 
+class MonadIO m => HasIndexOptions m where
+  getIndexBlockSize :: m Natural
+  setIndexBlockSize :: Natural -> m ()
+
+instance (MonadIO m, MonadReader Git3Env m) => HasIndexOptions m where
+  getIndexBlockSize = asks gitIndexBlockSize >>= readTVarIO
+
+  setIndexBlockSize n = do
+    e <- asks gitIndexBlockSize
+    atomically $ writeTVar e n
+
 newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
                    deriving newtype ( Applicative
                                     , Functor
@@ -169,6 +187,7 @@ nullGit3Env = Git3Disconnected
                 <$> newTVarIO Nothing
                 <*> newTVarIO defSegmentSize
                 <*> newTVarIO defCompressionLevel
+                <*> newTVarIO defIndexBlockSize
 
 connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a
 connectedDo what = do

hbs2-git3/lib/HBS2/Git3/State/Index.hs

@@ -97,8 +97,6 @@ mergeSortedFilesN :: forall m . MonadUnliftIO m
 
 mergeSortedFilesN _ [] out  = rm out
 
-mergeSortedFilesN _ [_] out = rm out
-
 mergeSortedFilesN getKey inputFiles outFile = do
 
   mmaped <- for inputFiles $ \fn -> do
@@ -113,12 +111,13 @@ mergeSortedFilesN getKey inputFiles outFile = do
       let h0 = HPSQ.minView heap
       maybe1 h0 none $ \case
         (_,_,[],rest) -> next rest
-        (_,_,e:xs,rest) -> do
+        (k,_,e:xs,rest) -> do
           liftIO $ writeSection (LBS.fromStrict e) (LBS.hPutStr hOut)
-          let new = maybe rest (\(a,b,c) -> HPSQ.insert a b c rest) (mkState xs)
+          let zu = maybe rest (\(a,b,c) -> HPSQ.insert a b c rest) (mkState xs)
+          let what = HPSQ.toList zu & mapMaybe (mkState . dropDupes k . view _3)
+                                    & HPSQ.fromList
+          let new = what
           next new
-          -- mapMaybe mkState (xs : fmap (view _3) (HPSQ.toList rest))
-          -- next (HPSQ.fromList new)
 
     mapM_ rm inputFiles
 
@@ -293,6 +292,7 @@ updateReflogIndex :: forall m . ( Git3Perks m
                                 , HasClientAPI PeerAPI UNIX m
                                 , HasClientAPI RefLogAPI UNIX m
                                 , HasStorage m
+                                , HasIndexOptions m
                                 ) => m ()
 updateReflogIndex = do
 
@@ -354,5 +354,5 @@ updateReflogIndex = do
             -- notice $ pretty sha1 <+> pretty tx
             writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh)
 
-      -- lift $ compactIndex ( 32 * 1024 * 1024 )
+      getIndexBlockSize >>= lift . compactIndex