diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 1f7d6d70..8d2817b8 100644 --- a/hbs2-git3/app/Main.hs +++ b/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 diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs index 814df0b0..6189afaf 100644 --- a/hbs2-git3/lib/HBS2/Git3/Prelude.hs +++ b/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) @@ -86,9 +91,10 @@ instance Exception Git3Exception data Git3Env = Git3Disconnected - { gitRefLog :: TVar (Maybe GitRemoteKey) + { 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 diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index 4e8f757e..5f7dc00b 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/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 @@ -289,11 +288,12 @@ readTxMay sto href = runMaybeT do & toMPlus updateReflogIndex :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - ) => m () + , MonadReader Git3Env m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI RefLogAPI UNIX m + , HasStorage m + , HasIndexOptions m + ) => m () updateReflogIndex = do reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet @@ -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