Hot / Warm / Established distinction

p2p and inbound protocol governors need 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.

ouroboros-network-framework/src/Ouroboros/Network/Mux.hs

@@ -1,20 +1,40 @@
+{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveFoldable        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveTraversable     #-}
 {-# 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 (..)
+  , SomeTokProtocolTemperature (..)
+  , WithProtocolTemperature (..)
+  , withoutProtocolTemperature
+  , WithSomeProtocolTemperature (..)
+  , withoutSomeProtocolTemperature
+  , Bundle (..)
+  , projectBundle
+  , OuroborosBundle
+  , MuxBundle
   , MiniProtocol (..)
   , MiniProtocolNum (..)
   , MiniProtocolLimits (..)
   , RunMiniProtocol (..)
   , MuxPeer (..)
   , toApplication
+  , mkMuxApplicationBundle
   , ControlMessage (..)
   , ControlMessageSTM
   , continueForever
@@ -113,13 +133,153 @@ 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 = Established | Warm | Hot
+  deriving (Eq, Ord, Show)
+
+
+-- | Singletons for 'AppKind'
+--
+data TokProtocolTemperature (pt :: ProtocolTemperature) where
+    TokHot         :: TokProtocolTemperature Hot
+    TokWarm        :: TokProtocolTemperature Warm
+    TokEstablished :: TokProtocolTemperature Established
+
+
+data SomeTokProtocolTemperature where
+    SomeTokProtocolTemperature :: TokProtocolTemperature pt
+                               -> SomeTokProtocolTemperature
+
+
+-- | 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)
+deriving instance Foldable    (WithProtocolTemperature pt)
+deriving instance Traversable (WithProtocolTemperature pt)
+
+instance Applicative (WithProtocolTemperature Hot) where
+    pure = WithHot
+    (<*>) (WithHot f) = fmap f
+instance Applicative (WithProtocolTemperature Warm) where
+    pure = WithWarm
+    (<*>) (WithWarm f) = fmap f
+instance Applicative (WithProtocolTemperature Established) where
+    pure = WithEstablished
+    (<*>) (WithEstablished f) = fmap f
+
+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
+
+
+data WithSomeProtocolTemperature a where
+    WithSomeProtocolTemperature :: WithProtocolTemperature pt a -> WithSomeProtocolTemperature a
+
+deriving instance Show a => Show (WithSomeProtocolTemperature a)
+deriving instance Functor WithSomeProtocolTemperature
+
+withoutSomeProtocolTemperature :: WithSomeProtocolTemperature a -> a
+withoutSomeProtocolTemperature (WithSomeProtocolTemperature a) = withoutProtocolTemperature 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, Foldable, Traversable)
+
+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 hotFn
+           warmFn
+           establishedFn
+      <*> Bundle hot
+                 warm
+                 established =
+          Bundle (hotFn <*> hot)
+                 (warmFn <*> warm)
+                 (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,
        miniProtocolLimits :: !MiniProtocolLimits,
        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
@@ -176,6 +336,22 @@ 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 controlMessageBundle appBundle =
+    mkApplication <$> controlMessageBundle <*> appBundle
+  where
+    mkApplication :: (ControlMessageSTM m)
+                  -> (MuxProtocolBundle mode addr bytes m a b)
+                  -> [MiniProtocol mode bytes m a b]
+    mkApplication controlMessageSTM app = app connectionId controlMessageSTM
+
+
 toMuxRunMiniProtocol :: forall mode m a b.
                         (MonadCatch m, MonadAsync m)
                      => RunMiniProtocol mode LBS.ByteString m a b