rollback git state in case of exception

.fixme/log

@@ -0,0 +1,2 @@
+
+(fixme-set "workflow" "test" "E6RNxRxpnJ")

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

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))
                     )
 

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

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
+                   , exceptions
                    , terminal-progress-bar
                    , http-types
+                   , uuid
 
     hs-source-dirs:   lib
     default-language: Haskell2010

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"

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)

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

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,12 +117,46 @@ 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"
+  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

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)

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,6 +25,12 @@ updateLocalState ref = do
 
   trace $ "updateLocalState" <+> pretty ref
 
+  sp <- withDB db savepointNew
+
+  withDB db $ savepointBegin sp
+
+  r <- try $ do
+
     -- TODO: read-reflog
     -- TODO: update-reflog
     importRefLog db ref
@@ -33,5 +41,14 @@ updateLocalState ref = do
 
     importObjects db hash
 
-  pure ()
+    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 ()
+