From d0ff5b456900163f3b0184f9432ea9d2c331e823 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 20 Apr 2024 14:55:03 +0300 Subject: [PATCH] wip --- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 9 +- .../src/HBS2/Git/DashBoard/State.hs | 123 +++++++++++++++++- 2 files changed, 129 insertions(+), 3 deletions(-) diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 8fbdf234..75c23910 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -224,8 +224,8 @@ runDashboardWeb wo = do get "/repo/:lww/tree/:hash" do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) - hash' <- captureParam @String "hash" <&> fromStringMay @GitHash - back <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<) + hash' <- captureParam @String "hash" <&> fromStringMay @GitHash + back <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<) flip runContT pure do lww <- lwws' & orFall (status status404) @@ -275,6 +275,8 @@ gitShowRefs what = do _ -> Nothing + + runScotty :: DashBoardPerks m => DashBoardM m () runScotty = do pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090 @@ -343,6 +345,9 @@ updateIndexPeriodially = do debug $ red "SYNC" <+> pretty cmd void $ runProcess $ shell cmd + lift $ buildCommitTreeIndex dir + + main :: IO () main = do execParser opts & join diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index df554e2c..d622b123 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -13,15 +13,26 @@ module HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types +import HBS2.Hash + import HBS2.Git.Data.Tx.Git +import HBS2.Git.Local +import HBS2.Git.Local.CLI import DBPipe.SQLite hiding (insert) +import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G + +import Data.ByteString.Lazy.Char8 qualified as LBS8 import Lucid.Base import Data.Text qualified as Text import Data.Word +import Data.Either import Data.List qualified as List +import Data.Map qualified as Map +import Data.Map (Map) +import System.FilePath data RepoListPred = RepoListPred @@ -87,9 +98,15 @@ evolveDB = do ) |] - pure () + createRepoTreeIndexTable +instance ToField GitHash where + toField x = toField $ show $ pretty x + +instance FromField GitHash where + fromField = fmap fromString . fromField @String + instance ToField HashRef where toField x = toField $ show $ pretty x @@ -420,4 +437,108 @@ selectRefLogs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoRefLog selectRefLogs = withState do select_ [qc|select distinct(reflog) from repolistview|] <&> fmap fromOnly +createRepoTreeIndexTable :: (DashBoardPerks m) => DBPipeM m () +createRepoTreeIndexTable = do + ddl [qc| + create table if not exists tree + ( parent text not null + , child text not null + , primary key (parent,child) + ) + |] + + ddl [qc| + create table if not exists committree + ( kommit text not null + , tree text not null + , primary key (kommit,tree) + ) + |] + +isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool +isProcessed href = do + select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href) + <&> not . List.null + +insertProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m () +insertProcessed href = do + S.insert [qc| + insert into processed (hash) + values(?) + on conflict(hash) do nothing + |] (Only href) + +insertCommitTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m () +insertCommitTree commit tree = do + S.insert [qc| + insert into committree (kommit,tree) + values (?,?) + on conflict (kommit,tree) do nothing + |] (commit,tree) + +insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m () +insertTree parent child = do + S.insert [qc| + insert into tree (parent,child) + values (?,?) + on conflict (parent,child) do nothing + |] (parent,child) + +{- HLINT ignore "Functor law" -} + +pattern TreeHash :: GitHash -> LBS8.ByteString +pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _)) + +buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m () +buildCommitTreeIndex dir = do + + commits <- gitRunCommand [qc|git --git-dir {dir} rev-list --all|] + <&> fromRight mempty + <&> mapMaybe (headMay . LBS8.words) . LBS8.lines + <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack) + + -- FIXME: check-names-with-spaces + + withState do + + for_ commits $ \co -> void $ runMaybeT do + let hkey = ("commit-for-tree-index", co) & serialise & hashObject @HbSync & HashRef + + done <- lift $ isProcessed hkey + + guard (not done) + + let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|] + + root <- gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> \case + (TreeHash ha : _) -> Just ha + _ -> Nothing + >>= toMPlus + + lift $ transactional do + insertCommitTree co root + + trees <- gitRunCommand [qc|git --git-dir {dir} ls-tree -r -t {pretty co}|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe \case + [_,"tree",h,n] -> + (reverse $ splitDirectories $ LBS8.unpack n,) <$> fromStringMay @GitHash (LBS8.unpack h) + _ -> Nothing + <&> Map.fromList + + for_ (Map.toList trees) $ \(t,h0) -> do + + let child = tailSafe t + debug $ red "TREE-REL:" <+> pretty t + let parent = Map.lookup child trees + + for_ parent $ \p -> do + debug $ red "FOUND SHIT:" <+> pretty (h0,p) + insertTree p h0 + + insertProcessed hkey