Decoder failure's context

ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToClient.hs

@@ -36,6 +36,7 @@ import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding)
 import           Control.Tracer
 import           Data.ByteString.Lazy (ByteString)
+import           Data.Typeable (Typeable)
 import           Data.Void (Void)
 
 import           Ouroboros.Network.Block (Serialised, decodePoint, decodeTip,
@@ -311,7 +312,12 @@ data Apps m peer bCS bTX bSQ a = Apps {
 
 -- | Construct the 'NetworkApplication' for the node-to-client protocols
 mkApps
-  :: forall m peer blk e bCS bTX bSQ. (IOLike m, Exception e)
+  :: forall m peer blk e bCS bTX bSQ.
+     ( IOLike m
+     , Exception e
+     , Typeable blk
+     , Typeable (ApplyTxErr blk)
+     )
   => Tracers m peer blk e
   -> Codecs blk e m bCS bTX bSQ
   -> Handlers m peer blk

ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs

@@ -17,6 +17,8 @@ module Ouroboros.Consensus.Node.Run (
   , RunNode (..)
   ) where
 
+import           Data.Typeable (Typeable)
+
 import           Ouroboros.Network.Block (Serialised)
 import           Ouroboros.Network.BlockFetch (SizeInBytes)
 
@@ -77,6 +79,8 @@ class ( LedgerSupportsProtocol           blk
       , SerialiseDiskConstraints         blk
       , SerialiseNodeToNodeConstraints   blk
       , SerialiseNodeToClientConstraints blk
+      , Typeable                         blk
+      , Typeable                         (ApplyTxErr blk)
       ) => RunNode blk where
   nodeBlockFetchSize      :: Header blk -> SizeInBytes
 

ouroboros-network-framework/demo/ping-pong.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Main where
@@ -28,12 +29,14 @@ import Ouroboros.Network.Snocket
 import Ouroboros.Network.Mux
 import Ouroboros.Network.ErrorPolicy
 import Ouroboros.Network.IOManager
+import Ouroboros.Network.Util.ShowProxy (ShowProxy (..))
 
 import Ouroboros.Network.Protocol.Handshake.Codec
 import Ouroboros.Network.Protocol.Handshake.Unversioned
 import Ouroboros.Network.Protocol.Handshake.Version
 
 import Network.TypedProtocol.Pipelined
+import Network.TypedProtocol.PingPong.Type (PingPong)
 import Network.TypedProtocol.PingPong.Client as PingPong
 import Network.TypedProtocol.PingPong.Server as PingPong
 import Network.TypedProtocol.PingPong.Codec.CBOR  as PingPong
@@ -56,6 +59,9 @@ main = do
 
       _          -> usage
 
+instance ShowProxy PingPong where
+    showProxy _ = "PingPong"
+
 usage :: IO ()
 usage = do
     hPutStrLn stderr "usage: demo-ping-pong [pingpong|pingpong2] {client|server} [addr]"

ouroboros-network-framework/ouroboros-network-framework.cabal

@@ -29,6 +29,7 @@ library
                        Ouroboros.Network.ErrorPolicy
                        Ouroboros.Network.IOManager
                        Ouroboros.Network.Mux
+                       Ouroboros.Network.Util.ShowProxy
 
                        Ouroboros.Network.Protocol.Handshake
                        Ouroboros.Network.Protocol.Handshake.Type
@@ -106,6 +107,7 @@ test-suite ouroboros-network-framework-tests
                        Test.Network.TypedProtocol.PingPong.Codec
                        Test.Network.TypedProtocol.ReqResp.Codec
                        Test.Ouroboros.Network.Driver
+                       Test.Ouroboros.Network.Orphans
                        Test.Ouroboros.Network.Socket
                        Test.Ouroboros.Network.Subscription
                        Test.Ouroboros.Network.RateLimiting

ouroboros-network-framework/src/Ouroboros/Network/Driver/Limits.hs

@@ -8,6 +8,8 @@
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Drivers for running 'Peer's.
 --
@@ -30,6 +32,7 @@ module Ouroboros.Network.Driver.Limits (
   ) where
 
 import Data.Maybe (fromMaybe)
+import Data.Typeable (Typeable)
 
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadFork
@@ -46,7 +49,8 @@ import Network.TypedProtocol.Driver
 
 import Ouroboros.Network.Codec
 import Ouroboros.Network.Channel
-import Ouroboros.Network.Driver.Simple (TraceSendRecv(..))
+import Ouroboros.Network.Driver.Simple (TraceSendRecv(..), DecoderFailure (..))
+import Ouroboros.Network.Util.ShowProxy
 
 
 data ProtocolSizeLimits ps bytes = ProtocolSizeLimits {
@@ -61,15 +65,52 @@ data ProtocolTimeLimits ps = ProtocolTimeLimits {
                             PeerHasAgency pr st -> Maybe DiffTime
      }
 
-data ProtocolLimitFailure = ExceededSizeLimit
-                          | ExceededTimeLimit
-  deriving (Eq, Show)
+data ProtocolLimitFailure where
+    ExceededSizeLimit :: forall (pr :: PeerRole) ps (st :: ps).
+                         ( Typeable ps
+                         , forall (st' :: ps). Show (ClientHasAgency st')
+                         , forall (st' :: ps). Show (ServerHasAgency st')
+                         , ShowProxy ps
+                         )
+                      => PeerHasAgency pr st
+                      -> ProtocolLimitFailure
+    ExceededTimeLimit :: forall (pr :: PeerRole) ps (st :: ps).
+                         ( Typeable ps
+                         , forall (st' :: ps). Show (ClientHasAgency st')
+                         , forall (st' :: ps). Show (ServerHasAgency st')
+                         , ShowProxy ps
+                         )
+                      => PeerHasAgency pr st
+                      -> ProtocolLimitFailure
 
-instance Exception ProtocolLimitFailure
+instance Show ProtocolLimitFailure where
+    show (ExceededSizeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+      concat
+        [ "ExceededSizeLimit "
+        , showProxy (Proxy :: Proxy ps)
+        , " "
+        , show stok
+        ]
+    show (ExceededTimeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+      concat
+        [ "ExceededTimeLimit "
+        , showProxy (Proxy :: Proxy ps)
+        , " "
+        , show stok
+        ]
+
+instance Exception ProtocolLimitFailure where
 
 
 driverWithLimits :: forall ps failure bytes m.
-                    (MonadThrow m, Exception failure)
+                    ( MonadThrow m
+                    , Typeable failure
+                    , Typeable ps
+                    , Show failure
+                    , ShowProxy ps
+                    , forall (st' :: ps). Show (ClientHasAgency st')
+                    , forall (st' :: ps). Show (ServerHasAgency st')
+                    )
                  => Tracer m (TraceSendRecv ps)
                  -> TimeoutFn m
                  -> Codec ps failure m bytes
@@ -107,9 +148,9 @@ driverWithLimits tracer timeoutFn
         Just (Right x@(SomeMessage msg, _trailing')) -> do
           traceWith tracer (TraceRecvMsg (AnyMessage msg))
           return x
-        Just (Left (Just failure)) -> throwM failure
-        Just (Left Nothing)        -> throwM ExceededSizeLimit
-        Nothing                    -> throwM ExceededTimeLimit
+        Just (Left (Just failure)) -> throwM (DecoderFailure stok failure)
+        Just (Left Nothing)        -> throwM (ExceededSizeLimit stok)
+        Nothing                    -> throwM (ExceededTimeLimit stok)
 
 runDecoderWithLimit
     :: forall m bytes failure a. Monad m
@@ -161,8 +202,19 @@ runDecoderWithLimit limit size Channel{recv} =
 
 runPeerWithLimits
   :: forall ps (st :: ps) pr failure bytes m a .
-     (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
-      MonadMonotonicTime m, MonadTimer m, Exception failure)
+     ( MonadAsync m
+     , MonadFork m
+     , MonadMask m
+     , MonadThrow (STM m)
+     , MonadMonotonicTime m
+     , MonadTimer m
+     , Typeable ps
+     , Typeable failure
+     , forall (st' :: ps). Show (ClientHasAgency st')
+     , forall (st' :: ps). Show (ServerHasAgency st')
+     , ShowProxy ps
+     , Show failure
+     )
   => Tracer m (TraceSendRecv ps)
   -> Codec ps failure m bytes
   -> ProtocolSizeLimits ps bytes
@@ -185,8 +237,19 @@ runPeerWithLimits tracer codec slimits tlimits channel peer =
 --
 runPipelinedPeerWithLimits
   :: forall ps (st :: ps) pr failure bytes m a.
-     (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
-      MonadMonotonicTime m, MonadTimer m, Exception failure)
+     ( MonadAsync m
+     , MonadFork m
+     , MonadMask m
+     , MonadThrow (STM m)
+     , MonadMonotonicTime m
+     , MonadTimer m
+     , Typeable ps
+     , Typeable failure
+     , forall (st' :: ps). Show (ClientHasAgency st')
+     , forall (st' :: ps). Show (ServerHasAgency st')
+     , ShowProxy ps
+     , Show failure
+     )
   => Tracer m (TraceSendRecv ps)
   -> Codec ps failure m bytes
   -> ProtocolSizeLimits ps bytes