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,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
+    mkdir packs
-             >>= orThrowUser "git directory not found"
-             <&> (</> "objects/pack")
 
-  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
+      ImportStart -> do
-    txListAll (Just p) <&> HS.fromList . fmap fst
 
-  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
+           | prev /= rvl -> do
-    ([], r) -> pure (gitTxTree <$> r)
+              again $ ImportWIP 0 prev
-    (TxSegment{}:xs, l) -> next (xs, l)
-    (cp@(TxCheckpoint n tree) : xs, l) -> do
 
-      -- full <- findMissedBlocks sto tree <&> L.null
+           | otherwise -> again $ ImportDone prev
-      missed_ <- newTVarIO 0
-      deepScan ScanDeep (\_ -> atomically $ modifyTVar missed_ succ)
-                        (coerce tree)
-                        (getBlock sto)
-                        (const none)
 
-      full <- readTVarIO missed_ <&> (==0)
+      ImportWIP attempt prev -> do
 
-      if full && Just n > (getGitTxRank <$> l) then do
+        updateReflogIndex
-        next (xs, Just cp)
-      else do
-        next (xs, l)
 
-  runMaybeT do
+        excl <- maybe1 prev (pure mempty) $ \p -> do
-    cp <- toMPlus cp'
+          txListAll (Just p) <&> HS.fromList . fmap fst
-    notice $ "found checkpoint" <+> pretty cp
-    txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
 
-    lift do
+        rv <- refLogRef
-      forConcurrently_ txs $ \case
-        (_, TxCheckpoint{}) -> none
-        (h, TxSegment tree) -> do
-          s <- writeAsGitPack  packs tree
 
-          for_ s $ \file -> do
+        hxs <- txList ( pure . not . flip HS.member excl ) rv
-            gitRunCommand [qc|git index-pack {file}|]
-              >>= orThrowPassIO
 
-          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
 

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