discord-haskell-1.9.0: src/Discord/Internal/Gateway/EventLoop.hs
{-# LANGUAGE OverloadedStrings #-}
-- | Provides logic code for interacting with the Discord websocket
-- gateway. Realistically, this is probably lower level than most
-- people will need
module Discord.Internal.Gateway.EventLoop where
import Prelude hiding (log)
import Control.Monad (forever, void)
import Control.Monad.Random (getRandomR)
import Control.Concurrent.Async (race)
import Control.Concurrent.Chan
import Control.Concurrent (threadDelay, killThread, forkIO)
import Control.Exception.Safe (try, finally, SomeException)
import Data.IORef
import Data.Aeson (eitherDecode, encode)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as BL
import Wuss (runSecureClient)
import Network.WebSockets (ConnectionException(..), Connection,
receiveData, sendTextData, sendClose)
import Discord.Internal.Types
data GatewayHandle = GatewayHandle
{ gatewayHandleEvents :: Chan (Either GatewayException Event)
, gatewayHandleUserSendables :: Chan GatewaySendable
, gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts)
, gatewayHandleLastSequenceId :: IORef Integer
, gatewayHandleSessionId :: IORef T.Text
}
data GatewayException = GatewayExceptionCouldNotConnect T.Text
| GatewayExceptionEventParseError T.Text T.Text
| GatewayExceptionUnexpected GatewayReceivable T.Text
| GatewayExceptionConnection ConnectionException T.Text
deriving (Show)
-- | State of the eventloop
data LoopState = LoopStart
| LoopClosed
| LoopReconnect
deriving Show
-- | Enough info for library to send info to discord.
data SendablesData = SendablesData
{ sendableConnection :: Connection
, librarySendables :: Chan GatewaySendableInternal
, startsendingUsers :: IORef Bool
, heartbeatInterval :: Integer
}
{-
Some quick documentation for some of the variables passed around:
Auth needed to connect
GatewayIntent needed to connect
GatewayHandle (eventsGifts,status,usersends,seq,sesh) needed all over
log :: Chan (T.Text) needed all over
sendableConnection set by setup, need sendableLoop
librarySendables :: Chan (GatewaySendableInternal) set by setup, need heartbeat
heartbeatInterval :: Int set by Hello, need heartbeat
sequenceId :: Int id of last event received set by Resume, need heartbeat and reconnect
sessionId :: Text set by Ready, need reconnect
-}
connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO ()
connectionLoop auth intent gatewayHandle log = outerloop LoopStart
where
outerloop :: LoopState -> IO ()
outerloop state = do
mfirst <- firstmessage state
case mfirst of
Nothing -> pure ()
Just first -> do
next <- try (startconnectionpls first)
case next :: Either SomeException LoopState of
Left _ -> do t <- getRandomR (3,20)
threadDelay (t * (10^(6 :: Int)))
writeChan log ("gateway - trying to reconnect after failure(s)")
outerloop LoopReconnect
Right n -> outerloop n
firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage state =
case state of
LoopStart -> pure $ Just $ Identify auth intent (0, 1)
LoopReconnect -> do seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle)
seshId <- readIORef (gatewayHandleSessionId gatewayHandle)
if seshId == ""
then do writeChan log ("gateway - WARNING seshID was not set by READY?")
pure $ Just $ Identify auth intent (0, 1)
else pure $ Just $ Resume auth seshId seqId
LoopClosed -> pure Nothing
startconnectionpls :: GatewaySendableInternal -> IO LoopState
startconnectionpls first = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" $ \conn -> do
msg <- getPayload conn log
case msg of
Right (Hello interval) -> do
internal <- newChan :: IO (Chan GatewaySendableInternal)
us <- newIORef False
-- start event loop
let sending = SendablesData conn internal us interval
sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log
heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle)
writeChan internal first
finally (runEventLoop gatewayHandle sending log)
(killThread heart >> killThread sendsId)
_ -> do
writeChan log "gateway - WARNING could not connect. Expected hello"
sendClose conn ("expected hello" :: BL.ByteString)
void $ forever $ void (receiveData conn :: IO BL.ByteString)
-- > after sendClose you should call receiveDataMessage until
-- > it throws an exception
-- haskell websockets documentation
threadDelay (3 * (10^(6 :: Int)))
pure LoopStart
runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState
runEventLoop thehandle sendablesData log = do loop
where
eventChan = gatewayHandleEvents thehandle
loop = do
eitherPayload <- getPayloadTimeout sendablesData log
case eitherPayload :: Either ConnectionException GatewayReceivable of
Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello")
loop
Right (Dispatch event sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq
writeChan eventChan (Right event)
case event of
(Ready _ _ _ _ seshID) ->
writeIORef (gatewayHandleSessionId thehandle) seshID
_ -> writeIORef (startsendingUsers sendablesData) True
loop
Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq
writeChan (librarySendables sendablesData) (Heartbeat sq)
loop
Right (Reconnect) -> pure LoopReconnect
Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart
Right (HeartbeatAck) -> loop
Right (ParseError e) -> do writeChan eventChan (Left (GatewayExceptionEventParseError e
"Normal event loop"))
pure LoopClosed
Left (CloseRequest code str) -> case code of
-- see Discord and MDN documentation on gateway close event codes
-- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes
-- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties
1000 -> pure LoopReconnect
1001 -> pure LoopReconnect
4000 -> pure LoopReconnect
4006 -> pure LoopStart
4007 -> pure LoopStart
4014 -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello 0) $
"Tried to declare an unauthorized GatewayIntent. " <>
"Use the discord app manager to authorize by following: " <>
"https://github.com/aquarial/discord-haskell/issues/76"))
pure LoopClosed
_ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str)
"Unknown close code. Closing connection. Consider opening an issue with discord-haskell"))
pure LoopClosed
Left _ -> pure LoopReconnect
heartbeat :: SendablesData -> IORef Integer -> IO ()
heartbeat sendablesData seqKey = do
threadDelay (3 * 10^(6 :: Int))
forever $ do
num <- readIORef seqKey
writeChan (librarySendables sendablesData) (Heartbeat num)
threadDelay (fromInteger (heartbeatInterval sendablesData * 1000))
getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout sendablesData log = do
let interval = heartbeatInterval sendablesData
res <- race (threadDelay (fromInteger ((interval * 1000 * 3) `div` 2)))
(getPayload (sendableConnection sendablesData) log)
case res of
Left () -> pure (Right Reconnect)
Right other -> pure other
getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)
getPayload conn log = try $ do
msg' <- receiveData conn
case eitherDecode msg' of
Right msg -> pure msg
Left err -> do writeChan log ("gateway - received parse Error - " <> T.pack err
<> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg'))
pure (ParseError (T.pack err))
-- simple idea: send payloads from user/sys to connection
-- has to be complicated though
sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO ()
sendableLoop conn ghandle sendablesData _log = sendSysLoop
where
sendSysLoop = do
threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double)
payload <- readChan (librarySendables sendablesData)
sendTextData conn (encode payload)
-- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload)))
usersending <- readIORef (startsendingUsers sendablesData)
if not usersending
then sendSysLoop
else do act <- readIORef (gatewayHandleLastStatus ghandle)
case act of Nothing -> pure ()
Just opts -> sendTextData conn (encode (UpdateStatus opts))
sendUserLoop
sendUserLoop = do
-- send a ~120 events a min by delaying
threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double)
-- payload :: Either GatewaySendableInternal GatewaySendable
payload <- race (readChan (gatewayHandleUserSendables ghandle)) (readChan (librarySendables sendablesData))
sendTextData conn (either encode encode payload)
-- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload)))
sendUserLoop