1 files changed, 10 insertions, 10 deletions

diff --git a/server/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs
index ea87abe4..69cc6f50 100644
--- a/server/src/Network/QueryResponse.hs
+++ b/server/src/Network/QueryResponse.hs
@@ -188,17 +188,16 @@ partitionTransport parse encodex tr =
 -- Note: If you add a handler to one of the branches before applying a
 -- 'mergeTransports' combinator, then this handler may not block or return
 -- Nothing.
-addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> TransportA err addr x y -> TransportA err addr x y
-addHandler onParseError f tr = tr
+addHandler :: (addr -> x -> IO (Maybe (x -> x))) -> TransportA err addr x y -> TransportA err addr x y
+addHandler f tr = tr
     { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \case
         Arrival addr x -> f addr x >>= maybe (join $ atomically eat) (kont . Arrival addr . ($ x))
-        ParseError e   -> onParseError e >> kont (ParseError e)
-        Terminated     -> kont Terminated
+        m              -> kont m
     }
 
 -- | Modify a 'Transport' to invoke an action upon every received packet.
 onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x
-onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr
+onInbound f tr = addHandler (\addr x -> f addr x >> return (Just id)) tr
 
 -- * Using a query\/response client.
 
@@ -208,19 +207,20 @@ onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (
 --  Example usage:
 --
 --  > -- Start client.
---  > quitServer <- forkListener "listener" (clientNet client)
+--  > quitServer <- forkListener "listener" (\_ -> return()) (clientNet client)
 --  > -- Send a query q, recieve a response r.
 --  > r <- sendQuery client method q
 --  > -- Quit client.
 --  > quitServer
-forkListener :: String -> Transport err addr x -> IO (IO ())
-forkListener name client = do
+forkListener :: String -> (err -> IO ()) -> Transport err addr x -> IO (IO ())
+forkListener name onParseError client = do
     setActive client True
     thread_id <- forkIO $ do
         myThreadId >>= flip labelThread ("listener."++name)
         fix $ \loop -> join $ atomically $ awaitMessage client $ \case
-            Terminated -> return ()
-            _          -> loop
+            Terminated   -> return ()
+            ParseError e -> onParseError e >> loop
+            _            -> loop
         dput XMisc $ "Listener died: " ++ name
     return $ do
         setActive client False