wip

hbs2-core/hbs2-core.cabal

@@ -93,6 +93,7 @@ library
                     , HBS2.Net.Proto.Peer
                     , HBS2.Net.Proto.PeerAnnounce
                     , HBS2.Net.Proto.PeerExchange
+                    , HBS2.Net.Proto.RefLinear
                     , HBS2.Net.Proto.Sessions
                     , HBS2.Net.Proto.Types
                     , HBS2.OrDie

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

@@ -18,6 +18,7 @@ import HBS2.Net.Proto.BlockInfo
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
+import HBS2.Net.Proto.RefLinear
 import HBS2.Prelude
 
 import Data.Functor
@@ -93,6 +94,11 @@ instance HasProtocol UDP (PeerExchange UDP) where
   decode = either (const Nothing) Just . deserialiseOrFail
   encode = serialise
 
+instance HasProtocol UDP (AnnLRef UDP) where
+  type instance ProtocolId (AnnLRef UDP) = 7
+  type instance Encoded UDP = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
 
 instance Expires (SessionKey UDP (BlockInfo UDP)) where
   expiresIn _ = Just defCookieTimeoutSec
@@ -115,6 +121,9 @@ instance Expires (SessionKey UDP (PeerHandshake UDP)) where
 instance Expires (EventKey UDP (PeerAnnounce UDP)) where
   expiresIn _ = Nothing
 
+instance Expires (EventKey UDP (AnnLRef UDP)) where
+  expiresIn _ = Nothing
+
 
 instance MonadIO m => HasNonces (PeerHandshake UDP) m where
   type instance Nonce (PeerHandshake UDP) = BS.ByteString

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

@@ -0,0 +1,73 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Net.Proto.RefLinear where
+
+import HBS2.Data.Types.Refs
+import HBS2.Events
+import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto
+import HBS2.Prelude.Plated
+
+import Codec.Serialise()
+import Data.ByteString.Lazy (ByteString)
+import Data.Hashable
+import Data.Word
+import Lens.Micro.Platform
+import Type.Reflection (someTypeRep)
+
+
+newtype AnnLRefNonce = AnnLRefNonce Word64
+                         deriving newtype (Num,Enum,Real,Integral)
+                         deriving stock (Ord,Eq,Generic,Show)
+
+instance Serialise AnnLRefNonce
+
+
+data AnnLRef e = AnnLRef (Hash HbSync) (Signed SignaturePresent (MutableRef e 'LinearRef))
+    deriving stock (Generic)
+
+instance Serialise (Signature e) => Serialise (AnnLRef e)
+
+
+-- annLRefProto :: forall e m  . ( MonadIO m
+--                                     , EventEmitter e (AnnLRef e) m
+--                                     , Response e (AnnLRef e) m
+--                                     ) => AnnLRef e -> m ()
+
+refLinearProto :: forall e m  . ( MonadIO m
+                                  , Response e (AnnLRef e) m
+                                  -- , HasDeferred e (AnnLRef e) m
+                                  -- , HasOwnPeer e m
+                                  -- , Pretty (Peer e)
+                                  )
+                 -- => RefLinearI e m
+                 -- -> AnnLRef e
+                 => AnnLRef e
+                 -> m ()
+-- refLinearProto adapter (AnnLRef c p) =
+refLinearProto = \case
+
+-- * Анонс ссылки (уведомление о новом состоянии без запроса)
+    AnnLRef h (LinearMutableRefSigned{}) -> do
+        undefined
+--     AnnLRef n info -> do
+--       that <- thatPeer (Proxy @(AnnLRef e))
+--       emit @e AnnLRefInfoKey (AnnLRefEvent that info n)
+
+
+-- data instance EventKey e (AnnLRef e) =
+--   AnnLRefInfoKey
+--   deriving stock (Typeable, Eq,Generic)
+
+-- data instance Event e (AnnLRef e) =
+--   AnnLRefEvent (Peer e) (AnnLRefInfo e) PeerNonce
+--   deriving stock (Typeable)
+
+-- instance Typeable (AnnLRefInfo e) => Hashable (EventKey e (AnnLRef e)) where
+--   hashWithSalt salt _ = hashWithSalt salt (someTypeRep p)
+--     where
+--       p = Proxy @(AnnLRefInfo e)
+
+-- instance EventType ( Event e ( AnnLRef e) ) where
+--   isPersistent = True

hbs2-core/lib/HBS2/OrDie.hs

@@ -14,6 +14,12 @@ instance OrDie IO (Maybe a) where
       Nothing -> die err
       Just x  -> pure x
 
+instance OrDie IO (Either String a) where
+  type instance OrDieResult (Either String a) = a
+  orDie ev err = ev >>= \case
+      Left e -> die (e <> ": " <> err)
+      Right x  -> pure x
+
 instance MonadIO m => OrDie m ExitCode where
   type instance OrDieResult ExitCode = ()
   orDie mv err = mv >>= \case

hbs2-core/lib/HBS2/Prelude.hs

@@ -4,6 +4,7 @@ module HBS2.Prelude
   , MonadIO(..)
   , void, guard, when, unless
   , maybe1
+  , orExcept
   , Hashable
   , lift
   , AsFileName(..)
@@ -22,6 +23,7 @@ import Safe
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad (void,guard,when,unless)
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except
 
 import Data.Function
 import Data.Char qualified as Char
@@ -55,3 +57,6 @@ class ToByteString a where
 
 class FromByteString a where
   fromByteString :: ByteString -> Maybe a
+
+orExcept :: Monad m => m (Maybe a) -> e -> ExceptT e m a
+orExcept mev msg = ExceptT $ maybe (Left msg) Right <$> mev

hbs2-peer/app/PeerMain.hs

@@ -20,6 +20,7 @@ import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
+import HBS2.Net.Proto.RefLinear
 import HBS2.Net.Proto.Sessions
 import HBS2.OrDie
 import HBS2.Prelude.Plated
@@ -139,6 +140,7 @@ makeLenses 'RPCOpt
 data RPCCommand =
     POKE
   | ANNOUNCE (Hash HbSync)
+  | ANNLREF (Hash HbSync)
   | PING (PeerAddr UDP) (Maybe (Peer UDP))
   | CHECK PeerNonce (PeerAddr UDP) (Hash HbSync)
   | FETCH (Hash HbSync)
@@ -202,6 +204,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                         <> command "run"       (info pRun  (progDesc "run peer"))
                         <> command "poke"      (info pPoke (progDesc "poke peer by rpc"))
                         <> command "announce"  (info pAnnounce (progDesc "announce block"))
+                        <> command "annlref"   (info pAnnLRef (progDesc "announce linear ref"))
                         <> command "ping"      (info pPing (progDesc "ping another peer"))
                         <> command "fetch"     (info pFetch (progDesc "fetch block"))
                         <> command "peers"     (info pPeers (progDesc "show known peers"))
@@ -246,6 +249,11 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
       h   <- strArgument ( metavar "HASH" )
       pure $ runRpcCommand rpc (ANNOUNCE h)
 
+    pAnnLRef = do
+      rpc <- pRpcCommon
+      h   <- strArgument ( metavar "HASH" )
+      pure $ runRpcCommand rpc (ANNLREF h)
+
     pFetch = do
       rpc <- pRpcCommon
       h   <- strArgument ( metavar "HASH" )
@@ -586,6 +594,28 @@ runPeer opts = Exception.handle myException $ do
                                     debug $ "send single-cast announces" <+> pretty p
                                     request @e p announce
 
+                            ANNLREF h -> do
+                              debug $ "got annlref rpc" <+> pretty h
+                              sto <- getStorage
+                              -- mbsize <- liftIO $ hasBlock sto h  -- FIXME:
+
+                              -- FIXME: get by hash h value AnnounceLinearRef(LinearMutableRefSigned{})
+
+                              -- maybe1 mbsize (pure ()) $ \size -> do
+                              --   debug "send multicast annlref"
+
+                              --   no <- peerNonce @e
+                              --   let annInfo = BlockAnnlrefInfo 0 NoBlockInfoMeta size h  -- FIXME:
+                              --   let annlref = BlockAnnlref @e no annInfo  -- FIXME:
+
+                              --   request localMulticast annlref
+
+                              --   liftIO $ withPeerM env do
+                              --     forKnownPeers $ \p _ -> do
+                              --       debug $ "send single-cast annlrefs" <+> pretty p
+                              --       request @e p annlref
+                              undefined
+
                             CHECK nonce pa h -> do
                               pip <- fromPeerAddr @e pa
 
@@ -634,6 +664,7 @@ runPeer opts = Exception.handle myException $ do
                     , makeResponse blockAnnounceProto
                     , makeResponse (withCredentials pc . peerHandShakeProto)
                     , makeResponse peerExchangeProto
+                    , makeResponse refLinearProto
                     ]
 
               void $ liftIO $ waitAnyCatchCancel workers
@@ -652,6 +683,7 @@ runPeer opts = Exception.handle myException $ do
         that <- thatPeer (Proxy @(RPC e))
         liftIO $ atomically $ writeTQueue rpcQ (PING pa (Just that))
 
+  -- FIXME
   let fetchAction h = do
         debug  $ "fetchAction" <+> pretty h
         liftIO $ withPeerM penv $ do

hbs2/Main.hs

@@ -10,6 +10,7 @@ import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging.UDP (UDP)
 import HBS2.Net.Proto.Definition()
 import HBS2.Net.Proto.Types
+import HBS2.Prelude
 import HBS2.Prelude.Plated
 import HBS2.Storage.Simple
 import HBS2.Storage.Simple.Extra
@@ -21,6 +22,7 @@ import Control.Arrow ((&&&))
 import Control.Concurrent.Async
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.State.Strict
 import Crypto.Saltine.Core.Box qualified as Encrypt
@@ -417,14 +419,20 @@ modifyLinearRef ss kr chh modIO = do
       `orDie` "can not write link"
     pure ()
 
+-- FIXME: make polymorphic, move to storage
+getLRef :: forall e.
+    (Serialise (Signature e))
+    => SimpleStorage HbSync -> Hash HbSync -> IO (Either String (Signed SignaturePresent (MutableRef e 'LinearRef)))
+getLRef ss refh = runExceptT do
+    refvalraw <- simpleReadLinkVal ss refh
+        `orExcept` "error reading ref val"
+    pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw)
+        `orExcept` "can not parse channel ref"
+
 runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO ()
 runGetLRef refh ss = do
     hPrint stderr $ "getting ref value" <+> pretty refh
-    refvalraw <- simpleReadLinkVal ss refh
+    LinearMutableRefSigned _ ref <- getLRef @UDP ss refh `orDie` "getLRef"
-        `orDie` "error reading ref val"
-    LinearMutableRefSigned _ ref
-        <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
-        `orDie` "can not parse channel ref"
     hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref)
     print $ pretty (lrefVal ref)