{-# 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)
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

-- | Securely run a connection IO action. Send a close on exception
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)

connectionLoop :: Auth -> DiscordHandleGateway -> Chan T.Text -> IO ()
connectionLoop :: Auth -> DiscordHandleGateway -> Chan Text -> IO ()
connectionLoop Auth
auth (Chan (Either GatewayException Event)
events, Chan GatewaySendable
userSend) 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
          -- only try-catch an IO Error
          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
-> 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 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 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 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
-> 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 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 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)

setSequence :: IORef Integer -> Integer -> IO ()
setSequence :: IORef Integer -> Integer -> IO ()
setSequence IORef Integer
key Integer
i = IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Integer
key Integer
i

-- | What we need to start an event stream
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 -> Chan T.Text -> IO ConnLoopState
startEventStream :: ConnectionData
-> Int
-> Integer
-> Chan GatewaySendable
-> Chan Text
-> IO ConnLoopState
startEventStream ConnectionData
conndata Int
interval Integer
seqN Chan GatewaySendable
userSend Chan Text
log = do
  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
    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 -> Sendables
Sendables Chan GatewaySendable
userSend Chan GatewaySendable
gateSends)
    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
-> Chan Text
-> IO ConnLoopState
eventStream ConnectionData
conndata IORef Integer
seqKey Int
interval Chan GatewaySendable
gateSends 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
                              -> Chan T.Text -> IO ConnLoopState
eventStream :: ConnectionData
-> IORef Integer
-> Int
-> Chan GatewaySendable
-> 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 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
          -- see Discord and MDN documentation on gateway close event codes
          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 ()
setSequence 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)
                                      IO ConnLoopState
loop
      Right (HeartbeatRequest Integer
sq) -> do IORef Integer -> Integer -> IO ()
setSequence 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 { -- | Things the user wants to send. Doesn't reset on reconnect
                             Sendables -> Chan GatewaySendable
userSends :: Chan GatewaySendable -- ^ Things the user wants to send
                            -- | Things the library needs to send. Resets to empty on reconnect
                           , Sendables -> Chan GatewaySendable
gatewaySends :: Chan GatewaySendable
                           }

sendableLoop :: Connection -> Sendables -> IO ()
sendableLoop :: Connection -> Sendables -> IO ()
sendableLoop Connection
conn Sendables
sends = 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
  -- send a ~120 events a min by delaying
  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
userSends 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)