mirror of https://github.com/voidlizard/hbs2
current refchan-notify and multiple fixes
This commit is contained in:
Dmitry Zuikov
parent
71e325f8bc
commit
7274c6ceeb
|
|
@ -1,2 +0,0 @@
|
|||
|
||||
(fixme-set "workflow" "test" "3nmxU5Ro8b")
|
||||
|
|
@ -1,3 +1,7 @@
|
|||
## 2023-07-30
|
||||
|
||||
какие-то косяки
|
||||
|
||||
## 2023-07-25
|
||||
|
||||
кажется, git push --force что-то портит
|
||||
|
|
|
|||
|
|
@ -92,6 +92,7 @@ library
|
|||
, HBS2.Net.Messaging.Fake
|
||||
, HBS2.Net.Messaging.UDP
|
||||
, HBS2.Net.Messaging.TCP
|
||||
, HBS2.Net.Messaging.Unix
|
||||
, HBS2.Net.PeerLocator
|
||||
, HBS2.Net.PeerLocator.Static
|
||||
, HBS2.Net.Proto
|
||||
|
|
|
|||
|
|
@ -277,16 +277,6 @@ instance ( MonadIO m
|
|||
se <- asks (view envSessions)
|
||||
liftIO $ Cache.delete se (newSKey @(SessionKey e p) k)
|
||||
|
||||
class HasProtocol e p => HasTimeLimits e p m where
|
||||
tryLockForPeriod :: Peer e -> p -> m Bool
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
(MonadIO (t m), Monad m, MonadTrans t, HasProtocol e p, HasTimeLimits e p m) => HasTimeLimits e p (t m) where
|
||||
tryLockForPeriod p m = lift (tryLockForPeriod p m)
|
||||
-- pure True
|
||||
-- liftIO $ print "LIMIT DOES NOT WORK"
|
||||
-- pure True
|
||||
|
||||
instance (MonadIO m, HasProtocol e p, Hashable (Encoded e))
|
||||
=> HasTimeLimits e p (PeerM e m) where
|
||||
tryLockForPeriod peer msg = case requestPeriodLim @e @p of
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Actors.Peer.Types where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Storage
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Hash
|
||||
|
|
@ -10,6 +11,17 @@ import Control.Monad.Trans.Maybe
|
|||
import Data.ByteString.Lazy (ByteString)
|
||||
|
||||
|
||||
class HasProtocol e p => HasTimeLimits e p m where
|
||||
tryLockForPeriod :: Peer e -> p -> m Bool
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
(MonadIO (t m), Monad m, MonadTrans t, HasProtocol e p, HasTimeLimits e p m) => HasTimeLimits e p (t m) where
|
||||
tryLockForPeriod p m = lift (tryLockForPeriod p m)
|
||||
-- pure True
|
||||
-- liftIO $ print "LIMIT DOES NOT WORK"
|
||||
-- pure True
|
||||
|
||||
|
||||
instance (IsKey HbSync) => Storage AnyStorage HbSync ByteString IO where
|
||||
putBlock (AnyStorage s) = putBlock s
|
||||
enqueueBlock (AnyStorage s) = enqueueBlock s
|
||||
|
|
|
|||
|
|
@ -0,0 +1,230 @@
|
|||
module HBS2.Net.Messaging.Unix where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Net.Messaging
|
||||
import HBS2.Clock
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Monad.Trans.Resource
|
||||
import Control.Monad
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
import Data.Hashable
|
||||
import Data.List qualified as List
|
||||
import Network.ByteOrder hiding (ByteString)
|
||||
import Network.Socket
|
||||
import Network.Socket.ByteString
|
||||
import Control.Concurrent.STM.TQueue (flushTQueue)
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set
|
||||
import UnliftIO
|
||||
|
||||
data UNIX
|
||||
|
||||
{- HLINT ignore "Use newtype instead of data" -}
|
||||
data MessagingUnixOpts =
|
||||
MUWatchdog Int
|
||||
deriving (Eq,Ord,Show,Generic,Data)
|
||||
|
||||
-- FIXME: use-bounded-queues
|
||||
data MessagingUnix =
|
||||
MessagingUnix
|
||||
{ msgUnixSockPath :: FilePath
|
||||
, msgUnixServer :: Bool
|
||||
, msgUnixRetryTime :: Timeout 'Seconds
|
||||
, msgUnixSelf :: Peer UNIX
|
||||
, msgUnixOpts :: Set MessagingUnixOpts
|
||||
, msgUnixInbox :: TQueue ByteString
|
||||
, msgUnixRecv :: TQueue (From UNIX, ByteString)
|
||||
, msgUnixLast :: TVar TimeSpec
|
||||
, msgUnixAccepts :: TVar Int
|
||||
}
|
||||
|
||||
|
||||
|
||||
newMessagingUnix :: MonadIO m
|
||||
=> Bool
|
||||
-> Timeout 'Seconds
|
||||
-> FilePath
|
||||
-> m MessagingUnix
|
||||
|
||||
newMessagingUnix server tsec path = do
|
||||
newMessagingUnixOpts mempty server tsec path
|
||||
|
||||
newMessagingUnixOpts :: MonadIO m
|
||||
=> [MessagingUnixOpts]
|
||||
-> Bool
|
||||
-> Timeout 'Seconds
|
||||
-> FilePath
|
||||
-> m MessagingUnix
|
||||
|
||||
newMessagingUnixOpts opts server tsec path = do
|
||||
let sa = SockAddrUnix path
|
||||
now <- getTimeCoarse
|
||||
MessagingUnix path
|
||||
server
|
||||
tsec
|
||||
(PeerUNIX sa)
|
||||
(Set.fromList opts)
|
||||
<$> liftIO newTQueueIO
|
||||
<*> liftIO newTQueueIO
|
||||
<*> liftIO (newTVarIO now)
|
||||
<*> liftIO (newTVarIO 0)
|
||||
|
||||
instance HasPeer UNIX where
|
||||
newtype instance Peer UNIX = PeerUNIX {fromPeerUnix :: SockAddr}
|
||||
deriving stock (Eq,Ord,Show,Generic)
|
||||
deriving newtype (Pretty)
|
||||
|
||||
instance IsString (Peer UNIX) where
|
||||
fromString p = PeerUNIX (SockAddrUnix p)
|
||||
|
||||
-- FIXME: fix-code-dup?
|
||||
instance Hashable (Peer UNIX) where
|
||||
hashWithSalt salt p = case fromPeerUnix p of
|
||||
SockAddrInet pn h -> hashWithSalt salt (4, fromIntegral pn, h)
|
||||
SockAddrInet6 pn _ h _ -> hashWithSalt salt (6, fromIntegral pn, h)
|
||||
SockAddrUnix s -> hashWithSalt salt ("unix", s)
|
||||
|
||||
|
||||
data ReadTimeoutException = ReadTimeoutException deriving (Show, Typeable)
|
||||
|
||||
instance Exception ReadTimeoutException
|
||||
|
||||
|
||||
runMessagingUnix :: MonadUnliftIO m => MessagingUnix -> m ()
|
||||
runMessagingUnix env = do
|
||||
|
||||
if msgUnixServer env then
|
||||
runServer
|
||||
else
|
||||
runClient
|
||||
|
||||
where
|
||||
|
||||
runServer = forever $ handleAny cleanupAndRetry $ runResourceT do
|
||||
|
||||
t0 <- getTimeCoarse
|
||||
atomically $ writeTVar (msgUnixLast env) t0
|
||||
|
||||
sock <- liftIO $ socket AF_UNIX Stream defaultProtocol
|
||||
|
||||
void $ allocate (pure sock) (`shutdown` ShutdownBoth)
|
||||
|
||||
liftIO $ bind sock $ SockAddrUnix (msgUnixSockPath env)
|
||||
liftIO $ listen sock 1
|
||||
|
||||
watchdog <- async $ do
|
||||
|
||||
let mwd = headMay [ n | MUWatchdog n <- Set.toList (msgUnixOpts env) ]
|
||||
|
||||
maybe1 mwd (forever (pause @'Seconds 60)) $ \wd -> do
|
||||
|
||||
forever do
|
||||
|
||||
pause $ TimeoutSec $ realToFrac $ min (wd `div` 2) 1
|
||||
|
||||
now <- getTimeCoarse
|
||||
seen <- readTVarIO (msgUnixLast env)
|
||||
acc <- readTVarIO (msgUnixAccepts env)
|
||||
|
||||
trace $ "watchdog" <+> pretty now <+> pretty seen <+> pretty acc
|
||||
|
||||
let diff = toNanoSeconds $ TimeoutTS (now - seen)
|
||||
|
||||
when ( acc > 0 && diff >= toNanoSeconds (TimeoutSec $ realToFrac wd) ) do
|
||||
throwIO ReadTimeoutException
|
||||
|
||||
run <- async $ forever $ runResourceT do
|
||||
(so, sa) <- liftIO $ accept sock
|
||||
|
||||
atomically $ modifyTVar (msgUnixAccepts env) succ
|
||||
|
||||
void $ allocate (pure so) close
|
||||
|
||||
writer <- async $ forever do
|
||||
msg <- liftIO . atomically $ readTQueue (msgUnixInbox env)
|
||||
let len = fromIntegral $ LBS.length msg :: Int
|
||||
liftIO $ sendAll so $ bytestring32 (fromIntegral len)
|
||||
liftIO $ sendAll so $ LBS.toStrict msg
|
||||
|
||||
void $ allocate (pure writer) cancel
|
||||
|
||||
link writer
|
||||
|
||||
fix \next -> do
|
||||
-- FIXME: timeout-hardcode
|
||||
frameLen <- liftIO $ recv so 4 <&> word32 <&> fromIntegral
|
||||
frame <- liftIO $ recv so frameLen
|
||||
atomically $ writeTQueue (msgUnixRecv env) (From (PeerUNIX sa), LBS.fromStrict frame)
|
||||
now <- getTimeCoarse
|
||||
atomically $ writeTVar (msgUnixLast env) now
|
||||
next
|
||||
|
||||
(_, r) <- waitAnyCatchCancel [run, watchdog]
|
||||
|
||||
case r of
|
||||
Left e -> throwIO e
|
||||
Right{} -> pure ()
|
||||
|
||||
|
||||
runClient = liftIO $ forever $ handleAny logAndRetry $ runResourceT do
|
||||
|
||||
sock <- liftIO $ socket AF_UNIX Stream defaultProtocol
|
||||
|
||||
void $ allocate (pure sock) close
|
||||
|
||||
let sa = SockAddrUnix (msgUnixSockPath env)
|
||||
|
||||
let attemptConnect = do
|
||||
result <- liftIO $ try $ connect sock $ SockAddrUnix (msgUnixSockPath env)
|
||||
case result of
|
||||
Right _ -> return ()
|
||||
Left (e :: SomeException) -> do
|
||||
pause (msgUnixRetryTime env)
|
||||
warn $ "MessagingUnix. failed to connect" <+> pretty sa <+> viaShow e
|
||||
attemptConnect
|
||||
|
||||
attemptConnect
|
||||
|
||||
reader <- async $ forever do
|
||||
-- Read response from server
|
||||
frameLen <- liftIO $ recv sock 4 <&> word32 <&> fromIntegral
|
||||
frame <- liftIO $ recv sock frameLen
|
||||
atomically $ writeTQueue (msgUnixRecv env) (From (PeerUNIX sa), LBS.fromStrict frame)
|
||||
|
||||
forever do
|
||||
msg <- liftIO . atomically $ readTQueue (msgUnixInbox env)
|
||||
let len = fromIntegral $ LBS.length msg :: Int
|
||||
liftIO $ sendAll sock $ bytestring32 (fromIntegral len)
|
||||
liftIO $ sendAll sock $ LBS.toStrict msg
|
||||
|
||||
void $ waitAnyCatchCancel [reader]
|
||||
|
||||
cleanupAndRetry e = liftIO do
|
||||
warn $ "MessagingUnix. client seems gone. restaring server" <+> pretty (msgUnixSelf env)
|
||||
err (viaShow e)
|
||||
atomically $ writeTVar (msgUnixAccepts env) 0
|
||||
liftIO $ atomically $ void $ flushTQueue (msgUnixInbox env)
|
||||
liftIO $ atomically $ void $ flushTQueue (msgUnixRecv env)
|
||||
pause (msgUnixRetryTime env)
|
||||
|
||||
logAndRetry :: SomeException -> IO ()
|
||||
logAndRetry e = do
|
||||
warn $ "MessagingUnix. runClient failed, probably server is gone. Retrying:" <+> pretty (msgUnixSelf env)
|
||||
err (viaShow e)
|
||||
pause (msgUnixRetryTime env)
|
||||
|
||||
|
||||
instance Messaging MessagingUnix UNIX ByteString where
|
||||
|
||||
sendTo bus (To _) _ msg = liftIO do
|
||||
atomically $ writeTQueue (msgUnixInbox bus) msg
|
||||
|
||||
receive bus _ = liftIO do
|
||||
atomically $ readTQueue (msgUnixRecv bus) <&> List.singleton
|
||||
|
||||
|
|
@ -9,6 +9,7 @@ module HBS2.Net.Proto.Definition
|
|||
import HBS2.Clock
|
||||
import HBS2.Defaults
|
||||
import HBS2.Hash
|
||||
import HBS2.Actors.Peer.Types
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.BlockAnnounce
|
||||
|
|
@ -22,6 +23,7 @@ import HBS2.Net.Proto.PeerExchange
|
|||
import HBS2.Net.Proto.PeerMeta
|
||||
import HBS2.Net.Proto.RefLog
|
||||
import HBS2.Net.Proto.RefChan
|
||||
import HBS2.Net.Messaging.Unix (UNIX)
|
||||
import HBS2.Prelude
|
||||
|
||||
import Control.Monad
|
||||
|
|
@ -39,6 +41,8 @@ import Crypto.Saltine.Core.Box qualified as Encrypt
|
|||
|
||||
type instance Encryption L4Proto = HBS2Basic
|
||||
|
||||
type instance Encryption UNIX = HBS2Basic
|
||||
|
||||
type instance PubKey 'Sign HBS2Basic = Sign.PublicKey
|
||||
type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
|
||||
type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey
|
||||
|
|
@ -191,6 +195,22 @@ instance HasProtocol L4Proto (DialResp L4Proto) where
|
|||
decode = dialRespDecode . BSL.toStrict
|
||||
encode = BSL.fromStrict . dialRespEncode
|
||||
|
||||
|
||||
instance Serialise (RefChanValidate UNIX) => HasProtocol UNIX (RefChanValidate UNIX) where
|
||||
type instance ProtocolId (RefChanValidate UNIX) = 0xFFFA0001
|
||||
type instance Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
instance MonadIO m => HasNonces (RefChanValidate UNIX) m where
|
||||
type instance Nonce (RefChanValidate UNIX) = BS.ByteString
|
||||
newNonce = do
|
||||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
pure $ BS.take 8 n
|
||||
|
||||
instance HasTimeLimits UNIX (RefChanValidate UNIX) IO where
|
||||
tryLockForPeriod _ _ = pure True
|
||||
|
||||
instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
|
||||
expiresIn _ = Just defCookieTimeoutSec
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import Codec.Serialise
|
|||
import Control.Monad.Identity
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Either
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
|
@ -258,12 +259,43 @@ data RefChanNotify e =
|
|||
|
||||
instance ForRefChans e => Serialise (RefChanNotify e)
|
||||
|
||||
type RefChanValidateNonce e = Nonce (RefChanValidate e)
|
||||
|
||||
data RefChanValidate e =
|
||||
RefChanValidate
|
||||
{ rcvNonce :: Nonce (RefChanValidate e)
|
||||
, rcvChan :: RefChanId e
|
||||
, rcvData :: RefChanValidateData e
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
data RefChanValidateData e =
|
||||
Validate HashRef
|
||||
| Accepted HashRef
|
||||
| Rejected HashRef
|
||||
| Poke
|
||||
deriving stock (Generic)
|
||||
|
||||
instance Serialise (RefChanValidateData e)
|
||||
|
||||
instance ( Serialise (PubKey 'Sign (Encryption e))
|
||||
, Serialise (Nonce (RefChanValidate e)) )
|
||||
=> Serialise (RefChanValidate e)
|
||||
|
||||
instance (ForRefChans e, Pretty (AsBase58 (Nonce (RefChanValidate e)))) => Pretty (RefChanValidate e) where
|
||||
pretty (RefChanValidate n c d) = case d of
|
||||
Validate r -> pretty "validate" <+> pretty (AsBase58 n) <+> pretty (AsBase58 c) <+> pretty r
|
||||
Accepted r -> pretty "accepted" <+> pretty (AsBase58 n) <+> pretty (AsBase58 c) <+> pretty r
|
||||
Rejected r -> pretty "rejected" <+> pretty (AsBase58 n) <+> pretty (AsBase58 c) <+> pretty r
|
||||
Poke -> pretty "poke" <+> pretty (AsBase58 n) <+> pretty (AsBase58 c)
|
||||
|
||||
-- FIXME: rename
|
||||
data RefChanAdapter e m =
|
||||
RefChanAdapter
|
||||
{ refChanOnHead :: RefChanId e -> RefChanHeadBlockTran e -> m ()
|
||||
, refChanSubscribed :: RefChanId e -> m Bool
|
||||
, refChanWriteTran :: HashRef -> m ()
|
||||
, refChanValidatePropose :: RefChanId e -> HashRef -> m Bool
|
||||
}
|
||||
|
||||
class HasRefChanId e p | p -> e where
|
||||
|
|
@ -279,6 +311,13 @@ instance HasRefChanId e (RefChanRequest e) where
|
|||
RefChanRequest c -> c
|
||||
RefChanResponse c _ -> c
|
||||
|
||||
instance HasRefChanId e (RefChanNotify e) where
|
||||
getRefChanId = \case
|
||||
Notify c _ -> c
|
||||
|
||||
instance HasRefChanId e (RefChanValidate e) where
|
||||
getRefChanId = rcvChan
|
||||
|
||||
refChanHeadProto :: forall e s m . ( MonadIO m
|
||||
, Request e (RefChanHead e) m
|
||||
, Request e (BlockAnnounce e) m
|
||||
|
|
@ -338,6 +377,7 @@ refChanHeadProto self adapter msg = do
|
|||
|
||||
|
||||
refChanUpdateProto :: forall e s m . ( MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, Request e (RefChanUpdate e) m
|
||||
, Response e (RefChanUpdate e) m
|
||||
, HasDeferred e (RefChanUpdate e) m
|
||||
|
|
@ -422,15 +462,36 @@ refChanUpdateProto self pc adapter msg = do
|
|||
|
||||
let pips = view refChanHeadPeers headBlock
|
||||
|
||||
guard $ checkACL headBlock peerKey authorKey
|
||||
guard $ checkACL headBlock (Just peerKey) authorKey
|
||||
|
||||
debug $ "OMG!!! TRANS AUTHORIZED" <+> pretty (AsBase58 peerKey) <+> pretty (AsBase58 authorKey)
|
||||
|
||||
-- TODO: validate-transaction
|
||||
-- итак, как нам валидировать транзакцию?
|
||||
-- HTTP ?
|
||||
-- TCP ?
|
||||
-- UDP ? (кстати, годно и быстро)
|
||||
-- CLI ?
|
||||
-- получается, риалтайм: ждём не более X секунд валидации,
|
||||
-- иначе не валидируем.
|
||||
-- по хорошему, не блокироваться бы в запросе.
|
||||
-- тут мы зависим от состояния конвейра, нас можно DDoS-ить
|
||||
-- большим количеством запросов и транзакции будут отклоняться
|
||||
-- при большом потоке.
|
||||
-- но решается это.. тадам! PoW! подбором красивых хэшей
|
||||
-- при увеличении нагрузки.
|
||||
-- тогда, правда, в открытой системе работает паттерн -- DDoS
|
||||
-- всех, кроме своих узлов, а свои узлы всё принимают.
|
||||
|
||||
-- для начала: сделаем хук для валидации, которыйне будет делать ничего
|
||||
|
||||
-- если не смогли сохранить транзу, то и Accept разослать
|
||||
-- не сможем
|
||||
-- это правильно, так как транза содержит ссылку на RefChanId
|
||||
-- следовательно, для другого рефчана будет другая транза
|
||||
|
||||
hash <- MaybeT $ liftIO $ putBlock sto (serialise msg)
|
||||
|
||||
ts <- liftIO getTimeCoarse
|
||||
|
||||
let toWait = TimeoutSec (fromIntegral $ 2 * view refChanHeadWaitAccept headBlock)
|
||||
|
|
@ -450,14 +511,31 @@ refChanUpdateProto self pc adapter msg = do
|
|||
lift $ update defRound rcrk id
|
||||
lift $ emit @e RefChanRoundEventKey (RefChanRoundEvent rcrk)
|
||||
|
||||
-- не обрабатывать propose, если он уже в процессе
|
||||
guard (isNothing rndHere)
|
||||
|
||||
-- FIXME: fixed-timeout-is-no-good
|
||||
validated <- either id id <$> lift ( race (pause @'Seconds 5 >> pure False)
|
||||
$ refChanValidatePropose adapter chan (HashRef hash)
|
||||
)
|
||||
-- почему так:
|
||||
-- мы можем тормозить в проверке транзакции,
|
||||
-- другие пиры могут работать быстрее и от них
|
||||
-- может прийти accept.
|
||||
-- так что раунд всё равно нужно завести,
|
||||
-- даже если транза не очень.
|
||||
|
||||
unless validated do
|
||||
maybe1 rndHere none $ \rnd -> do
|
||||
atomically $ writeTVar (view refChanRoundClosed rnd) True
|
||||
liftIO $ delBlock sto hash
|
||||
|
||||
guard validated
|
||||
|
||||
debug $ "TRANS VALIDATED" <+> pretty (AsBase58 chan) <+> pretty hash
|
||||
|
||||
lift $ gossip msg
|
||||
|
||||
-- FIXME: random-delay-to-avoid-race
|
||||
-- выглядит не очень хорошо, 100ms
|
||||
-- и не гарантирует от гонок
|
||||
-- pause @'Seconds 0.25
|
||||
|
||||
-- FIXME: check-if-we-authorized
|
||||
-- проверить, что мы вообще авторизованы
|
||||
-- рассылать ACCEPT
|
||||
|
||||
|
|
@ -480,11 +558,21 @@ refChanUpdateProto self pc adapter msg = do
|
|||
|
||||
Accept chan box -> deferred proto do
|
||||
|
||||
-- что если получили ACCEPT раньше PROPOSE ?
|
||||
-- что если PROPOSE еще обрабатывается?
|
||||
-- надо, короче, блокироваться и ждать тут Propose
|
||||
-- но если блокироваться --- то конвейр вообще
|
||||
-- может встать. что делать?
|
||||
--
|
||||
|
||||
debug $ "RefChanUpdate/ACCEPT" <+> pretty h0
|
||||
|
||||
(peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box
|
||||
|
||||
let refchanKey = RefChanHeadKey @s chan
|
||||
|
||||
headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
|
||||
|
||||
h <- MaybeT $ liftIO $ getRef sto refchanKey
|
||||
|
||||
guard (HashRef h == headRef)
|
||||
|
|
@ -495,7 +583,18 @@ refChanUpdateProto self pc adapter msg = do
|
|||
-- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы
|
||||
-- почти одновременно. ну или не успело записаться. и что делать?
|
||||
|
||||
here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust
|
||||
-- вот прямо тут надо ждать, пока придёт / завершится Propose
|
||||
-- -- или до таймаута
|
||||
|
||||
let afterPropose = runMaybeT do
|
||||
|
||||
here <- fix \next -> do
|
||||
blk <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust
|
||||
if blk then
|
||||
pure blk
|
||||
else do
|
||||
pause @'Seconds 0.25
|
||||
next
|
||||
|
||||
unless here do
|
||||
warn $ "No propose transaction saved yet!" <+> pretty hashRef
|
||||
|
|
@ -504,7 +603,6 @@ refChanUpdateProto self pc adapter msg = do
|
|||
|
||||
tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just
|
||||
|
||||
headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
|
||||
|
||||
proposed <- MaybeT $ pure $ case tran of
|
||||
Propose _ pbox -> Just pbox
|
||||
|
|
@ -521,7 +619,7 @@ refChanUpdateProto self pc adapter msg = do
|
|||
(authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox
|
||||
|
||||
-- может, и не надо второй раз проверять
|
||||
guard $ checkACL headBlock peerKey authorKey
|
||||
guard $ checkACL headBlock (Just peerKey) authorKey
|
||||
|
||||
debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef
|
||||
|
||||
|
|
@ -537,6 +635,8 @@ refChanUpdateProto self pc adapter msg = do
|
|||
|
||||
accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size
|
||||
|
||||
-- FIXME: why-accepts-quorum-on-failed-proposal?
|
||||
|
||||
debug $ "ACCEPTS:" <+> pretty accepts
|
||||
|
||||
closed <- readTVarIO (view refChanRoundClosed rcRound)
|
||||
|
|
@ -554,25 +654,36 @@ refChanUpdateProto self pc adapter msg = do
|
|||
let pips = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList
|
||||
votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys
|
||||
|
||||
debug $ "PIPS" <+> pretty (HashSet.toList pips & fmap AsBase58)
|
||||
debug $ "VOTES" <+> pretty (HashSet.toList votes & fmap AsBase58)
|
||||
|
||||
when (pips `HashSet.isSubsetOf` votes) do
|
||||
debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans)
|
||||
atomically $ writeTVar (view refChanRoundClosed rcRound) True
|
||||
|
||||
-- мы не можем ждать / поллить в deferred потому,
|
||||
-- что мы так забьем конвейр - там сейчас всего 8
|
||||
-- воркеров, и 8 параллельных ждущих запросов
|
||||
-- все остановят.
|
||||
|
||||
let w = TimeoutSec (realToFrac $ view refChanHeadWaitAccept headBlock)
|
||||
void $ lift $ race ( pause (2 * w) ) afterPropose
|
||||
|
||||
where
|
||||
proto = Proxy @(RefChanUpdate e)
|
||||
|
||||
|
||||
checkACL :: forall e s . (Encryption e ~ s, ForRefChans e)
|
||||
=> RefChanHeadBlock e
|
||||
-> PubKey 'Sign s
|
||||
-> Maybe (PubKey 'Sign s)
|
||||
-> PubKey 'Sign s
|
||||
-> Bool
|
||||
|
||||
checkACL theHead peerKey authorKey = match
|
||||
checkACL theHead mbPeerKey authorKey = match
|
||||
where
|
||||
pips = view refChanHeadPeers theHead
|
||||
aus = view refChanHeadAuthors theHead
|
||||
match = peerKey `HashMap.member` pips
|
||||
match = maybe True (`HashMap.member` pips) mbPeerKey
|
||||
&& authorKey `HashSet.member` aus
|
||||
|
||||
-- TODO: refchan-poll-proto
|
||||
|
|
@ -641,14 +752,18 @@ refChanRequestProto self adapter msg = do
|
|||
|
||||
refChanNotifyProto :: forall e s m . ( MonadIO m
|
||||
, Request e (RefChanNotify e) m
|
||||
, Response e (RefChanNotify e) m
|
||||
, HasRefChanId e (RefChanNotify e)
|
||||
, HasDeferred e (RefChanNotify e) m
|
||||
, HasGossip e (RefChanNotify e) m
|
||||
, IsPeerAddr e m
|
||||
, Pretty (Peer e)
|
||||
, Sessions e (RefChanHeadBlock e) m
|
||||
, Sessions e (KnownPeer e) m
|
||||
, HasStorage m
|
||||
, Signatures s
|
||||
, IsRefPubKey s
|
||||
, ForRefChans e
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, s ~ Encryption e
|
||||
)
|
||||
|
|
@ -657,11 +772,38 @@ refChanNotifyProto :: forall e s m . ( MonadIO m
|
|||
-> RefChanNotify e
|
||||
-> m ()
|
||||
|
||||
refChanNotifyProto _ _ _ = do
|
||||
refChanNotifyProto self adapter msg@(Notify rchan box) = do
|
||||
-- аутентифицируем
|
||||
-- проверяем ACL
|
||||
-- пересылаем всем
|
||||
pure ()
|
||||
|
||||
peer <- thatPeer proto
|
||||
|
||||
auth <- find (KnownPeerKey peer) id <&> isJust
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
guard =<< lift (refChanSubscribed adapter rchan)
|
||||
|
||||
guard (self || auth)
|
||||
|
||||
(authorKey, bs) <- MaybeT $ pure $ unboxSignedBox0 box
|
||||
|
||||
let refchanKey = RefChanHeadKey @s rchan
|
||||
headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
|
||||
|
||||
guard $ checkACL headBlock Nothing authorKey
|
||||
|
||||
-- теперь пересылаем по госсипу
|
||||
lift $ gossip msg
|
||||
|
||||
trace $ "refChanNotifyProto" <+> pretty (BS.length bs)
|
||||
|
||||
-- тут надо заслать во внешнее приложение,
|
||||
-- равно как и в остальных refchan-протоколах
|
||||
|
||||
where
|
||||
proto = Proxy @(RefChanNotify e)
|
||||
|
||||
|
||||
getActualRefChanHead :: forall e s m . ( MonadIO m
|
||||
|
|
@ -788,3 +930,8 @@ instance ForRefChans e => Pretty (RefChanHeadBlock e) where
|
|||
|
||||
|
||||
|
||||
-- FIXME: reconnect-validator-client-after-restart
|
||||
-- почему-то сейчас если рестартовать пира,
|
||||
-- но не растартовать валидатор --- то не получится
|
||||
-- повторно соединиться с валидатором.
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ import Data.Maybe
|
|||
pRefChan :: Parser (IO ())
|
||||
pRefChan = hsubparser ( command "head" (info pRefChanHead (progDesc "head commands" ))
|
||||
<> command "propose" (info pRefChanPropose (progDesc "post propose transaction"))
|
||||
<> command "notify" (info pRefChanNotify (progDesc "post notify message"))
|
||||
<> command "fetch" (info pRefChanFetch (progDesc "fetch and sync refchan value"))
|
||||
<> command "get" (info pRefChanGet (progDesc "get refchan value"))
|
||||
)
|
||||
|
|
@ -119,6 +120,23 @@ pRefChanPropose = do
|
|||
else do
|
||||
runRpcCommand opts (REFCHANPROPOSE (puk, serialise box))
|
||||
|
||||
pRefChanNotify :: Parser (IO ())
|
||||
pRefChanNotify = do
|
||||
opts <- pRpcCommon
|
||||
kra <- strOption (long "author" <> short 'a' <> help "author credentials")
|
||||
fn <- optional $ strOption (long "file" <> short 'f' <> help "file")
|
||||
sref <- strArgument (metavar "REFCHAH-REF")
|
||||
pure do
|
||||
sc <- BS.readFile kra
|
||||
puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key"
|
||||
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
|
||||
lbs <- maybe1 fn LBS.getContents LBS.readFile
|
||||
|
||||
let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs)
|
||||
|
||||
runRpcCommand opts (REFCHANNOTIFY (puk, serialise box))
|
||||
|
||||
|
||||
pRefChanGet :: Parser (IO ())
|
||||
pRefChanGet = do
|
||||
|
|
|
|||
|
|
@ -621,6 +621,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
{ refChanOnHead = refChanOnHeadFn rce
|
||||
, refChanSubscribed = isPolledRef @e brains
|
||||
, refChanWriteTran = refChanWriteTranFn rce
|
||||
, refChanValidatePropose = refChanValidateTranFn @e rce
|
||||
}
|
||||
|
||||
let pexFilt pips = do
|
||||
|
|
@ -1131,14 +1132,22 @@ runPeer opts = U.handle (\e -> myException e
|
|||
box <- MaybeT $ pure $ deserialiseOrFail lbs & either (const Nothing) Just
|
||||
proposed <- MaybeT $ makeProposeTran @e pc puk box
|
||||
|
||||
debug $ "PROPOSAL:" <+> pretty (LBS.length (serialise proposed))
|
||||
lift $ broadCastMessage (Propose @e puk proposed)
|
||||
-- debug $ "PROPOSAL:" <+> pretty (LBS.length (serialise proposed))
|
||||
-- lift $ broadCastMessage (Propose @e puk proposed)
|
||||
|
||||
-- FIXME: remove-this-debug-stuff
|
||||
-- или оставить? нода будет сама себе
|
||||
-- консенсус слать тогда. может, и оставить
|
||||
lift $ runResponseM me $ refChanUpdateProto @e True pc refChanAdapter (Propose @e puk proposed)
|
||||
|
||||
let refChanNotifyAction (puk, lbs) = do
|
||||
trace "refChanNotifyAction"
|
||||
void $ liftIO $ async $ withPeerM penv $ do
|
||||
me <- ownPeer @e
|
||||
runMaybeT do
|
||||
box <- MaybeT $ pure $ deserialiseOrFail lbs & either (const Nothing) Just
|
||||
lift $ runResponseM me $ refChanNotifyProto @e True refChanAdapter (Notify @e puk box)
|
||||
|
||||
let refChanGetAction puk = do
|
||||
trace $ "refChanGetAction" <+> pretty (AsBase58 puk)
|
||||
who <- thatPeer (Proxy @(RPC e))
|
||||
|
|
@ -1182,6 +1191,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, rpcOnRefChanGetAnsw = dontHandle -- rpcOnRefChanGetAnsw
|
||||
|
||||
, rpcOnRefChanPropose = refChanProposeAction
|
||||
, rpcOnRefChanNotify = refChanNotifyAction
|
||||
}
|
||||
|
||||
dialReqProtoAdapter <- do
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ data RPCCommand =
|
|||
| REFCHANFETCH (PubKey 'Sign (Encryption L4Proto))
|
||||
| REFCHANGET (PubKey 'Sign (Encryption L4Proto))
|
||||
| REFCHANPROPOSE (PubKey 'Sign (Encryption L4Proto), ByteString)
|
||||
| REFCHANNOTIFY (PubKey 'Sign (Encryption L4Proto), ByteString)
|
||||
|
||||
data RPC e =
|
||||
RPCDie
|
||||
|
|
@ -99,6 +100,7 @@ data RPC e =
|
|||
| RPCRefChanGetAnsw (Maybe (Hash HbSync))
|
||||
|
||||
| RPCRefChanPropose (PubKey 'Sign (Encryption e), ByteString)
|
||||
| RPCRefChanNotify (PubKey 'Sign (Encryption e), ByteString)
|
||||
|
||||
deriving stock (Generic)
|
||||
|
||||
|
|
@ -155,6 +157,7 @@ data RpcAdapter e m =
|
|||
, rpcOnRefChanGetAnsw :: Maybe (Hash HbSync) -> m ()
|
||||
|
||||
, rpcOnRefChanPropose :: (PubKey 'Sign (Encryption e), ByteString) -> m ()
|
||||
, rpcOnRefChanNotify :: (PubKey 'Sign (Encryption e), ByteString) -> m ()
|
||||
}
|
||||
|
||||
newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a }
|
||||
|
|
@ -224,6 +227,7 @@ rpcHandler adapter = \case
|
|||
(RPCRefChanFetch s) -> rpcOnRefChanFetch adapter s
|
||||
|
||||
(RPCRefChanPropose s) -> rpcOnRefChanPropose adapter s
|
||||
(RPCRefChanNotify s) -> rpcOnRefChanNotify adapter s
|
||||
|
||||
data RPCOpt =
|
||||
RPCOpt
|
||||
|
|
@ -258,6 +262,7 @@ runRpcCommand opt = \case
|
|||
REFCHANFETCH s -> withRPC opt (RPCRefChanFetch s)
|
||||
|
||||
REFCHANPROPOSE s -> withRPC opt (RPCRefChanPropose s)
|
||||
REFCHANNOTIFY s -> withRPC opt (RPCRefChanNotify s)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
|
|
@ -323,6 +328,8 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
|
|||
, rpcOnRefChanGetAnsw = (liftIO . putMVar rchangetMVar)
|
||||
|
||||
, rpcOnRefChanPropose = dontHandle
|
||||
|
||||
, rpcOnRefChanNotify = dontHandle
|
||||
}
|
||||
|
||||
prpc <- async $ runRPC udp1 do
|
||||
|
|
@ -426,6 +433,10 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
|
|||
pause @'Seconds 0.25
|
||||
exitSuccess
|
||||
|
||||
RPCRefChanNotify{} -> liftIO do
|
||||
pause @'Seconds 0.25
|
||||
exitSuccess
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
void $ liftIO $ waitAnyCancel [proto]
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ module RefChan (
|
|||
, refChanWorkerEnvDownload
|
||||
, refChanOnHeadFn
|
||||
, refChanWriteTranFn
|
||||
, refChanValidateTranFn
|
||||
, refChanWorker
|
||||
, refChanWorkerEnv
|
||||
, refChanNotifyOnUpdated
|
||||
|
|
@ -15,18 +16,18 @@ import HBS2.Prelude.Plated
|
|||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Base58
|
||||
import HBS2.Merkle
|
||||
import HBS2.Clock
|
||||
import HBS2.Events
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Data.Detect
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.RefChan
|
||||
import HBS2.Net.Proto.Definition()
|
||||
import HBS2.Events
|
||||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.Definition()
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.RefChan
|
||||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Storage
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
|
@ -36,23 +37,27 @@ import PeerConfig
|
|||
import BlockDownload
|
||||
import Brains
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Concurrent.STM (flushTQueue)
|
||||
import Control.Exception ()
|
||||
import Control.Monad.Except (throwError, runExceptT)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Concurrent.STM (flushTQueue)
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Cache (Cache)
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.Coerce
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Data.Heap ()
|
||||
-- import Data.Heap qualified as Heap
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe
|
||||
import Data.Text qualified as Text
|
||||
import Lens.Micro.Platform
|
||||
-- import Data.Heap qualified as Heap
|
||||
import Data.Heap ()
|
||||
import Codec.Serialise
|
||||
import UnliftIO
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
|
@ -66,13 +71,21 @@ instance Exception DataNotReady
|
|||
|
||||
type OnDownloadComplete = HashRef -> IO ()
|
||||
|
||||
data RefChanValidator =
|
||||
RefChanValidator
|
||||
{ rcvInbox :: TQueue (RefChanValidate UNIX, MVar (RefChanValidate UNIX))
|
||||
, rcvAsync :: Async ()
|
||||
}
|
||||
|
||||
data RefChanWorkerEnv e =
|
||||
RefChanWorkerEnv
|
||||
{ _refChanWorkerEnvDEnv :: DownloadEnv e
|
||||
{ _refChanWorkerConf :: PeerConfig
|
||||
, _refChanWorkerEnvDEnv :: DownloadEnv e
|
||||
, _refChanWorkerEnvHeadQ :: TQueue (RefChanId e, RefChanHeadBlockTran e)
|
||||
, _refChanWorkerEnvDownload :: TVar (HashMap HashRef (RefChanId e, (TimeSpec, OnDownloadComplete)))
|
||||
, _refChanWorkerEnvNotify :: TVar (HashMap (RefChanId e) ())
|
||||
, _refChanWorkerEnvWriteQ :: TQueue HashRef
|
||||
, _refChanWorkerValidators :: TVar (HashMap (RefChanId e) RefChanValidator)
|
||||
}
|
||||
|
||||
makeLenses 'RefChanWorkerEnv
|
||||
|
|
@ -82,11 +95,12 @@ refChanWorkerEnv :: forall m e . (MonadIO m, ForRefChans e)
|
|||
-> DownloadEnv e
|
||||
-> m (RefChanWorkerEnv e)
|
||||
|
||||
refChanWorkerEnv _ de = liftIO $ RefChanWorkerEnv @e de <$> newTQueueIO
|
||||
refChanWorkerEnv conf de = liftIO $ RefChanWorkerEnv @e conf de
|
||||
<$> newTQueueIO
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTQueueIO
|
||||
|
||||
<*> newTVarIO mempty
|
||||
|
||||
refChanOnHeadFn :: forall e m . (ForRefChans e, MonadIO m) => RefChanWorkerEnv e -> RefChanId e -> RefChanHeadBlockTran e -> m ()
|
||||
refChanOnHeadFn env chan tran = do
|
||||
|
|
@ -97,6 +111,34 @@ refChanWriteTranFn :: MonadIO m => RefChanWorkerEnv e -> HashRef -> m ()
|
|||
refChanWriteTranFn env href = do
|
||||
atomically $ writeTQueue (view refChanWorkerEnvWriteQ env) href
|
||||
|
||||
refChanValidateTranFn :: forall e m . ( MonadUnliftIO m
|
||||
, ForRefChans e, e ~ L4Proto
|
||||
, HasNonces (RefChanValidate UNIX) m
|
||||
)
|
||||
=> RefChanWorkerEnv e
|
||||
-> RefChanId e
|
||||
-> HashRef
|
||||
-> m Bool
|
||||
|
||||
refChanValidateTranFn env chan htran = do
|
||||
mbv <- readTVarIO (view refChanWorkerValidators env) <&> HashMap.lookup chan
|
||||
-- отправить запрос в соответствующий... что?
|
||||
-- ждать ответа
|
||||
debug $ "VALIDATE TRAN" <+> pretty (AsBase58 chan) <+> pretty htran
|
||||
|
||||
r <- maybe1 mbv (pure True) $ \(RefChanValidator q _) -> do
|
||||
answ <- newEmptyMVar
|
||||
nonce <- newNonce @(RefChanValidate UNIX)
|
||||
atomically $ writeTQueue q (RefChanValidate nonce chan (Validate @UNIX htran), answ)
|
||||
withMVar answ $ \msg -> case rcvData msg of
|
||||
Accepted{} -> pure True
|
||||
_ -> pure False
|
||||
|
||||
|
||||
debug $ "TRANS VALIDATION RESULT: " <+> pretty htran <+> pretty r
|
||||
|
||||
pure r
|
||||
|
||||
-- FIXME: leak-when-block-never-really-updated
|
||||
refChanNotifyOnUpdated :: (MonadIO m, ForRefChans e) => RefChanWorkerEnv e -> RefChanId e -> m ()
|
||||
refChanNotifyOnUpdated env chan = do
|
||||
|
|
@ -110,6 +152,7 @@ refChanAddDownload :: forall e m . ( m ~ PeerM e IO
|
|||
-> HashRef
|
||||
-> OnDownloadComplete
|
||||
-> m ()
|
||||
|
||||
refChanAddDownload env chan r onComlete = do
|
||||
penv <- ask
|
||||
t <- getTimeCoarse
|
||||
|
|
@ -144,6 +187,143 @@ readLog sto (HashRef h) =
|
|||
Left{} -> pure ()
|
||||
Right (hrr :: [HashRef]) -> S.each hrr
|
||||
|
||||
data ValidateEnv =
|
||||
ValidateEnv
|
||||
{ _validateClient :: Fabriq UNIX
|
||||
, _validateSelf :: Peer UNIX
|
||||
}
|
||||
|
||||
newtype ValidateProtoM m a = PingPongM { fromValidateProto :: ReaderT ValidateEnv m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader ValidateEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
|
||||
runValidateProtoM :: (MonadIO m, PeerMessaging UNIX) => MessagingUnix -> ValidateProtoM m a -> m a
|
||||
runValidateProtoM tran m = runReaderT (fromValidateProto m) (ValidateEnv (Fabriq tran) (msgUnixSelf tran))
|
||||
|
||||
|
||||
instance Monad m => HasFabriq UNIX (ValidateProtoM m) where
|
||||
getFabriq = asks _validateClient
|
||||
|
||||
instance Monad m => HasOwnPeer UNIX (ValidateProtoM m) where
|
||||
ownPeer = asks _validateSelf
|
||||
|
||||
|
||||
refChanValidateProto :: forall e m . ( MonadIO m
|
||||
, Request e (RefChanValidate e) m
|
||||
, Response e (RefChanValidate e) m
|
||||
, e ~ UNIX
|
||||
)
|
||||
=> Cache (RefChanValidateNonce e) (MVar (RefChanValidate e))
|
||||
-> RefChanValidate e
|
||||
-> m ()
|
||||
|
||||
refChanValidateProto waiters msg = do
|
||||
debug $ "GOT ANSWER FROM VALIDATOR" <+> pretty msg
|
||||
case rcvData msg of
|
||||
Accepted h -> emitAnswer h msg
|
||||
Rejected h -> emitAnswer h msg
|
||||
_ -> none
|
||||
|
||||
where
|
||||
emitAnswer h m = liftIO do
|
||||
debug $ "EMIT ANSWER" <+> pretty h
|
||||
mbAnsw <- Cache.lookup waiters (rcvNonce m)
|
||||
maybe1 mbAnsw none $ \answ -> do
|
||||
putMVar answ m
|
||||
|
||||
|
||||
refChanWorkerInitValidators :: forall e m . ( MonadIO m
|
||||
, MonadUnliftIO m
|
||||
-- , MyPeer e
|
||||
-- , ForRefChans e
|
||||
-- , ForRefChans UNIX
|
||||
-- , m ~ PeerM e IO
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> RefChanWorkerEnv e
|
||||
-> m ()
|
||||
|
||||
|
||||
refChanWorkerInitValidators env = do
|
||||
debug "refChanWorkerInitValidators"
|
||||
|
||||
let (PeerConfig syn) = view refChanWorkerConf env
|
||||
|
||||
let validators = [ mkV rc x | ListVal [ SymbolVal "validate"
|
||||
, SymbolVal "refchan"
|
||||
, LitStrVal rc
|
||||
, ListVal [ SymbolVal "socket", SymbolVal "unix", LitStrVal x ]
|
||||
] <- syn
|
||||
] & catMaybes
|
||||
|
||||
|
||||
forM_ validators $ \(rc, sa) -> do
|
||||
debug $ "** VALIDATOR FOR" <+> pretty (AsBase58 rc, sa)
|
||||
|
||||
here <- readTVarIO (_refChanWorkerValidators env) <&> HashMap.member rc
|
||||
|
||||
unless here do
|
||||
q <- newTQueueIO
|
||||
val <- async $ validatorThread rc sa q
|
||||
let rcv = RefChanValidator q val
|
||||
atomically $ modifyTVar (_refChanWorkerValidators env) (HashMap.insert rc rcv)
|
||||
|
||||
where
|
||||
|
||||
mkV :: Text -> Text -> Maybe (RefChanId e, String)
|
||||
mkV rc x = (,Text.unpack x) <$> fromStringMay @(RefChanId e) (Text.unpack rc)
|
||||
|
||||
-- FIXME: make-thread-respawning
|
||||
validatorThread chan sa q = liftIO do
|
||||
client <- newMessagingUnix False 1.0 sa
|
||||
msg <- async $ runMessagingUnix client
|
||||
|
||||
-- FIXME: hardcoded-timeout
|
||||
waiters <- Cache.newCache (Just (toTimeSpec (10 :: Timeout 'Seconds)))
|
||||
|
||||
runValidateProtoM client do
|
||||
|
||||
poke <- async $ forever do
|
||||
pause @'Seconds 10
|
||||
mv <- newEmptyMVar
|
||||
nonce <- newNonce @(RefChanValidate UNIX)
|
||||
atomically $ writeTQueue q (RefChanValidate @UNIX nonce chan Poke, mv)
|
||||
|
||||
z <- async $ runProto
|
||||
[ makeResponse (refChanValidateProto waiters)
|
||||
]
|
||||
|
||||
forever do
|
||||
(req, answ) <- atomically $ readTQueue q
|
||||
case rcvData req of
|
||||
Validate href -> do
|
||||
debug $ "DO REQUEST VALIDATE" <+> pretty href <+> pretty sa
|
||||
liftIO $ Cache.insert waiters (rcvNonce req) answ
|
||||
let pa = fromString sa
|
||||
request pa req
|
||||
|
||||
Poke{} -> do
|
||||
debug "DO SEND POKE"
|
||||
let pa = fromString sa
|
||||
request pa req
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
(_, r) <- waitAnyCatch [z,poke]
|
||||
debug $ "SOMETHING WRONG:" <+> viaShow r
|
||||
|
||||
cancel msg
|
||||
warn $ "validatorThread is terminated for some reasons" <+> pretty (AsBase58 chan)
|
||||
|
||||
|
||||
refChanWorker :: forall e s m . ( MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MyPeer e
|
||||
|
|
@ -154,12 +334,13 @@ refChanWorker :: forall e s m . ( MonadIO m
|
|||
, Signatures s
|
||||
, s ~ Encryption e
|
||||
, IsRefPubKey s
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
-- , Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, ForRefChans e
|
||||
, EventListener e (RefChanRound e) m
|
||||
, EventListener e (RefChanRequest e) m
|
||||
, Sessions e (RefChanRound e) m
|
||||
, m ~ PeerM e IO
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> RefChanWorkerEnv e
|
||||
-> SomeBrains e
|
||||
|
|
@ -174,6 +355,11 @@ refChanWorker env brains = do
|
|||
-- FIXME: resume-on-exception
|
||||
hw <- async (refChanHeadMon penv)
|
||||
|
||||
-- FIXME: insist-more-during-download
|
||||
-- что-то частая ситуация, когда блоки
|
||||
-- с трудом докачиваются. надо бы
|
||||
-- разобраться. возможно переделать
|
||||
-- механизм скачивания блоков
|
||||
downloads <- async monitorHeadDownloads
|
||||
|
||||
polls <- async refChanPoll
|
||||
|
|
@ -186,6 +372,8 @@ refChanWorker env brains = do
|
|||
|
||||
sto <- getStorage
|
||||
|
||||
liftIO $ refChanWorkerInitValidators env
|
||||
|
||||
subscribe @e RefChanRequestEventKey $ \(RefChanRequestEvent chan val) -> do
|
||||
debug $ "RefChanRequestEvent" <+> pretty (AsBase58 chan) <+> pretty val
|
||||
|
||||
|
|
@ -218,7 +406,7 @@ refChanWorker env brains = do
|
|||
|
||||
forever do
|
||||
-- FIXME: use-polling-function-and-respect-wait
|
||||
pause @'Seconds 30
|
||||
pause @'Seconds 10
|
||||
|
||||
now <- getTimeCoarse
|
||||
xs <- readTVarIO rounds <&> HashSet.toList
|
||||
|
|
@ -516,7 +704,7 @@ logMergeProcess env q = do
|
|||
hd <- MaybeT $ lift $ getHead menv headRef
|
||||
|
||||
let quo = view refChanHeadQuorum hd & fromIntegral
|
||||
guard $ checkACL hd pk ak
|
||||
guard $ checkACL hd (Just pk) ak
|
||||
pure [(href, (quo,mempty))]
|
||||
|
||||
Accept _ box -> do
|
||||
|
|
@ -559,5 +747,3 @@ logMergeProcess env q = do
|
|||
updateRef sto chanKey nref
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -161,6 +161,108 @@ executable test-udp
|
|||
, uniplate
|
||||
, vector
|
||||
|
||||
|
||||
executable refchan-dummy-validator
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options:
|
||||
-- -prof
|
||||
-- -fprof-auto
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
-- type: exitcode-stdio-1.0
|
||||
hs-source-dirs: refchan-dummy-validator
|
||||
main-is: DummyValidatorMain.hs
|
||||
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-storage-simple
|
||||
, async
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, cache
|
||||
, clock
|
||||
, containers
|
||||
, data-default
|
||||
, data-textual
|
||||
, directory
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, mwc-random
|
||||
, network
|
||||
, network-ip
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, random
|
||||
, safe
|
||||
, serialise
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, text
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
, unliftio
|
||||
|
||||
|
||||
|
||||
executable test-unix
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options:
|
||||
-- -prof
|
||||
-- -fprof-auto
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
-- type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: TestUNIX.hs
|
||||
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-storage-simple
|
||||
, async
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, cache
|
||||
, clock
|
||||
, containers
|
||||
, data-default
|
||||
, data-textual
|
||||
, directory
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, mwc-random
|
||||
, network
|
||||
, network-ip
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, random
|
||||
, safe
|
||||
, serialise
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, text
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
|
||||
|
||||
test-suite test-tcp
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
|
|
|
|||
|
|
@ -0,0 +1,167 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Base58
|
||||
import HBS2.OrDie
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Net.Proto.RefChan
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto.Definition()
|
||||
import HBS2.Net.Auth.Credentials()
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.Functor
|
||||
import Data.List qualified as List
|
||||
import Options.Applicative hiding (info)
|
||||
import Options.Applicative qualified as O
|
||||
import System.Directory
|
||||
import UnliftIO
|
||||
|
||||
tracePrefix :: SetLoggerEntry
|
||||
tracePrefix = logPrefix "[trace] "
|
||||
|
||||
debugPrefix :: SetLoggerEntry
|
||||
debugPrefix = logPrefix "[debug] "
|
||||
|
||||
errorPrefix :: SetLoggerEntry
|
||||
errorPrefix = logPrefix "[error] "
|
||||
|
||||
warnPrefix :: SetLoggerEntry
|
||||
warnPrefix = logPrefix "[warn] "
|
||||
|
||||
noticePrefix :: SetLoggerEntry
|
||||
noticePrefix = logPrefix "[notice] "
|
||||
|
||||
|
||||
data Verdict = DoAccept | DoReject
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
instance Pretty Verdict where
|
||||
pretty = viaShow
|
||||
|
||||
withLogging :: MonadIO m => m a -> m ()
|
||||
withLogging m = do
|
||||
setLogging @DEBUG debugPrefix
|
||||
setLogging @INFO defLog
|
||||
setLogging @ERROR errorPrefix
|
||||
setLogging @WARN warnPrefix
|
||||
setLogging @NOTICE noticePrefix
|
||||
|
||||
m
|
||||
|
||||
setLoggingOff @DEBUG
|
||||
setLoggingOff @INFO
|
||||
setLoggingOff @ERROR
|
||||
setLoggingOff @WARN
|
||||
setLoggingOff @NOTICE
|
||||
|
||||
data MyEnv =
|
||||
MyEnv
|
||||
{ mySelf :: Peer UNIX
|
||||
, myFab :: Fabriq UNIX
|
||||
, myChan :: RefChanId UNIX
|
||||
}
|
||||
|
||||
|
||||
newtype App m a = App { fromApp :: ReaderT MyEnv m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadReader MyEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
runApp :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> App m a -> m a
|
||||
runApp env m = runReaderT (fromApp m) env
|
||||
|
||||
instance Monad m => HasFabriq UNIX (App m) where
|
||||
getFabriq = asks myFab
|
||||
|
||||
instance Monad m => HasOwnPeer UNIX (App m) where
|
||||
ownPeer = asks mySelf
|
||||
|
||||
|
||||
runMe :: String -> FilePath -> Verdict -> IO ()
|
||||
runMe chan' sa verdict = withLogging do
|
||||
chan <- pure (fromStringMay @(RefChanId UNIX) chan') `orDie` "invalid REFCHAN"
|
||||
|
||||
info $ "I'm dummy refchan validator" <+> pretty (AsBase58 chan) <+> pretty sa <+> pretty verdict
|
||||
|
||||
here <- doesFileExist sa
|
||||
|
||||
when here do
|
||||
removeFile sa
|
||||
|
||||
server <- newMessagingUnix True 1.0 sa
|
||||
|
||||
abus <- async $ runMessagingUnix server
|
||||
|
||||
let env = MyEnv (fromString sa) (Fabriq server) chan
|
||||
|
||||
runApp env do
|
||||
debug "BOO"
|
||||
runProto $ List.singleton $ makeResponse (myProto chan)
|
||||
|
||||
void $ waitAnyCatchCancel [abus]
|
||||
err "WTF?"
|
||||
|
||||
where
|
||||
|
||||
myProto :: forall e m . ( MonadIO m
|
||||
, Request e (RefChanValidate e) m
|
||||
, Response e (RefChanValidate e) m
|
||||
, e ~ UNIX
|
||||
)
|
||||
=> RefChanId e
|
||||
-> RefChanValidate e
|
||||
-> m ()
|
||||
|
||||
myProto chan msg = do
|
||||
case rcvData msg of
|
||||
Poke{} -> debug "poked"
|
||||
Validate href -> do
|
||||
debug $ "validate request" <+> pretty (AsBase58 (rcvChan msg)) <+> pretty href
|
||||
|
||||
case verdict of
|
||||
DoAccept -> do
|
||||
debug $ "sending accept for" <+> brackets (pretty (AsBase58 (rcvNonce msg))) <+> pretty href
|
||||
response (RefChanValidate (rcvNonce msg) chan (Accepted @UNIX href))
|
||||
|
||||
DoReject -> do
|
||||
debug $ "sending reject for" <+> brackets (pretty (AsBase58 (rcvNonce msg))) <+> pretty href
|
||||
response (RefChanValidate (rcvNonce msg) chan (Rejected @UNIX href))
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = join . customExecParser (prefs showHelpOnError) $
|
||||
O.info (helper <*> parser)
|
||||
( fullDesc
|
||||
<> header "refchan-dummy-validator"
|
||||
<> progDesc "for test and demo purposed"
|
||||
)
|
||||
where
|
||||
parser :: Parser (IO ())
|
||||
parser = do
|
||||
rchan <- strArgument ( metavar "REFCHAN" ) <&> fromString
|
||||
soname <- strArgument ( metavar "UNIX-SOCKET" )
|
||||
|
||||
verdict <- accept <|> reject <|> pure DoAccept
|
||||
|
||||
pure $ runMe rchan soname verdict
|
||||
|
||||
accept = do
|
||||
void $ flag' True ( long "accept" <> short 'y' )
|
||||
pure DoAccept
|
||||
|
||||
reject = do
|
||||
void $ flag' True ( long "reject" <> short 'n' )
|
||||
pure DoReject
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Clock
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.OrDie
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Lens.Micro.Platform
|
||||
import Prettyprinter
|
||||
import System.FilePath.Posix
|
||||
import System.IO
|
||||
import System.IO.Temp
|
||||
import UnliftIO.Async
|
||||
|
||||
|
||||
debug :: (MonadIO m) => Doc ann -> m ()
|
||||
debug p = liftIO $ hPrint stderr p
|
||||
|
||||
|
||||
data PingPong e = Ping Int
|
||||
| Pong Int
|
||||
deriving stock (Eq,Generic,Show,Read)
|
||||
|
||||
|
||||
instance Serialise (PingPong e)
|
||||
|
||||
|
||||
instance HasProtocol UNIX (PingPong UNIX) where
|
||||
type instance ProtocolId (PingPong UNIX) = 1
|
||||
type instance Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
pingPongHandler :: forall e m . ( MonadIO m
|
||||
, Response e (PingPong e) m
|
||||
, HasProtocol e (PingPong e)
|
||||
)
|
||||
=> Int
|
||||
-> PingPong e
|
||||
-> m ()
|
||||
|
||||
pingPongHandler n = \case
|
||||
|
||||
Ping c -> debug ("Ping" <+> pretty c) >> response (Pong @e c)
|
||||
|
||||
Pong c | c < n -> debug ("Pong" <+> pretty c) >> response (Ping @e (succ c))
|
||||
| otherwise -> pure ()
|
||||
|
||||
data PPEnv =
|
||||
PPEnv
|
||||
{ _ppSelf :: Peer UNIX
|
||||
, _ppFab :: Fabriq UNIX
|
||||
}
|
||||
|
||||
makeLenses 'PPEnv
|
||||
|
||||
newtype PingPongM m a = PingPongM { fromPingPong :: ReaderT PPEnv m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadReader PPEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
runPingPong :: (MonadIO m, PeerMessaging UNIX) => MessagingUnix -> PingPongM m a -> m a
|
||||
runPingPong tran m = runReaderT (fromPingPong m) (PPEnv (msgUnixSelf tran) (Fabriq tran))
|
||||
|
||||
instance Monad m => HasFabriq UNIX (PingPongM m) where
|
||||
getFabriq = asks (view ppFab)
|
||||
|
||||
instance Monad m => HasOwnPeer UNIX (PingPongM m) where
|
||||
ownPeer = asks (view ppSelf)
|
||||
|
||||
instance HasTimeLimits UNIX (PingPong UNIX) IO where
|
||||
tryLockForPeriod _ _ = pure True
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
liftIO $ hSetBuffering stdout LineBuffering
|
||||
liftIO $ hSetBuffering stderr LineBuffering
|
||||
|
||||
withSystemTempDirectory "test-unix-socket" $ \tmp -> do
|
||||
|
||||
let soname = tmp </> "unix.socket"
|
||||
|
||||
server <- newMessagingUnix True 1.0 soname
|
||||
|
||||
client <- newMessagingUnix False 1.0 soname
|
||||
|
||||
m1 <- async $ runMessagingUnix server
|
||||
m2 <- async $ runMessagingUnix client
|
||||
|
||||
p1 <- async $ runPingPong server do
|
||||
runProto @UNIX
|
||||
[ makeResponse (pingPongHandler 100000)
|
||||
]
|
||||
|
||||
p2 <- async $ runPingPong client do
|
||||
request (msgUnixSelf server) (Ping @UNIX 0)
|
||||
runProto @UNIX
|
||||
[ makeResponse (pingPongHandler 100000)
|
||||
]
|
||||
|
||||
(_,r) <- liftIO $ waitAnyCatchCancel [m1,m2,p1,p2]
|
||||
|
||||
debug (viaShow r)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue