voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Sergey Ivanov 2023-03-06 17:54:41 +04:00
parent beb3015a53
commit ecf97b1e9c
6 changed files with 175 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hbs2-core/hbs2-core.cabal
View File

@ -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

12
hbs2-core/lib/HBS2/Net/Proto/Definition.hs
View File

@ -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

42
hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs
View File

@ -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

132
hbs2-core/lib/HBS2/Refs/Linear.hs Normal file
View File

@ -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

1
hbs2-peer/app/PeerMain.hs
View File

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

78
hbs2/Main.hs
View File

@ -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