{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | 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 Data.Time (getCurrentTime)

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)


-- | Info the event processing loop needs to
data GatewayHandle = GatewayHandle
  { -- | Realtime events from discord
    GatewayHandle -> Chan (Either GatewayException EventInternalParse)
gatewayHandleEvents         :: Chan (Either GatewayException EventInternalParse),
    -- | Events the user sends to discord
    GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables  :: Chan GatewaySendable,
    -- | Recent set status (resent to discord on reconnect)
    GatewayHandle -> IORef (Maybe UpdateStatusOpts)
gatewayHandleLastStatus     :: IORef (Maybe UpdateStatusOpts),
    -- | Recent sent event sequence (used to reconnect)
    GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId :: IORef Integer,
    -- | Which discord server session (used to reconnect)
    GatewayHandle -> IORef Text
gatewayHandleSessionId      :: IORef T.Text,
    -- | Which discord gateway to connect to. This should contain a default value
    -- ("gateway.discord.gg") on first connect, but on subsequent Resumes this
    -- may contain a different value. This should never contain trailing slashes,
    -- or any "wss://" prefixes, since HostNames of this kind are not supported
    -- by the websockets library.
    GatewayHandle -> IORef String
gatewayHandleHostname       :: IORef HostName,
    -- | The last time a heartbeatack was received
    GatewayHandle -> IORef UTCTime
gatewayHandleHeartbeatAckTimes    :: IORef UTCTime,
    -- | The last two times a heartbeat was sent
    GatewayHandle -> IORef (UTCTime, UTCTime)
gatewayHandleHeartbeatTimes       :: IORef (UTCTime, UTCTime)
  }

-- | Ways the gateway connection can fail with no possibility of recovery.
newtype GatewayException = GatewayExceptionIntent 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
$cshowsPrec :: Int -> GatewayException -> ShowS
showsPrec :: Int -> GatewayException -> ShowS
$cshow :: GatewayException -> String
show :: GatewayException -> String
$cshowList :: [GatewayException] -> ShowS
showList :: [GatewayException] -> ShowS
Show)


-- | State of the eventloop
data LoopState = LoopStart
               | LoopClosed
               | LoopReconnect
  deriving Int -> LoopState -> ShowS
[LoopState] -> ShowS
LoopState -> String
(Int -> LoopState -> ShowS)
-> (LoopState -> String)
-> ([LoopState] -> ShowS)
-> Show LoopState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoopState -> ShowS
showsPrec :: Int -> LoopState -> ShowS
$cshow :: LoopState -> String
show :: LoopState -> String
$cshowList :: [LoopState] -> ShowS
showList :: [LoopState] -> ShowS
Show

-- | Info the sendableLoop reads when it writes to the websocket
data SendablesData = SendablesData
  { SendablesData -> Connection
sendableConnection :: Connection
  , SendablesData -> Chan GatewaySendableInternal
librarySendables :: Chan GatewaySendableInternal
  , SendablesData -> IORef Bool
startsendingUsers :: IORef Bool
  , SendablesData -> Integer
heartbeatInterval :: Integer
  }


-- | Gateway connection infinite loop. Get events from websocket and send them to the library user
--
-- @
--  Auth                                                         needed to connect
--  GatewayIntent                                                needed to connect
--  GatewayHandle (eventsGives,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 -> GatewayIntent -> GatewayHandle -> Chan Text -> IO ()
connectionLoop Auth
auth GatewayIntent
intent GatewayHandle
gatewayHandle Chan Text
log = LoopState -> IO ()
outerloop LoopState
LoopStart
    where

    -- | Main connection loop. Catch exceptions and reconnect.
    outerloop :: LoopState -> IO ()
    outerloop :: LoopState -> IO ()
outerloop LoopState
state = do
        String
gatewayHost <- IORef String -> IO String
forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef String
gatewayHandleHostname GatewayHandle
gatewayHandle)
        Maybe GatewaySendableInternal
mfirst <- LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state -- construct first message
        case Maybe GatewaySendableInternal
mfirst of
          Maybe GatewaySendableInternal
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- close

          Just GatewaySendableInternal
message -> do
              Either SomeException LoopState
nextstate <- IO LoopState -> IO (Either SomeException LoopState)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (String -> GatewaySendableInternal -> IO LoopState
startOneConnection String
gatewayHost GatewaySendableInternal
message)  -- connection
              case Either SomeException LoopState
nextstate :: Either SomeException LoopState of
                Left SomeException
_ -> do Int
t <- (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
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 failure(s)"
                             LoopState -> IO ()
outerloop LoopState
LoopReconnect
                Right LoopState
n -> LoopState -> IO ()
outerloop LoopState
n

    -- | Construct the initial websocket message to send based on which state of the loop.
    --   Fresh start is Identify and a reconnect is Resume
    firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
    firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state =
      case LoopState
state of
        LoopState
LoopStart -> Maybe GatewaySendableInternal -> IO (Maybe GatewaySendableInternal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GatewaySendableInternal
 -> IO (Maybe GatewaySendableInternal))
-> Maybe GatewaySendableInternal
-> IO (Maybe GatewaySendableInternal)
forall a b. (a -> b) -> a -> b
$ GatewaySendableInternal -> Maybe GatewaySendableInternal
forall a. a -> Maybe a
Just (GatewaySendableInternal -> Maybe GatewaySendableInternal)
-> GatewaySendableInternal -> Maybe GatewaySendableInternal
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  <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
gatewayHandle)
                            Text
seshId <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (GatewayHandle -> IORef Text
gatewayHandleSessionId GatewayHandle
gatewayHandle)
                            if Text
seshId Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
""
                            then do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log Text
"gateway - WARNING seshID was not set by READY?"
                                    Maybe GatewaySendableInternal -> IO (Maybe GatewaySendableInternal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GatewaySendableInternal
 -> IO (Maybe GatewaySendableInternal))
-> Maybe GatewaySendableInternal
-> IO (Maybe GatewaySendableInternal)
forall a b. (a -> b) -> a -> b
$ GatewaySendableInternal -> Maybe GatewaySendableInternal
forall a. a -> Maybe a
Just (GatewaySendableInternal -> Maybe GatewaySendableInternal)
-> GatewaySendableInternal -> Maybe GatewaySendableInternal
forall a b. (a -> b) -> a -> b
$ Auth -> GatewayIntent -> (Int, Int) -> GatewaySendableInternal
Identify Auth
auth GatewayIntent
intent (Int
0, Int
1)
                            else Maybe GatewaySendableInternal -> IO (Maybe GatewaySendableInternal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GatewaySendableInternal
 -> IO (Maybe GatewaySendableInternal))
-> Maybe GatewaySendableInternal
-> IO (Maybe GatewaySendableInternal)
forall a b. (a -> b) -> a -> b
$ GatewaySendableInternal -> Maybe GatewaySendableInternal
forall a. a -> Maybe a
Just (GatewaySendableInternal -> Maybe GatewaySendableInternal)
-> GatewaySendableInternal -> Maybe GatewaySendableInternal
forall a b. (a -> b) -> a -> b
$ Auth -> Text -> Integer -> GatewaySendableInternal
Resume Auth
auth Text
seshId Integer
seqId
        LoopState
LoopClosed -> Maybe GatewaySendableInternal -> IO (Maybe GatewaySendableInternal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GatewaySendableInternal
forall a. Maybe a
Nothing

    startOneConnection
      :: HostName
      -- ^ The gateway address to connect to. Should be "gateway.discord.gg" on first try, but
      -- all Resumes should go to the resume_gateway_url specified in the Ready event
      -- https://discord.com/developers/docs/change-log#sessionspecific-gateway-resume-urls
      -> GatewaySendableInternal
      -- ^ The first message to send. Either an Identify or Resume.
      -> IO LoopState
    startOneConnection :: String -> GatewaySendableInternal -> IO LoopState
startOneConnection String
gatewayAddr GatewaySendableInternal
message = String
-> PortNumber -> String -> ClientApp LoopState -> IO LoopState
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> PortNumber -> String -> ClientApp a -> m a
runSecureClient String
gatewayAddr PortNumber
443 (String
"/?v=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
apiVersion String -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
"&encoding=json") (ClientApp LoopState -> IO LoopState)
-> ClientApp LoopState -> IO LoopState
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
                                -- setup sendables data
                                Chan GatewaySendableInternal
internal <- IO (Chan GatewaySendableInternal)
forall a. IO (Chan a)
newChan :: IO (Chan GatewaySendableInternal)
                                IORef Bool
sendingUser <- Bool -> IO (IORef Bool)
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
                                                            }
                                -- start websocket sending loop
                                ThreadId
sendsId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO ()
heartbeat SendablesData
sending (GatewayHandle -> IORef (UTCTime, UTCTime)
gatewayHandleHeartbeatTimes GatewayHandle
gatewayHandle) (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
gatewayHandle)
                                Chan GatewaySendableInternal -> GatewaySendableInternal -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan GatewaySendableInternal
internal GatewaySendableInternal
message

                                -- run connection eventloop
                                IO LoopState -> IO () -> IO LoopState
forall (m :: * -> *) a b.
(HasCallStack, 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 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
sendsId)

                            Either ConnectionException GatewayReceivable
_ -> do
                                Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log Text
"gateway - WARNING could not connect. Expected hello"
                                Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn (ByteString
"expected hello" :: BL.ByteString)
                                IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn :: IO BL.ByteString)
                                -- > after sendClose you should call receiveDataMessage until
                                -- > it throws an exception
                                -- haskell websockets documentation
                                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)))
                                LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart


-- | Process events from discord and write them to the onDiscordEvent Channel
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

  -- | Keep receiving Dispatch events until a reconnect or a restart
  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 -- GOT AN EVENT:
                                      IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
thehandle) Integer
sq
                                      Chan (Either GatewayException EventInternalParse)
-> Either GatewayException EventInternalParse -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException EventInternalParse)
eventChan (EventInternalParse -> Either GatewayException EventInternalParse
forall a b. b -> Either a b
Right EventInternalParse
event) -- send the event to user
                                      case EventInternalParse
event of
                                        (InternalReady Int
_ User
_ [GuildUnavailable]
_ Text
seshID String
resumeHost Maybe (Int, Int)
_ PartialApplication
_) -> do
                                            IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Text
gatewayHandleSessionId GatewayHandle
thehandle) Text
seshID
                                            IORef String -> String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef String
gatewayHandleHostname GatewayHandle
thehandle) String
resumeHost
                                        EventInternalParse
_ -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData) Bool
True
                                      IO LoopState
loop
      Right (Hello Integer
_interval) -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log Text
"eventloop - unexpected hello"
                                    IO LoopState
loop
      Right (HeartbeatRequest Integer
sq) -> do IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
thehandle) Integer
sq
                                        SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO ()
sendHeartbeat SendablesData
sendablesData (GatewayHandle -> IORef (UTCTime, UTCTime)
gatewayHandleHeartbeatTimes GatewayHandle
thehandle) Integer
sq
                                        IO LoopState
loop
      Right (InvalidSession Bool
retry) -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoopState -> IO LoopState) -> LoopState -> IO LoopState
forall a b. (a -> b) -> a -> b
$ if Bool
retry then LoopState
LoopReconnect else LoopState
LoopStart
      Right GatewayReceivable
Reconnect        -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
      Right GatewayReceivable
HeartbeatAck     -> do
        UTCTime
currTime <- IO UTCTime
getCurrentTime
        UTCTime
_ <- IORef UTCTime -> (UTCTime -> (UTCTime, UTCTime)) -> IO UTCTime
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (GatewayHandle -> IORef UTCTime
gatewayHandleHeartbeatAckTimes GatewayHandle
thehandle) (UTCTime -> (UTCTime, UTCTime)
forall a. a -> (a, a)
dupe (UTCTime -> (UTCTime, UTCTime))
-> (UTCTime -> UTCTime) -> UTCTime -> (UTCTime, UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> UTCTime
forall a b. a -> b -> a
const UTCTime
currTime)
        IO LoopState
loop
      Right (ParseError Text
_)   -> IO LoopState
loop  -- getPayload logs the parse error. nothing to do here

      Left (CloseRequest Word16
code ByteString
str) -> case Word16
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
          Word16
1000 -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
1001 -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
4000 -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
4006 -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
          Word16
4007 -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
          Word16
4014 -> do Chan (Either GatewayException EventInternalParse)
-> Either GatewayException EventInternalParse -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either GatewayException EventInternalParse)
eventChan (GatewayException -> Either GatewayException EventInternalParse
forall a b. a -> Either a b
Left (Text -> GatewayException
GatewayExceptionIntent (Text -> GatewayException) -> Text -> GatewayException
forall a b. (a -> b) -> a -> b
$
                           Text
"Tried to declare an unauthorized GatewayIntent. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
"Use the discord app manager to authorize by following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
"https://github.com/discord-haskell/discord-haskell/blob/master/docs/intents.md"))
                     LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopClosed
          Word16
_ -> do Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"gateway - unknown websocket close code " 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)
                                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
str) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]. Consider opening an issue "
                                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"https://github.com/discord-haskell/discord-haskell/issues")
                  LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
      Left ConnectionException
_ -> LoopState -> IO LoopState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect


-- | Blocking wait for next payload from the websocket (returns "Reconnect" after 1.5*heartbeatInterval seconds)
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 <- 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 (Integer -> Int
forall a. Num a => Integer -> a
fromInteger ((Integer
interval Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
3) Integer -> Integer -> Integer
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 () -> Either ConnectionException GatewayReceivable
-> IO (Either ConnectionException GatewayReceivable)
forall a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConnectionException GatewayReceivable
other

-- | Blocking wait for next payload from the websocket
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.
(HasCallStack, 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 a. a -> IO a
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 exception [" 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
"]"
                                      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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GatewayReceivable
ParseError (String -> Text
T.pack String
err))

-- | Infinite loop to send heartbeats to the chan
heartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO ()
heartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO ()
heartbeat SendablesData
sendablesData IORef (UTCTime, UTCTime)
sendTimes IORef Integer
seqKey = do
  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))
  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
    SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO ()
sendHeartbeat SendablesData
sendablesData IORef (UTCTime, UTCTime)
sendTimes Integer
num
    Int -> IO ()
threadDelay (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (SendablesData -> Integer
heartbeatInterval SendablesData
sendablesData Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000))

sendHeartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO ()
sendHeartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO ()
sendHeartbeat SendablesData
sendablesData IORef (UTCTime, UTCTime)
sendTimes Integer
seqKey = do
  UTCTime
currTime <- IO UTCTime
getCurrentTime
  (UTCTime, UTCTime)
_ <- IORef (UTCTime, UTCTime)
-> ((UTCTime, UTCTime) -> ((UTCTime, UTCTime), (UTCTime, UTCTime)))
-> IO (UTCTime, UTCTime)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (UTCTime, UTCTime)
sendTimes ((UTCTime, UTCTime) -> ((UTCTime, UTCTime), (UTCTime, UTCTime))
forall a. a -> (a, a)
dupe ((UTCTime, UTCTime) -> ((UTCTime, UTCTime), (UTCTime, UTCTime)))
-> ((UTCTime, UTCTime) -> (UTCTime, UTCTime))
-> (UTCTime, UTCTime)
-> ((UTCTime, UTCTime), (UTCTime, UTCTime))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime
currTime,) (UTCTime -> (UTCTime, UTCTime))
-> ((UTCTime, UTCTime) -> UTCTime)
-> (UTCTime, UTCTime)
-> (UTCTime, UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, UTCTime) -> UTCTime
forall a b. (a, b) -> a
fst)
  Chan GatewaySendableInternal -> GatewaySendableInternal -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData) (Integer -> GatewaySendableInternal
Heartbeat Integer
seqKey)

-- | Infinite loop to send library/user events to discord with the actual websocket connection
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 = IO ()
forall {b}. IO b
sendLoop
  where
  sendLoop :: IO b
sendLoop = 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 b. Integral b => Double -> b
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)
   -- payload :: Either GatewaySendableInternal GatewaySendable
      Either GatewaySendableInternal GatewaySendable
payload <- IO GatewaySendableInternal
-> IO GatewaySendable
-> IO (Either GatewaySendableInternal GatewaySendable)
forall a b. IO a -> IO b -> IO (Either a b)
race IO GatewaySendableInternal
nextLibrary IO GatewaySendable
nextUser
      Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn ((GatewaySendableInternal -> ByteString)
-> (GatewaySendable -> ByteString)
-> Either GatewaySendableInternal GatewaySendable
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GatewaySendableInternal -> ByteString
forall a. ToJSON a => a -> ByteString
encode GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode Either GatewaySendableInternal GatewaySendable
payload)
      IO b
sendLoop

  -- | next event sent by library
  nextLibrary :: IO GatewaySendableInternal
  nextLibrary :: IO GatewaySendableInternal
nextLibrary = Chan GatewaySendableInternal -> IO GatewaySendableInternal
forall a. Chan a -> IO a
readChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData)

  -- | next event sent by user (once startsendingUsers is set)
  nextUser :: IO GatewaySendable
  nextUser :: IO GatewaySendable
nextUser = do Bool
usersending <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData)
                if Bool
usersending
                then Chan GatewaySendable -> IO GatewaySendable
forall a. Chan a -> IO a
readChan (GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables GatewayHandle
ghandle)
                else Int -> IO ()
threadDelay (Int
4 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 GatewaySendable -> IO GatewaySendable
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO GatewaySendable
nextUser

dupe :: a -> (a, a)
dupe :: forall a. a -> (a, a)
dupe a
a = (a
a, a
a)