wip

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

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
+instance HasProtocol UDP (LRef UDP) where
-  type instance ProtocolId (AnnLRef UDP) = 7
+  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
+
 
 

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)
 
-
+data AnnLRefI e m =
--- annLRefProto :: forall e m  . ( MonadIO m
+  AnnLRefI
---                                     , EventEmitter e (AnnLRef e) m
+  { blkSize         :: GetBlockSize HbSync m
---                                     , Response e (AnnLRef e) m
+  }
---                                     ) => AnnLRef e -> m ()
 
 refLinearProto :: forall e m  . ( MonadIO m
-                                  , Response e (AnnLRef e) m
+                                  , Response e (LRef e) m
-                                  -- , HasDeferred e (AnnLRef 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
+                 => LRef e
-                 => AnnLRef 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

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

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)

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
+  nodeRefListAdd ss nodeCred chh
-  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"
 
 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