{-# LANGUAGE OverloadedStrings #-}

-- | Provides logic code for interacting with the Discord websocket
--   gateway. Realistically, this is probably lower level than most
--   people will need
module Discord.Internal.Gateway.EventLoop where

import Prelude hiding (log)

import Control.Monad (forever, void)
import Control.Monad.Random (getRandomR)
import Control.Concurrent.Async (race)
import Control.Concurrent.Chan
import Control.Concurrent (threadDelay, killThread, forkIO)
import Control.Exception.Safe (try, finally, SomeException)
import Data.IORef
import Data.Aeson (eitherDecode, encode)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as BL

import Wuss (runSecureClient)
import Network.WebSockets (ConnectionException(..), Connection,
                           receiveData, sendTextData, sendClose)

import Discord.Internal.Types


data GatewayHandle = GatewayHandle
  { GatewayHandle -> Chan (Either GatewayException Event)
gatewayHandleEvents         :: Chan (Either GatewayException Event)
  , GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables  :: Chan GatewaySendable
  , GatewayHandle -> IORef (Maybe UpdateStatusOpts)
gatewayHandleLastStatus     :: IORef (Maybe UpdateStatusOpts)
  , GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId :: IORef Integer
  , GatewayHandle -> IORef Text
gatewayHandleSessionId      :: IORef T.Text
  }

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)


-- | 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
showList :: [LoopState] -> ShowS
$cshowList :: [LoopState] -> ShowS
show :: LoopState -> String
$cshow :: LoopState -> String
showsPrec :: Int -> LoopState -> ShowS
$cshowsPrec :: Int -> LoopState -> ShowS
Show

-- | Enough info for library to send info to discord.
data SendablesData = SendablesData
  { SendablesData -> Connection
sendableConnection :: Connection
  , SendablesData -> Chan GatewaySendableInternal
librarySendables :: Chan GatewaySendableInternal
  , SendablesData -> IORef Bool
startsendingUsers :: IORef Bool
  , SendablesData -> Integer
heartbeatInterval :: Integer
  }

{-
Some quick documentation for some of the variables passed around:

Auth                                                         needed to connect
GatewayIntent                                                needed to connect
GatewayHandle (eventsGifts,status,usersends,seq,sesh)        needed all over
log :: Chan (T.Text)                                         needed all over

sendableConnection                                 set by setup,  need sendableLoop
librarySendables :: Chan (GatewaySendableInternal) set by setup,  need heartbeat
heartbeatInterval :: Int                           set by Hello,  need heartbeat

sequenceId :: Int id of last event received        set by Resume, need heartbeat and reconnect
sessionId :: Text                                  set by Ready,  need reconnect
-}

connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO ()
connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan Text -> IO ()
connectionLoop Auth
auth GatewayIntent
intent GatewayHandle
gatewayHandle Chan Text
log = LoopState -> IO ()
outerloop LoopState
LoopStart
  where

  outerloop :: LoopState -> IO ()
  outerloop :: LoopState -> IO ()
outerloop LoopState
state = do
      Maybe GatewaySendableInternal
mfirst <- LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state
      case Maybe GatewaySendableInternal
mfirst of
        Maybe GatewaySendableInternal
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just GatewaySendableInternal
first -> do
            Either SomeException LoopState
next <- IO LoopState -> IO (Either SomeException LoopState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (GatewaySendableInternal -> IO LoopState
startconnectionpls GatewaySendableInternal
first)
            case Either SomeException LoopState
next :: Either SomeException LoopState 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 failure(s)")
                           LoopState -> IO ()
outerloop LoopState
LoopReconnect
              Right LoopState
n -> LoopState -> IO ()
outerloop LoopState
n

  firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
  firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)
firstmessage LoopState
state =
    case LoopState
state of
      LoopState
LoopStart -> Maybe GatewaySendableInternal -> IO (Maybe GatewaySendableInternal)
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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GatewaySendableInternal
forall a. Maybe a
Nothing

  startconnectionpls :: GatewaySendableInternal -> IO LoopState
  startconnectionpls :: GatewaySendableInternal -> IO LoopState
startconnectionpls GatewaySendableInternal
first = String
-> PortNumber -> String -> ClientApp LoopState -> IO LoopState
forall a. String -> PortNumber -> String -> ClientApp a -> IO a
runSecureClient String
"gateway.discord.gg" PortNumber
443 String
"/?v=6&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

                          Chan GatewaySendableInternal
internal <- IO (Chan GatewaySendableInternal)
forall a. IO (Chan a)
newChan :: IO (Chan GatewaySendableInternal)
                          IORef Bool
us <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
                          -- start event loop
                          let sending :: SendablesData
sending = Connection
-> Chan GatewaySendableInternal
-> IORef Bool
-> Integer
-> SendablesData
SendablesData Connection
conn Chan GatewaySendableInternal
internal IORef Bool
us Integer
interval
                          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 Integer -> IO ()
heartbeat SendablesData
sending (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
gatewayHandle)

                          Chan GatewaySendableInternal -> GatewaySendableInternal -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan GatewaySendableInternal
internal GatewaySendableInternal
first
                          IO LoopState -> IO () -> IO LoopState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (GatewayHandle -> SendablesData -> Chan Text -> IO LoopState
runEventLoop GatewayHandle
gatewayHandle SendablesData
sending Chan Text
log)
                                  (ThreadId -> IO ()
killThread ThreadId
heart IO () -> IO () -> IO ()
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 (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart


runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState
runEventLoop :: GatewayHandle -> SendablesData -> Chan Text -> IO LoopState
runEventLoop GatewayHandle
thehandle SendablesData
sendablesData Chan Text
log = do IO LoopState
loop
  where
  eventChan :: Chan (Either GatewayException Event)
eventChan = GatewayHandle -> Chan (Either GatewayException Event)
gatewayHandleEvents GatewayHandle
thehandle

  loop :: IO LoopState
loop = do
    Either ConnectionException GatewayReceivable
eitherPayload <- SendablesData
-> Chan Text -> IO (Either ConnectionException GatewayReceivable)
getPayloadTimeout SendablesData
sendablesData Chan Text
log
    case Either ConnectionException GatewayReceivable
eitherPayload :: Either ConnectionException GatewayReceivable of
      Right (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 (Dispatch Event
event Integer
sq) -> do IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Integer
gatewayHandleLastSequenceId GatewayHandle
thehandle) 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)
                                      case Event
event of
                                        (Ready Int
_ User
_ [Channel]
_ [GuildUnavailable]
_ Text
seshID) ->
                                            IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef Text
gatewayHandleSessionId GatewayHandle
thehandle) Text
seshID
                                        Event
_ -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData) Bool
True
                                      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
                                        Chan GatewaySendableInternal -> GatewaySendableInternal -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData) (Integer -> GatewaySendableInternal
Heartbeat Integer
sq)
                                        IO LoopState
loop
      Right (GatewayReceivable
Reconnect)      -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
      Right (InvalidSession Bool
retry) -> LoopState -> IO LoopState
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
HeartbeatAck)   -> IO LoopState
loop
      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"))
                                 LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopClosed
      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 (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
1001 -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
4000 -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect
          Word16
4006 -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
          Word16
4007 -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopStart
          Word16
4014 -> 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 (Integer -> GatewayReceivable
Hello Integer
0) (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/aquarial/discord-haskell/issues/76"))
                     LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopClosed
          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
"Unknown close code. Closing connection. Consider opening an issue with discord-haskell"))
                  LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopClosed
      Left ConnectionException
_ -> LoopState -> IO LoopState
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopState
LoopReconnect


heartbeat :: SendablesData -> IORef Integer -> IO ()
heartbeat :: SendablesData -> IORef Integer -> IO ()
heartbeat SendablesData
sendablesData 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
    Chan GatewaySendableInternal -> GatewaySendableInternal -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData) (Integer -> GatewaySendableInternal
Heartbeat 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))

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 (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))


-- simple idea: send payloads from user/sys to connection
-- has to be complicated though
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
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)
      GatewaySendableInternal
payload <- Chan GatewaySendableInternal -> IO GatewaySendableInternal
forall a. Chan a -> IO a
readChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData)
      Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (GatewaySendableInternal -> ByteString
forall a. ToJSON a => a -> ByteString
encode GatewaySendableInternal
payload)
   -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload)))
      Bool
usersending <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (SendablesData -> IORef Bool
startsendingUsers SendablesData
sendablesData)
      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 (GatewayHandle -> IORef (Maybe UpdateStatusOpts)
gatewayHandleLastStatus GatewayHandle
ghandle)
              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
   -- 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)
   -- payload :: Either GatewaySendableInternal GatewaySendable
      Either GatewaySendable GatewaySendableInternal
payload <- IO GatewaySendable
-> IO GatewaySendableInternal
-> IO (Either GatewaySendable GatewaySendableInternal)
forall a b. IO a -> IO b -> IO (Either a b)
race (Chan GatewaySendable -> IO GatewaySendable
forall a. Chan a -> IO a
readChan (GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables GatewayHandle
ghandle)) (Chan GatewaySendableInternal -> IO GatewaySendableInternal
forall a. Chan a -> IO a
readChan (SendablesData -> Chan GatewaySendableInternal
librarySendables SendablesData
sendablesData))
      Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn ((GatewaySendable -> ByteString)
-> (GatewaySendableInternal -> ByteString)
-> Either GatewaySendable GatewaySendableInternal
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GatewaySendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode GatewaySendableInternal -> ByteString
forall a. ToJSON a => a -> ByteString
encode Either GatewaySendable GatewaySendableInternal
payload)
   -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload)))
      IO b
sendUserLoop