{-# LANGUAGE OverloadedStrings #-}
module Discord.Internal.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.Concurrent (threadDelay, killThread, forkIO)
import Control.Exception.Safe (try, finally, handle, 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)
import Discord.Internal.Types
data GatewayException = GatewayExceptionCouldNotConnect T.Text
| GatewayExceptionEventParseError T.Text T.Text
| GatewayExceptionUnexpected GatewayReceivable T.Text
| GatewayExceptionConnection ConnectionException T.Text
deriving (Int -> GatewayException -> ShowS
[GatewayException] -> ShowS
GatewayException -> String
(Int -> GatewayException -> ShowS)
-> (GatewayException -> String)
-> ([GatewayException] -> ShowS)
-> Show GatewayException
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 ConnLoopState = ConnStart
| ConnClosed
| ConnReconnect Auth T.Text Integer
deriving Int -> ConnLoopState -> ShowS
[ConnLoopState] -> ShowS
ConnLoopState -> String
(Int -> ConnLoopState -> ShowS)
-> (ConnLoopState -> String)
-> ([ConnLoopState] -> ShowS)
-> Show ConnLoopState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnLoopState] -> ShowS
$cshowList :: [ConnLoopState] -> ShowS
show :: ConnLoopState -> String
$cshow :: ConnLoopState -> String
showsPrec :: Int -> ConnLoopState -> ShowS
$cshowsPrec :: Int -> ConnLoopState -> ShowS
Show
connect :: (Connection -> IO a) -> IO a
connect :: (Connection -> IO a) -> IO a
connect = String -> PortNumber -> String -> (Connection -> IO a) -> IO a
forall a. String -> PortNumber -> String -> ClientApp a -> IO a
runSecureClient String
"gateway.discord.gg" PortNumber
443 String
"/?v=6&encoding=json"
type DiscordHandleGateway = (Chan (Either GatewayException Event), Chan GatewaySendable, IORef (Maybe UpdateStatusOpts))
connectionLoop :: Auth -> DiscordHandleGateway -> Chan T.Text -> IO ()
connectionLoop :: Auth -> DiscordHandleGateway -> Chan Text -> IO ()
connectionLoop Auth
auth (Chan (Either GatewayException Event)
events, Chan GatewaySendable
userSend, IORef (Maybe UpdateStatusOpts)
lastStatus) Chan Text
log = ConnLoopState -> Int -> IO ()
loop ConnLoopState
ConnStart Int
0
where
loop :: ConnLoopState -> Int -> IO ()
loop :: ConnLoopState -> Int -> IO ()
loop ConnLoopState
s Int
retries =
case ConnLoopState
s of
(ConnLoopState
ConnClosed) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(ConnLoopState
ConnStart) -> do
Either SomeException ConnLoopState
next <- IO ConnLoopState -> IO (Either SomeException ConnLoopState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO ConnLoopState -> IO (Either SomeException ConnLoopState))
-> IO ConnLoopState -> IO (Either SomeException ConnLoopState)
forall a b. (a -> b) -> a -> b
$ (Connection -> IO ConnLoopState) -> IO ConnLoopState
forall a. (Connection -> IO a) -> IO a
connect ((Connection -> IO ConnLoopState) -> IO ConnLoopState)
-> (Connection -> IO ConnLoopState) -> IO ConnLoopState
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 Int
interval) -> do
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Auth -> Bool -> Integer -> (Int, Int) -> GatewaySendable
Identify Auth
auth Bool
False Integer
50 (Int
0, Int
1)))
Either ConnectionException GatewayReceivable
msg2 <- Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload Connection
conn Chan Text
log
case Either ConnectionException GatewayReceivable
msg2 of
Right (Dispatch r :: Event
r@(Ready Int
_ User
_ [Channel]
_ [GuildUnavailable]
_ Text
seshID) Integer
_) -> do
Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (Event -> Either GatewayException Event
forall a b. b -> Either a b
Right Event
r)
ConnectionData
-> Int
-> Integer
-> Chan GatewaySendable
-> IORef (Maybe UpdateStatusOpts)
-> Chan Text
-> IO ConnLoopState
startEventStream (Connection
-> Text
-> Auth
-> Chan (Either GatewayException Event)
-> ConnectionData
ConnData Connection
conn Text
seshID Auth
auth Chan (Either GatewayException Event)
events) Int
interval Integer
0 Chan GatewaySendable
userSend IORef (Maybe UpdateStatusOpts)
lastStatus Chan Text
log
Right GatewayReceivable
m -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (GatewayReceivable -> Text -> GatewayException
GatewayExceptionUnexpected GatewayReceivable
m
Text
"Response to Identify must be Ready"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Left (CloseRequest Word16
code ByteString
_str) -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - close " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
code))
Int -> IO ()
threadDelay (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnStart
Left ConnectionException
ce -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (ConnectionException -> Text -> GatewayException
GatewayExceptionConnection ConnectionException
ce
Text
"Response to Identify"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Right GatewayReceivable
m -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - first message must be hello: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Either ConnectionException GatewayReceivable -> String
forall a. Show a => a -> String
show Either ConnectionException GatewayReceivable
msg))
Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (GatewayReceivable -> Text -> GatewayException
GatewayExceptionUnexpected GatewayReceivable
m
Text
"Response to connecting must be hello"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Left (CloseRequest Word16
code ByteString
_str) -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - close " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
code))
Int -> IO ()
threadDelay (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnStart
Left ConnectionException
ce -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (ConnectionException -> Text -> GatewayException
GatewayExceptionConnection ConnectionException
ce
Text
"Response to connecting"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
case Either SomeException ConnLoopState
next :: Either SomeException ConnLoopState of
Left SomeException
_ -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (Text -> GatewayException
GatewayExceptionCouldNotConnect
Text
"SomeException in gateway Connection"))
ConnLoopState -> Int -> IO ()
loop ConnLoopState
ConnClosed Int
0
Right ConnLoopState
n -> ConnLoopState -> Int -> IO ()
loop ConnLoopState
n Int
0
(ConnReconnect (Auth Text
tok) Text
seshID Integer
seqID) -> do
Either SomeException ConnLoopState
next <- IO ConnLoopState -> IO (Either SomeException ConnLoopState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO ConnLoopState -> IO (Either SomeException ConnLoopState))
-> IO ConnLoopState -> IO (Either SomeException ConnLoopState)
forall a b. (a -> b) -> a -> b
$ (Connection -> IO ConnLoopState) -> IO ConnLoopState
forall a. (Connection -> IO a) -> IO a
connect ((Connection -> IO ConnLoopState) -> IO ConnLoopState)
-> (Connection -> IO ConnLoopState) -> IO ConnLoopState
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Text -> Text -> Integer -> GatewaySendable
Resume Text
tok Text
seshID Integer
seqID))
Either ConnectionException GatewayReceivable
eitherPayload <- Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload Connection
conn Chan Text
log
case Either ConnectionException GatewayReceivable
eitherPayload of
Right (Hello Int
interval) ->
ConnectionData
-> Int
-> Integer
-> Chan GatewaySendable
-> IORef (Maybe UpdateStatusOpts)
-> Chan Text
-> IO ConnLoopState
startEventStream (Connection
-> Text
-> Auth
-> Chan (Either GatewayException Event)
-> ConnectionData
ConnData Connection
conn Text
seshID Auth
auth Chan (Either GatewayException Event)
events) Int
interval Integer
seqID Chan GatewaySendable
userSend IORef (Maybe UpdateStatusOpts)
lastStatus Chan Text
log
Right (InvalidSession Bool
retry) -> do
Int
t <- (Int, Int) -> IO Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
1,Int
5)
Int -> IO ()
threadDelay (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnLoopState -> IO ConnLoopState)
-> ConnLoopState -> IO ConnLoopState
forall a b. (a -> b) -> a -> b
$ if Bool
retry
then Auth -> Text -> Integer -> ConnLoopState
ConnReconnect (Text -> Auth
Auth Text
tok) Text
seshID Integer
seqID
else ConnLoopState
ConnStart
Right GatewayReceivable
payload -> do
Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (GatewayReceivable -> Text -> GatewayException
GatewayExceptionUnexpected GatewayReceivable
payload
Text
"Response to Resume must be Hello/Invalid Session"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Left (CloseRequest Word16
code ByteString
_str) -> do
Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - retrying from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
code))
Int -> IO ()
threadDelay (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Auth -> Text -> Integer -> ConnLoopState
ConnReconnect (Text -> Auth
Auth Text
tok) Text
seshID Integer
seqID)
Left ConnectionException
e -> do
Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
events (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (ConnectionException -> Text -> GatewayException
GatewayExceptionConnection ConnectionException
e Text
"Could not ConnReconnect"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
case Either SomeException ConnLoopState
next :: Either SomeException ConnLoopState of
Left SomeException
_ -> do Int
t <- (Int, Int) -> IO Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
3,Int
20)
Int -> IO ()
threadDelay (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - trying to reconnect after " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
retries)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failures")
ConnLoopState -> Int -> IO ()
loop (Auth -> Text -> Integer -> ConnLoopState
ConnReconnect (Text -> Auth
Auth Text
tok) Text
seshID Integer
seqID) (Int
retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Right ConnLoopState
n -> ConnLoopState -> Int -> IO ()
loop ConnLoopState
n Int
1
getPayloadTimeout :: Connection -> Int -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout :: Connection
-> Int
-> Chan Text
-> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout Connection
conn Int
interval Chan Text
log = do
Either () (Either ConnectionException GatewayReceivable)
res <- IO ()
-> IO (Either ConnectionException GatewayReceivable)
-> IO (Either () (Either ConnectionException GatewayReceivable))
forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay ((Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
(Connection
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayload Connection
conn Chan Text
log)
case Either () (Either ConnectionException GatewayReceivable)
res of
Left () -> Either ConnectionException GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GatewayReceivable -> Either ConnectionException GatewayReceivable
forall a b. b -> Either a b
Right GatewayReceivable
Reconnect)
Right Either ConnectionException GatewayReceivable
other -> Either ConnectionException GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable)
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 = IO GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable))
-> IO GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable)
forall a b. (a -> b) -> a -> b
$ do
ByteString
msg' <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
case ByteString -> Either String GatewayReceivable
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
msg' of
Right GatewayReceivable
msg -> GatewayReceivable -> IO GatewayReceivable
forall (f :: * -> *) a. Applicative f => a -> f a
pure GatewayReceivable
msg
Left String
err -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - received parse Error - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" while decoding " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
msg'))
GatewayReceivable -> IO GatewayReceivable
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GatewayReceivable
ParseError (String -> Text
T.pack String
err))
heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> IO ()
heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> IO ()
heartbeat Chan GatewaySendable
send Int
interval IORef Integer
seqKey = do
Int -> IO ()
threadDelay (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int))
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Integer
num <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Chan GatewaySendable -> GatewaySendable -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan GatewaySendable
send (Integer -> GatewaySendable
Heartbeat Integer
num)
Int -> IO ()
threadDelay (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
data ConnectionData = ConnData { ConnectionData -> Connection
connection :: Connection
, ConnectionData -> Text
connSessionID :: T.Text
, ConnectionData -> Auth
connAuth :: Auth
, ConnectionData -> Chan (Either GatewayException Event)
connChan :: Chan (Either GatewayException Event)
}
startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> IORef (Maybe UpdateStatusOpts) -> Chan T.Text -> IO ConnLoopState
startEventStream :: ConnectionData
-> Int
-> Integer
-> Chan GatewaySendable
-> IORef (Maybe UpdateStatusOpts)
-> Chan Text
-> IO ConnLoopState
startEventStream ConnectionData
conndata Int
interval Integer
seqN Chan GatewaySendable
userSend IORef (Maybe UpdateStatusOpts)
status Chan Text
log = do
Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log Text
"startEventStream"
IORef Integer
seqKey <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
seqN
let err :: SomeException -> IO ConnLoopState
err :: SomeException -> IO ConnLoopState
err SomeException
e = do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - eventStream error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
Auth -> Text -> Integer -> ConnLoopState
ConnReconnect (ConnectionData -> Auth
connAuth ConnectionData
conndata) (ConnectionData -> Text
connSessionID ConnectionData
conndata) (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
(SomeException -> IO ConnLoopState)
-> IO ConnLoopState -> IO ConnLoopState
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO ConnLoopState
err (IO ConnLoopState -> IO ConnLoopState)
-> IO ConnLoopState -> IO ConnLoopState
forall a b. (a -> b) -> a -> b
$ do
Chan GatewaySendable
gateSends <- IO (Chan GatewaySendable)
forall a. IO (Chan a)
newChan
IORef Bool
sendingUsers <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
ThreadId
sendsId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection -> Sendables -> IO ()
sendableLoop (ConnectionData -> Connection
connection ConnectionData
conndata) (Chan GatewaySendable
-> Chan GatewaySendable
-> IORef Bool
-> IORef (Maybe UpdateStatusOpts)
-> Chan Text
-> Sendables
Sendables Chan GatewaySendable
userSend Chan GatewaySendable
gateSends IORef Bool
sendingUsers IORef (Maybe UpdateStatusOpts)
status Chan Text
log)
ThreadId
heart <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Chan GatewaySendable -> Int -> IORef Integer -> IO ()
heartbeat Chan GatewaySendable
gateSends Int
interval IORef Integer
seqKey
IO ConnLoopState -> IO () -> IO ConnLoopState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (ConnectionData
-> IORef Integer
-> Int
-> Chan GatewaySendable
-> IORef Bool
-> Chan Text
-> IO ConnLoopState
eventStream ConnectionData
conndata IORef Integer
seqKey Int
interval Chan GatewaySendable
gateSends IORef Bool
sendingUsers Chan Text
log)
(ThreadId -> IO ()
killThread ThreadId
heart IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
sendsId)
eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable -> IORef Bool
-> Chan T.Text -> IO ConnLoopState
eventStream :: ConnectionData
-> IORef Integer
-> Int
-> Chan GatewaySendable
-> IORef Bool
-> Chan Text
-> IO ConnLoopState
eventStream (ConnData Connection
conn Text
seshID Auth
auth Chan (Either GatewayException Event)
eventChan) IORef Integer
seqKey Int
interval Chan GatewaySendable
send IORef Bool
userSends Chan Text
log = IO ConnLoopState
loop
where
loop :: IO ConnLoopState
loop :: IO ConnLoopState
loop = do
Either ConnectionException GatewayReceivable
eitherPayload <- Connection
-> Int
-> Chan Text
-> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout Connection
conn Int
interval Chan Text
log
case Either ConnectionException GatewayReceivable
eitherPayload :: Either ConnectionException GatewayReceivable of
Left (CloseRequest Word16
code ByteString
str) -> case Word16
code of
Word16
1000 -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Word16
1001 -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Word16
4000 -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Word16
4006 -> ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnStart
Word16
4007 -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Word16
4014 -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Word16
_ -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
eventChan (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (ConnectionException -> Text -> GatewayException
GatewayExceptionConnection (Word16 -> ByteString -> ConnectionException
CloseRequest Word16
code ByteString
str)
Text
"Normal event loop close request"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Left ConnectionException
_ -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Right (Dispatch Event
event Integer
sq) -> do IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Integer
seqKey Integer
sq
Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
eventChan (Event -> Either GatewayException Event
forall a b. b -> Either a b
Right Event
event)
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
userSends Bool
True
IO ConnLoopState
loop
Right (HeartbeatRequest Integer
sq) -> do IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Integer
seqKey Integer
sq
Chan GatewaySendable -> GatewaySendable -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan GatewaySendable
send (Integer -> GatewaySendable
Heartbeat Integer
sq)
IO ConnLoopState
loop
Right (GatewayReceivable
Reconnect) -> Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
Right (InvalidSession Bool
retry) -> if Bool
retry
then Auth -> Text -> Integer -> ConnLoopState
ConnReconnect Auth
auth Text
seshID (Integer -> ConnLoopState) -> IO Integer -> IO ConnLoopState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
seqKey
else ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnStart
Right (GatewayReceivable
HeartbeatAck) -> IO ConnLoopState
loop
Right (Hello Int
e) -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
eventChan (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (GatewayReceivable -> Text -> GatewayException
GatewayExceptionUnexpected (Int -> GatewayReceivable
Hello Int
e)
Text
"Normal event loop"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
Right (ParseError Text
e) -> do Chan (Either GatewayException Event)
-> Either GatewayException Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException Event)
eventChan (GatewayException -> Either GatewayException Event
forall a b. a -> Either a b
Left (Text -> Text -> GatewayException
GatewayExceptionEventParseError Text
e
Text
"Normal event loop"))
ConnLoopState -> IO ConnLoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnLoopState
ConnClosed
data Sendables = Sendables {
Sendables -> Chan GatewaySendable
sendchan :: Chan GatewaySendable
, Sendables -> Chan GatewaySendable
gatewaySends :: Chan GatewaySendable
, Sendables -> IORef Bool
startSendingUser :: IORef Bool
, Sendables -> IORef (Maybe UpdateStatusOpts)
sendslastStatus :: IORef (Maybe UpdateStatusOpts)
, Sendables -> Chan Text
sendlog :: Chan T.Text
}
sendableLoop :: Connection -> Sendables -> IO ()
sendableLoop :: Connection -> Sendables -> IO ()
sendableLoop Connection
conn Sendables
sends = IO ()
forall b. IO b
sendSysLoop
where
sendSysLoop :: IO b
sendSysLoop = do
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
10Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
62 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
120) :: Double)
GatewaySendable
payload <- Chan GatewaySendable -> IO GatewaySendable
forall a. Chan a -> IO a
readChan (Sendables -> Chan GatewaySendable
gatewaySends Sendables
sends)
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode GatewaySendable
payload)
Bool
usersending <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Sendables -> IORef Bool
startSendingUser Sendables
sends)
if Bool -> Bool
not Bool
usersending
then IO b
sendSysLoop
else do Maybe UpdateStatusOpts
act <- IORef (Maybe UpdateStatusOpts) -> IO (Maybe UpdateStatusOpts)
forall a. IORef a -> IO a
readIORef (Sendables -> IORef (Maybe UpdateStatusOpts)
sendslastStatus Sendables
sends)
case Maybe UpdateStatusOpts
act of Maybe UpdateStatusOpts
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just UpdateStatusOpts
opts -> Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (UpdateStatusOpts -> GatewaySendable
UpdateStatus UpdateStatusOpts
opts))
IO b
forall b. IO b
sendUserLoop
sendUserLoop :: IO b
sendUserLoop = do
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
10Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
62 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
120) :: Double)
let e :: Either GatewaySendable GatewaySendable -> GatewaySendable
e :: Either GatewaySendable GatewaySendable -> GatewaySendable
e = (GatewaySendable -> GatewaySendable)
-> (GatewaySendable -> GatewaySendable)
-> Either GatewaySendable GatewaySendable
-> GatewaySendable
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GatewaySendable -> GatewaySendable
forall a. a -> a
id GatewaySendable -> GatewaySendable
forall a. a -> a
id
GatewaySendable
payload <- Either GatewaySendable GatewaySendable -> GatewaySendable
e (Either GatewaySendable GatewaySendable -> GatewaySendable)
-> IO (Either GatewaySendable GatewaySendable)
-> IO GatewaySendable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO GatewaySendable
-> IO GatewaySendable
-> IO (Either GatewaySendable GatewaySendable)
forall a b. IO a -> IO b -> IO (Either a b)
race (Chan GatewaySendable -> IO GatewaySendable
forall a. Chan a -> IO a
readChan (Sendables -> Chan GatewaySendable
sendchan Sendables
sends)) (Chan GatewaySendable -> IO GatewaySendable
forall a. Chan a -> IO a
readChan (Sendables -> Chan GatewaySendable
gatewaySends Sendables
sends))
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode GatewaySendable
payload)
case GatewaySendable
payload of UpdateStatus UpdateStatusOpts
opts -> IORef (Maybe UpdateStatusOpts) -> Maybe UpdateStatusOpts -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Sendables -> IORef (Maybe UpdateStatusOpts)
sendslastStatus Sendables
sends) (UpdateStatusOpts -> Maybe UpdateStatusOpts
forall a. a -> Maybe a
Just UpdateStatusOpts
opts)
GatewaySendable
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IO b
sendUserLoop