ErrorPolicies - remove return callback and simplify types

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

@@ -24,20 +24,13 @@ import           Ouroboros.Consensus.Node.ProtocolInfo.Byron
 import           Ouroboros.Consensus.Util.ResourceRegistry
                      (RegistryClosedException, ResourceRegistryThreadException)
 
-consensusErrorPolicy :: ErrorPolicies addr ()
+consensusErrorPolicy :: ErrorPolicies
 consensusErrorPolicy = ErrorPolicies {
       -- Exception raised during connect
       --
       -- This is entirely a network-side concern.
       epConErrorPolicies = []
 
-      -- What to do when the protocol exits cleanly
-      --
-      -- This never happens (we always throw an exception), so this function
-      -- should never be called; if for some reason it /does/, we make it
-      -- throw an exception.
-    , epReturnCallback = \_time _addr () -> ourBug
-
       -- Exception raised during interaction with the peer
       --
       -- The list below should contain an entry for every type declared as an

ouroboros-network/src/Ouroboros/Network/Diffusion.hs

@@ -130,10 +130,8 @@ data DiffusionApplications = DiffusionApplications {
                                           ())
       -- ^ NodeToClient responder applicaton (server role)
 
-    , daErrorPolicies :: ErrorPolicies SockAddr ()
+    , daErrorPolicies :: ErrorPolicies
       -- ^ error policies
-      --
-      -- TODO: one cannot use `forall a. ErrorPolicies SockAddr a`
     }
 
 runDataDiffusion
@@ -218,7 +216,7 @@ runDataDiffusion tracers
       , laUnix = Nothing
       }
 
-    remoteErrorPolicy, localErrorPolicy :: ErrorPolicies SockAddr ()
+    remoteErrorPolicy, localErrorPolicy :: ErrorPolicies
     remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies
     localErrorPolicy  = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies
 

ouroboros-network/src/Ouroboros/Network/ErrorPolicy.hs

@@ -31,7 +31,7 @@ module Ouroboros.Network.ErrorPolicy
 import           Control.Exception (Exception, IOException, SomeException (..))
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromMaybe, mapMaybe)
+import           Data.Maybe (mapMaybe)
 import           Data.Semigroup (sconcat)
 import           Data.Set (Set)
 import qualified Data.Set as Set
@@ -47,8 +47,6 @@ import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadSTM
 import           Control.Monad.Class.MonadTime
 
-import           Data.Semigroup.Action
-
 import           Ouroboros.Network.Subscription.PeerState
 
 data ErrorPolicy where
@@ -99,20 +97,19 @@ evalErrorPolicies e =
 -- | List of error policies for exception handling and a policy for handing
 -- application return values.
 --
-data ErrorPolicies addr a = ErrorPolicies {
+data ErrorPolicies = ErrorPolicies {
     -- | Application Error Policies
     epAppErrorPolicies  :: [ErrorPolicy]
     -- | `connect` Error Policies
   , epConErrorPolicies  :: [ErrorPolicy]
-  , epReturnCallback :: Time -> addr -> a -> SuspendDecision DiffTime
   }
 
-nullErrorPolicies :: ErrorPolicies addr a
-nullErrorPolicies = ErrorPolicies [] [] (\_ _ _ -> Throw)
+nullErrorPolicies :: ErrorPolicies
+nullErrorPolicies = ErrorPolicies [] []
 
-instance Semigroup (ErrorPolicies addr a) where
-    ErrorPolicies aep cep fn <> ErrorPolicies aep' cep' fn'
-      = ErrorPolicies (aep <> aep') (cep <> cep') (fn <> fn')
+instance Semigroup ErrorPolicies where
+    ErrorPolicies aep cep <> ErrorPolicies aep' cep' 
+      = ErrorPolicies (aep <> aep') (cep <> cep')
 
 -- | Sum type which distinguishes between connection and application
 -- exception traces.
@@ -181,7 +178,7 @@ completeApplicationTx
      , Ord addr
      , Ord (Async m ())
      )
-  => ErrorPolicies addr a
+  => ErrorPolicies
   -> CompleteApplication m
        (PeerStates m addr)
        addr
@@ -196,22 +193,12 @@ completeApplicationTx _ _ ps@ThrowException{} = pure $
       }
 
 -- application returned; classify the return value and update the state.
-completeApplicationTx ErrorPolicies {epReturnCallback} (ApplicationResult t addr r) (PeerStates ps) =
-  let cmd = epReturnCallback t addr r
-      fn :: Maybe (PeerState m)
-         -> ( Set (Async m ())
-            , Maybe (PeerState m)
-            )
-      fn mbps = ( maybe Set.empty (`threadsToCancel` cmd) mbps
-                , mbps <| (flip addTime t <$> cmd)
-                )
-  in case alterAndLookup fn addr ps of
-    (ps', mbthreads) -> pure $
-      CompleteApplicationResult {
-          carState   = PeerStates ps',
-          carThreads = fromMaybe Set.empty mbthreads,
-          carTrace   = WithAddr addr <$> traceErrorPolicy (Right r) cmd
-        }
+completeApplicationTx _ ApplicationResult{} ps =
+    pure $ CompleteApplicationResult {
+        carState   = ps,
+        carThreads = Set.empty,
+        carTrace   = Nothing
+      }
 
 -- application errored
 completeApplicationTx ErrorPolicies {epAppErrorPolicies} (ApplicationError t addr e) ps =

ouroboros-network/src/Ouroboros/Network/NodeToClient.hs

@@ -224,7 +224,7 @@ withServer
   -> ClientAddress
   -> Versions NodeToClientVersion DictVersion
               (OuroborosApplication appType (ConnectionId ClientAddress) NodeToClientProtocols IO BL.ByteString a b)
-  -> ErrorPolicies ClientAddress ()
+  -> ErrorPolicies
   -> IO Void
 withServer sn tracers networkState addr versions errPolicies =
   withServerNode
@@ -257,7 +257,7 @@ withServer_V1
   -- ^ applications which has the reponder side, i.e.
   -- 'OuroborosResponderApplication' or
   -- 'OuroborosInitiatorAndResponderApplication'.
-  -> ErrorPolicies ClientAddress ()
+  -> ErrorPolicies
   -> IO Void
 withServer_V1 sn tracers networkState addr versionData application =
     withServer
@@ -362,7 +362,7 @@ ncSubscriptionWorker_V1
 --
 -- If a trusted node sends us a wrong data or 
 --
-networkErrorPolicies :: ErrorPolicies addr a
+networkErrorPolicies :: ErrorPolicies
 networkErrorPolicies = ErrorPolicies
     { epAppErrorPolicies = [
         -- Handshake client protocol error: we either did not recognise received
@@ -407,7 +407,6 @@ networkErrorPolicies = ErrorPolicies
         ErrorPolicy $ \(_ :: IOException) -> Just $
           SuspendPeer shortDelay shortDelay
       ]
-    , epReturnCallback = \_ _ _ -> ourBug
     }
   where
     ourBug :: SuspendDecision DiffTime

ouroboros-network/src/Ouroboros/Network/NodeToNode.hs

@@ -243,7 +243,7 @@ withServer
   -> NetworkMutableState addr
   -> addr
   -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId addr) NodeToNodeProtocols IO BL.ByteString a b)
-  -> ErrorPolicies addr ()
+  -> ErrorPolicies
   -> IO Void
 withServer sn tracers networkState addr versions errPolicies =
   withServerNode
@@ -272,7 +272,7 @@ withServer_V1
   -> addr
   -> NodeToNodeVersionData
   -> (OuroborosApplication appType (ConnectionId addr) NodeToNodeProtocols IO BL.ByteString x y)
-  -> ErrorPolicies addr ()
+  -> ErrorPolicies
   -> IO Void
 withServer_V1 sn tracers networkState addr versionData application =
     withServer
@@ -444,7 +444,7 @@ dnsSubscriptionWorker_V1
 -- | A minimal error policy for remote peers, which only handles exceptions
 -- raised by `ouroboros-network`.
 --
-remoteNetworkErrorPolicy :: ErrorPolicies Socket.SockAddr a
+remoteNetworkErrorPolicy :: ErrorPolicies
 remoteNetworkErrorPolicy = ErrorPolicies {
       epAppErrorPolicies = [
           -- Handshake client protocol error: we either did not recognise received
@@ -511,9 +511,7 @@ remoteNetworkErrorPolicy = ErrorPolicies {
       epConErrorPolicies = [
           ErrorPolicy $ \(_ :: IOException) -> Just $
             SuspendConsumer shortDelay
-        ],
-
-      epReturnCallback = \_ _ _ -> ourBug
+        ]
     }
   where
     theyBuggyOrEvil :: SuspendDecision DiffTime
@@ -522,9 +520,6 @@ remoteNetworkErrorPolicy = ErrorPolicies {
     misconfiguredPeer :: SuspendDecision DiffTime
     misconfiguredPeer = SuspendConsumer defaultDelay
 
-    ourBug :: SuspendDecision DiffTime
-    ourBug = Throw
-
     defaultDelay :: DiffTime
     defaultDelay = 200 -- seconds
 
@@ -539,7 +534,7 @@ remoteNetworkErrorPolicy = ErrorPolicies {
 -- killed and not penalised by this policy.  This allows to restart the local
 -- client without a delay.
 --
-localNetworkErrorPolicy :: ErrorPolicies Socket.SockAddr a
+localNetworkErrorPolicy :: ErrorPolicies
 localNetworkErrorPolicy = ErrorPolicies {
       epAppErrorPolicies = [
           -- exception thrown by `runDecoderWithByteLimit`
@@ -558,12 +553,7 @@ localNetworkErrorPolicy = ErrorPolicies {
         ],
 
       -- The node never connects to a local client
-      epConErrorPolicies = [],
-
-      epReturnCallback = \_ _ _ -> ourBug
+      epConErrorPolicies = []
     }
-  where
-    ourBug :: SuspendDecision DiffTime
-    ourBug = Throw
 
 type RemoteConnectionId = ConnectionId Socket.SockAddr

ouroboros-network/src/Ouroboros/Network/Socket.hs

@@ -489,7 +489,7 @@ runServerThread
     -> VersionDataCodec extra CBOR.Term
     -> (forall vData. extra vData -> vData -> vData -> Accept)
     -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b)
-    -> ErrorPolicies addr ()
+    -> ErrorPolicies
     -> IO Void
 runServerThread NetworkServerTracers { nstMuxTracer
                                      , nstHandshakeTracer
@@ -589,7 +589,7 @@ withServerNode
     -- ^ The mux application that will be run on each incoming connection from
     -- a given address.  Note that if @'MuxClientAndServerApplication'@ is
     -- returned, the connection will run a full duplex set of mini-protocols.
-    -> ErrorPolicies addr ()
+    -> ErrorPolicies
     -> (addr -> Async Void -> IO t)
     -- ^ callback which takes the @Async@ of the thread that is running the server.
     -- Note: the server thread will terminate when the callback returns or

ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs

@@ -65,7 +65,7 @@ data SubscriptionParams a target = SubscriptionParams
   { spLocalAddresses         :: LocalAddresses Socket.SockAddr
   , spConnectionAttemptDelay :: Socket.SockAddr -> Maybe DiffTime
     -- ^ should return expected delay for the given address
-  , spErrorPolicies          :: ErrorPolicies Socket.SockAddr a
+  , spErrorPolicies          :: ErrorPolicies
   , spSubscriptionTarget     :: target
   }
 
@@ -181,7 +181,7 @@ subscriptionWorker
     -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace)
     -> NetworkMutableState Socket.SockAddr
     -> WorkerParams IO Socket.SockAddr
-    -> ErrorPolicies Socket.SockAddr a
+    -> ErrorPolicies
     -> Main IO (PeerStates IO Socket.SockAddr) x
     -- ^ main callback
     -> (Socket.Socket -> IO a)

ouroboros-network/test/Test/PeerState.hs

@@ -344,13 +344,12 @@ prop_subscriptionWorker
     -> Int -- local address
     -> Int -- remote address
     -> ArbValidPeerState IO
-    -> (Fun (ArbTime, Int, ()) (ArbSuspendDecision ArbDiffTime))
     -> ArbErrorPolicies
     -> (Blind (ArbApp Int))
     -> Property
 prop_subscriptionWorker
     sockType localAddr remoteAddr (ArbValidPeerState ps)
-    returnCallback (ArbErrorPolicies appErrPolicies conErrPolicies)
+    (ArbErrorPolicies appErrPolicies conErrPolicies)
     (Blind (ArbApp merr app))
   =
     tabulate "peer states & app errors" [printf "%-20s %s" (peerStateType ps) (exceptionType merr)] $
@@ -391,10 +390,7 @@ prop_subscriptionWorker
     completeTx = completeApplicationTx
        (ErrorPolicies
           appErrPolicies
-          conErrPolicies
-          (\t addr r -> fmap getArbDiffTime . getArbSuspendDecision $ case returnCallback of
-              Fn3 f -> f (ArbTime t) addr r
-              _     -> error "impossible happend"))
+          conErrPolicies)
 
     main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool
     main doneVar s = do