hbs2-git db bugfix

hbs2-git/lib/HBS2Git/State.hs

@@ -5,6 +5,8 @@ import HBS2.Data.Types.Refs
 import HBS2.Git.Types
 import HBS2.Hash
 
+import HBS2.System.Logger.Simple
+
 import Data.Functor
 import Data.Function
 import Database.SQLite.Simple
@@ -22,6 +24,8 @@ import Data.Text (Text)
 import Prettyprinter
 import Data.UUID.V4 qualified as UUID
 import Control.Monad.Catch
+import Control.Concurrent.STM
+import System.IO.Unsafe
 
 instance ToField GitHash where
   toField h = toField (show $ pretty h)
@@ -59,14 +63,26 @@ instance (HasRefCredentials m) => HasRefCredentials (DB m) where
   getCredentials = lift . getCredentials
   setCredentials r s  = lift (setCredentials r s)
 
+dbConnTV :: TVar (Maybe DBEnv)
+dbConnTV = unsafePerformIO $ newTVarIO Nothing
+{-# NOINLINE dbConnTV #-}
+
 dbEnv :: MonadIO m => FilePath -> m DBEnv
 dbEnv fp = do
+  trace  "dbEnv called"
   let dir = takeDirectory fp
   liftIO $ createDirectoryIfMissing True dir
+  mbDb <- liftIO $ readTVarIO dbConnTV
+
+  case mbDb of
+    Nothing -> do
       co <- liftIO $ open fp
+      liftIO $ atomically $ writeTVar dbConnTV (Just co)
       withDB co stateInit
       pure co
 
+    Just db -> pure db
+
 withDB :: DBEnv -> DB m a -> m a
 withDB env action = runReaderT (fromDB action) env
 

hbs2-git/lib/HBS2Git/Update.hs

@@ -23,6 +23,8 @@ updateLocalState ref = do
 
   db <- dbEnv dbPath
 
+  withDB db stateInit
+
   trace $ "updateLocalState" <+> pretty ref
 
   sp <- withDB db savepointNew