From 0af3056664fb2d1a7b3737372231ea7d199de682 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 3 Jul 2023 09:40:58 +0300 Subject: [PATCH] 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 | 27 +++ hbs2-git/git-hbs2-http/GitHttpDumbMain.hs | 249 ++++++++++++++++++++++ hbs2-git/git-hbs2/GitRemoteMain.hs | 5 - hbs2-git/git-hbs2/RunShow.hs | 11 +- hbs2-git/hbs2-git.cabal | 25 +++ hbs2-git/lib/HBS2/Git/Types.hs | 5 + hbs2-git/lib/HBS2Git/App.hs | 6 +- hbs2-git/lib/HBS2Git/Export.hs | 18 +- hbs2-git/lib/HBS2Git/Import.hs | 95 ++++++++- hbs2-git/lib/HBS2Git/ListRefs.hs | 4 +- hbs2-git/lib/HBS2Git/State.hs | 109 ++++++---- hbs2-git/lib/HBS2Git/Types.hs | 7 +- 12 files changed, 491 insertions(+), 70 deletions(-) create mode 100644 docs/todo/hbs2-git-ux.txt create mode 100644 hbs2-git/git-hbs2-http/GitHttpDumbMain.hs diff --git a/docs/todo/hbs2-git-ux.txt b/docs/todo/hbs2-git-ux.txt new file mode 100644 index 00000000..b89028c5 --- /dev/null +++ b/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. diff --git a/hbs2-git/git-hbs2-http/GitHttpDumbMain.hs b/hbs2-git/git-hbs2-http/GitHttpDumbMain.hs new file mode 100644 index 00000000..53537a2b --- /dev/null +++ b/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 + + + diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 5fb66833..0b024175 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/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 diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs index ef8a553d..f8de184a 100644 --- a/hbs2-git/git-hbs2/RunShow.hs +++ b/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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 9722a39a..0d939561 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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 + + diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs index 7918da37..4deeef81 100644 --- a/hbs2-git/lib/HBS2/Git/Types.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index a5d0563f..05bd7878 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index 2a0b8328..f168d513 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -68,15 +68,15 @@ makeLenses 'ExportEnv exportRefDeleted :: forall o m . ( MonadIO m - , MonadCatch m - -- , MonadMask m - , MonadUnliftIO m - , HasCatAPI m - , HasConf m - , HasRefCredentials m - , HasProgress m - , ExportRepoOps o - ) + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + , HasCatAPI m + , HasConf m + , HasRefCredentials m + , HasProgress m + , ExportRepoOps o + ) => o -> RepoRef -> GitRef diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index 673b4c88..e9b68ab9 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/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 - statePutTranImported e + -- otherwise we wan't process those logs next time. + 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) - liftIO $ LBS.writeFile nf s - hPutStrLn gitHandle nf - hFlush gitHandle - trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf + unless (importDontWriteGit opts) do + let nf = dir show (pretty h) + liftIO $ LBS.writeFile nf s + hPutStrLn gitHandle nf + hFlush gitHandle + trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs index 6a29e268..97c2860f 100644 --- a/hbs2-git/lib/HBS2Git/ListRefs.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index c22fe964..dcfe33d9 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/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) -dbConnTV = unsafePerformIO $ newTVarIO Nothing -{-# NOINLINE dbConnTV #-} +stateConnection :: MonadIO m => DB m Connection +stateConnection = do + env <- ask + initConnection env -dbEnv :: MonadIO m => FilePath -> m DBEnv -dbEnv fp = do +initConnection :: MonadIO m => DBEnv -> m Connection +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 - Nothing -> do - co <- liftIO $ open fp - liftIO $ atomically $ writeTVar dbConnTV (Just co) - withDB co stateInit - pure co +dbEnv :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv +dbEnv = dbEnv0 stateInit - Just db -> pure db +dbEnvReadOnly :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv +dbEnvReadOnly = dbEnv0 none -withDB :: DBEnv -> DB m a -> m a -withDB env action = runReaderT (fromDB action) env +withDB :: (MonadIO m, MonadMask m) => DBEnv -> DB m a -> m a +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|] diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 64e56f96..fd1af37b 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/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