diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index 060ea813..b9ea7c8e 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -3,6 +3,7 @@ module HBS2.Base58 where import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alphabet(..)) import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS import Prettyprinter @@ -25,3 +26,6 @@ fromBase58 = decodeBase58 bitcoinAlphabet instance Pretty (AsBase58 ByteString) where pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 bs +instance Pretty (AsBase58 LBS.ByteString) where + pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 (LBS.toStrict bs) + diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index c4b1f6e5..23c12317 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -282,6 +282,25 @@ refChanUpdateProto self adapter msg = do where proto = Proxy @(RefChanUpdate e) +makeProposeTran :: forall e s m . ( MonadIO m + , ForRefChans e + , Signatures (Encryption e) + , HasStorage m + , s ~ Encryption e + ) + => PeerCredentials s + -> RefChanId e + -> SignedBox ByteString e + -> m (Maybe (SignedBox (ProposeTran e) e)) + +makeProposeTran creds chan box1 = do + sto <- getStorage + runMaybeT do + h <- MaybeT $ liftIO $ getRef sto (RefChanHeadKey @s chan) + let tran = ProposeTran @e (HashRef h) box1 + let pk = view peerSignPk creds + let sk = view peerSignSk creds + pure $ makeSignedBox @e pk sk tran makeSignedBox :: forall e p . (Serialise p, ForRefChans e, Signatures (Encryption e)) => PubKey 'Sign (Encryption e) diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index cdc5d084..81dca1ce 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/hbs2-peer/app/CLI/RefChan.hs @@ -14,12 +14,15 @@ import RPC import Options.Applicative import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy (ByteString) import Lens.Micro.Platform import Codec.Serialise +import Data.Maybe 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")) + ) pRefChanHead :: Parser (IO ()) @@ -88,7 +91,29 @@ pRefChanHeadGet :: Parser (IO ()) pRefChanHeadGet = do opts <- pRpcCommon ref <- strArgument (metavar "REFCHAH-HEAD-REF") - pure $ do + pure do href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF" runRpcCommand opts (REFCHANHEADGET href) + +pRefChanPropose :: Parser (IO ()) +pRefChanPropose = do + opts <- pRpcCommon + kra <- strOption (long "author" <> short 'a' <> help "author credentials") + fn <- optional $ strOption (long "file" <> short 'f' <> help "file") + dry <- optional (flag' True (long "dry" <> short 'n' <> help "only dump transaction")) <&> fromMaybe False + sref <- strArgument (metavar "REFCHAH-REF") + pure do + sc <- BS.readFile kra + puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key" + creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file" + + lbs <- maybe1 fn LBS.getContents LBS.readFile + + let box = makeSignedBox @L4Proto @ByteString (view peerSignPk creds) (view peerSignSk creds) lbs + + if dry then do + LBS.putStr (serialise box) + else do + runRpcCommand opts (REFCHANPROPOSE (puk, serialise box)) + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index d372684d..944a0196 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -427,6 +427,7 @@ respawn opts = case view peerRespawn opts of runPeer :: forall e s . ( e ~ L4Proto , FromStringMaybe (PeerAddr e) , s ~ Encryption e + , HasStorage (PeerM e IO) ) => PeerOpts -> IO () runPeer opts = U.handle (\e -> myException e @@ -1007,6 +1008,14 @@ runPeer opts = U.handle (\e -> myException e void $ liftIO $ async $ withPeerM penv $ do broadCastMessage (RefChanGetHead @e puk) + let refChanProposeAction (puk, lbs) = do + trace "reChanProposeAction" + void $ liftIO $ async $ withPeerM penv $ do + let mbox = deserialiseOrFail lbs & either (const Nothing) Just + maybe1 mbox (err "proposal: Can't read SignedBox") $ \box -> do + proposed <- makeProposeTran @e pc puk box + debug $ "PROPOSAL:" <+> pretty (LBS.length (serialise proposed)) + let arpc = RpcAdapter pokeAction dieAction dontHandle @@ -1026,6 +1035,7 @@ runPeer opts = U.handle (\e -> myException e refChanHeadGetAction dontHandle refChanHeadFetchAction + refChanProposeAction rpc <- async $ runRPC udp1 do runProto @e diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index c4c84c22..20cfa5d8 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -64,6 +64,7 @@ data RPCCommand = | REFCHANHEADSEND (Hash HbSync) | REFCHANHEADGET (PubKey 'Sign (Encryption L4Proto)) | REFCHANHEADFETCH (PubKey 'Sign (Encryption L4Proto)) + | REFCHANPROPOSE (PubKey 'Sign (Encryption L4Proto), ByteString) data RPC e = RPCDie @@ -85,6 +86,7 @@ data RPC e = | RPCRefChanHeadGet (PubKey 'Sign (Encryption e)) | RPCRefChanHeadGetAnsw (Maybe (Hash HbSync)) | RPCRefChanHeadFetch (PubKey 'Sign (Encryption e)) + | RPCRefChanPropose (PubKey 'Sign (Encryption e), ByteString) deriving stock (Generic) @@ -126,6 +128,7 @@ data RpcAdapter e m = , rpcOnRefChanHeadGet :: PubKey 'Sign (Encryption e) -> m () , rpcOnRefChanHeadGetAnsw :: Maybe (Hash HbSync) -> m () , rpcOnRefChanHeadFetch :: PubKey 'Sign (Encryption e) -> m () + , rpcOnRefChanPropose :: (PubKey 'Sign (Encryption e), ByteString) -> m () } newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a } @@ -185,6 +188,7 @@ rpcHandler adapter = \case (RPCRefChanHeadGet s) -> rpcOnRefChanHeadGet adapter s (RPCRefChanHeadGetAnsw s) -> rpcOnRefChanHeadGetAnsw adapter s (RPCRefChanHeadFetch s) -> rpcOnRefChanHeadFetch adapter s + (RPCRefChanPropose s) -> rpcOnRefChanPropose adapter s data RPCOpt = RPCOpt @@ -210,6 +214,7 @@ runRpcCommand opt = \case REFCHANHEADSEND h -> withRPC opt (RPCRefChanHeadSend h) REFCHANHEADGET s -> withRPC opt (RPCRefChanHeadGet s) REFCHANHEADFETCH s -> withRPC opt (RPCRefChanHeadFetch s) + REFCHANPROPOSE s -> withRPC opt (RPCRefChanPropose s) _ -> pure () @@ -273,6 +278,8 @@ withRPC o cmd = rpcClientMain o $ runResourceT do dontHandle -- rpcOnRefChanHeadFetch + dontHandle -- rpcOnRefChanPropose + prpc <- async $ runRPC udp1 do env <- ask @@ -353,6 +360,10 @@ withRPC o cmd = rpcClientMain o $ runResourceT do pause @'Seconds 0.25 exitSuccess + RPCRefChanPropose{} -> liftIO do + pause @'Seconds 0.25 + exitSuccess + _ -> pure () void $ liftIO $ waitAnyCancel [proto]