diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 7a696d0c..06037d8e 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 7c2672f2..da636e51 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -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:" diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs index b1b6e603..f37634d4 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index cf21a9d4..253adc06 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -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