wip

2023-03-07 04:11:17 +04:00 · 2023-03-07 04:11:17 +04:00 · aa76b28b1a
parent ecf97b1e9c
commit aa76b28b1a
6 changed files with 124 additions and 40 deletions
--- 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
--- 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)

--- 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
+type GetBlockI h m = Hash h -> m (Maybe ByteString)
+
+type TryUpdateLinearRefI e h m = Hash h -> Signed SignatureVerified (MutableRef e 'LinearRef) -> m Bool
+
+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)
+    , HasCredentials e m
+    , Serialise (PubKey 'Sign e)
+    , Signatures e
    )
-                 -- => RefLinearI e m
-                 => LRef e
+    => LRefI e m
+    -> LRef e
    -> m ()
-refLinearProto = \case
+refLinearProto LRefI{..} = \case

    -- Анонс ссылки (уведомление о новом состоянии без запроса)
-    AnnLRef h (LinearMutableRefSigned{}) -> do
+    AnnLRef h (lref@LinearMutableRefSigned{}) -> do
+        creds <- getCredentials @e

-        -- 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)
+        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
--- 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
--- 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
--- 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