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

hbs2-peer refchan cat && hbs2-peer reflog cat

This commit is contained in:
Dmitry Zuikov 2024-04-09 11:49:31 +03:00
parent e9eaae2795
commit 26a023d60d
10 changed files with 87 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-core/hbs2-core.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-core
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

20
hbs2-core/lib/HBS2/Net/Proto/Service.hs
View File

@ -261,6 +261,26 @@ callService caller input = do
_ -> pure (Left ErrorInvalidResponse)
callRpcWaitMay :: forall method (api :: [Type]) m e proto t . ( MonadUnliftIO m
, KnownNat (FromJust (FindMethodIndex 0 method api))
, HasProtocol e (ServiceProto api e)
, Serialise (Input method)
, Serialise (Output method)
, IsTimeout t
, proto ~ ServiceProto api e
)
=> Timeout t
-> ServiceCaller api e
-> Input method
-> m (Maybe (Output method))
callRpcWaitMay t caller args = do
race (pause t) (callService @method @api @e @m caller args)
>>= \case
Right (Right x) -> pure (Just x)
_ -> pure Nothing
makeClient :: forall api e m . ( MonadIO m
, HasProtocol e (ServiceProto api e)
, Pretty (Peer e)

2
hbs2-fixer/hbs2-fixer.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-fixer
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

2
hbs2-git/hbs2-git.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-git
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

2
hbs2-keyman/hbs2-keyman.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-keyman
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

72
hbs2-peer/app/CLI/RefChan.hs
View File

@ -5,6 +5,7 @@ import HBS2.Prelude.Plated
import HBS2.Hash
import HBS2.Net.Auth.Credentials
import HBS2.Net.Auth.Credentials.Sigil
import HBS2.Merkle
import HBS2.Peer.Proto.RefChan
import HBS2.Net.Proto.Types
import HBS2.Data.Types.Refs
@ -46,12 +47,13 @@ import UnliftIO
pRefChan :: Parser (IO ())
pRefChan = hsubparser ( command "head" (info pRefChanHead (progDesc "head commands" ))
pRefChan = hsubparser ( command "head" (info pRefChanHead (progDesc "head commands" ))
<> command "propose" (info pRefChanPropose (progDesc "post propose transaction"))
<> command "notify" (info pRefChanNotify (progDesc "post notify message"))
<> command "fetch" (info pRefChanFetch (progDesc "fetch and sync refchan value"))
<> command "get" (info pRefChanGet (progDesc "get refchan value"))
<> command "gk" (info pRefChanGK (progDesc "generate a group key"))
<> command "notify" (info pRefChanNotify (progDesc "post notify message"))
<> command "fetch" (info pRefChanFetch (progDesc "fetch and sync refchan value"))
<> command "get" (info pRefChanGet (progDesc "get refchan value"))
<> command "gk" (info pRefChanGK (progDesc "generate a group key"))
<> command "cat" (info pRefChanCat (progDesc "dump refchan content"))
)
@ -65,11 +67,13 @@ pRefChanHead = hsubparser ( command "gen" (info pRefChanHeadGen (progDesc "ge
pRefChanHeadGen :: Parser (IO ())
pRefChanHeadGen = do
kr <- strOption (long "keyring" <> short 'k' <> help "owner credentials")
fn <- optional $ strArgument (metavar "head dsl file")
rchan <- argument pRefChanId (metavar "REFCHAN-KEY")
pure $ do
sc <- BS.readFile kr
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
creds <- runKeymanClient $ loadCredentials rchan
>>= orThrowUser "can't load credentials"
s <- maybe1 fn getContents readFile
hd <- pure (fromStringMay @(RefChanHeadBlock L4Proto) s) `orDie` "can't generate head block"
let qq = makeSignedBox @L4Proto @(RefChanHeadBlock L4Proto) (view peerSignPk creds) (view peerSignSk creds) hd
@ -84,8 +88,6 @@ pRefChanHeadDump= do
print $ pretty hdblk
pRefChanHeadPost :: Parser (IO ())
pRefChanHeadPost = do
opts <- pRpcCommon
@ -117,13 +119,14 @@ pRefChanHeadGet = do
pRefChanPropose :: Parser (IO ())
pRefChanPropose = do
opts <- pRpcCommon
kra <- strOption (long "author" <> short 'a' <> help "author credentials")
kra <- option pRefChanId (long "author" <> short 'a' <> help "author key")
fn <- optional $ strOption (long "file" <> short 'f' <> help "file")
dry <- optional (flag' True (long "dry" <> short 'n' <> help "only dump transaction")) <&> fromMaybe False
puk <- argument pRefChanId (metavar "REFCHAH-KEY")
pure $ withMyRPC @RefChanAPI opts $ \caller -> do
sc <- BS.readFile kra
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
creds <- runKeymanClient $ loadCredentials kra
>>= orThrowUser "can't load credentials"
lbs <- maybe1 fn LBS.getContents LBS.readFile
@ -369,3 +372,46 @@ pRefChanGK = do
liftIO $ print $ pretty (AsGroupKeyFile gk)
pRefChanCat :: Parser (IO ())
pRefChanCat = do
opts <- pRpcCommon
puk <- argument pRefChanId (metavar "REFCHAH-REF")
pure $ flip runContT pure do
client <- ContT $ withRPCMessaging opts
self <- runReaderT (ownPeer @UNIX) client
refChanAPI <- makeServiceCaller @RefChanAPI self
storageAPI <- makeServiceCaller @StorageAPI self
let endpoints = [ Endpoint @UNIX refChanAPI
, Endpoint @UNIX storageAPI
]
void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel
let sto = AnyStorage (StorageClient storageAPI)
rv' <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) refChanAPI puk)
>>= orThrowUser "rpc call error/timeout"
rv <- ContT $ maybe1 rv' none
walkMerkle (fromHashRef rv) (getBlock sto) $ \case
Left{} -> pure ()
Right (hrs :: [HashRef]) -> do
for_ hrs $ \h -> void $ runMaybeT do
s <- getBlock sto (fromHashRef h)
>>= toMPlus
<&> deserialiseOrFail @(RefChanUpdate L4Proto)
>>= toMPlus
case s of
Accept{} -> pure ()
Propose _ box -> do
(_, ProposeTran _ pbox :: ProposeTran L4Proto) <- toMPlus $ unboxSignedBox0 box
(_, bs2) <- toMPlus $ unboxSignedBox0 pbox
liftIO $ BS.putStr bs2

2
hbs2-peer/hbs2-peer.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-peer
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

2
hbs2-share/hbs2-share.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-share
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

2
hbs2-storage-simple/hbs2-storage-simple.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2-storage-simple
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause

2
hbs2/hbs2.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: hbs2
version: 0.24.1.1
version: 0.24.1.2
-- synopsis:
-- description:
license: BSD-3-Clause