voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-03-14 13:26:56 +03:00
parent 708d9464c7
commit b6c85789b9
2 changed files with 13 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs
View File

@ -160,11 +160,16 @@ export key refs = do
reflog <- asks _refLogAPI reflog <- asks _refLogAPI
ip <- asks _progress ip <- asks _progress
LWWBlockData{..} <- waitOrInitLWWRef lww@LWWBlockData{..} <- waitOrInitLWWRef
debug $ red $ pretty $ AsBase58 lwwRefLogPubKey debug $ red $ pretty $ AsBase58 lwwRefLogPubKey
puk <- error $ show $ "FIXME: puk" <+> pretty (AsBase58 lwwRefLogPubKey) (sk0,pk0) <- liftIO $ runKeymanClient do
creds <- loadCredentials lwwRefLogPubKey
>>= orThrowUser "can't load credentials"
pure ( view peerSignSk creds, view peerSignPk creds )
(puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0
subscribeRefLog puk subscribeRefLog puk
@ -246,7 +251,7 @@ export key refs = do
debug $ red "MAKE TX" <+> pretty rw <+> pretty gk0old <+> "->" <+> pretty gk0new debug $ red "MAKE TX" <+> pretty rw <+> pretty gk0old <+> "->" <+> pretty gk0new
tx <- lift $ makeTx sto rw rank puk repohead bss out tx <- lift $ makeTx sto rw rank puk (const $ pure (Just sk)) repohead bss out
r <- lift $ race (pause @'Seconds 1) (callService @RpcRefLogPost reflog tx) r <- lift $ race (pause @'Seconds 1) (callService @RpcRefLogPost reflog tx)
>>= orThrowUser "hbs2-peer rpc timeout" >>= orThrowUser "hbs2-peer rpc timeout"

12
hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs
View File

@ -85,26 +85,24 @@ makeRepoHeadSimple name brief manifest gk refs = do
writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef
writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef
makeTx :: (MonadUnliftIO m, GroupKeyOperations m) makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
=> AnyStorage => AnyStorage
-> Bool -- ^ rewrite bundle merkle tree with new gk0 -> Bool -- ^ rewrite bundle merkle tree with new gk0
-> Rank -- ^ tx rank -> Rank -- ^ tx rank
-> RefLogId -> RefLogId
-> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
-> RepoHead -> RepoHead
-> [HashRef] -> [HashRef]
-> [LBS] -> [LBS]
-> m RepoTx -> m RepoTx
makeTx sto rewrite r puk rh prev lbss = do makeTx sto rewrite r puk findSk rh prev lbss = do
let rfk = RefLogKey @HBS2Basic puk let rfk = RefLogKey @HBS2Basic puk
creds <- liftIO ( runKeymanClient $ loadCredentials puk ) privk <- findSk puk
>>= orThrow TxKeyringNotFound >>= orThrow TxKeyringNotFound
let pubk = view peerSignPk creds
let privk = view peerSignSk creds
-- FIXME: delete-on-fail -- FIXME: delete-on-fail
headRef <- writeRepoHead sto rh headRef <- writeRepoHead sto rh
@ -168,7 +166,7 @@ makeTx sto rewrite r puk rh prev lbss = do
& serialise & serialise
& LBS.toStrict & LBS.toStrict
makeRefLogUpdate @L4Proto @HBS2Basic pubk privk tx makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx
unpackTx :: MonadIO m unpackTx :: MonadIO m