wip

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,20 +122,42 @@ importGitRefLog :: forall m . ( HBS2GitPerks m
                               )
              => Git3 m (Maybe HashRef)
 
-importGitRefLog = withStateDo do
+importGitRefLog = withStateDo $ ask >>= \case
-
+  Git3Disconnected{} -> throwIO Git3PeerNotConnected
-  updateReflogIndex
+  env@Git3Connected{..} ->  do
 
     packs <- gitDir
-             >>= orThrowUser "git directory not found"
+               >>= orThrow NoGitDir
                <&> (</> "objects/pack")
 
     mkdir packs
 
     sto <- getStorage
 
+    flip fix ImportStart $ \again -> \case
+      ImportDone x -> pure x
+
+      ImportWait next -> do
+        notice "wait some time..."
+        pause @'Seconds 3
+        again next
+
+      ImportStart -> do
+
+        rvl  <- readTVarIO gitRefLogVal
         prev <- importedCheckpoint
 
+        if | isNothing prev -> again $ ImportWIP 0 prev
+
+           | prev /= rvl -> do
+              again $ ImportWIP 0 prev
+
+           | otherwise -> again $ ImportDone prev
+
+      ImportWIP attempt prev -> do
+
+        updateReflogIndex
+
         excl <- maybe1 prev (pure mempty) $ \p -> do
           txListAll (Just p) <&> HS.fromList . fmap fst
 
@@ -155,12 +184,14 @@ importGitRefLog = withStateDo do
             else do
               next (xs, l)
 
-  runMaybeT do
+        case cp' of
-    cp <- toMPlus cp'
+          Nothing -> again $ ImportDone Nothing
-    notice $ "found checkpoint" <+> pretty cp
+          Just cp -> do
-    txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
 
-    lift 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
@@ -174,5 +205,11 @@ importGitRefLog = withStateDo do
 
               updateImportedCheckpoint cp
 
-      pure 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
 

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:"
 

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

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