From 192d7472c150496dd11ad485b28a90452728ff87 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Sat, 4 Mar 2023 18:41:07 +0400 Subject: [PATCH] wip --- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 9 +++ hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs | 73 ++++++++++++++++++++++ hbs2-core/lib/HBS2/OrDie.hs | 6 ++ hbs2-core/lib/HBS2/Prelude.hs | 5 ++ hbs2-peer/app/PeerMain.hs | 32 ++++++++++ hbs2/Main.hs | 18 ++++-- 7 files changed, 139 insertions(+), 5 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index c812f07e..bf6f7518 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 676552cd..58bc2c45 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs new file mode 100644 index 00000000..4dbd8a2a --- /dev/null +++ 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 diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 5a01a3e7..8fef27f0 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 601e6f41..f99645dc 100644 --- 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 1f298db6..d7bae05d 100644 --- 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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index d7a3bccd..dbf25ee0 100644 --- 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)