diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index be658ff8..a1b198eb 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -9,6 +9,7 @@ module Main where import HBS2.Prelude.Plated import HBS2.OrDie import HBS2.Base58 +import HBS2.Merkle import HBS2.Storage import HBS2.Peer.CLI.Detect @@ -586,8 +587,23 @@ theDict = do debug $ "pack-merkle-tree-hash" <+> pretty href - withState do + debug $ "make cblock" + + phashes <- withState $ for parents \p -> do + selectCBlock p + >>= orThrowUser ("pack export failed" <+> pretty p) + + debug $ "write cblock" + + let cblock = href : phashes + let pt = toPTree (MaxSize 1024) (MaxNum 1024) cblock + + root <- makeMerkle 0 pt $ \(_,_,s) -> do + void $ putBlock sto s + + withState $ transactional do insertGitPack co href + insertCBlock co (HashRef root) atomically $ modifyTVar done (HS.insert co) else do @@ -597,7 +613,8 @@ theDict = do ExportCheck -> do debug $ "ExportCheck dummy" <+> pretty r - debug "exit export" + c <- lift $ withState $ selectCBlock r >>= orThrowUser "export failed" + liftIO $ hPrint stdout (pretty c) -- case co' of -- Just co -> do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index fc583f35..d1abe826 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -49,6 +49,15 @@ gitpack ) |] + ddl [qc| +create table if not exists +cblock + ( kommit text not null primary key + , cblock text not null + ) +|] + + instance ToField GitHash where toField h = toField (show $ pretty h) @@ -81,3 +90,15 @@ selectGitPack gh = do <&> listToMaybe . fmap fromOnly +insertCBlock :: MonadIO m => GitHash -> HashRef -> DBPipeM m () +insertCBlock co cblk = do + insert [qc| + insert into cblock (kommit, cblock) values(?,?) + on conflict (kommit) do update set cblock = excluded.cblock + |] (co, cblk) + +selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe HashRef) +selectCBlock gh = do + select [qc|select cblock from cblock where kommit = ? limit 1|] (Only gh) + <&> listToMaybe . fmap fromOnly +