git-hbs2-http - very basic git http dumb algorithm

for fetching repos from hbs2-git for third-side
 programs (like nix).

 pushes are not supported (yet?).

docs/todo/hbs2-git-ux.txt

@@ -0,0 +1,27 @@
+FIXME: hbs2-git-config-path-ux
+  1. Пользователю неочевидно, где этот конфиг искать ( ~/.local/config/hbs2-git/repo/config )
+  2. Если пользователь переименует репозиторий, то путь к конфигу станет неактуален
+     и это вызовет непонятную внезапную проблему.
+
+  Решение:
+   Пока непонятно. Если привязаться к inode, то при перемещении между FS будет ломаться,
+   и кроссплатформенность пострадает.
+
+   Кажется, при инициализации репо надо заводить cookie, и сохранять её в конфиге гита (буэ).
+   Тогда все операции ведутся через эту cookie, все развязки в стейте через эту cookie,
+   тогда importRefLogNew начинает работать с многими каталогами git, стейт с одной
+   стороны глобальный, с другой стороны зависит от cookie.
+
+   Если пользователь специально или случайно удалит/поменяет cookie -- то импорт для этого
+   репозитория пойдёт заново (ну и что, мы этого и хотели. глобальный у нас
+   только logobject и связаные с ним вью и таблицы, а таблицы, которые отмечают
+   обработанные данные --- имеют локальный смысл. )
+
+   Кроме того, надо задуматься о перемещении конфига в каталог гит локально,
+   что бы избежать проблем 1 и 2.
+
+   Введение конфига, привязанного к cookie, еще больше усугубит проблему (1), но решит
+   в принципе проблему 2.
+
+   От конфига нам, кстати, вообще ничего не нужно, кроме указания ключа записи в рефлог.
+   Кажется, можно его просто упразднить или писать в тот же gitconfig.

hbs2-git/git-hbs2-http/GitHttpDumbMain.hs

@@ -0,0 +1,249 @@
+module Main where
+
+import HBS2.Prelude.Plated
+import HBS2.Clock
+
+import HBS2Git.App
+import HBS2Git.State
+import HBS2Git.Import (getLogFlags, importRefLogNew)
+import HBS2Git.GitRepoLog
+import HBS2.Git.Types
+import HBS2.Data.Types.Refs
+import HBS2.Data.Detect (deepScan,ScanLevel(..))
+import HBS2.OrDie
+
+import HBS2.System.Logger.Simple
+
+import Codec.Compression.Zlib (compress)
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Resource
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Function
+import Data.Functor
+import Data.HashMap.Strict as HashMap
+import Data.List (sortOn)
+import Data.Text.Lazy qualified as Text
+import Lens.Micro.Platform
+import Network.HTTP.Types.Status
+import Network.Wai.Handler.Warp (Port)
+import Network.Wai.Middleware.RequestLogger
+import System.Directory
+import System.FilePath.Posix
+import System.IO.Temp
+import System.Timeout (timeout)
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO.Async
+
+import Streaming.ByteString qualified as SB
+import Streaming.Zip qualified as SZip
+
+import Web.Scotty
+
+instance Parsable RepoRef where
+  parseParam txt = fromStringMay @RepoRef (Text.unpack txt)
+                    & maybe (Left [qc|{txt}|]) Right
+
+instance Parsable GitRef where
+  parseParam txt = Right $ fromString (Text.unpack txt)
+
+getAppStatePath :: MonadIO m => RepoRef -> m FilePath
+getAppStatePath repo = do
+  stateDir <- getAppStateDir
+  pure $ stateDir </> show (pretty repo)
+
+
+blockSource :: MonadIO m => API -> HashRef -> SB.ByteStream m ()
+blockSource api h = do
+  deepScan ScanDeep (const none) (fromHashRef h) (readBlockFrom api . HashRef) $ \ha -> do
+    sec <- lift $ readBlockFrom api (HashRef ha) `orDie` [qc|missed block {pretty ha}|]
+    when (h /= HashRef ha) do
+      SB.fromLazy sec
+
+unpackObjects :: MonadIO m => API -> HashRef -> FilePath -> m ()
+unpackObjects catApi lo path = do
+
+  let logPath = path </> show (pretty lo)
+  let logFile = logPath </> "data"
+
+  liftIO $ createDirectoryIfMissing True logPath
+
+  flags <- getLogFlags (readBlockFrom catApi) lo
+  let gzipped = or $ False : [ True | "gz" <- universeBi flags ]
+  let unzipped = if gzipped then SZip.gunzip else id
+  debug $ "GOT FLAGS:" <+> pretty lo <+> pretty flags
+
+  liftIO $ do
+    runResourceT $ SB.writeFile logFile $ unzipped $ blockSource catApi lo
+
+    gitRepoLogScan True logFile $ \entry mlbs -> do
+
+      let tp = case view gitLogEntryType entry of
+                 GitLogEntryCommit -> Just Commit
+                 GitLogEntryTree   -> Just Tree
+                 GitLogEntryBlob   -> Just Blob
+                 _                 -> Nothing
+
+
+      let r = (,,) <$> tp
+                   <*> view gitLogEntryHash entry
+                   <*> mlbs
+
+      maybe1 r none $ \(t, eh, lbs) -> do
+        let fname = logPath </> show (pretty eh)
+        let pref = fromString (show (pretty t) <> " " <> show (LBS.length lbs) <> "\0")
+        -- debug $ "writing object" <+> pretty eh <+> pretty (LBS.unpack $ LBS.takeWhile (/= '\0') pref)
+        let co = compress (pref <> lbs)
+        liftIO $ LBS.writeFile fname co
+
+retryFor :: RealFrac r => Int -> r -> Timeout 'Seconds  -> IO a -> IO (Maybe a)
+retryFor num waity sleep action = timeout (ceiling $ waity * 1000000) $ go num
+  where
+    go 0 = action
+    go n = ( (Just <$> action) `catch` handler ) >>= maybe (go (n-1)) pure
+    handler (_ :: SomeException) = pause @'Seconds sleep >> pure Nothing
+
+dumbHttpServe :: MonadUnliftIO m => Port -> m ()
+dumbHttpServe pnum = do
+
+  locks <- liftIO $ newMVar (HashMap.empty @HashRef @(MVar ()))
+
+  catApi <- liftIO (retryFor 100 30 0.5 detectHBS2PeerCatAPI) `orDie` [qc|Can't locate hbs2-peer API|]
+
+  notice $ "hbs2-peer API:" <+> pretty catApi
+
+  -- TODO: lru-like-cache-for-unpacked-logs
+  --  Деражть кэш, обновлять в нём таймстемпы
+  --  доступа к логам.
+  --  как только запись протухла - сносить каталог
+  --  с логом, тогда в следующий раз будет обратно
+  --  распакован
+
+  updater <- async $ forever do
+    pause @'Seconds 300
+    pure ()
+
+  runResourceT do
+
+    let myTempDir = "hbs-git-http"
+    temp <- liftIO getCanonicalTemporaryDirectory
+
+    (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
+
+
+    liftIO $ scotty pnum $ do
+
+      middleware logStdoutDev
+
+      get "/:repo/info/refs" $ do
+        repo <- param @RepoRef "repo"
+        res <- liftIO do
+          db <- makeDbPath repo >>= dbEnvReadOnly
+          refs <- withDB db stateGetActualRefs
+          let answ = Text.unlines $ Text.pack <$> [ show (pretty h) <> "\t" <> show (pretty r) | (r,h) <- refs  ]
+          shutdownDB db
+          pure answ
+
+        text res
+
+      -- | REPO OBJECT REF
+      get (regex "^/(.+)/(refs/.+)$") $ do
+        repo <-  fromString <$> param "1"   -- reflog
+        ref  <- param "2"  -- refname
+        val <- liftIO do
+          db <- makeDbPath repo >>= dbEnvReadOnly
+          debug $ "QUERY: " <+> pretty ref
+          val <- withDB db $ stateGetActualRefValue ref
+          shutdownDB db
+          pure val
+
+        maybe1 val (status status404) $ \x -> do
+          text $ Text.pack $ show $ pretty x
+
+      get "/:repo/objects/:dd/:rest" $ do
+        repo <- param @RepoRef "repo"
+        dd   <- param @String "dd"
+        rest <- param @String "rest"
+        let ha = fromString ( dd <> rest )
+
+        res <- runMaybeT do
+                 db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
+                 lo <- MaybeT $ liftIO $ withDB db $ stateGetGitLogObject ha
+                 shutdownDB db
+
+                 let logDir = dir </> show (pretty lo)
+                 let fname = logDir </> show (pretty ha)
+
+                 here <- liftIO $ doesFileExist fname
+
+                 if here then do
+                   pure fname
+                 else do
+                    lock <- liftIO $ getLock locks lo
+                    MaybeT $ liftIO $ withMVar lock $ \_ -> do
+                      unpackObjects catApi lo dir
+                      here1 <- liftIO $ doesFileExist fname
+                      if here1 then do
+                        pure (Just fname)
+                      else do
+                        pure Nothing
+
+        maybe1 res (status status404) $ \r -> do
+          addHeader "content-type" "application/octet-stream"
+          file r
+
+      get "/:topic/HEAD" $ do
+        repo <- fromString <$> param "topic"
+        headRef <- liftIO $ do
+          db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
+          re <- withDB db stateGetActualRefs <&> headMay . sortOn guessHead . fmap (view _1)
+          shutdownDB db
+          pure re
+
+        case headRef of
+          Nothing -> status status404
+          Just hd -> do
+            text [qc|ref: {show $ pretty $ hd}|]
+
+  cancel updater
+
+  where
+    getLock locks k = modifyMVar locks $ \m -> do
+        case HashMap.lookup k m of
+            Just lock -> return (m, lock)
+            Nothing -> do
+                lock <- newMVar ()
+                pure (HashMap.insert k lock m, lock)
+
+
+
+  -- TODO: hbs2-peer-http-api-reflog-fetch
+  --  Ручка, что бы сделать reflog fetch
+
+  -- TODO: hbs2-peer-dyn-reflog-subscribe
+  --   Возможность динамически подписываться на рефлоги
+
+  -- TODO: hbs2-peer-hook-on-reflog-update
+  --  нужен хук, который даст возможность обрабатывать апдейты
+  --  по нужному рефлогу. нужно много где
+
+
+main :: IO ()
+main = do
+
+  setLogging @DEBUG  debugPrefix
+  setLogging @INFO   defLog
+  setLogging @ERROR  errorPrefix
+  setLogging @WARN   warnPrefix
+  setLogging @NOTICE noticePrefix
+  setLoggingOff @TRACE
+
+  -- TODO: hbs2-git-own-config
+
+  -- FIXME: port-number-to-config
+  dumbHttpServe 4017
+
+
+

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -72,11 +72,6 @@ capabilities :: BS.ByteString
 capabilities = BS.unlines ["push","fetch"]
 
 
-guessHead :: GitRef -> Integer
-guessHead = \case
-  "refs/heads/master" -> 0
-  "refs/heads/main"   -> 0
-  _                   -> 1
 
 loop :: forall m . ( MonadIO m
                    , MonadCatch m

hbs2-git/git-hbs2/RunShow.hs

@@ -8,12 +8,13 @@ import HBS2Git.State
 import HBS2Git.Config
 import HBS2Git.ListRefs
 
+import Control.Monad.Catch (MonadMask)
 import Data.Foldable
 import Prettyprinter.Render.Terminal
 
 data ShowObject = ShowRef RepoRef | ShowConfig
 
-showRef :: MonadIO m => RepoRef -> App m ()
+showRef :: (MonadIO m, MonadMask m) => RepoRef -> App m ()
 showRef h = do
   db <- makeDbPath h >>= dbEnv
   -- FIXME: re-implement-showRef
@@ -27,25 +28,25 @@ showRef h = do
   --     print $ pretty "last operations:"
   --     for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2)
 
-showRefs :: MonadIO m => App m ()
+showRefs :: (MonadIO m, MonadMask m) => App m ()
 showRefs = do
   liftIO $ putDoc $ line <> green "References:" <> section
   runListRefs
 
-showConfig :: MonadIO m => App m ()
+showConfig :: (MonadIO m, MonadMask m) => App m ()
 showConfig = liftIO do
   ConfigPathInfo{..} <- getConfigPathInfo
   cfg <- readFile configFilePath
   putDoc $ green "Config file location:" <> section <> pretty configFilePath <> section
   putDoc $ green "Config contents:" <> line <> pretty cfg
 
-showSummary :: MonadIO m => App m ()
+showSummary :: (MonadIO m, MonadMask m) => App m ()
 showSummary = do
   showRefs
   liftIO $ putDoc section
   showConfig
 
-runShow :: MonadIO m => Maybe ShowObject -> App m ()
+runShow :: (MonadIO m, MonadMask m) => Maybe ShowObject -> App m ()
 runShow (Just (ShowRef h)) = showRef h
 runShow (Just ShowConfig) = showConfig
 runShow Nothing = showSummary

hbs2-git/hbs2-git.cabal

@@ -173,3 +173,28 @@ executable git-remote-hbs2
     hs-source-dirs:   git-hbs2
     default-language: Haskell2010
 
+executable git-hbs2-http
+    import:           shared-properties
+    main-is:          GitHttpDumbMain.hs
+
+    ghc-options:
+        -threaded
+        -rtsopts
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+    other-modules:
+
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git
+      , http-types
+      , optparse-applicative
+      , scotty
+      , wai-extra
+      , warp
+      , zlib
+
+    hs-source-dirs:   git-hbs2-http
+    default-language: Haskell2010
+
+

hbs2-git/lib/HBS2/Git/Types.hs

@@ -116,6 +116,11 @@ normalizeRef (GitRef x) = GitRef "refs/heads/" <> GitRef (fromMaybe x (Text.stri
   where
     strip = Text.dropWhile (=='+')
 
+guessHead :: GitRef -> Integer
+guessHead = \case
+  "refs/heads/master" -> 0
+  "refs/heads/main"   -> 0
+  _                   -> 1
 
 shutUp :: MonadIO m => m ()
 shutUp = do

hbs2-git/lib/HBS2Git/App.hs

@@ -241,7 +241,11 @@ writeBlockIO api bs = do
 readBlock :: forall m . (HasCatAPI m, MonadIO m) => HashRef -> m (Maybe ByteString)
 readBlock h = do
   req1 <-  getHttpCatAPI
-  let reqs = req1 <> "/" <> show (pretty h)
+  readBlockFrom req1 h
+
+readBlockFrom :: forall m . (MonadIO m) => API -> HashRef -> m (Maybe ByteString)
+readBlockFrom api h = do
+  let reqs = api <> "/" <> show (pretty h)
   req  <- liftIO $ parseRequest reqs
   resp <- httpLBS req
 

hbs2-git/lib/HBS2Git/Export.hs

@@ -68,15 +68,15 @@ makeLenses 'ExportEnv
 
 
 exportRefDeleted :: forall  o m . ( MonadIO m
-                               , MonadCatch m
+                                  , MonadCatch m
-                               -- , MonadMask m
+                                  , MonadMask m
-                               , MonadUnliftIO m
+                                  , MonadUnliftIO m
-                               , HasCatAPI m
+                                  , HasCatAPI m
-                               , HasConf m
+                                  , HasConf m
-                               , HasRefCredentials m
+                                  , HasRefCredentials m
-                               , HasProgress m
+                                  , HasProgress m
-                               , ExportRepoOps o
+                                  , ExportRepoOps o
-                               )
+                                  )
               => o
               -> RepoRef
               -> GitRef

hbs2-git/lib/HBS2Git/Import.hs

@@ -72,14 +72,87 @@ blockSource h = do
 
   liftIO $ readTVarIO tsize <&> fromIntegral
 
+getLogFlags :: MonadIO m
+            => (HashRef -> m (Maybe LBS.ByteString))
+            -> HashRef
+            -> m (Maybe [Text])
+
+getLogFlags doRead h = do
+
+  runMaybeT do
+
+    treeBs   <- MaybeT $ doRead h
+
+    let something =  tryDetect (fromHashRef h) treeBs
+    let meta = mconcat $ rights [ parseTop (Text.unpack s) | ShortMetadata s <- universeBi something ]
+
+    -- TODO: check-if-it-is-hbs2-git-log
+    let tp = lastMay [ "hbs2-git-push-log"
+                     | (ListVal (Key "type:" [SymbolVal "hbs2-git-push-log"]) ) <- meta
+                     ]
+
+    guard ( tp == Just "hbs2-git-push-log" )
+
+    pure $ mconcat [ Text.splitOn ":" (Text.pack (show $ pretty s))
+                   | (ListVal (Key "flags:" [SymbolVal s]) ) <- meta
+                   ]
+
+class HasImportOpts a where
+  importForce :: a -> Bool
+  importDontWriteGit :: a -> Bool
+
+instance HasImportOpts Bool where
+  importForce f = f
+  importDontWriteGit = const False
+
+instance HasImportOpts (Bool, Bool) where
+  importForce = fst
+  importDontWriteGit = snd
+
+-- FIXME: ASAP-will-work-only-for-one-repo
+--  сейчас все транзакции помечаются, как обработанные
+--  в глобальном стейте для ссылки. таким образом,
+--  если мы вызвали для одного репозитория,
+--  то import не будет работать для остальных, т.к. решит,
+--  что всё обработано.
+--
+--  Решение:
+--    Вариант N1. Держать стейт локально в каждом
+--    каталоге git.
+--    Минусы:
+--      - большой оверхед по данным
+--      - мусор в каталоге git
+--      - например, git-hbs2-http вообще работает без "репозитория",
+--        как ему быть
+--
+--    Вариант N2. сделать развязку через какой-то ID
+--    репозитория или путь к нему.
+--    Минусы:
+--      - выглядит хрупко
+--      - например, git-hbs2-http вообще работает без "репозитория",
+--        как ему быть
+--
+--    Вариант N3. БД обновлять отдельно, объекты git - отдельно
+--    для каждого репозитория, запоминать (где?) проигранные для
+--    него логи.
+--    Минусы:
+--      - двойное сканирование файлов логов - получение, распаковка,
+--        сканирование и т.п. сначала для БД, потом для непосредственно
+--        репозитория
+--
 importRefLogNew :: ( MonadIO m
                    , MonadUnliftIO m
                    , MonadCatch m
+                   , MonadMask m
                    , HasCatAPI m
+                   , HasImportOpts opts
                    )
-                => Bool -> RepoRef -> m ()
+                => opts -> RepoRef -> m ()
+
+importRefLogNew opts ref = runResourceT do
+
+  let force = importForce opts
 
-importRefLogNew force ref = runResourceT do
   let myTempDir = "hbs-git"
   temp <- liftIO getCanonicalTemporaryDirectory
   (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
@@ -232,8 +305,10 @@ importRefLogNew force ref = runResourceT do
 
                   _ -> pure ()
 
-                statePutLogImported h
+                -- otherwise we wan't process those logs next time.
-                statePutTranImported e
+                unless (importDontWriteGit opts) do
+                  statePutLogImported h
+                  statePutTranImported e
 
       mapM_ hClose handles
 
@@ -242,13 +317,13 @@ importRefLogNew force ref = runResourceT do
         statePutRefImported logRoot
         savepointRelease sp0
 
-
   where
 
     writeIfNew gitHandle dir h (GitObject tp s) = do
-      let nf = dir </> show (pretty h)
+      unless (importDontWriteGit opts) do
-      liftIO $ LBS.writeFile nf s
+        let nf = dir </> show (pretty h)
-      hPutStrLn gitHandle nf
+        liftIO $ LBS.writeFile nf s
-      hFlush gitHandle
+        hPutStrLn gitHandle nf
-      trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf
+        hFlush gitHandle
+        trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf
 

hbs2-git/lib/HBS2Git/ListRefs.hs

@@ -73,14 +73,14 @@ runListRefs = do
   where
     isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b
 
-runToolsScan :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m ()
+runToolsScan :: (MonadUnliftIO m,MonadCatch m,MonadMask m) => RepoRef -> App m ()
 runToolsScan ref = do
   trace $ "runToolsScan" <+> pretty ref
   importRefLogNew False ref
   shutUp
   pure ()
 
-runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m ()
+runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m,MonadMask m) => RepoRef -> App m ()
 runToolsGetRefs ref = do
   db <- makeDbPath ref >>= dbEnv
   refs <- withDB db stateGetActualRefs

hbs2-git/lib/HBS2Git/State.hs

@@ -1,5 +1,6 @@
 module HBS2Git.State where
 
+import HBS2.Prelude
 import HBS2Git.Types
 import HBS2.Data.Types.Refs
 import HBS2.Git.Types
@@ -7,6 +8,7 @@ import HBS2.Hash
 
 import HBS2.System.Logger.Simple
 
+import Control.Monad.Trans.Resource
 import Data.Functor
 import Data.Function
 import Database.SQLite.Simple
@@ -27,6 +29,7 @@ import Control.Concurrent.STM
 import System.IO.Unsafe
 import Data.Graph (graphFromEdges, topSort)
 import Data.Map qualified as Map
+import Lens.Micro.Platform
 
 -- FIXME: move-orphans-to-separate-module
 
@@ -61,7 +64,7 @@ newtype DB m a =
                    , Functor
                    , Monad
                    , MonadIO
-                   , MonadReader Connection
+                   , MonadReader DBEnv
                    , MonadTrans
                    , MonadThrow
                    , MonadCatch
@@ -71,32 +74,54 @@ instance (HasRefCredentials m) => HasRefCredentials (DB m) where
   getCredentials = lift . getCredentials
   setCredentials r s  = lift (setCredentials r s)
 
-dbConnTV :: TVar (Maybe DBEnv)
+stateConnection :: MonadIO m => DB m Connection
-dbConnTV = unsafePerformIO $ newTVarIO Nothing
+stateConnection = do
-{-# NOINLINE dbConnTV #-}
+  env <- ask
+  initConnection env
 
-dbEnv :: MonadIO m => FilePath -> m DBEnv
+initConnection :: MonadIO m => DBEnv -> m Connection
-dbEnv fp = do
+initConnection env = do
+  mco <- liftIO $ readTVarIO (view dbConn env)
+  case mco of
+    Just co -> pure co
+    Nothing -> do
+      co <- liftIO $ open (view dbFilePath env)
+      liftIO $ atomically $ writeTVar (view dbConn env) (Just co)
+      pure co
+
+dbEnv0 :: (MonadIO m, MonadMask m) => DB m () -> FilePath -> m DBEnv
+dbEnv0 dbInit fp = do
   trace  "dbEnv called"
   let dir = takeDirectory fp
   liftIO $ createDirectoryIfMissing True dir
-  mbDb <- liftIO $ readTVarIO dbConnTV
+  env <- DBEnv fp <$> liftIO (newTVarIO Nothing)
+  void $ withDB env dbInit
+  pure env
 
-  case mbDb of
+dbEnv :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
-    Nothing -> do
+dbEnv = dbEnv0 stateInit
-      co <- liftIO $ open fp
-      liftIO $ atomically $ writeTVar dbConnTV (Just co)
-      withDB co stateInit
-      pure co
 
-    Just db -> pure db
+dbEnvReadOnly :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
+dbEnvReadOnly = dbEnv0 none
 
-withDB :: DBEnv -> DB m a -> m a
+withDB :: (MonadIO m, MonadMask m) => DBEnv -> DB m a -> m a
-withDB env action = runReaderT (fromDB action) env
+withDB env action = do
+  conn <- initConnection env
+  finally (runReaderT (fromDB action) env) $ do
+    -- NOTE: we could not close connection here.
+    pure ()
+
+shutdownDB :: MonadIO m => DBEnv -> m ()
+shutdownDB env = liftIO do
+  co <- atomically do
+    conn <- readTVar (view dbConn env)
+    writeTVar (view dbConn env) Nothing
+    pure conn
+  maybe1 co none close
 
 stateInit :: MonadIO m => DB m ()
 stateInit = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute_ conn [qc|
   create table if not exists logrefval
   ( loghash text not null
@@ -203,17 +228,17 @@ savepointNew  = do
 
 savepointBegin :: forall m . MonadIO m => Savepoint -> DB m ()
 savepointBegin (Savepoint sp) = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute_ conn [qc|SAVEPOINT {sp}|]
 
 savepointRelease:: forall m . MonadIO m => Savepoint -> DB m ()
 savepointRelease (Savepoint sp) = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute_ conn [qc|RELEASE SAVEPOINT {sp}|]
 
 savepointRollback :: forall m . MonadIO m => Savepoint -> DB m ()
 savepointRollback (Savepoint sp) = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
 
 transactional :: forall a m . (MonadCatch m, MonadIO m) => DB m a -> DB m a
@@ -242,7 +267,7 @@ transactional action = do
 
 statePutLogRefVal :: MonadIO m => (HashRef, GitRef, GitHash) -> DB m ()
 statePutLogRefVal row = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into logrefval (loghash,refname,refval) values(?,?,?)
   on conflict (loghash,refname) do nothing
@@ -251,7 +276,7 @@ statePutLogRefVal row = do
 
 statePutLogObject :: MonadIO m => (HashRef, GitObjectType, GitHash) -> DB m ()
 statePutLogObject row = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into logobject (loghash,type,githash) values(?,?,?)
   on conflict (loghash,githash) do nothing
@@ -259,14 +284,24 @@ statePutLogObject row = do
 
 stateIsLogObjectExists :: MonadIO m => GitHash -> DB m Bool
 stateIsLogObjectExists h = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ query conn [qc|
   SELECT NULL FROM logobject WHERE githash = ? LIMIT 1
   |] (Only h) <&> isJust . listToMaybe . fmap (fromOnly @(Maybe Int))
 
+
+stateGetGitLogObject :: MonadIO m => GitHash -> DB m (Maybe HashRef)
+stateGetGitLogObject h = do
+  conn <- stateConnection
+  liftIO $ query conn [qc|
+  SELECT loghash FROM logobject
+  WHERE githash = ? and type in ('commit', 'tree', 'blob')
+  LIMIT 1
+  |] (Only h) <&> listToMaybe . fmap fromOnly
+
 statePutLogContextCommit :: MonadIO m => HashRef -> GitHash -> DB m ()
 statePutLogContextCommit loghash ctx = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into logobject (loghash,type,githash) values(?,'context',?)
   on conflict (loghash,githash) do nothing
@@ -274,7 +309,7 @@ statePutLogContextCommit loghash ctx = do
 
 statePutLogCommitParent :: MonadIO m => (GitHash, GitHash) -> DB m ()
 statePutLogCommitParent row = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into logcommitparent (kommit,parent) values(?,?)
   on conflict (kommit,parent) do nothing
@@ -283,7 +318,7 @@ statePutLogCommitParent row = do
 
 statePutLogImported :: MonadIO m => HashRef -> DB m ()
 statePutLogImported h = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into logimported (hash) values(?)
   on conflict (hash) do nothing
@@ -292,7 +327,7 @@ statePutLogImported h = do
 
 stateGetLogImported :: MonadIO m => HashRef -> DB m Bool
 stateGetLogImported h = do
-  conn <- ask
+  conn <- stateConnection
   r <- liftIO $ query @_ @(Only Int) conn [qc|
     select 1 from logimported where hash = ? limit 1
   |] (Only h)
@@ -301,7 +336,7 @@ stateGetLogImported h = do
 
 statePutRefImported :: MonadIO m => HashRef -> DB m ()
 statePutRefImported h = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into refimported (hash) values(?)
   on conflict (hash) do nothing
@@ -309,7 +344,7 @@ statePutRefImported h = do
 
 stateGetRefImported :: MonadIO m => HashRef -> DB m Bool
 stateGetRefImported h = do
-  conn <- ask
+  conn <- stateConnection
   r <- liftIO $ query @_ @(Only Int) conn [qc|
     select 1 from refimported where hash = ? limit 1
   |] (Only h)
@@ -317,7 +352,7 @@ stateGetRefImported h = do
 
 statePutTranImported :: MonadIO m => HashRef -> DB m ()
 statePutTranImported h = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ execute conn [qc|
   insert into tranimported (hash) values(?)
   on conflict (hash) do nothing
@@ -325,7 +360,7 @@ statePutTranImported h = do
 
 stateGetTranImported :: MonadIO m => HashRef -> DB m Bool
 stateGetTranImported h = do
-  conn <- ask
+  conn <- stateConnection
   r <- liftIO $ query @_ @(Only Int) conn [qc|
     select 1 from tranimported where hash = ? limit 1
   |] (Only h)
@@ -333,7 +368,7 @@ stateGetTranImported h = do
 
 stateGetAllTranImported :: MonadIO m => DB m [HashRef]
 stateGetAllTranImported = do
-  conn <- ask
+  conn <- stateConnection
   results <- liftIO $ query_ conn [qc|
     select hash from tranimported
   |]
@@ -341,21 +376,21 @@ stateGetAllTranImported = do
 
 stateGetImportedCommits :: MonadIO m => DB m [GitHash]
 stateGetImportedCommits = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ query_ conn [qc|
     select distinct(githash) from logobject where type = 'commit'
   |] <&> fmap fromOnly
 
 stateGetActualRefs :: MonadIO m => DB m [(GitRef, GitHash)]
 stateGetActualRefs = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ query_ conn [qc|
     select refname,refval from v_refval_actual
   |]
 
 stateGetActualRefValue :: MonadIO m => GitRef -> DB m (Maybe GitHash)
 stateGetActualRefValue ref = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ query conn [qc|
     select refval from v_refval_actual
     where refname = ?
@@ -363,14 +398,14 @@ stateGetActualRefValue ref = do
 
 stateGetLastKnownCommits :: MonadIO m => Int -> DB m [GitHash]
 stateGetLastKnownCommits n  = do
-  conn <- ask
+  conn <- stateConnection
   liftIO $ query conn [qc|
     select kommit from logcommitdepth order by depth asc limit ?;
   |] (Only n) <&> fmap fromOnly
 
 stateUpdateCommitDepths :: MonadIO m => DB m ()
 stateUpdateCommitDepths = do
-  conn <- ask
+  conn <- stateConnection
   sp <- savepointNew
 
   rows <- liftIO $ query_ @(GitHash, GitHash) conn [qc|SELECT kommit, parent FROM logcommitparent|]

hbs2-git/lib/HBS2Git/Types.hs

@@ -53,7 +53,12 @@ type HBS2L4Proto = L4Proto
 -- FIXME: introduce-API-type
 type API = String
 
-type DBEnv = Connection
+data DBEnv =
+  DBEnv { _dbFilePath :: FilePath
+        , _dbConn     :: TVar (Maybe Connection)
+        }
+
+makeLenses 'DBEnv
 
 type RepoRef = RefLogKey Schema