diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index bef25552..61a6f250 100644 --- a/hbs2-git3/app/Main.hs +++ b/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 - -- e <- mapM gitObjectExists co <&> and - -- 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 + r <- lift (withState $ selectImported cblock) + pure (not r) 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 diff --git a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs index 539485fa..093fd0e7 100644 --- a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs +++ b/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 - >>= orThrowUser ".git not found" - <&> ( name) . takeDirectory + touch conf - touch g - - liftIO (IO.readFile g) + liftIO (IO.readFile conf) <&> parseTop >>= either (error.show) pure diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index 3538e57c..43c73f27 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/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 - pure $ dir show (pretty p) - + d <- getConfigPath + 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| - 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) + transactional do + n <- select @(Only Word32) [qc| + insert into cblock (cblock) values(?) + on conflict (cblock) do update set cblock = excluded.cblock + returning id |] + (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] -selectCommitsByCBlock cb = do - select [qc|select kommit from cblock where cblock = ? limit 1|] (Only cb) - <&> fmap fromOnly +-- selectCBlockId :: MonadIO m => HashRef -> DBPipeM m (Maybe Word32) +-- selectCBlockId hh = do +-- select [qc|select id from cblock where cblock = ? limit 1|] (Only hh) +-- <&> 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