{-# LANGUAGE OverloadedStrings #-}
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.Socket (HostName)
import Network.WebSockets (ConnectionException(..), Connection,
receiveData, sendTextData, sendClose)
import Discord.Internal.Types
import Discord.Internal.Rest.Prelude (apiVersion)
data GatewayHandle = GatewayHandle
{
GatewayHandle -> Chan (Either GatewayException EventInternalParse)
gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse),
GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables :: Chan GatewaySendable,
GatewayHandle -> IORef (Maybe UpdateStatusOpts)
gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts),
GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId :: IORef Integer,
GatewayHandle -> IORef Text
gatewayHandleSessionId :: IORef T.Text,
GatewayHandle -> IORef String
gatewayHandleHostname :: IORef HostName
}
data GatewayException = GatewayExceptionIntent T.Text
deriving (Int -> GatewayException -> ShowS
[GatewayException] -> ShowS
GatewayException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GatewayException] -> ShowS
$cshowList :: [GatewayException] -> ShowS
show :: GatewayException -> String
$cshow :: GatewayException -> String
showsPrec :: Int -> GatewayException -> ShowS
$cshowsPrec :: Int -> GatewayException -> ShowS
Show)
data LoopState = LoopStart
| LoopClosed
| LoopReconnect
deriving Int -> LoopState -> ShowS
[LoopState] -> ShowS
LoopState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoopState] -> ShowS
$cshowList :: [LoopState] -> ShowS
show :: LoopState -> String
$cshow :: LoopState -> String
showsPrec :: Int -> LoopState -> ShowS
$cshowsPrec :: Int -> LoopState -> ShowS
Show
data SendablesData = SendablesData
{ SendablesData -> Connection
sendableConnection :: Connection
, SendablesData -> Chan GatewaySendableInternal
librarySendables :: Chan GatewaySendableInternal
, SendablesData -> IORef Bool
startsendingUsers :: IORef Bool
, SendablesData -> Integer
heartbeatInterval :: Integer
}
connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO ()
connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan Text -> IO ()
connectionLoop Auth
auth GatewayIntent
intent GatewayHandle
gatewayHandle Chan Text
log = LoopState -> IO ()
outerloop LoopState
LoopStart
where
outerloop :: LoopState -> IO ()
outerloop :: LoopState -> IO ()
outerloop LoopState
state = do
String
gatewayHost <- forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef String
gatewayHandleHostname GatewayHandle
gatewayHandle)
Maybe GatewaySendableInternal
mfirst <- LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state
case Maybe GatewaySendableInternal
mfirst of
Maybe GatewaySendableInternal
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just GatewaySendableInternal
message -> do
Either SomeException LoopState
nextstate <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (String -> GatewaySendableInternal -> IO LoopState
startOneConnection String
gatewayHost GatewaySendableInternal
message)
case Either SomeException LoopState
nextstate :: Either SomeException LoopState of
Left SomeException
_ -> do Int
t <- forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
3,Int
20)
Int -> IO ()
threadDelay (Int
t forall a. Num a => a -> a -> a
* (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - trying to reconnect after failure(s)")
LoopState -> IO ()
outerloop LoopState
LoopReconnect
Right LoopState
n -> LoopState -> IO ()
outerloop LoopState
n
firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state =
case LoopState
state of
LoopState
LoopStart -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Auth -> GatewayIntent -> (Int, Int) -> GatewaySendableInternal
Identify Auth
auth GatewayIntent
intent (Int
0, Int
1)
LoopState
LoopReconnect -> do Integer
seqId <- forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
gatewayHandle)
Text
seshId <- forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef Text
gatewayHandleSessionId GatewayHandle
gatewayHandle)
if Text
seshId forall a. Eq a => a -> a -> Bool
== Text
""
then do forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - WARNING seshID was not set by READY?")
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Auth -> GatewayIntent -> (Int, Int) -> GatewaySendableInternal
Identify Auth
auth GatewayIntent
intent (Int
0, Int
1)
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Auth -> Text -> Integer -> GatewaySendableInternal
Resume Auth
auth Text
seshId Integer
seqId
LoopState
LoopClosed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
startOneConnection
:: HostName
-> GatewaySendableInternal
-> IO LoopState
startOneConnection :: String -> GatewaySendableInternal -> IO LoopState
startOneConnection String
gatewayAddr GatewaySendableInternal
message = forall a. String -> PortNumber -> String -> ClientApp a -> IO a
runSecureClient String
gatewayAddr PortNumber
443 (String
"/?v=" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
apiVersion forall a. Semigroup a => a -> a -> a
<>String
"&encoding=json") forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
Either ConnectionException GatewayReceivable
msg <- Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload Connection
conn Chan Text
log
case Either ConnectionException GatewayReceivable
msg of
Right (Hello Integer
interval) -> do
Chan GatewaySendableInternal
internal <- forall a. IO (Chan a)
newChan :: IO (Chan GatewaySendableInternal)
IORef Bool
sendingUser <- forall a. a -> IO (IORef a)
newIORef Bool
False
let sending :: SendablesData
sending = SendablesData { sendableConnection :: Connection
sendableConnection = Connection
conn
, librarySendables :: Chan GatewaySendableInternal
librarySendables = Chan GatewaySendableInternal
internal
, startsendingUsers :: IORef Bool
startsendingUsers = IORef Bool
sendingUser
, heartbeatInterval :: Integer
heartbeatInterval = Integer
interval
}
ThreadId
sendsId <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Connection -> GatewayHandle -> SendablesData -> Chan Text -> IO ()
sendableLoop Connection
conn GatewayHandle
gatewayHandle SendablesData
sending Chan Text
log
ThreadId
heart <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ SendablesData -> IORef Integer -> IO ()
heartbeat SendablesData
sending (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
gatewayHandle)
forall a. Chan a -> a -> IO ()
writeChan Chan GatewaySendableInternal
internal GatewaySendableInternal
message
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (GatewayHandle -> SendablesData -> Chan Text -> IO LoopState
runEventLoop GatewayHandle
gatewayHandle SendablesData
sending Chan Text
log)
(ThreadId -> IO ()
killThread ThreadId
heart forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
sendsId)
Either ConnectionException GatewayReceivable
_ -> do
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log Text
"gateway - WARNING could not connect. Expected hello"
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn (ByteString
"expected hello" :: BL.ByteString)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn :: IO BL.ByteString)
Int -> IO ()
threadDelay (Int
3 forall a. Num a => a -> a -> a
* (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState
runEventLoop :: GatewayHandle -> SendablesData -> Chan Text -> IO LoopState
runEventLoop GatewayHandle
thehandle SendablesData
sendablesData Chan Text
log = do IO LoopState
loop
where
eventChan :: Chan (Either GatewayException EventInternalParse)
eventChan :: Chan (Either GatewayException EventInternalParse)
eventChan = GatewayHandle -> Chan (Either GatewayException EventInternalParse)
gatewayHandleEvents GatewayHandle
thehandle
loop :: IO LoopState
loop = do
Either ConnectionException GatewayReceivable
eitherPayload <- SendablesData
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout SendablesData
sendablesData Chan Text
log
case Either ConnectionException GatewayReceivable
eitherPayload :: Either ConnectionException GatewayReceivable of
Right (Dispatch EventInternalParse
event Integer
sq) -> do
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
thehandle) Integer
sq
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException EventInternalParse)
eventChan (forall a b. b -> Either a b
Right EventInternalParse
event)
case EventInternalParse
event of
(InternalReady Int
_ User
_ [GuildUnavailable]
_ Text
seshID String
resumeHost Maybe (Int, Int)
_ PartialApplication
_) -> do
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Text
gatewayHandleSessionId GatewayHandle
thehandle) Text
seshID
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef String
gatewayHandleHostname GatewayHandle
thehandle) forall a b. (a -> b) -> a -> b
$ String
resumeHost
EventInternalParse
_ -> forall a. IORef a -> a -> IO ()
writeIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData) Bool
True
IO LoopState
loop
Right (Hello Integer
_interval) -> do forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"eventloop - unexpected hello")
IO LoopState
loop
Right (HeartbeatRequest Integer
sq) -> do forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
thehandle) Integer
sq
forall a. Chan a -> a -> IO ()
writeChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData) (Integer -> GatewaySendableInternal
Heartbeat Integer
sq)
IO LoopState
loop
Right (InvalidSession Bool
retry) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
retry then LoopState
LoopReconnect else LoopState
LoopStart
Right (GatewayReceivable
Reconnect) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
Right (GatewayReceivable
HeartbeatAck) -> IO LoopState
loop
Right (ParseError Text
_e) -> IO LoopState
loop
Left (CloseRequest Word16
code ByteString
str) -> case Word16
code of
Word16
1000 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
Word16
1001 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
Word16
4000 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
Word16
4006 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
Word16
4007 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
Word16
4014 -> do forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException EventInternalParse)
eventChan (forall a b. a -> Either a b
Left (Text -> GatewayException
GatewayExceptionIntent forall a b. (a -> b) -> a -> b
$
Text
"Tried to declare an unauthorized GatewayIntent. " forall a. Semigroup a => a -> a -> a
<>
Text
"Use the discord app manager to authorize by following: " forall a. Semigroup a => a -> a -> a
<>
Text
"https://github.com/discord-haskell/discord-haskell/blob/master/docs/intents.md"))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopClosed
Word16
_ -> do forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - unknown websocket close code " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Word16
code)
forall a. Semigroup a => a -> a -> a
<> Text
" [" forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
str) forall a. Semigroup a => a -> a -> a
<> Text
"]. Consider opening an issue "
forall a. Semigroup a => a -> a -> a
<> Text
"https://github.com/discord-haskell/discord-haskell/issues")
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
Left ConnectionException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout :: SendablesData
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout SendablesData
sendablesData Chan Text
log = do
let interval :: Integer
interval = SendablesData -> Integer
heartbeatInterval SendablesData
sendablesData
Either () (Either ConnectionException GatewayReceivable)
res <- forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay (forall a. Num a => Integer -> a
fromInteger ((Integer
interval forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
3) forall a. Integral a => a -> a -> a
`div` Integer
2)))
(Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload (SendablesData -> Connection
sendableConnection SendablesData
sendablesData) Chan Text
log)
case Either () (Either ConnectionException GatewayReceivable)
res of
Left () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right GatewayReceivable
Reconnect)
Right Either ConnectionException GatewayReceivable
other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConnectionException GatewayReceivable
other
getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)
getPayload :: Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload Connection
conn Chan Text
log = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
ByteString
msg' <- forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
case forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
msg' of
Right GatewayReceivable
msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GatewayReceivable
msg
Left String
err -> do forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - received exception [" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err forall a. Semigroup a => a -> a -> a
<> Text
"]"
forall a. Semigroup a => a -> a -> a
<> Text
" while decoding " forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
msg'))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GatewayReceivable
ParseError (String -> Text
T.pack String
err))
heartbeat :: SendablesData -> IORef Integer -> IO ()
heartbeat :: SendablesData -> IORef Integer -> IO ()
heartbeat SendablesData
sendablesData IORef Integer
seqKey = do
Int -> IO ()
threadDelay (Int
3 forall a. Num a => a -> a -> a
* Int
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int))
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Integer
num <- forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
forall a. Chan a -> a -> IO ()
writeChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData) (Integer -> GatewaySendableInternal
Heartbeat Integer
num)
Int -> IO ()
threadDelay (forall a. Num a => Integer -> a
fromInteger (SendablesData -> Integer
heartbeatInterval SendablesData
sendablesData forall a. Num a => a -> a -> a
* Integer
1000))
sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO ()
sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan Text -> IO ()
sendableLoop Connection
conn GatewayHandle
ghandle SendablesData
sendablesData Chan Text
_log = forall {b}. IO b
sendLoop
where
sendLoop :: IO b
sendLoop = do
Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)) forall a. Num a => a -> a -> a
* (Double
62 forall a. Fractional a => a -> a -> a
/ Double
120) :: Double)
Either GatewaySendableInternal GatewaySendable
payload <- forall a b. IO a -> IO b -> IO (Either a b)
race IO GatewaySendableInternal
nextLibrary IO GatewaySendable
nextUser
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ToJSON a => a -> ByteString
encode forall a. ToJSON a => a -> ByteString
encode Either GatewaySendableInternal GatewaySendable
payload)
IO b
sendLoop
nextLibrary :: IO GatewaySendableInternal
nextLibrary :: IO GatewaySendableInternal
nextLibrary = forall a. Chan a -> IO a
readChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData)
nextUser :: IO GatewaySendable
nextUser :: IO GatewaySendable
nextUser = do Bool
usersending <- forall a. IORef a -> IO a
readIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData)
if Bool
usersending
then forall a. Chan a -> IO a
readChan (GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables GatewayHandle
ghandle)
else Int -> IO ()
threadDelay (Int
4 forall a. Num a => a -> a -> a
* (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6::Int))) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO GatewaySendable
nextUser