mirror of https://github.com/voidlizard/hbs2
wip, removing obsolete stuff, mkdir for state
This commit is contained in:
voidlizard
parent
c3fc7fa69b
commit
5dc82c5a81
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue