diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index f40016ca..626b81d9 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -2,6 +2,7 @@ {-# Language AllowAmbiguousTypes #-} {-# Language TemplateHaskell #-} {-# Language FunctionalDependencies #-} +{-# LANGUAGE ImplicitParams #-} module HBS2.Net.Proto.RefChan where import HBS2.Prelude.Plated @@ -125,6 +126,25 @@ data AcceptTran e = AcceptTran HashRef HashRef -- ссылка на (ProposTran instance ForRefChans e => Serialise (ProposeTran e) instance ForRefChans e => Serialise (AcceptTran e) + +data RefChanRound e = + RefChanRound + { _refChanKey :: HashRef -- ^ hash of the Propose transaction + , _refChanRound :: HashMap (PubKey 'Sign (Encryption e)) () + } + deriving stock (Typeable, Generic) + +newtype instance SessionKey e (RefChanRound e) = + RefChanRoundKey HashRef + deriving stock (Generic, Typeable) + +type instance SessionData e (RefChanRound e) = RefChanRound e + +-- TODO: find-out-proper-timeout +-- например, wait * 2 +instance Expires (SessionKey e (RefChanRound e)) where + expiresIn _ = Just 600 + -- TODO: find-out-sure-transaction-size -- транзакция должна быть маленькая! -- хочешь что-то большое просунуть -- шли хэши. @@ -313,11 +333,8 @@ refChanUpdateProto self pc adapter msg = do headBlock <- MaybeT $ getActualRefChanHead @e refchanKey let pips = view refChanHeadPeers headBlock - let aus = view refChanHeadAuthors headBlock - guard ( peerKey `HashMap.member` pips ) - - guard ( authorKey `HashSet.member` aus ) + guard $ checkACL headBlock peerKey authorKey debug $ "OMG!!! TRANS AUTHORIZED" <+> pretty (AsBase58 peerKey) <+> pretty (AsBase58 authorKey) @@ -348,10 +365,51 @@ refChanUpdateProto self pc adapter msg = do -- -- рассылаем ли себе? что бы был хоть один accept lift $ refChanUpdateProto True pc adapter accept - Accept chan box -> do + pure () + + Accept chan box -> deferred proto do guard =<< lift (refChanHeadSubscribed adapter chan) + debug "RefChanUpdate/ACCEPT" + (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box + + let refchanKey = RefChanHeadKey @s chan + h <- MaybeT $ liftIO $ getRef sto refchanKey + + guard (HashRef h == headRef) + + lift $ gossip msg + + tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef) + + tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just + + headBlock <- MaybeT $ getActualRefChanHead @e refchanKey + + -- -- TODO: additional-validation + -- -- можно бы проверить транзакцию еще раз, + -- -- но можно считать, что раз мы её записали, + -- -- то она годная + proposed <- MaybeT $ pure $ case tran of + Propose _ pbox -> Just pbox + _ -> Nothing + + + (peerKey, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed + + -- compiler bug? + let (ProposeTran _ pbox) = ptran + + (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox + + -- может и не надо второй раз проверять + guard $ checkACL headBlock peerKey authorKey + + debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef + + pure () + -- TODO: implement-accept -- проверяем подпись пира -- смотрим, что такая транза у нас вообще есть @@ -362,6 +420,16 @@ refChanUpdateProto self pc adapter msg = do where proto = Proxy @(RefChanUpdate e) + checkACL :: RefChanHeadBlock e + -> PubKey 'Sign s + -> PubKey 'Sign s + -> Bool + checkACL theHead peerKey authorKey = match + where + pips = view refChanHeadPeers theHead + aus = view refChanHeadAuthors theHead + match = peerKey `HashMap.member` pips + && authorKey `HashSet.member` aus getActualRefChanHead :: forall e s m . ( MonadIO m , Sessions e (RefChanHeadBlock e) m