mirror of https://github.com/voidlizard/hbs2
87 lines
2.6 KiB
Haskell
87 lines
2.6 KiB
Haskell
{-# Language TemplateHaskell #-}
|
||
{-# Language UndecidableInstances #-}
|
||
module HBS2.Net.Proto.RefLinear where
|
||
|
||
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 (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
|
||
import Type.Reflection (someTypeRep)
|
||
|
||
|
||
newtype AnnLRefNonce = AnnLRefNonce Word64
|
||
deriving newtype (Num,Enum,Real,Integral)
|
||
deriving stock (Ord,Eq,Generic,Show)
|
||
|
||
instance Serialise AnnLRefNonce
|
||
|
||
|
||
data LRef e
|
||
= AnnLRef (Hash HbSync) (Signed SignaturePresent (MutableRef e 'LinearRef))
|
||
deriving stock (Generic)
|
||
|
||
instance Serialise (Signature e) => Serialise (LRef e)
|
||
|
||
data LRefI e m =
|
||
LRefI
|
||
{ getBlockI :: GetBlockI HbSync m
|
||
, tryUpdateLinearRefI :: TryUpdateLinearRefI e HbSync 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
|
||
, 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
|
||
-- deriving stock (Typeable, Eq,Generic)
|
||
|
||
-- data instance Event e (LRef e) =
|
||
-- AnnLRefEvent (Peer e) (AnnLRefInfo e) PeerNonce
|
||
-- deriving stock (Typeable)
|
||
|
||
-- 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 ( LRef e) ) where
|
||
-- isPersistent = True
|