wip, dump refchan head block

hbs2-core/lib/HBS2/Net/Proto/RefChan.hs

@@ -18,16 +18,15 @@ import Data.Config.Suckless
 
 -- import HBS2.System.Logger.Simple
 
--- import Data.Maybe
--- import Data.Hashable
-import Data.Text qualified as Text
+import Codec.Serialise
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
--- import Type.Reflection (someTypeRep)
 import Data.Either
 import Data.Maybe
+import Data.Text qualified as Text
 import Lens.Micro.Platform
-import Codec.Serialise
 
 {- HLINT ignore "Use newtype instead of data" -}
 
@@ -56,8 +55,12 @@ makeLenses 'RefChanHeadBlockSmall
 type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e))
                      , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
                      , FromStringMaybe (PubKey 'Sign (Encryption e))
+                     , Serialise (Signature (Encryption e))
                      )
 
+instance ForRefChans e => Serialise (RefChanHeadBlock e)
+instance ForRefChans e => Serialise (SignedBox p e)
+
 -- блок головы может быть довольно большой.
 -- поэтому посылаем его, как merkle tree
 newtype RefChanHeadBlockTran e =
@@ -116,6 +119,19 @@ makeSignedBox pk sk msg = SignedBox @p @e pk bs sign
     bs = LBS.toStrict (serialise msg)
     sign = makeSign @(Encryption e) sk bs
 
+unboxSignedBox :: forall p e . (Serialise p, ForRefChans e, Signatures (Encryption e))
+               => LBS.ByteString
+               -> Maybe p
+
+unboxSignedBox bs = runIdentity $ runMaybeT do
+
+  (SignedBox pk bs sign) <- MaybeT $ pure
+                                   $ deserialiseOrFail @(SignedBox p e) bs
+                                       & either (pure Nothing) Just
+
+  guard $ verifySign @(Encryption e) pk sign bs
+
+  MaybeT $ pure $ deserialiseOrFail @p (LBS.fromStrict bs) & either (const Nothing) Just
 
 instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where
   fromStringMay str = RefChanHeadBlockSmall <$> version

hbs2-peer/app/PeerMain.hs

@@ -48,6 +48,7 @@ import RefLog (reflogWorker)
 import HttpWorker
 import ProxyMessaging
 import PeerMeta
+import CLI.RefChan
 
 import Codec.Serialise
 -- import Control.Concurrent.Async
@@ -244,6 +245,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                         <> command "ping"      (info pPing (progDesc "ping another peer"))
                         <> command "fetch"     (info pFetch (progDesc "fetch block"))
                         <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
+                        <> command "refchan"   (info pRefChan (progDesc "refchan commands"))
                         <> command "peers"     (info pPeers (progDesc "show known peers"))
                         <> command "log"       (info pLog   (progDesc "set logging level"))
                         )
@@ -335,7 +337,6 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
         setLogging @TRACE tracePrefix
         trace "pRefLogSend"
         s <- BS.readFile kr
-        -- FIXME: UDP is weird here
         creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile s)) `orDie` "bad keyring file"
         bs <- BS.take defChunkSize  <$> BS.hGetContents stdin
         let pubk = view peerSignPk creds

hbs2-peer/hbs2-peer.cabal

@@ -131,6 +131,7 @@ executable hbs2-peer
                     , HttpWorker
                     , Brains
                     , ProxyMessaging
+                    , CLI.RefChan
 
     -- other-extensions:
     build-depends:    base