From 5dc82c5a810ef0e722cf400614a7dbd33b6ee387 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 15 Jan 2025 11:55:31 +0300 Subject: [PATCH] wip, removing obsolete stuff, mkdir for state --- hbs2-git3/app/Main.hs | 108 +----------------- hbs2-git3/hbs2-git3.cabal | 1 - hbs2-git3/lib/HBS2/Git3/Prelude.hs | 4 + hbs2-git3/lib/HBS2/Git3/State/Direct.hs | 141 ------------------------ hbs2-git3/lib/HBS2/Git3/State/Index.hs | 26 ++++- 5 files changed, 28 insertions(+), 252 deletions(-) delete mode 100644 hbs2-git3/lib/HBS2/Git3/State/Direct.hs diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index abcc8872..0fc17009 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -30,14 +30,12 @@ import HBS2.CLI.Run.RefLog (getCredentialsForReflog,mkRefLogUpdateFrom) import HBS2.System.Dir import HBS2.Git3.Types -import HBS2.Git3.State.Direct import HBS2.Git3.Config.Local import HBS2.Git3.Git import HBS2.Git3.Export import Data.Config.Suckless.Script import Data.Config.Suckless.Script.File -import DBPipe.SQLite import Codec.Compression.Zstd.Streaming qualified as ZstdS import Codec.Compression.Zstd.Streaming (Result(..)) @@ -142,6 +140,10 @@ recover m = fix \again -> do ref <- getGitRemoteKey >>= orThrowUser "remote ref not set" + state <- getStatePath (AsBase58 ref) + + mkdir state + let sto = AnyStorage (StorageClient storageAPI) connected <- Git3Connected soname sto peerAPI refLogAPI @@ -582,46 +584,6 @@ theDict = do _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "test:git:log:index:entry" $ nil_ $ \case - [LitIntVal i, StringLike fn] -> lift do - - bs <- liftIO $ mmapFileByteString fn Nothing - let index = fromIntegral i - let offset = index * 24 - - let record = BS.take 24 (BS.drop offset bs) - let n = BS.take 4 record & N.word32 - let key = BS.take 20 $ BS.drop 4 record - liftIO $ print $ pretty n <+> pretty (GitHash key) - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "test:git:log:index:flat" $ nil_ $ \syn -> lift do - let (_, argz) = splitOpts [] syn - let fnames = [ x | StringLike x <- argz] - - s <- randomIO @Word16 - liftIO $ withBinaryFile (show ("index" <> pretty s <> ".idx")) AppendMode $ \fh -> do - - all <- S.toList_ do - - for_ fnames $ \f -> do - theLog <- liftIO $ LBS.readFile f - - void $ runConsumeLBS (ZstdL.decompress theLog) $ readLogFileLBS () $ \h s lbs -> do - lift $ S.yield (coerce @_ @BS.ByteString h) - debug $ "object" <+> pretty h - - let sorted = Set.toList $ Set.fromList all - - for_ sorted $ \ghs -> do - let ks = BS.length ghs - let entrySize = N.bytestring32 (fromIntegral ks) - BS.hPutStr fh entrySize - BS.hPutStr fh ghs - - entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do sto <- getStorage let (_, argz) = splitOpts [] syn @@ -838,68 +800,6 @@ theDict = do _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "test:git:reflog:index:sqlite" $ nil_ $ \syn -> lift $ connectedDo do - - reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" - - api <- getClientAPI @RefLogAPI @UNIX - - sto <- getStorage - - flip runContT pure do - - what' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) api reflog - >>= orThrowUser "rpc timeout" - - what <- ContT $ maybe1 what' none - - idxPath <- getStatePath (AsBase58 reflog) <&> ( "index") - mkdir idxPath - - debug $ "STATE" <+> pretty idxPath - - sink <- S.toList_ do - walkMerkle (coerce what) (getBlock sto) $ \case - Left{} -> throwIO MissedBlockError - Right (hs :: [HashRef]) -> do - for_ hs $ \h -> void $ runMaybeT do - - tx <- getBlock sto (coerce h) - >>= toMPlus - - RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx - & toMPlus - - AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData) - & toMPlus - - -- FIXME: error logging - lbs <- liftIO (runExceptT (getTreeContents sto href)) - >>= orThrow MissedBlockError - - pieces <- S.toList_ do - void $ runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \o s _ -> do - lift $ S.yield o - - lift $ S.yield (h, pieces) - - file <- liftIO $ Temp.emptyTempFile "" "index.db" - - db <- newDBPipeEnv dbPipeOptsDef file - - liftIO $ withDB db do - - ddl [qc|create table object (sha1 text not null primary key, tx text not null)|] - - for_ sink $ \(h, pieces) -> do - transactional do - for_ pieces $ \p -> do - void $ insert [qc|insert into - object (sha1,tx) - values(?,?) - on conflict (sha1) - do update set tx = excluded.tx|] (p,h) - entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift do size <- getIndexBlockSize compactIndex size diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 3812bc93..b42dd5cb 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -125,7 +125,6 @@ library HBS2.Git3.Prelude HBS2.Git3.Export HBS2.Git3.State.Types - HBS2.Git3.State.Direct HBS2.Git3.State.Index HBS2.Git3.Config.Local HBS2.Git3.Git diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs index 6189afaf..7db9ca6c 100644 --- a/hbs2-git3/lib/HBS2/Git3/Prelude.hs +++ b/hbs2-git3/lib/HBS2/Git3/Prelude.hs @@ -2,6 +2,7 @@ {-# Language RecordWildCards #-} {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} +{-# Language PatternSynonyms #-} module HBS2.Git3.Prelude ( module HBS2.Git3.Prelude , module Exported @@ -9,6 +10,7 @@ module HBS2.Git3.Prelude , module HBS2.Peer.RPC.Client.Unix , module Codec.Serialise , runExceptT + , pattern SignPubKeyLike ) where import HBS2.Prelude.Plated as Exported @@ -17,6 +19,7 @@ import HBS2.Data.Types.Refs as Exported import HBS2.Base58 as Exported import HBS2.Merkle as Exported import HBS2.Misc.PrettyStuff as Exported +import HBS2.Net.Auth.Credentials import HBS2.Peer.Proto.RefLog as Exported import HBS2.Peer.RPC.API.RefLog as Exported import HBS2.Peer.RPC.API.Peer as Exported @@ -27,6 +30,7 @@ import HBS2.Storage.Operations.Class as Exported import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.Git3.Types as Exported +import HBS2.Git3.State.Types as Exported -- TODO: about-to-remove import DBPipe.SQLite diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs deleted file mode 100644 index 46b6e570..00000000 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module HBS2.Git3.State.Direct - ( module HBS2.Git3.State.Direct - , module HBS2.Git3.State.Types - ) where - -import HBS2.Prelude.Plated -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 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) - - -getStatePathDB :: (MonadIO m, DBRef db) => db -> m FilePath -getStatePathDB p = do - getStatePath p <&> ( "state" "state.db") - -withState :: (MonadIO m, HasStateDB m) => DBPipeM m a -> m a -withState action = getStateDB >>= flip withDB action - -evolveState :: (MonadIO m, HasStateDB m) => m () -evolveState = do - withState do - - ddl [qc| -create table if not exists -cblock - ( id integer primary key autoincrement - , cblock text not null - , 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) - -instance ToField GitRef where - toField h = toField (show $ pretty h) - -instance FromField GitRef where - fromField = fmap fromString . fromField @String - -instance FromField GitHash where - fromField = fmap fromString . fromField @String - -instance ToField HashRef where - toField x = toField $ show $ pretty x - -instance FromField HashRef where - fromField = fmap (fromString @HashRef) . fromField @String - -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 - 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 c.id, c.cblock - from kommit k join cblock c on k.cblock = c.id - where kommit = ? limit 1|] (Only gh) - <&> listToMaybe - --- 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 - diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index 19fd8cfa..2d90f81f 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -70,7 +70,7 @@ indexPath :: forall m . ( Git3Perks m ) => m FilePath indexPath = do reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet - getStatePath (AsBase58 reflog) <&> ( "index") + getStatePath (AsBase58 reflog) data IndexEntry = IndexEntry @@ -125,7 +125,7 @@ mergeSortedFilesN getKey inputFiles outFile = do compactIndex :: forall m . (Git3Perks m, MonadReader Git3Env m) => Natural -> m () compactIndex maxSize = do reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" - idxPath <- getStatePath (AsBase58 reflog) <&> ( "index") + idxPath <- getStatePath (AsBase58 reflog) mkdir idxPath files <- listObjectIndexFiles <&> L.sortOn snd @@ -384,13 +384,16 @@ updateReflogIndex = do | ListVal [LitIntVal t, GitHashLike h, StringLike x] <- parseTop (LBS8.unpack llbs) & fromRight mempty ] - liftIO $ mapM_ (print . pretty) refs - lift $ S.yield o + lift $ S.yield (Left refs) - lift $ S.yield (h, pieces) + lift $ S.yield (Right o) - liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do + lift do + S.yield (Right (h, rights pieces)) + S.yield (Left (h, lefts pieces)) + + liftIO $ forConcurrently_ (rights sink) $ \(tx, pieces) -> do idxName <- emptyTempFile idxPath "objects-.idx" let ss = L.sort pieces UIO.withBinaryFileAtomic idxName WriteMode $ \wh -> do @@ -402,3 +405,14 @@ updateReflogIndex = do getIndexBlockSize >>= lift . compactIndex + liftIO do + name <- emptyTempFile idxPath ".ref" + UIO.withBinaryFileAtomic name WriteMode $ \wh -> do + for_ (lefts sink) $ \(tx, refs) -> do + for_ (mconcat refs) $ \(ts,gh,nm) -> do + LBS8.hPutStrLn wh $ LBS8.pack $ show $ + "R" <+> pretty tx + <+> pretty ts + <+> pretty gh + <+> pretty nm +