wip

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)
+

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)

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))
+

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

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]