wip37

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
+                -- co <- listOnlyCommitsFromCBlock sto cblock
-                e <- mapM gitObjectExists co <&> and
+                -- e <- mapM gitObjectExists co <&> and
-                let continue = deep || not e || (only  && cblock == cb0)
+                -- 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
+                -- unless continue do
-                  debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co
+                --   debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co
-
+                pure True
-                pure continue
 
           flip runContT pure $ callCC \exit -> do
 

hbs2-git3/hbs2-git3.cabal

@@ -71,6 +71,7 @@ common shared-properties
       , atomic-write
       , bytestring
       , binary
+      , bitvec
       , containers
       , directory
       , exceptions

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)
+  select [qc|select id, cblock from cblock where kommit = ? limit 1|] (Only gh)
-   <&> listToMaybe . fmap fromOnly
+   <&> 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
 
-