wip

2023-03-04 18:41:07 +04:00 · 2023-03-04 18:41:07 +04:00 · 192d7472c1
parent 41b8c52373
commit 192d7472c1
7 changed files with 139 additions and 5 deletions
--- a/hbs2-core/hbs2-core.cabal
+++ b/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
--- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs
+++ b/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
--- a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs
+++ b/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
--- a/hbs2-core/lib/HBS2/OrDie.hs
+++ b/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
--- a/hbs2-core/lib/HBS2/Prelude.hs
+++ b/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
--- a/hbs2-peer/app/PeerMain.hs
+++ b/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
--- a/hbs2/Main.hs
+++ b/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
-        `orDie` "error reading ref val"
-    LinearMutableRefSigned _ ref
-        <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
-        `orDie` "can not parse channel ref"
+    LinearMutableRefSigned _ ref <- getLRef @UDP ss refh `orDie` "getLRef"
    hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref)
    print $ pretty (lrefVal ref)