diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index bf6f7518..d86c5fa0 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -99,6 +99,7 @@ library , HBS2.OrDie , HBS2.Prelude , HBS2.Prelude.Plated + , HBS2.Refs.Linear , HBS2.Storage , HBS2.System.Logger.Simple , HBS2.System.Logger.Simple.Class diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 58bc2c45..e6857c3a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -8,6 +8,7 @@ module HBS2.Net.Proto.Definition import HBS2.Clock import HBS2.Defaults +import HBS2.Hash import HBS2.Merkle import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.UDP @@ -94,8 +95,8 @@ 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 +instance HasProtocol UDP (LRef UDP) where + type instance ProtocolId (LRef UDP) = 7 type instance Encoded UDP = ByteString decode = either (const Nothing) Just . deserialiseOrFail encode = serialise @@ -121,7 +122,7 @@ instance Expires (SessionKey UDP (PeerHandshake UDP)) where instance Expires (EventKey UDP (PeerAnnounce UDP)) where expiresIn _ = Nothing -instance Expires (EventKey UDP (AnnLRef UDP)) where +instance Expires (EventKey UDP (LRef UDP)) where expiresIn _ = Nothing @@ -155,5 +156,10 @@ instance Signatures MerkleEncryptionType where makeSign = Sign.signDetached verifySign = Sign.signVerifyDetached +instance Signatures [Hash HbSync] where + type Signature [Hash HbSync] = Sign.Signature + makeSign = Sign.signDetached + verifySign = Sign.signVerifyDetached + diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs index 1215f397..963cfd00 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs @@ -24,50 +24,58 @@ newtype AnnLRefNonce = AnnLRefNonce Word64 instance Serialise AnnLRefNonce -data AnnLRef e = AnnLRef (Hash HbSync) (Signed SignaturePresent (MutableRef e 'LinearRef)) +data LRef e + = AnnLRef (Hash HbSync) (Signed SignaturePresent (MutableRef e 'LinearRef)) deriving stock (Generic) -instance Serialise (Signature e) => Serialise (AnnLRef e) +instance Serialise (Signature e) => Serialise (LRef e) - --- annLRefProto :: forall e m . ( MonadIO m --- , EventEmitter e (AnnLRef e) m --- , Response e (AnnLRef e) m --- ) => AnnLRef e -> m () +data AnnLRefI e m = + AnnLRefI + { blkSize :: GetBlockSize HbSync m + } refLinearProto :: forall e m . ( MonadIO m - , Response e (AnnLRef e) m - -- , HasDeferred e (AnnLRef e) m + , Response e (LRef e) m +-- , EventEmitter e (LRef e) m +-- , Response e (LRef e) m + -- , HasDeferred e (LRef e) m -- , HasOwnPeer e m -- , Pretty (Peer e) ) -- => RefLinearI e m - -- -> AnnLRef e - => AnnLRef e + => LRef e -> m () --- refLinearProto adapter (AnnLRef c p) = refLinearProto = \case --- * Анонс ссылки (уведомление о новом состоянии без запроса) +-- Анонс ссылки (уведомление о новом состоянии без запроса) AnnLRef h (LinearMutableRefSigned{}) -> do + + -- g :: RefGenesis e <- (((either (const Nothing) Just . deserialiseOrFail) =<<) + -- <$> getBlock ss chh) + -- Проверить подпись ссылки + -- Достать наше текущее значение ссылки, сравнить счётчик + -- Если новое значение больше, обновить его + -- И разослать анонс на другие ноды undefined + -- -- AnnLRef n info -> do -- that <- thatPeer (Proxy @(AnnLRef e)) -- emit @e AnnLRefInfoKey (AnnLRefEvent that info n) --- data instance EventKey e (AnnLRef e) = +-- data instance EventKey e (LRef e) = -- AnnLRefInfoKey -- deriving stock (Typeable, Eq,Generic) --- data instance Event e (AnnLRef e) = +-- data instance Event e (LRef e) = -- AnnLRefEvent (Peer e) (AnnLRefInfo e) PeerNonce -- deriving stock (Typeable) --- instance Typeable (AnnLRefInfo e) => Hashable (EventKey e (AnnLRef e)) where +-- instance Typeable (AnnLRefInfo e) => Hashable (EventKey e (LRef e)) where -- hashWithSalt salt _ = hashWithSalt salt (someTypeRep p) -- where -- p = Proxy @(AnnLRefInfo e) --- instance EventType ( Event e ( AnnLRef e) ) where +-- instance EventType ( Event e ( LRef e) ) where -- isPersistent = True diff --git a/hbs2-core/lib/HBS2/Refs/Linear.hs b/hbs2-core/lib/HBS2/Refs/Linear.hs new file mode 100644 index 00000000..f9d3aea0 --- /dev/null +++ b/hbs2-core/lib/HBS2/Refs/Linear.hs @@ -0,0 +1,132 @@ +module HBS2.Refs.Linear where + +import HBS2.Actors +import HBS2.Clock +import HBS2.Data.Types.Refs +import HBS2.Defaults +import HBS2.Events +import HBS2.Hash +import HBS2.Net.Auth.Credentials +import HBS2.Net.Messaging +import HBS2.Net.PeerLocator +import HBS2.Net.PeerLocator.Static +import HBS2.Net.Proto +import HBS2.Net.Proto.Sessions +import HBS2.OrDie +import HBS2.Prelude.Plated +import HBS2.Storage + +import Codec.Serialise (serialise, deserialiseOrFail) +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe +import Data.Set qualified as Set + +modifyLinearRef :: forall e st block h. + ( e ~ [h] + , h ~ Hash HbSync + , Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + , Block block ~ LBS.ByteString + , Storage (st HbSync) HbSync block IO + -- , IsKey HbSync, Key HbSync ~ h + ) + => st HbSync + -> PeerCredentials e -- owner keyring + -> (h) -- channel id + -> (Maybe (h) -> IO (h)) + -> IO () +modifyLinearRef ss kr chh modIO = do + g :: RefGenesis e <- (((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock ss chh) + `orDie` "can not read channel ref genesis" + when (refOwner g /= _peerSignPk kr) do + (pure Nothing) `orDie` "channel ref owner does not match genesis owner" + mrefvalraw <- readLinkRaw ss chh + lmr <- case mrefvalraw of + Nothing -> do + val <- modIO Nothing + pure LinearMutableRef + { lrefId = chh + , lrefHeight = 0 + , lrefVal = val + } + Just refvalraw -> do + -- assert lrefId == h + LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) + <- pure ((either (const Nothing) Just . deserialiseOrFail) refvalraw) + `orDie` "can not parse channel ref" + val <- modIO (Just (lrefVal ref)) + pure LinearMutableRef + { lrefId = chh + , lrefHeight = lrefHeight ref + 1 + , lrefVal = val + } + (writeLinkRaw ss chh . serialise) + (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) + `orDie` "can not write link" + pure () + +modifyNodeLinearRefList :: forall e st block h. + ( e ~ [h] + , h ~ Hash HbSync + , Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + , Block block ~ LBS.ByteString + , Storage (st HbSync) HbSync block IO + -- , IsKey HbSync, Key HbSync ~ h + ) + => st HbSync -> PeerCredentials e -> h -> ([h] -> [h]) -> IO () +modifyNodeLinearRefList ss kr chh f = + modifyLinearRef ss kr chh \mh -> do + v <- case mh of + Nothing -> pure mempty + Just h -> fromMaybe mempty . ((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock ss h + (putBlock ss . serialise) (f v) + `orDie` "can not put new node channel list block" + +readNodeLinearRefList :: forall e st block h. + ( e ~ [h] + , h ~ Hash HbSync + , Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + , Block block ~ LBS.ByteString + , Storage (st HbSync) HbSync block IO + -- , IsKey HbSync, Key HbSync ~ h + ) + => st HbSync -> PubKey 'Sign e -> IO [h] +readNodeLinearRefList ss pk = do + -- полученный хэш будет хэшем ссылки на список референсов ноды + lrh :: h <- pure $ (hashObject . serialise) (nodeLinearRefsRef @e pk) + readLinkRaw ss lrh >>= \case + Nothing -> pure [] + Just refvalraw -> do + LinearMutableRefSigned _ ref + <- pure ((either (const Nothing) Just . deserialiseOrFail @(Signed SignaturePresent (MutableRef e 'LinearRef))) refvalraw) + `orDie` "can not parse channel ref" + fromMaybe mempty . ((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock ss (lrefVal ref) + +nodeRefListAdd :: forall e st block h. + ( e ~ [h] + , h ~ Hash HbSync + , Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + , Block block ~ LBS.ByteString + , Storage (st HbSync) HbSync block IO + -- , IsKey HbSync, Key HbSync ~ h + ) + => st HbSync -> PeerCredentials e -> h -> IO () +nodeRefListAdd ss nodeCred chh = do + -- полученный хэш будет хэшем ссылки на список референсов ноды + lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred)) + `orDie` "can not create node refs genesis" + modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index be0dcbbf..7dc43b67 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -25,6 +25,7 @@ import HBS2.Net.Proto.RefLinear import HBS2.Net.Proto.Sessions import HBS2.OrDie import HBS2.Prelude.Plated +import HBS2.Refs.Linear import HBS2.Storage.Simple import HBS2.System.Logger.Simple hiding (info) diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 09af43a5..e71f01c7 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -8,14 +8,15 @@ import HBS2.Merkle import HBS2.Net.Auth.AccessKey import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.UDP (UDP) +import HBS2.Net.Proto.ACB import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Types +import HBS2.OrDie import HBS2.Prelude import HBS2.Prelude.Plated +import HBS2.Refs.Linear import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra -import HBS2.OrDie -import HBS2.Net.Proto.ACB import Control.Arrow ((&&&)) @@ -321,29 +322,14 @@ runDumpACB inFile = do runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO () runNewLRef nf uf refName ss = do hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf - nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf) + nodeCred <- (parseCredentials . AsCredFile <$> BS.readFile nf) `orDie` "bad node keyring file" - ownerCred <- (parseCredentials @MerkleEncryptionType . AsCredFile <$> BS.readFile uf) + ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" - -- FIXME: extract reusable functions - -- полученный хэш будет хэшем ссылки на список референсов ноды - lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @[HashRef] (_peerSignPk nodeCred)) - `orDie` "can not create node refs genesis" -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData) `orDie` "can not put channel genesis block" - modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList - print $ "channel ref:" <+> pretty chh - -modifyNodeLinearRefList :: (Signatures e, Serialise (Signature e)) - => SimpleStorage HbSync -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () -modifyNodeLinearRefList ss kr chh f = - modifyLinearRef ss kr chh \mh -> do - v <- case mh of - Nothing -> pure mempty - Just h -> fromMaybe mempty . mdeserialiseMay <$> getBlock ss h - (putBlock ss . serialise) (f v) - `orDie` "can not put new node channel list block" + nodeRefListAdd ss nodeCred chh runListLRef :: FilePath -> SimpleStorage HbSync -> IO () runListLRef nf ss = do @@ -369,56 +355,6 @@ runListLRef nf ss = do print $ "height: " <+> viaShow (lrefHeight ref) print $ "val: " <+> pretty (lrefVal ref) -readNodeLinearRefList :: forall e. (e ~ UDP) - => SimpleStorage HbSync -> PubKey 'Sign e -> IO [Hash HbSync] -readNodeLinearRefList ss pk = do - -- полученный хэш будет хэшем ссылки на список референсов ноды - lrh :: Hash HbSync <- pure do - (hashObject . serialise) (nodeLinearRefsRef @e pk) - simpleReadLinkRaw ss lrh >>= \case - Nothing -> pure [] - Just refvalraw -> do - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw) - `orDie` "can not parse channel ref" - fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref) - -modifyLinearRef :: forall e. (Signatures e, Serialise (Signature e)) - => SimpleStorage HbSync - -> PeerCredentials e -- owner keyring - -> Hash HbSync -- channel id - -> (Maybe (Hash HbSync) -> IO (Hash HbSync)) - -> IO () -modifyLinearRef ss kr chh modIO = do - g :: RefGenesis [Hash HbSync] <- (mdeserialiseMay <$> getBlock ss chh) - `orDie` "can not read channel ref genesis" - when (refOwner g /= _peerSignPk kr) do - (pure Nothing) `orDie` "channel ref owner does not match genesis owner" - mrefvalraw <- simpleReadLinkRaw ss chh - lmr <- case mrefvalraw of - Nothing -> do - val <- modIO Nothing - pure LinearMutableRef - { lrefId = chh - , lrefHeight = 0 - , lrefVal = val - } - Just refvalraw -> do - -- assert lrefId == h - LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) - <- pure (deserialiseMay refvalraw) - `orDie` "can not parse channel ref" - val <- modIO (Just (lrefVal ref)) - pure LinearMutableRef - { lrefId = chh - , lrefHeight = lrefHeight ref + 1 - , lrefVal = val - } - (simpleWriteLinkRaw ss chh . serialise) - (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) - `orDie` "can not write link" - pure () - runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO () runGetLRef refh ss = do hPrint stderr $ "getting ref value" <+> pretty refh @@ -433,7 +369,7 @@ runGetLRef refh ss = do runUpdateLRef :: FilePath -> Hash HbSync -> Hash HbSync -> SimpleStorage HbSync -> IO () runUpdateLRef uf refh valh ss = do hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh - ownerCred <- (parseCredentials @MerkleEncryptionType . AsCredFile <$> BS.readFile uf) + ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" modifyLinearRef ss ownerCred refh \_ -> pure valh