diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index d86c5fa0..4fc88c82 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -52,6 +52,7 @@ common shared-properties , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes + , RecordWildCards , ScopedTypeVariables , StandaloneDeriving , TupleSections diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index f39e6e2a..55f43170 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -1,4 +1,3 @@ -{-# Language DuplicateRecordFields #-} {-# Language UndecidableInstances #-} module HBS2.Data.Types.Refs ( module HBS2.Data.Types.Refs @@ -107,8 +106,8 @@ data family Signed ( p :: SignPhase ) a data instance Signed SignaturePresent (MutableRef e 'LinearRef) = LinearMutableRefSigned - { signature :: Signature e - , signedRef :: MutableRef e 'LinearRef + { lmrefSignature :: Signature e + , lmrefSignedRef :: MutableRef e 'LinearRef } deriving stock (Generic) @@ -117,9 +116,9 @@ instance Serialise (Signature e) => data instance Signed 'SignatureVerified (MutableRef e 'LinearRef) = LinearMutableRefSignatureVerified - { signature :: Signature e - , signedRef :: MutableRef e 'LinearRef - , signer :: PubKey 'Sign e + { lmrefVSignature :: Signature e + , lmrefVSignedRef :: MutableRef e 'LinearRef + , lmrefVSigner :: PubKey 'Sign e } deriving stock (Generic) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs index 963cfd00..5ade7e23 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs @@ -2,15 +2,18 @@ {-# Language UndecidableInstances #-} module HBS2.Net.Proto.RefLinear where --- import HBS2.Actors.Peer import HBS2.Data.Types.Refs import HBS2.Hash import HBS2.Net.Auth.Credentials import HBS2.Net.Proto import HBS2.Prelude.Plated +import HBS2.Refs.Linear -import Codec.Serialise() +import Codec.Serialise (serialise, deserialiseOrFail) +import Control.Monad +import Control.Monad.Trans.Maybe import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as LBS import Data.Hashable import Data.Word import Lens.Micro.Platform @@ -30,39 +33,41 @@ data LRef e instance Serialise (Signature e) => Serialise (LRef e) -data AnnLRefI e m = - AnnLRefI - { blkSize :: GetBlockSize HbSync m +data LRefI e m = + LRefI + { getBlockI :: GetBlockI HbSync m + , tryUpdateLinearRefI :: TryUpdateLinearRefI e HbSync m } -refLinearProto :: forall e m . ( MonadIO 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 - => LRef e - -> m () -refLinearProto = \case +type GetBlockI h m = Hash h -> m (Maybe ByteString) --- Анонс ссылки (уведомление о новом состоянии без запроса) - AnnLRef h (LinearMutableRefSigned{}) -> do +type TryUpdateLinearRefI e h m = Hash h -> Signed SignatureVerified (MutableRef e 'LinearRef) -> m Bool - -- 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) +refLinearProto :: forall e m . + ( MonadIO m + , Response e (LRef e) m + , HasCredentials e m + , Serialise (PubKey 'Sign e) + , Signatures e + ) + => LRefI e m + -> LRef e + -> m () +refLinearProto LRefI{..} = \case + -- Анонс ссылки (уведомление о новом состоянии без запроса) + AnnLRef h (lref@LinearMutableRefSigned{}) -> do + creds <- getCredentials @e + + void $ runMaybeT do + g :: RefGenesis e <- MaybeT $ + (((either (const Nothing) Just . deserialiseOrFail) =<<) <$> getBlockI h) + + lift $ forM_ (verifyLinearMutableRefSigned (refOwner g) lref) \vlref -> do + r <- tryUpdateLinearRefI h vlref + when r do + -- FIXME: В случае успеха разослать анонс на другие ноды + pure () -- data instance EventKey e (LRef e) = -- AnnLRefInfoKey diff --git a/hbs2-core/lib/HBS2/Refs/Linear.hs b/hbs2-core/lib/HBS2/Refs/Linear.hs index f9d3aea0..1a0008fe 100644 --- a/hbs2-core/lib/HBS2/Refs/Linear.hs +++ b/hbs2-core/lib/HBS2/Refs/Linear.hs @@ -34,7 +34,7 @@ modifyLinearRef :: forall e st block h. ) => st HbSync -> PeerCredentials e -- owner keyring - -> (h) -- channel id + -> h -- channel id -> (Maybe (h) -> IO (h)) -> IO () modifyLinearRef ss kr chh modIO = do @@ -53,10 +53,10 @@ modifyLinearRef ss kr chh modIO = do , 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" + -- guard $ lrefId ref == chh val <- modIO (Just (lrefVal ref)) pure LinearMutableRef { lrefId = chh @@ -68,6 +68,55 @@ modifyLinearRef ss kr chh modIO = do `orDie` "can not write link" pure () +verifyLinearMutableRefSigned :: forall e. (Signatures e) + => PubKey 'Sign e + -> Signed SignaturePresent (MutableRef e 'LinearRef) + -> Maybe (Signed SignatureVerified (MutableRef e 'LinearRef)) +verifyLinearMutableRefSigned pk lref = do + guard $ verifySign @e pk (lmrefSignature lref) dat + pure (LinearMutableRefSignatureVerified (lmrefSignature lref) (lmrefSignedRef lref) pk) + where + dat = (LBS.toStrict . serialise) (lmrefSignedRef lref) + +tryUpdateLinearRef :: 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 + -> h -- channel id + -> Signed SignatureVerified (MutableRef e 'LinearRef) + -> IO Bool +tryUpdateLinearRef ss chh vlref = do + g :: RefGenesis e <- (((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock ss chh) + `orDie` "can not read channel ref genesis" + when (refOwner g /= lmrefVSigner vlref) do + (pure Nothing) `orDie` "channel ref signer does not match genesis owner" + -- Достать наше текущее значение ссылки, сравнить счётчик + mrefvalraw <- readLinkRaw ss chh + allowUpdate <- case mrefvalraw of + Nothing -> pure True + Just refvalraw -> do + LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) + <- pure ((either (const Nothing) Just . deserialiseOrFail) refvalraw) + `orDie` "can not parse channel ref" + -- Если новое значение больше, обновить его + pure (lrefHeight ref < lrefHeight (lmrefVSignedRef vlref)) + if allowUpdate + then do + (writeLinkRaw ss chh . serialise) + (LinearMutableRefSigned @e (lmrefVSignature vlref) (lmrefVSignedRef vlref)) + `orDie` "can not write link" + pure True + else (pure False) + modifyNodeLinearRefList :: forall e st block h. ( e ~ [h] , h ~ Hash HbSync diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 7dc43b67..88641290 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -360,6 +360,32 @@ forKnownPeers m = do pd' <- find (KnownPeerKey p) id maybe1 pd' (pure ()) (m p) +-- FIXME: implement mkLRefAdapter +mkLRefAdapter :: forall e st block m . + ( m ~ PeerM e IO + -- , e ~ [Hash HbSync] + -- , e ~ UDP + , Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + -- , Block block ~ LBS.ByteString + -- , Storage (st HbSync) HbSync block IO + -- ( m ~ LRefI e (CredentialsM e (ResponseM e (PeerM e IO))) + -- , Pretty (Peer e) + -- , Block ByteString ~ ByteString + ) + => m (LRefI e (CredentialsM e (ResponseM e m))) +mkLRefAdapter = do + st <- getStorage + pure $ + LRefI + { getBlockI = liftIO . getBlock st + -- :: TryUpdateLinearRefI e HbSync m + , tryUpdateLinearRefI = undefined + -- , tryUpdateLinearRefI = \h lvref -> liftIO $ tryUpdateLinearRef (_ st) h lvref + } + runPeer :: forall e . e ~ UDP => PeerOpts -> IO () runPeer opts = Exception.handle myException $ do @@ -465,6 +491,9 @@ runPeer opts = Exception.handle myException $ do runPeerM penv $ do adapter <- mkAdapter + lrefAdapter <- mkLRefAdapter + -- lrefAdapter :: LRefI UDP (CredentialsM UDP (ResponseM UDP (PeerM UDP IO))) + -- <- undefined :: (PeerM UDP IO) (LRefI UDP (CredentialsM UDP (ResponseM UDP (PeerM UDP IO)))) env <- ask pnonce <- peerNonce @e @@ -611,7 +640,7 @@ runPeer opts = Exception.handle myException $ do . deserialiseOrFail @(Signed SignaturePresent (MutableRef e 'LinearRef))) refvalraw) `orLogError` "can not parse channel ref" - let annlref :: AnnLRef UDP + let annlref :: LRef UDP annlref = AnnLRef @e h slref lift do @@ -672,7 +701,7 @@ runPeer opts = Exception.handle myException $ do , makeResponse blockAnnounceProto , makeResponse (withCredentials pc . peerHandShakeProto) , makeResponse peerExchangeProto - , makeResponse refLinearProto + , makeResponse (withCredentials pc . refLinearProto lrefAdapter) ] void $ liftIO $ waitAnyCatchCancel workers diff --git a/hbs2/Main.hs b/hbs2/Main.hs index e71f01c7..14a6bb70 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -327,6 +327,7 @@ runNewLRef nf uf refName ss = do ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred + -- Это тоже перенести в Refs.hs ? chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData) `orDie` "can not put channel genesis block" nodeRefListAdd ss nodeCred chh