QueryResponse: non-error ignored case Discarded.

1 files changed, 5 insertions, 1 deletions

diff --git a/server/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs
index 470b7ce7..6af1f355 100644
--- a/server/src/Network/QueryResponse.hs
+++ b/server/src/Network/QueryResponse.hs
@@ -65,13 +65,14 @@ resultToMaybe _           = Nothing
 -- | An inbound packet or condition raised while monitoring a connection.
 data Arrival err addr x
     = Terminated       -- ^ Virtual message that signals EOF.
+    | Discarded        -- ^ Message dropped or passed to another thread.
     | ParseError !err  -- ^ A badly-formed message was received.
     | Arrival { arrivedFrom :: !addr , arrivedMsg  :: !x } -- ^ Inbound message.
 
 -- | Three methods are required to implement a datagram based query\/response protocol.
 data TransportA err addr x y = Transport
     { -- | Blocks until an inbound packet is available. Then calls the provided
-      -- continuation with the packet and origin addres or an error condition.
+      -- continuation with the packet and origin address or an error condition.
       awaitMessage :: forall a. (Arrival err addr x -> IO a) -> STM (IO a)
       -- | Send an /y/ packet to the given destination /addr/.
     , sendMessage :: addr -> y -> IO ()
@@ -109,6 +110,7 @@ layerTransportM parse encode tr =
     tr { awaitMessage = \kont ->
                 awaitMessage tr $ \case
                     Terminated     -> kont $ Terminated
+                    Discarded      -> kont $ Discarded
                     ParseError e   -> kont $ ParseError e
                     Arrival addr x -> parse x addr >>= \case
                         Left e           -> kont $ ParseError e
@@ -153,6 +155,7 @@ partitionTransportM parse encodex tr = do
                             Left x          -> atomically (writeTChan tchan (Just x)) >> join (atomically again)
                             Right (y,yaddr) -> kont $ Arrival yaddr y
                         ParseError e     -> kont $ ParseError e
+                        Discarded        -> kont $ Discarded
                         Terminated       -> atomically (writeTChan tchan Nothing) >> kont Terminated
                  , sendMessage = sendMessage tr
                  }
@@ -708,6 +711,7 @@ newtype Tagged x addr = Tagged x
 
 decorateAddr :: tag addr -> Arrival e addr x -> Arrival e (DSum tag Identity) x
 decorateAddr tag Terminated       = Terminated
+decorateAddr tag Discarded        = Discarded
 decorateAddr tag (ParseError e)   = ParseError e
 decorateAddr tag (Arrival addr x) = Arrival (tag ==> addr) x