voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, refs calculation

This commit is contained in:
voidlizard 2025-01-17 07:47:17 +03:00
parent 250099af7e
commit 10ff2ceaff
4 changed files with 107 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
hbs2-git3/app/Main.hs
View File

@ -17,6 +17,7 @@ import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.API.LWWRef
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client.StorageClient
import HBS2.Storage.Operations.Missed
-- move to Data.Config.Suckless.Script.Filea sepatate library
import HBS2.Data.Log.Structured
@ -52,6 +53,7 @@ import Data.List.Split (chunksOf)
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy ( ByteString )
import Data.ByteString.Builder as Builder
import Network.ByteOrder qualified as N
@ -81,7 +83,7 @@ import System.Directory (setCurrentDirectory)
import System.Random hiding (next)
import System.IO.MMap (mmapFileByteString)
import System.IO qualified as IO
import System.IO (hPrint)
import System.IO (hPrint,hPutStrLn,hPutStr)
import System.IO.Temp as Temp
import System.TimeIt
@ -889,7 +891,11 @@ theDict = do
forM_ decoded print
entry $ bindMatch "reflog:import:pack" $ nil_ $ \syn -> lift $ connectedDo do
entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do
rrefs <- importedRefs
liftIO $ print $ pretty rrefs
entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
updateReflogIndex
packs <- findGitDir
@ -898,11 +904,11 @@ theDict = do
state <- getStatePathM
sto <- getStorage
let imported = state </> "imported"
prev <- runMaybeT do
f <- liftIO (try @_ @IOError (readFile imported)) >>= toMPlus
toMPlus (fromStringMay @HashRef f)
prev <- importedCheckpoint
excl <- maybe1 prev (pure mempty) $ \p -> do
txListAll (Just p) <&> HS.fromList . fmap fst
@ -911,7 +917,23 @@ theDict = do
hxs <- txList ( pure . not . flip HS.member excl ) rv
forConcurrently_ hxs $ \case
cp' <- flip fix (fmap snd hxs, Nothing) $ \next -> \case
([], r) -> pure (gitTxTree <$> r)
(TxSegment{}:xs, l) -> next (xs, l)
(cp@(TxCheckpoint n tree) : xs, l) -> do
full <- findMissedBlocks sto tree <&> L.null
if full && Just n > (getGitTxRank <$> l) then do
next (xs, Just cp)
else do
next (xs, l)
void $ runMaybeT do
cp <- toMPlus cp'
notice $ "found checkpoint" <+> pretty cp
txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
lift do
forConcurrently_ txs $ \case
(_, TxCheckpoint{}) -> none
(h, TxSegment tree) -> do
s <- writeAsGitPack packs tree
@ -922,9 +944,7 @@ theDict = do
notice $ "imported" <+> pretty h
for_ rv $ \r -> do
liftIO $ UIO.withBinaryFileAtomic imported WriteMode $ \fh -> do
IO.hPutStr fh (show $ pretty r)
updateImportedCheckpoint cp
exportEntries "reflog:"

1
hbs2-git3/lib/HBS2/Git3/Prelude.hs
View File

@ -49,6 +49,7 @@ import Data.HashSet qualified as HS
import Data.Kind
import System.Exit qualified as Q
import System.IO.MMap as Exported
import System.FilePattern as Exported
import GHC.Natural as Exported
import UnliftIO as Exported

63
hbs2-git3/lib/HBS2/Git3/State/Index.hs
View File

@ -11,6 +11,7 @@ import HBS2.Git3.Git
import HBS2.Data.Log.Structured
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy ( ByteString )
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
@ -32,6 +33,8 @@ import Data.Word
import Data.Config.Suckless
import Data.Config.Suckless.Script.File
import System.IO (hPrint)
import Streaming.Prelude qualified as S
import System.TimeIt
@ -378,3 +381,63 @@ updateReflogIndex = do
UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
for_ es $ \s -> LBS8.hPutStrLn wh s
importedCheckpoint :: forall m . ( Git3Perks m
, MonadReader Git3Env m
, HasClientAPI RefLogAPI UNIX m
, HasStorage m
) => m (Maybe HashRef)
importedCheckpoint = do
state <- getStatePathM
let imported = state </> "imported"
runMaybeT do
f <- liftIO (try @_ @IOError (readFile imported)) >>= toMPlus
toMPlus (fromStringMay @HashRef f)
{- HLINT ignore "Functor law"-}
importedRefs :: forall m . ( Git3Perks m
, MonadReader Git3Env m
, HasClientAPI RefLogAPI UNIX m
, HasStorage m
) => m [(GitRef, GitHash)]
importedRefs = do
state <- getStatePathM
refs <- dirFiles state
<&> filter ( (== ".ref") . takeExtension )
>>= mapM (try @_ @IOError . liftIO . readFile)
<&> unlines . rights
<&> parseTop
<&> fromRight mempty
txh <- maybe mempty HS.fromList <$> runMaybeT do
cp <- lift importedCheckpoint >>= toMPlus
fmap fst <$> lift (txListAll (Just cp))
let rrefs = [ (n,((GitRef (BS8.pack n),g),r))
| ListVal [ SymbolVal "R"
, HashLike th
, LitIntVal r
, GitHashLike g
, StringLike n ] <- refs
, HS.member th txh
] & HM.fromListWith (\(a,t1) (b,t2) -> if t1 > t2 then (a,t1) else (b,t2))
& fmap fst . HM.elems
pure rrefs
updateImportedCheckpoint :: forall m . ( Git3Perks m
, MonadReader Git3Env m
, HasClientAPI RefLogAPI UNIX m
, HasStorage m
) => HashRef -> m ()
updateImportedCheckpoint cp = do
state <- getStatePathM
let imported = state </> "imported"
liftIO $ UIO.withBinaryFileAtomic imported WriteMode $ \fh -> do
hPrint fh (show $ pretty cp)

9
hbs2-git3/lib/HBS2/Git3/State/RefLog.hs
View File

@ -8,8 +8,13 @@ import Data.Maybe
import Streaming.Prelude qualified as S
data GitTx =
TxSegment HashRef
| TxCheckpoint Natural HashRef
TxSegment { gitTxTree :: HashRef }
| TxCheckpoint { gitTxRank :: Natural, gitTxTree :: HashRef }
getGitTxRank :: GitTx -> Natural
getGitTxRank = \case
TxSegment _ -> 0
TxCheckpoint n _ -> n
data RefLogException =
RefLogRPCException