wip39

hbs2-git3/app/Main.hs

@@ -68,6 +68,7 @@ import Text.InterpolatedString.Perl6 (qc)
 import Data.Set qualified as Set
 import Data.Map qualified as Map
 import Data.IntMap qualified as IntMap
+import Data.IntMap (IntMap(..))
 import Data.HashSet qualified as HS
 import Data.HashSet (HashSet(..))
 import Data.HashMap.Strict qualified as HM
@@ -1256,19 +1257,17 @@ theDict = do
           sto <- getStorage
 
           let whatever cblock = do
-                -- co <- listOnlyCommitsFromCBlock sto cblock
+                r <- lift (withState $ selectImported cblock)
-                -- e <- mapM gitObjectExists co <&> and
+                pure (not r)
-                -- let continue = deep || not e || (only  && cblock == cb0)
-
-                -- debug $ "WHATEVER" <+> pretty e <+> pretty cblock <+> pretty co
-
-                -- unless continue do
-                --   debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co
-                pure True
 
           flip runContT pure $ callCC \exit -> do
 
+            ContT $ bracket none $ const do
+              doneSize <- readTVarIO _done <&> HS.size
+              notice $ red "DONE" <+> pretty doneSize
+
             traverseToCBlock sto cb0 whatever  $ \i theCblk hs -> do
+
               debug $ green "process cblock data" <+> pretty i <+> pretty theCblk
 
               _orphans <- newTVarIO ( mempty :: HashSet GitHash )
@@ -1343,6 +1342,7 @@ theDict = do
                   cbs <- atomically $ STM.flushTQueue _cblocks
                   for_ cbs $ \(cbh, commit) -> do
                     insertCBlock commit cbh
+                    insertImported cbh
 
         entry $ bindMatch "test:git:cblock:size:deep" $ nil_ $ \case
           [ HashLike cblock ] -> lift do

hbs2-git3/lib/HBS2/Git3/Config/Local.hs

@@ -12,18 +12,23 @@ import Data.Config.Suckless.Script
 
 import Data.Text.IO qualified as IO
 
+getConfigPath :: MonadIO m => m FilePath
+getConfigPath = do
+
+  let name = ".hbs2-git3"
+
+  findGitDir
+    >>= orThrowUser ".git not found"
+    <&> (</> name) . takeDirectory
+
 readLocalConf :: MonadIO m => m [Syntax C]
 readLocalConf = do
 
-  let name = ".hbs2-git3/config"
+  conf <- getConfigPath <&> (</> "config")
 
-  g <- findGitDir
+  touch conf
-          >>= orThrowUser ".git not found"
-          <&> (</> name) . takeDirectory
 
-  touch g
+  liftIO (IO.readFile conf)
-
-  liftIO (IO.readFile g)
     <&> parseTop
     >>= either (error.show) pure
 

hbs2-git3/lib/HBS2/Git3/State/Direct.hs

@@ -9,15 +9,19 @@ import HBS2.OrDie
 import HBS2.Data.Types.Refs
 import HBS2.System.Dir
 
+import HBS2.Git3.Config.Local
 import HBS2.Git.Local
+import HBS2.Git.Local.CLI (findGitDir)
 
 import HBS2.Git3.State.Types
 
-import DBPipe.SQLite
+import DBPipe.SQLite as SQL
 
 import System.Directory
+import Control.Monad.Trans.Maybe
 import Data.Maybe
 import Data.Word
+import Data.List qualified as List
 
 import Text.InterpolatedString.Perl6 (qc)
 
@@ -26,14 +30,12 @@ unit = "hbs2-git"
 
 getStatePath :: (MonadIO m, DBRef db) => db -> m FilePath
 getStatePath p = do
-  dir <- liftIO $ getXdgDirectory XdgState unit
+  d <- getConfigPath
-  pure $ dir </> show (pretty p)
+  pure $ d </> show (pretty p)
-
 
 getStatePathDB :: (MonadIO m, DBRef db) => db -> m FilePath
 getStatePathDB p = do
-  getStatePath p <&> (</> "state.db")
+  getStatePath p <&> (</> "state" </> "state.db")
-
 
 withState :: (MonadIO m, HasStateDB m) => DBPipeM m a -> m a
 withState action = getStateDB >>= flip withDB action
@@ -46,12 +48,23 @@ evolveState = do
 create table if not exists
 cblock
   ( id      integer primary key autoincrement
-  , kommit  text not null
   , cblock  text not null
-  , unique  (kommit, cblock)
+  , unique  (cblock)
   )
 |]
 
+    ddl [qc|
+create table if not exists
+kommit
+  ( kommit  text primary key
+  , cblock  integer not null
+  )
+|]
+
+    ddl [qc|
+create table if not exists
+imported ( cblock integer primary key )
+|]
 
 instance ToField GitHash where
   toField h = toField (show $ pretty h)
@@ -71,22 +84,65 @@ instance ToField HashRef where
 instance FromField HashRef where
   fromField = fmap (fromString @HashRef) . fromField @String
 
-insertCBlock :: MonadIO m => GitHash -> HashRef -> DBPipeM m ()
+data DatabaseError =
+  SomeDatabaseError
+  deriving stock (Typeable,Show)
+
+instance Exception DatabaseError
+
+insertImported :: MonadUnliftIO m => HashRef -> DBPipeM m ()
+insertImported cblock = void $ runMaybeT do
+  (n,_) <- lift (selectCBlockByHash cblock) >>= toMPlus
+  lift do
+    insert [qc| insert into imported (cblock) values(?)
+                on conflict (cblock) do nothing
+              |] (Only n)
+
+selectImported :: MonadUnliftIO m => HashRef -> DBPipeM m Bool
+selectImported cblock = do
+  select @(Only Bool)
+      [qc| select true from imported i join cblock c on c.id = i.cblock
+           where c.cblock = ?
+           limit 1
+         |] (Only cblock)
+  <&> not . List.null
+
+insertCBlock :: MonadUnliftIO m => GitHash -> HashRef -> DBPipeM m ()
 insertCBlock co cblk = do
-  insert [qc|
+  transactional do
-    insert into cblock (kommit, cblock) values(?,?)
+    n <- select @(Only Word32) [qc|
-    on conflict (kommit,cblock) do update set cblock = excluded.cblock
+      insert into cblock (cblock) values(?)
-    on conflict (id) do update set kommit = excluded.kommit
+      on conflict (cblock) do update set cblock = excluded.cblock
-                                 , cblock = excluded.cblock
+      returning id |]
-         |] (co, cblk)
+            (Only cblk)
+            <&> listToMaybe . fmap fromOnly
+            >>= orThrow SomeDatabaseError
+
+    insert [qc| insert into kommit (kommit,cblock) values(?,?)
+                on conflict (kommit) do update set cblock = excluded.cblock
+           |] (co,n)
+
+selectCBlockByHash :: MonadIO m => HashRef -> DBPipeM m (Maybe (Word32, HashRef))
+selectCBlockByHash cblock = do
+  select [qc| select c.id, c.cblock
+              from cblock c
+              where c.cblock = ? limit 1|] (Only cblock)
+   <&> listToMaybe
 
 selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe (Word32, HashRef))
 selectCBlock gh = do
-  select [qc|select id, cblock from cblock where kommit = ? limit 1|] (Only gh)
+  select [qc| select c.id, c.cblock
+              from kommit k join cblock c on k.cblock = c.id
+              where kommit = ? limit 1|] (Only gh)
    <&> listToMaybe
 
-selectCommitsByCBlock :: MonadIO m => HashRef -> DBPipeM m [GitHash]
+-- selectCBlockId :: MonadIO m => HashRef -> DBPipeM m (Maybe Word32)
-selectCommitsByCBlock cb = do
+-- selectCBlockId hh = do
-  select [qc|select kommit from cblock where cblock = ? limit 1|] (Only cb)
+--   select [qc|select id from cblock where cblock = ? limit 1|] (Only hh)
-   <&> fmap fromOnly
+--    <&> 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