{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune, not-home #-}
module Discord.Gateway.EventLoop where
import Prelude hiding (log)
import Control.Monad (forever, (<=<))
import Control.Monad.Random (getRandomR)
import Control.Concurrent.Async (race)
import Control.Concurrent.Chan
import Control.Exception.Safe (try, finally, handle, SomeException)
import Control.Concurrent (threadDelay, killThread, forkIO)
import Data.Monoid ((<>))
import Data.IORef
import Data.Aeson (eitherDecode, encode)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as QL
import Wuss (runSecureClient)
import Network.WebSockets (ConnectionException(..), Connection,
receiveData, sendTextData)
import Discord.Types
data ConnLoopState = ConnStart
| ConnClosed
| ConnReconnect T.Text String Integer
deriving Show
data ConnectionData = ConnData { connection :: Connection
, connSessionID :: String
, connAuth :: T.Text
, connChan :: Chan Event
}
data Sendables = Sendables { userSends :: Chan GatewaySendable
, gatewaySends :: Chan GatewaySendable
}
connect :: (Connection -> IO a) -> IO a
connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json"
connectionLoop :: Auth -> Chan Event -> Chan GatewaySendable -> Chan String -> IO ()
connectionLoop auth events userSend log = loop ConnStart
where
loop :: ConnLoopState -> IO ()
loop s = do
writeChan log ("gateway - connection loop state " <> show s)
case s of
(ConnClosed) -> pure ()
(ConnStart) -> do
loop <=< connect $ \conn -> do
msg <- getPayload conn log
case msg of
Right (Hello interval) -> do
sendTextData conn (encode (Identify auth False 50 (0, 1)))
msg2 <- getPayload conn log
case msg2 of
Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do
writeChan events r
startEventStream conn events auth seshID interval 0 userSend log
_ -> writeChan log ("gateway - connstart must be ready: " <> show msg2) >> pure ConnClosed
_ -> writeChan log ("gateway - connstart must be hello: " <> show msg) >> pure ConnClosed
(ConnReconnect tok seshID seqID) -> do
next <- try $ connect $ \conn -> do
sendTextData conn (encode (Resume tok seshID seqID))
eitherPayload <- getPayload conn log
case eitherPayload of
Right (Hello interval) ->
startEventStream conn events auth seshID interval seqID userSend log
Right (InvalidSession retry) -> do
t <- getRandomR (1,5)
threadDelay (t * 10^6)
pure $ if retry
then ConnReconnect tok seshID seqID
else ConnStart
Right payload -> do
writeChan log ("gateway - connreconnect invalid response: " <> show payload)
pure ConnClosed
Left e ->
writeChan log ("gateway - connreconnect error " <> show e) >> pure ConnClosed
case next :: Either SomeException ConnLoopState of
Left e -> do writeChan log ("gateway - connreconnect after eventStream error: " <> show e)
t <- getRandomR (3,10)
threadDelay (t * 10^6)
loop (ConnReconnect tok seshID seqID)
Right n -> loop n
getPayloadTimeout :: Connection -> Int -> Chan String -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout conn interval log = do
res <- race (threadDelay ((interval * 1000 * 3) `div` 2))
(getPayload conn log)
case res of
Left () -> pure (Right Reconnect)
Right other -> pure other
getPayload :: Connection -> Chan String -> IO (Either ConnectionException GatewayReceivable)
getPayload conn log = try $ do
msg' <- receiveData conn
writeChan log ("gateway - received " <> QL.unpack msg')
case eitherDecode msg' of
Right msg -> return msg
Left err -> do writeChan log ("gateway - received parse Error - " <> err)
return (ParseError err)
heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> Chan String -> IO ()
heartbeat send interval seqKey log = do
threadDelay (1 * 10^6)
writeChan log "gateway - starting heartbeat"
forever $ do
num <- readIORef seqKey
writeChan send (Heartbeat num)
threadDelay (interval * 1000)
setSequence :: IORef Integer -> Integer -> IO ()
setSequence key i = writeIORef key i
startEventStream :: Connection -> Chan Event -> Auth -> String -> Int
-> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState
startEventStream conn events (Auth auth) seshID interval seqN userSend log = do
seqKey <- newIORef seqN
let err :: SomeException -> IO ConnLoopState
err e = do writeChan log ("gateway - eventStream error: " <> show e)
ConnReconnect auth seshID <$> readIORef seqKey
handle err $ do
gateSends <- newChan
sendsId <- forkIO $ sendableLoop conn (Sendables userSend gateSends) log
heart <- forkIO $ heartbeat gateSends interval seqKey log
finally (eventStream (ConnData conn seshID auth events) seqKey interval gateSends log)
(killThread heart >> killThread sendsId)
eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable
-> Chan String -> IO ConnLoopState
eventStream (ConnData conn seshID auth eventChan) seqKey interval send log = loop
where
loop :: IO ConnLoopState
loop = do
eitherPayload <- getPayloadTimeout conn interval log
case eitherPayload :: Either ConnectionException GatewayReceivable of
Left (CloseRequest code str) -> case code of
1000 -> ConnReconnect auth seshID <$> readIORef seqKey
4000 -> ConnReconnect auth seshID <$> readIORef seqKey
4006 -> pure ConnStart
4007 -> ConnReconnect auth seshID <$> readIORef seqKey
4014 -> ConnReconnect auth seshID <$> readIORef seqKey
e -> do writeChan log ("gateway - Closing connection because #"
<> show e <> " " <> show str)
pure ConnClosed
Left _ -> ConnReconnect auth seshID <$> readIORef seqKey
Right (Dispatch event sq) -> do setSequence seqKey sq
writeChan eventChan event
loop
Right (HeartbeatRequest sq) -> do setSequence seqKey sq
writeChan send (Heartbeat sq)
loop
Right (Reconnect) -> do writeChan log "Should reconnect"
ConnReconnect auth seshID <$> readIORef seqKey
Right (InvalidSession retry) -> if retry
then ConnReconnect auth seshID <$> readIORef seqKey
else pure ConnStart
Right (HeartbeatAck) -> loop
Right p -> do writeChan log ("gateway - Invalid gateway payload: " <> show p)
pure ConnClosed
sendableLoop :: Connection -> Sendables -> Chan [Char] -> IO ()
sendableLoop conn sends log = forever $ do
threadDelay (round (10^6 * (62 / 120)))
let e :: Either GatewaySendable GatewaySendable -> GatewaySendable
e = either id id
payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends))
writeChan log ("gateway - sending " <> QL.unpack (encode payload))
sendTextData conn (encode payload)