diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index a6edb9b8..1493aeec 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Service.hs b/hbs2-core/lib/HBS2/Net/Proto/Service.hs index 630473c7..893e68a0 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Service.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Service.hs @@ -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) diff --git a/hbs2-fixer/hbs2-fixer.cabal b/hbs2-fixer/hbs2-fixer.cabal index ad1222e9..e6aa884f 100644 --- a/hbs2-fixer/hbs2-fixer.cabal +++ b/hbs2-fixer/hbs2-fixer.cabal @@ -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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 0623dd7b..e309a75c 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -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 diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal index 68c14b00..d80897a2 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/hbs2-keyman/hbs2-keyman.cabal @@ -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 diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index 0dea5f5f..eac1cf77 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/hbs2-peer/app/CLI/RefChan.hs @@ -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 + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 00ea789a..94860f98 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -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 diff --git a/hbs2-share/hbs2-share.cabal b/hbs2-share/hbs2-share.cabal index db94afb1..2ab9d413 100644 --- a/hbs2-share/hbs2-share.cabal +++ b/hbs2-share/hbs2-share.cabal @@ -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 diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 9cc56f44..4eccfd58 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -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 diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 47d9f258..d73c3f4a 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -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