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

wip

This commit is contained in:
voidlizard 2025-01-22 10:00:46 +03:00
parent 242101fd9c
commit b263bfbdc9
4 changed files with 105 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
hbs2-git3/lib/HBS2/Git3/Import.hs
View File

@ -1,5 +1,6 @@
{-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language MultiWayIf #-}
module HBS2.Git3.Import where
import HBS2.Git3.Prelude
@ -20,6 +21,7 @@ import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Maybe
import Data.List qualified as L
import Network.ByteOrder qualified as N
import System.IO.Temp as Temp
@ -105,6 +107,11 @@ writeAsGitPack dir href = do
pure Nothing
data ImportStage =
ImportStart
| ImportWIP Int (Maybe HashRef)
| ImportWait ImportStage
| ImportDone (Maybe HashRef)
importGitRefLog :: forall m . ( HBS2GitPerks m
-- , HasStorage m
@ -115,64 +122,94 @@ importGitRefLog :: forall m . ( HBS2GitPerks m
)
=> Git3 m (Maybe HashRef)
importGitRefLog = withStateDo do
importGitRefLog = withStateDo $ ask >>= \case
Git3Disconnected{} -> throwIO Git3PeerNotConnected
env@Git3Connected{..} -> do
updateReflogIndex
packs <- gitDir
>>= orThrow NoGitDir
<&> (</> "objects/pack")
packs <- gitDir
>>= orThrowUser "git directory not found"
<&> (</> "objects/pack")
mkdir packs
mkdir packs
sto <- getStorage
sto <- getStorage
flip fix ImportStart $ \again -> \case
ImportDone x -> pure x
prev <- importedCheckpoint
ImportWait next -> do
notice "wait some time..."
pause @'Seconds 3
again next
excl <- maybe1 prev (pure mempty) $ \p -> do
txListAll (Just p) <&> HS.fromList . fmap fst
ImportStart -> do
rv <- refLogRef
rvl <- readTVarIO gitRefLogVal
prev <- importedCheckpoint
hxs <- txList ( pure . not . flip HS.member excl ) rv
if | isNothing prev -> again $ ImportWIP 0 prev
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
| prev /= rvl -> do
again $ ImportWIP 0 prev
-- full <- findMissedBlocks sto tree <&> L.null
missed_ <- newTVarIO 0
deepScan ScanDeep (\_ -> atomically $ modifyTVar missed_ succ)
(coerce tree)
(getBlock sto)
(const none)
| otherwise -> again $ ImportDone prev
full <- readTVarIO missed_ <&> (==0)
ImportWIP attempt prev -> do
if full && Just n > (getGitTxRank <$> l) then do
next (xs, Just cp)
else do
next (xs, l)
updateReflogIndex
runMaybeT do
cp <- toMPlus cp'
notice $ "found checkpoint" <+> pretty cp
txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
excl <- maybe1 prev (pure mempty) $ \p -> do
txListAll (Just p) <&> HS.fromList . fmap fst
lift do
forConcurrently_ txs $ \case
(_, TxCheckpoint{}) -> none
(h, TxSegment tree) -> do
s <- writeAsGitPack packs tree
rv <- refLogRef
for_ s $ \file -> do
gitRunCommand [qc|git index-pack {file}|]
>>= orThrowPassIO
hxs <- txList ( pure . not . flip HS.member excl ) rv
notice $ "imported" <+> pretty h
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
updateImportedCheckpoint cp
-- full <- findMissedBlocks sto tree <&> L.null
missed_ <- newTVarIO 0
deepScan ScanDeep (\_ -> atomically $ modifyTVar missed_ succ)
(coerce tree)
(getBlock sto)
(const none)
pure cp
full <- readTVarIO missed_ <&> (==0)
if full && Just n > (getGitTxRank <$> l) then do
next (xs, Just cp)
else do
next (xs, l)
case cp' of
Nothing -> again $ ImportDone Nothing
Just cp -> do
notice $ "found checkpoint" <+> pretty cp
txs <- txList ( pure . not . flip HS.member excl ) (Just cp)
r <- liftIO $ try @_ @SomeException $ withGit3Env env do
forConcurrently_ txs $ \case
(_, TxCheckpoint{}) -> none
(h, TxSegment tree) -> do
s <- writeAsGitPack packs tree
for_ s $ \file -> do
gitRunCommand [qc|git index-pack {file}|]
>>= orThrowPassIO
notice $ "imported" <+> pretty h
updateImportedCheckpoint cp
case r of
Right _ -> again $ ImportDone (Just cp)
Left e -> do
case (fromException e :: Maybe OperationError) of
Just (MissedBlockError2 _) -> again $ ImportWait (ImportWIP (succ attempt) prev)
Just MissedBlockError -> again $ ImportWait (ImportWIP (succ attempt) prev)
_ -> throwIO e

7
hbs2-git3/lib/HBS2/Git3/Run.hs
View File

@ -486,5 +486,12 @@ repo:key ; shows current repo key
entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
Repo.initRepo syn
entry $ bindMatch "repo:relay-only" $ nil_ $ \case
[ SignPubKeyLike repo ] -> lift $ connectedDo do
setGitRepoKey repo
waitRepo (Just 2)
_ -> throwIO (BadFormException @C nil)
exportEntries "reflog:"

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

@ -43,6 +43,7 @@ import System.TimeIt
import Lens.Micro.Platform
import Control.Concurrent.STM qualified as STM
import Control.Exception qualified as E
import UnliftIO.IO.File qualified as UIO
@ -305,7 +306,7 @@ updateReflogIndex = do
flip runContT pure do
what' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) api reflog
>>= orThrow Git3RpcTimeout
>>= orThrow RpcTimeout
what <- ContT $ maybe1 what' none
@ -437,7 +438,7 @@ trimRefs = do
mapM_ rm files
importedCheckpoint :: forall m . ( Git3Perks m
importedCheckpoint :: forall m . ( MonadIO m
, MonadReader Git3Env m
, HasClientAPI RefLogAPI UNIX m
, HasStorage m
@ -448,7 +449,7 @@ importedCheckpoint = do
state <- getStatePathM
let imported = state </> "imported"
runMaybeT do
f <- liftIO (try @_ @IOError (readFile imported <&> headMay . lines))
f <- liftIO (E.try @IOError (readFile imported <&> headMay . lines))
>>= toMPlus
>>= toMPlus
@ -484,7 +485,7 @@ readRefsRaw :: forall m . ( Git3Perks m
=> [FilePath] -> m [Syntax C]
readRefsRaw files = do
mapM (try @_ @IOError . liftIO . readFile) files
mapM (liftIO . E.try @IOError . readFile) files
<&> unlines . rights
<&> parseTop
<&> fromRight mempty

24
hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs
View File

@ -55,6 +55,9 @@ data HBS2GitExcepion =
| RefLogCredentialsNotMatched
| RefLogNotReady
| RpcTimeout
| Git3PeerNotConnected
| Git3ReflogNotSet
| NoGitDir
deriving stock (Show,Typeable)
instance Exception HBS2GitExcepion
@ -86,14 +89,6 @@ instance Hashable GitWritePacksOptVal
instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where
excludeParents o = not $ HS.member WriteFullPack o
data Git3Exception =
Git3PeerNotConnected
| Git3ReflogNotSet
| Git3RpcTimeout
deriving (Show,Typeable,Generic)
instance Exception Git3Exception
data Git3Env =
Git3Disconnected
{ gitPackedSegmentSize :: TVar Int
@ -170,6 +165,10 @@ instance (MonadIO m) => HasGitRemoteKey (Git3 m) where
e <- ask
liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k)
instance (MonadIO m, HasGitRemoteKey (Git3 m)) => HasGitRemoteKey (ContT whatever (Git3 m)) where
getGitRemoteKey = lift getGitRemoteKey
getGitRepoKey = lift getGitRepoKey
setGitRepoKey = lift . setGitRepoKey
newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
deriving newtype ( Applicative
@ -185,7 +184,6 @@ type Git3Perks m = ( MonadIO m
, MonadUnliftIO m
)
instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where
getClientAPI = do
ask >>= \case
@ -205,7 +203,13 @@ instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where
Git3Disconnected{} -> throwIO Git3PeerNotConnected
Git3Connected{..} -> pure lwwAPI
getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath
instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (ContT whatever (Git3 m)) where
getClientAPI = lift (getClientAPI @api @UNIX)
instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (MaybeT (Git3 m)) where
getClientAPI = lift getClientAPI
getStatePathM :: forall m . (MonadIO m, HasGitRemoteKey m) => m FilePath
getStatePathM = do
k <- getGitRemoteKey >>= orThrow RefLogNotSet
getStatePath (AsBase58 k) >>= orThrow StateDirNotDefined