From dcc94f928af11f701fd3e6b9dd9f2e1ab9bb48fc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 8 Jun 2020 16:57:29 +0200 Subject: [PATCH] Hot / Warm / Established distinction The governor needs to take care about three types of protocols: ones that run for established connections, warm and hot peers. For this purpose we provide a type level `ProtocolTemperature` with three constructors: `Hot`, `Warm` and `Established`. This patch provides convientient functions to work with the introduced complexity. --- .../src/Ouroboros/Network/Mux.hs | 168 +++++++++++++++++- 1 file changed, 167 insertions(+), 1 deletion(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs b/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs index c95cff75dee..04868a1ef38 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs @@ -1,20 +1,35 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module Ouroboros.Network.Mux ( MuxMode (..) , OuroborosApplication (..) + , MuxProtocolBundle + , ProtocolTemperature (..) + , TokProtocolTemperature (..) + , WithProtocolTemperature (..) + , withoutProtocolTemperature + , Bundle (..) + , projectBundle + , OuroborosBundle + , MuxBundle , MiniProtocol (..) , MiniProtocolNum (..) , MiniProtocolLimits (..) , RunMiniProtocol (..) , MuxPeer (..) , toApplication + , mkMuxApplicationBundle , ControlMessage (..) , ControlMessageSTM , continueForever @@ -79,7 +94,6 @@ continueForever :: Applicative (STM m) -> ControlMessageSTM m continueForever _ = pure Continue - -- | Like 'MuxApplication' but using a 'MuxPeer' rather than a raw -- @Channel -> m a@ action. -- @@ -87,6 +101,114 @@ newtype OuroborosApplication (mode :: MuxMode) addr bytes m a b = OuroborosApplication (ConnectionId addr -> ControlMessageSTM m -> [MiniProtocol mode bytes m a b]) + +-- | There are three kinds of applications: warm, hot and established (ones +-- that run in for both warm and hot peers). +-- +data ProtocolTemperature = Hot | Warm | Established + + +-- | Singletons for 'AppKind' +-- +data TokProtocolTemperature (pt :: ProtocolTemperature) where + TokHot :: TokProtocolTemperature Hot + TokWarm :: TokProtocolTemperature Warm + TokEstablished :: TokProtocolTemperature Established + + +-- | We keep hot and warm application (or their context) distinct. It's only +-- needed for a handly 'projectBundle' map. +-- +data WithProtocolTemperature (pt :: ProtocolTemperature) a where + WithHot :: !a -> WithProtocolTemperature Hot a + WithWarm :: !a -> WithProtocolTemperature Warm a + WithEstablished :: !a -> WithProtocolTemperature Established a + +deriving instance Eq a => Eq (WithProtocolTemperature pt a) +deriving instance Show a => Show (WithProtocolTemperature pt a) +deriving instance (Functor (WithProtocolTemperature pt)) + +instance Semigroup a => Semigroup (WithProtocolTemperature pt a) where + WithHot a <> WithHot b = WithHot (a <> b) + WithWarm a <> WithWarm b = WithWarm (a <> b) + WithEstablished a <> WithEstablished b = WithEstablished (a <> b) + +instance Monoid a => Monoid (WithProtocolTemperature Hot a) where + mempty = WithHot mempty + +instance Monoid a => Monoid (WithProtocolTemperature Warm a) where + mempty = WithWarm mempty + +instance Monoid a => Monoid (WithProtocolTemperature Established a) where + mempty = WithEstablished mempty + + +withoutProtocolTemperature :: WithProtocolTemperature pt a -> a +withoutProtocolTemperature (WithHot a) = a +withoutProtocolTemperature (WithWarm a) = a +withoutProtocolTemperature (WithEstablished a) = a + + +-- | A bundle of 'HotApp', 'WarmApp' and 'EstablishedApp'. +-- +data Bundle a = + Bundle { + -- | hot mini-protocols + -- + withHot + :: !(WithProtocolTemperature Hot a), + + -- | warm mini-protocols + -- + withWarm + :: !(WithProtocolTemperature Warm a), + + -- | established mini-protocols + -- + withEstablished + :: !(WithProtocolTemperature Established a) + } + deriving (Eq, Show, Functor) + +instance Semigroup a => Semigroup (Bundle a) where + Bundle hot warm established <> Bundle hot' warm' established' = + Bundle (hot <> hot') + (warm <> warm') + (established <> established') + +instance Monoid a => Monoid (Bundle a) where + mempty = Bundle mempty mempty mempty + +projectBundle :: TokProtocolTemperature pt -> Bundle a -> a +projectBundle TokHot = withoutProtocolTemperature . withHot +projectBundle TokWarm = withoutProtocolTemperature . withWarm +projectBundle TokEstablished = withoutProtocolTemperature . withEstablished + + +instance Applicative Bundle where + pure a = Bundle (WithHot a) (WithWarm a) (WithEstablished a) + Bundle (WithHot hotFn) + (WithWarm warmFn) + (WithEstablished establishedFn) + <*> Bundle (WithHot hot) + (WithWarm warm) + (WithEstablished established) = + Bundle (WithHot $ hotFn hot) + (WithWarm $ warmFn warm) + (WithEstablished $ establishedFn established) + +-- +-- Useful type synonyms +-- + +type MuxProtocolBundle (mode :: MuxMode) addr bytes m a b + = ConnectionId addr + -> ControlMessageSTM m + -> [MiniProtocol mode bytes m a b] + +type OuroborosBundle (mode :: MuxMode) addr bytes m a b = + Bundle (MuxProtocolBundle mode addr bytes m a b) + data MiniProtocol (mode :: MuxMode) bytes m a b = MiniProtocol { miniProtocolNum :: !MiniProtocolNum, @@ -94,6 +216,10 @@ data MiniProtocol (mode :: MuxMode) bytes m a b = miniProtocolRun :: !(RunMiniProtocol mode bytes m a b) } +type MuxBundle (mode :: MuxMode) bytes m a b = + Bundle [MiniProtocol mode bytes m a b] + + data RunMiniProtocol (mode :: MuxMode) bytes m a b where InitiatorProtocolOnly :: MuxPeer bytes m a @@ -150,6 +276,46 @@ toApplication connectionId controlMessageSTM (OuroborosApplication ptcls) = } | ptcl <- ptcls connectionId controlMessageSTM ] + +mkMuxApplicationBundle + :: forall mode addr bytes m a b. + ConnectionId addr + -> Bundle (ControlMessageSTM m) + -> OuroborosBundle mode addr bytes m a b + -> MuxBundle mode bytes m a b +mkMuxApplicationBundle connectionId + (Bundle + hotControlMessageSTM + warmControlMessageSTM + establishedControlMessageSTM) + (Bundle + hotApp + warmApp + establishedApp) = + Bundle { + withHot = + mkApplication hotControlMessageSTM hotApp, + + withWarm = + mkApplication warmControlMessageSTM warmApp, + + withEstablished = + mkApplication establishedControlMessageSTM establishedApp + } + where + mkApplication :: WithProtocolTemperature pt (ControlMessageSTM m) + -> WithProtocolTemperature pt (MuxProtocolBundle mode addr bytes m a b) + -> WithProtocolTemperature pt [MiniProtocol mode bytes m a b] + mkApplication (WithHot scheduleStop) (WithHot app) = + WithHot $ app connectionId scheduleStop + + mkApplication (WithWarm scheduleStop) (WithWarm app) = + WithWarm $ app connectionId scheduleStop + + mkApplication (WithEstablished scheduleStop) (WithEstablished app) = + WithEstablished $ app connectionId scheduleStop + + toMuxRunMiniProtocol :: forall mode m a b. (MonadCatch m, MonadAsync m) => RunMiniProtocol mode LBS.ByteString m a b