wip

hbs2-core/hbs2-core.cabal

@@ -52,6 +52,7 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections

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
+  { lmrefSignature :: Signature e
-  , signedRef :: MutableRef e 'LinearRef
+  , 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
+  { lmrefVSignature :: Signature e
-  , signedRef :: MutableRef e 'LinearRef
+  , lmrefVSignedRef :: MutableRef e 'LinearRef
-  , signer :: PubKey 'Sign e
+  , lmrefVSigner :: PubKey 'Sign e
   }
   deriving stock (Generic)
 

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 =
+data LRefI e m =
-  AnnLRefI
+  LRefI
-  { blkSize         :: GetBlockSize HbSync m
+  { 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
+    , HasCredentials e m
---                                     , Response e (LRef e) m
+    , Serialise (PubKey 'Sign e)
-                                  -- , HasDeferred e (LRef e) m
+    , Signatures e
-                                  -- , HasOwnPeer e m
-                                  -- , Pretty (Peer e)
     )
-                 -- => RefLinearI e m
+    => LRefI e m
-                 => LRef e
+    -> 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) =<<)
+        void $ runMaybeT do
-        --     <$> getBlock ss chh)
+            g :: RefGenesis e <- MaybeT $
-        -- Проверить подпись ссылки
+                (((either (const Nothing) Just . deserialiseOrFail) =<<) <$> getBlockI h)
-        -- Достать наше текущее значение ссылки, сравнить счётчик
-        -- Если новое значение больше, обновить его
-        -- И разослать анонс на другие ноды
-        undefined
-        --
---     AnnLRef n info -> do
---       that <- thatPeer (Proxy @(AnnLRef e))
---       emit @e AnnLRefInfoKey (AnnLRefEvent that info n)
 
+            lift $ forM_ (verifyLinearMutableRefSigned (refOwner g) lref) \vlref -> do
+                r <- tryUpdateLinearRefI h vlref
+                when r do
+                    -- FIXME: В случае успеха разослать анонс на другие ноды
+                    pure ()
 
 -- data instance EventKey e (LRef e) =
 --   AnnLRefInfoKey

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

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

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