diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 76f44f5d..bef25552 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -783,7 +783,7 @@ export mref' r = connectedDo $ flip runContT pure do packs <- atomically $ STM.flushTQueue out - phashes <- catMaybes <$> withState (for parents selectCBlock) + phashes <- catMaybes <$> withState (for parents (fmap (fmap snd) . selectCBlock)) let v = "hbs2-git 3.0 zstd" let pps = vcat $ mconcat $ for phashes $ \p -> ["p" <+> pretty p] @@ -1256,16 +1256,15 @@ theDict = do sto <- getStorage let whatever cblock = do - co <- listOnlyCommitsFromCBlock sto cblock - e <- mapM gitObjectExists co <&> and - let continue = deep || not e || (only && cblock == cb0) + -- co <- listOnlyCommitsFromCBlock sto cblock + -- e <- mapM gitObjectExists co <&> and + -- let continue = deep || not e || (only && cblock == cb0) - debug $ "WHATEVER" <+> pretty e <+> pretty cblock <+> pretty co + -- debug $ "WHATEVER" <+> pretty e <+> pretty cblock <+> pretty co - unless continue do - debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co - - pure continue + -- unless continue do + -- debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co + pure True flip runContT pure $ callCC \exit -> do diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 2eaed4b8..5155e835 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -71,6 +71,7 @@ common shared-properties , atomic-write , bytestring , binary + , bitvec , containers , directory , exceptions diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index 898f8e85..3538e57c 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -17,6 +17,7 @@ import DBPipe.SQLite import System.Directory import Data.Maybe +import Data.Word import Text.InterpolatedString.Perl6 (qc) @@ -44,9 +45,10 @@ evolveState = do ddl [qc| create table if not exists cblock - ( kommit text not null + ( id integer primary key autoincrement + , kommit text not null , cblock text not null - , primary key (kommit, cblock) + , unique (kommit, cblock) ) |] @@ -74,16 +76,17 @@ insertCBlock co cblk = do insert [qc| insert into cblock (kommit, cblock) values(?,?) on conflict (kommit,cblock) do update set cblock = excluded.cblock + on conflict (id) do update set kommit = excluded.kommit + , cblock = excluded.cblock |] (co, cblk) -selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe HashRef) +selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe (Word32, HashRef)) selectCBlock gh = do - select [qc|select cblock from cblock where kommit = ? limit 1|] (Only gh) - <&> listToMaybe . fmap fromOnly + select [qc|select id, cblock from cblock where kommit = ? limit 1|] (Only gh) + <&> listToMaybe selectCommitsByCBlock :: MonadIO m => HashRef -> DBPipeM m [GitHash] selectCommitsByCBlock cb = do select [qc|select kommit from cblock where cblock = ? limit 1|] (Only cb) <&> fmap fromOnly -