Put pings at the head of the send queue

src/Client/Network/Async.hs

@@ -27,6 +27,7 @@ module Client.Network.Async
   , NetworkEvent(..)
   , createConnection
   , Client.Network.Async.send
+  , sendNext
   , Client.Network.Async.recv
   , upgrade
 
@@ -121,6 +122,13 @@ instance Exception TerminationReason where
 send :: NetworkConnection -> ByteString -> IO ()
 send c msg = atomically (writeTQueue (connOutQueue c) msg)
 
+-- | Insert a message to be transmitted on the network connection immediately.
+-- These messages are sent unmodified. The message should contain a
+-- newline terminator. This should be used for very high priority messages
+-- that must not get stuck in the queue.
+sendNext :: NetworkConnection -> ByteString -> IO ()
+sendNext c msg = atomically (unGetTQueue (connOutQueue c) msg)
+
 recv :: NetworkConnection -> STM [NetworkEvent]
 recv = flushTQueue . connInQueue
 

src/Client/State/Network.hs

@@ -230,6 +230,11 @@ defaultChannelTypes = "#&"
 csNick :: Lens' NetworkState Identifier
 csNick = csUserInfo . uiNick
 
+-- | Transmit a 'RawIrcMsg' with high priority. This is done without
+-- the message splitting that 'sendMsg' usually does.
+sendMsgNext :: NetworkState -> RawIrcMsg -> IO ()
+sendMsgNext cs msg = send (view csSocket cs) (renderRawIrcMsg msg)
+
 -- | Transmit a 'RawIrcMsg' on the connection associated
 -- with the given network. For @PRIVMSG@ and @NOTICE@ overlong
 -- commands are detected and transmitted as multiple messages.
@@ -1229,7 +1234,7 @@ applyTimedAction action cs =
 
     TimedSendPing ->
       do now <- getCurrentTime
-         sendMsg cs (ircPing ["ping"])
+         sendMsgNext cs (ircPing ["ping"])
          return $! set csNextPingTime (Just $! addUTCTime 60 now)
                 $  set csPingStatus   (PingSent now) cs