From 0b12d6db792274f71cd474c24a7c1ab7af1696d4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 28 Mar 2023 17:09:40 +0300 Subject: [PATCH] rollback git state in case of exception --- .fixme/log | 2 ++ hbs2-git/git-hbs2/GitRemoteMain.hs | 3 +- hbs2-git/git-hbs2/GitRemotePush.hs | 4 +++ hbs2-git/git-hbs2/GitRemoteTypes.hs | 3 ++ hbs2-git/hbs2-git.cabal | 7 ++-- hbs2-git/lib/HBS2Git/App.hs | 1 + hbs2-git/lib/HBS2Git/Export.hs | 5 ++- hbs2-git/lib/HBS2Git/Import.hs | 3 +- hbs2-git/lib/HBS2Git/State.hs | 54 +++++++++++++++++++++++++---- hbs2-git/lib/HBS2Git/Types.hs | 10 +++++- hbs2-git/lib/HBS2Git/Update.hs | 33 +++++++++++++----- 11 files changed, 105 insertions(+), 20 deletions(-) diff --git a/.fixme/log b/.fixme/log index e69de29b..d368fcc6 100644 --- a/.fixme/log +++ b/.fixme/log @@ -0,0 +1,2 @@ + +(fixme-set "workflow" "test" "E6RNxRxpnJ") \ No newline at end of file diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index ec125147..205c780d 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/hbs2-git/git-hbs2/GitRemoteMain.hs @@ -40,7 +40,7 @@ import System.ProgressBar import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO as UIO import Control.Monad.Trans.Maybe - +import Control.Monad.Catch send :: MonadIO m => BS.ByteString -> m () send = liftIO . BS.hPutStr stdout @@ -80,6 +80,7 @@ readHeadDef db = readObject r <&> fromMaybe "\n" loop :: forall m . ( MonadIO m + , MonadCatch m , HasProgress (RunWithConfig (GitRemoteApp m)) ) => [String] -> GitRemoteApp m () loop args = do diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs index 0fb97674..4abed369 100644 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ b/hbs2-git/git-hbs2/GitRemotePush.hs @@ -31,6 +31,7 @@ import Text.InterpolatedString.Perl6 (qc) import Data.ByteString qualified as BS import Control.Concurrent.STM.TVar import Control.Concurrent.STM +import Control.Monad.Catch newtype RunWithConfig m a = WithConfig { fromWithConf :: ReaderT [Syntax C] m a } @@ -40,6 +41,8 @@ newtype RunWithConfig m a = , MonadIO , MonadReader [Syntax C] , MonadTrans + , MonadThrow + , MonadCatch ) @@ -60,6 +63,7 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where setCredentials r c = lift $ setCredentials r c push :: forall m . ( MonadIO m + , MonadCatch m , HasProgress (RunWithConfig (GitRemoteApp m)) ) diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs index af231358..f8871447 100644 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ b/hbs2-git/git-hbs2/GitRemoteTypes.hs @@ -13,6 +13,7 @@ import Lens.Micro.Platform import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict (HashMap) import Control.Concurrent.STM +import Control.Monad.Catch data RemoteEnv = RemoteEnv @@ -32,6 +33,8 @@ newtype GitRemoteApp m a = , Monad , MonadIO , MonadReader RemoteEnv + , MonadThrow + , MonadCatch ) runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index fc97466e..2b83d7a3 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -82,6 +82,7 @@ common shared-properties , unordered-containers , filelock , http-conduit + , exceptions library import: shared-properties @@ -102,8 +103,10 @@ library -- other-modules: -- other-extensions: build-depends: base - , terminal-progress-bar - , http-types + , exceptions + , terminal-progress-bar + , http-types + , uuid hs-source-dirs: lib default-language: Haskell2010 diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 51e36fce..d587014c 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -52,6 +52,7 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Cache qualified as Cache import Control.Concurrent.Async import System.Environment +import Control.Monad.Catch instance MonadIO m => HasCfgKey ConfBranch (Set String) m where key = "branch" diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index 5f68b254..26839719 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -31,6 +31,7 @@ import Data.Set (Set) import Lens.Micro.Platform import Control.Concurrent.STM import Control.Concurrent.Async +import Control.Monad.Catch data HashCache = HashCache @@ -54,6 +55,7 @@ newHashCache db = do export :: forall m . ( MonadIO m + , MonadCatch m , HasCatAPI m , HasConf m , HasRefCredentials m @@ -175,7 +177,8 @@ export h repoHead = do pure (HashRef root, hh) -runExport :: forall m . (MonadIO m, HasProgress (App m)) => Maybe FilePath -> RepoRef -> App m () +runExport :: forall m . (MonadIO m, MonadCatch m, HasProgress (App m)) + => Maybe FilePath -> RepoRef -> App m () runExport fp h = do trace $ "Export" <+> pretty (AsBase58 h) diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index 6cc68b4e..c6439ac0 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -29,6 +29,7 @@ import Data.ByteString.Lazy qualified as LBS import Lens.Micro.Platform -- import System.Exit import Codec.Serialise +import Control.Monad.Catch data RunImportOpts = RunImportOpts @@ -79,7 +80,7 @@ importRefLog db ref = do when new do pure () -importObjects :: (MonadIO m, HasCatAPI m) => DBEnv -> HashRef -> m () +importObjects :: (MonadIO m, MonadCatch m, HasCatAPI m) => DBEnv -> HashRef -> m () importObjects db root = do q <- liftIO newTQueueIO diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 4267b2e1..c8e36737 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -3,8 +3,10 @@ module HBS2Git.State where import HBS2Git.Types import HBS2.Data.Types.Refs import HBS2.Git.Types +import HBS2.Hash import Data.Functor +import Data.Function import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField @@ -12,11 +14,14 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Text.InterpolatedString.Perl6 (qc) import Data.String +import Data.ByteString.Lazy.Char8 qualified as LBS import System.Directory import System.FilePath import Data.Maybe import Data.Text (Text) import Prettyprinter +import Data.UUID.V4 qualified as UUID +import Control.Monad.Catch instance ToField GitHash where toField h = toField (show $ pretty h) @@ -46,10 +51,13 @@ newtype DB m a = , MonadIO , MonadReader Connection , MonadTrans + , MonadThrow + , MonadCatch ) instance (HasRefCredentials m) => HasRefCredentials (DB m) where getCredentials = lift . getCredentials + setCredentials r s = lift (setCredentials r s) dbEnv :: MonadIO m => FilePath -> m DBEnv dbEnv fp = do @@ -109,13 +117,47 @@ stateInit = do |] -transactional :: forall a m . MonadIO m => DB m a -> DB m a -transactional action = do +newtype Savepoint = + Savepoint String + deriving newtype (IsString) + deriving stock (Eq,Ord) + +savepointNew :: forall m . MonadIO m => DB m Savepoint +savepointNew = do + uu <- liftIO UUID.nextRandom + let s = LBS.pack (show uu) & hashObject @HbSync & pretty & show + pure $ fromString ("sp" <> s) + +savepointBegin :: forall m . MonadIO m => Savepoint -> DB m () +savepointBegin (Savepoint sp) = do conn <- ask - liftIO $ execute_ conn "begin" - x <- action - liftIO $ execute_ conn "commit" - pure x + liftIO $ execute_ conn [qc|SAVEPOINT {sp}|] + +savepointRelease:: forall m . MonadIO m => Savepoint -> DB m () +savepointRelease (Savepoint sp) = do + conn <- ask + liftIO $ execute_ conn [qc|RELEASE SAVEPOINT {sp}|] + +savepointRollback :: forall m . MonadIO m => Savepoint -> DB m () +savepointRollback (Savepoint sp) = do + conn <- ask + liftIO $ execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|] + +transactional :: forall a m . (MonadCatch m, MonadIO m) => DB m a -> DB m a +transactional action = do + + sp <- savepointNew + + savepointBegin sp + r <- try action + + case r of + Left (e :: SomeException) -> do + savepointRollback sp + throwM e + + Right x -> do + pure x -- TODO: backlog-head-history -- можно сделать таблицу history, в которую diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 97740dd8..aa4f6b49 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -33,6 +33,7 @@ import Control.Concurrent.STM import System.IO qualified as IO import System.IO (Handle) import Data.Kind +import Control.Monad.Catch type Schema = UDP @@ -142,7 +143,14 @@ class Monad m => HasConf m where newtype App m a = App { fromApp :: ReaderT AppEnv m a } - deriving newtype ( Applicative, Functor, Monad, MonadIO, MonadReader AppEnv ) + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadReader AppEnv + , MonadThrow + , MonadCatch + ) instance MonadIO m => HasConf (App m) where getConf = asks (view appConf) diff --git a/hbs2-git/lib/HBS2Git/Update.hs b/hbs2-git/lib/HBS2Git/Update.hs index b1986926..a079be7d 100644 --- a/hbs2-git/lib/HBS2Git/Update.hs +++ b/hbs2-git/lib/HBS2Git/Update.hs @@ -11,8 +11,10 @@ import HBS2Git.App import HBS2Git.State import HBS2Git.Import +import Control.Monad.Catch -updateLocalState :: (MonadIO m, HasCatAPI m) => RepoRef -> m () + +updateLocalState :: (MonadIO m, HasCatAPI m, MonadCatch m) => RepoRef -> m () updateLocalState ref = do dbPath <- makeDbPath ref @@ -23,15 +25,30 @@ updateLocalState ref = do trace $ "updateLocalState" <+> pretty ref - -- TODO: read-reflog - -- TODO: update-reflog - importRefLog db ref + sp <- withDB db savepointNew - (n,hash) <- withDB db $ stateGetRefLogLast `orDie` "empty reflog" + withDB db $ savepointBegin sp - trace $ "got reflog" <+> pretty (n,hash) + r <- try $ do - importObjects db hash + -- TODO: read-reflog + -- TODO: update-reflog + importRefLog db ref + + (n,hash) <- withDB db $ stateGetRefLogLast `orDie` "empty reflog" + + trace $ "got reflog" <+> pretty (n,hash) + + importObjects db hash + + withDB db (savepointRelease sp) + + case r of + Left (e :: SomeException) -> do + withDB db $ savepointRollback sp + err (viaShow e) + err "error happened. state rolled back" + + Right{} -> pure () - pure ()