{-# Options_GHC -Wno-unused-do-bind #-}
module Client.Network.Async
( NetworkConnection
, NetworkId
, NetworkEvent(..)
, createConnection
, Client.Network.Async.send
, abortConnection
, TerminationReason(..)
) where
import Client.Configuration.ServerSettings
import Client.Network.Connect
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Foldable
import Data.Time
import Irc.RateLimit
import Hookup
type NetworkId = Int
data NetworkConnection = NetworkConnection
{ connOutQueue :: !(TQueue ByteString)
, connAsync :: !(Async ())
}
data NetworkEvent
= NetworkOpen !NetworkId !ZonedTime
| NetworkLine !NetworkId !ZonedTime !ByteString
| NetworkError !NetworkId !ZonedTime !SomeException
| NetworkClose !NetworkId !ZonedTime
instance Show NetworkConnection where
showsPrec p _ = showParen (p > 10)
$ showString "NetworkConnection _"
data TerminationReason
= PingTimeout
| ForcedDisconnect
deriving Show
instance Exception TerminationReason where
displayException PingTimeout = "connection killed due to ping timeout"
displayException ForcedDisconnect = "connection killed by client command"
send :: NetworkConnection -> ByteString -> IO ()
send c msg = atomically (writeTQueue (connOutQueue c) msg)
abortConnection :: TerminationReason -> NetworkConnection -> IO ()
abortConnection reason c = cancelWith (connAsync c) reason
createConnection ::
Int ->
NetworkId ->
ServerSettings ->
TQueue NetworkEvent ->
IO NetworkConnection
createConnection delay network settings inQueue =
do outQueue <- atomically newTQueue
supervisor <- async $
threadDelay (delay * 1000000) >>
startConnection network settings inQueue outQueue
forkIO $ do outcome <- waitCatch supervisor
case outcome of
Right{} -> recordNormalExit
Left e -> recordFailure e
return NetworkConnection
{ connOutQueue = outQueue
, connAsync = supervisor
}
where
recordFailure :: SomeException -> IO ()
recordFailure ex =
do now <- getZonedTime
atomically (writeTQueue inQueue (NetworkError network now ex))
recordNormalExit :: IO ()
recordNormalExit =
do now <- getZonedTime
atomically (writeTQueue inQueue (NetworkClose network now))
startConnection ::
NetworkId ->
ServerSettings ->
TQueue NetworkEvent ->
TQueue ByteString ->
IO ()
startConnection network settings inQueue outQueue =
do rate <- newRateLimit
(view ssFloodPenalty settings)
(view ssFloodThreshold settings)
withConnection settings $ \h ->
do reportNetworkOpen network inQueue
withAsync (sendLoop h outQueue rate) $ \sender ->
withAsync (receiveLoop network h inQueue) $ \receiver ->
do res <- waitEitherCatch sender receiver
case res of
Left Right{} -> fail "PANIC: sendLoop returned"
Right Right{} -> return ()
Left (Left e) -> throwIO e
Right (Left e) -> throwIO e
reportNetworkOpen :: NetworkId -> TQueue NetworkEvent -> IO ()
reportNetworkOpen network inQueue =
do now <- getZonedTime
atomically (writeTQueue inQueue (NetworkOpen network now))
sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO ()
sendLoop h outQueue rate =
forever $
do msg <- atomically (readTQueue outQueue)
tickRateLimit rate
Hookup.send h msg
ircMaxMessageLength :: Int
ircMaxMessageLength = 512
receiveLoop :: NetworkId -> Connection -> TQueue NetworkEvent -> IO ()
receiveLoop network h inQueue =
do mb <- recvLine h (2*ircMaxMessageLength)
for_ mb $ \msg ->
do now <- getZonedTime
atomically $ writeTQueue inQueue
$ NetworkLine network now msg
receiveLoop network h inQueue