{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-|
Module      : Discord.Internal.Voice.WebsocketLoop
Description : Strictly for internal use only. See Discord.Voice for the public interface.
Copyright   : (c) Yuto Takano (2021)
License     : MIT
Maintainer  : moa17stock@gmail.com

= WARNING

This module is considered __internal__.

The Package Versioning Policy __does not apply__.

The contents of this module may change __in any way whatsoever__ and __without__
__any warning__ between minor versions of this package.

= Description

This module provides @launchWebsocket@, a function used to launch a websocket to
the Discord Voice Gateway, and perform necessary handshakes including
heartbeat setup, mode selection, and IP Discovery. The function will also set up
the UDP socket for voice data transmission by calling @launchUDP@ from the
"Discord.Internal.Voice.UDPLoop" module.
-}
module Discord.Internal.Voice.WebsocketLoop
    ( launchWebsocket
    ) where

import Control.Concurrent.Async ( race )
import Control.Concurrent
    ( Chan
    , newChan
    , writeChan
    , readChan
    , threadDelay
    , forkIO
    , killThread
    , MVar
    , putMVar
    , newEmptyMVar
    , ThreadId
    , myThreadId
    , mkWeakThreadId
    , modifyMVar_
    , newMVar
    , readMVar
    )
import Control.Exception.Safe ( try, tryAsync, SomeException, finally, handle )
import Control.Lens
import Control.Monad ( forever, guard )
import Control.Monad.Except ( runExceptT, ExceptT (ExceptT), lift )
import Control.Monad.IO.Class ( liftIO )
import Data.Aeson ( encode, eitherDecode )
import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time.Clock.POSIX
import Data.Time
import Data.Word ( Word16 )
import Network.WebSockets
    ( ConnectionException(..)
    , Connection
    , sendClose
    , receiveData
    , sendTextData
    )
import Wuss ( runSecureClient )

import Discord
import Discord.Internal.Gateway ( GatewayException )
import Discord.Internal.Types ( GuildId, UserId, User(..), Event(..) )
import Discord.Internal.Types.VoiceCommon
import Discord.Internal.Types.VoiceWebsocket
import Discord.Internal.Types.VoiceUDP
import Discord.Internal.Voice.CommonUtils
import Discord.Internal.Voice.UDPLoop

data WSState
    = WSStart
    | WSClosed
    | WSResume
    deriving Int -> WSState -> ShowS
[WSState] -> ShowS
WSState -> String
(Int -> WSState -> ShowS)
-> (WSState -> String) -> ([WSState] -> ShowS) -> Show WSState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WSState] -> ShowS
$cshowList :: [WSState] -> ShowS
show :: WSState -> String
$cshow :: WSState -> String
showsPrec :: Int -> WSState -> ShowS
$cshowsPrec :: Int -> WSState -> ShowS
Show

-- | A custom logging function that writes the date/time and the thread ID.
(✍) :: Chan T.Text -> T.Text -> IO ()
Chan Text
logChan ✍ :: Chan Text -> Text -> IO ()
✍ Text
log = do
    String
t <- TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T %q" (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    ThreadId
tid <- IO ThreadId
myThreadId
    Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
logChan (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> Text
T.pack String
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ThreadId -> Text
forall a. Show a => a -> Text
tshow ThreadId
tid) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
log

-- | A variant of (✍) that prepends the wsError text.
(✍!) :: Chan T.Text -> T.Text -> IO ()
Chan Text
logChan ✍! :: Chan Text -> Text -> IO ()
✍! Text
log = Chan Text
logChan Chan Text -> Text -> IO ()
✍ (Text
"!!! Voice Websocket Error - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
log)

-- | @connect@ is an alias for running a websocket connection using the Discord
-- endpoint URL (which contains the port as well). It makes sure to connect to
-- the correct voice gateway version as well, as the default version of 1 is
-- severely out of date (the opcode behaviours are not according to docs).
connect :: T.Text -> (Connection -> IO a) -> IO a
connect :: Text -> (Connection -> IO a) -> IO a
connect Text
endpoint = String -> PortNumber -> String -> (Connection -> IO a) -> IO a
forall a. String -> PortNumber -> String -> ClientApp a -> IO a
runSecureClient String
url PortNumber
port String
"/?v=4"
  where
    url :: String
url = (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')) Text
endpoint
    port :: PortNumber
port = (String -> PortNumber
forall a. Read a => String -> a
read (String -> PortNumber) -> (Text -> String) -> Text -> PortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')) Text
endpoint

-- | Attempt to connect (and reconnect on disconnects) to the voice websocket.
-- Also launches the UDP thread after the initialisation.
launchWebsocket :: WebsocketLaunchOpts -> Chan T.Text -> IO ()
launchWebsocket :: WebsocketLaunchOpts -> Chan Text -> IO ()
launchWebsocket WebsocketLaunchOpts
opts Chan Text
log = do
    -- Keep an MVar (only for use in this function), to store the UDP launch
    -- options across Resume events.
    MVar UDPLaunchOpts
udpOpts <- UDPLaunchOpts -> IO (MVar UDPLaunchOpts)
forall a. a -> IO (MVar a)
newMVar UDPLaunchOpts
forall a. HasCallStack => a
undefined
    WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
WSStart Int
0 MVar UDPLaunchOpts
udpOpts
  where
    websocketFsm :: WSState -> Int -> MVar UDPLaunchOpts -> IO ()
    -- Websocket closed legitimately. The UDP thread and this thread
    -- will be closed by the cleanup in runVoice.
    websocketFsm :: WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
WSClosed Int
retries MVar UDPLaunchOpts
udpInfo = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- First time. Let's open a Websocket connection to the Voice
    -- Gateway, do the initial Websocket handshake routine, then
    -- ask to open the UDP connection.
    -- When creating the UDP thread, we will fill in the MVars in
    -- @opts@ to report back to runVoice, so it can be killed in the
    -- future.
    websocketFsm WSState
WSStart Int
retries MVar UDPLaunchOpts
udpInfo = do
        -- Use of tryAsync (unsafe, as it catches asynchronous exceptions) is
        -- justified here, since it will only log, then go to WSClosed.
        Either SomeException WSState
next <- IO WSState -> IO (Either SomeException WSState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
tryAsync (IO WSState -> IO (Either SomeException WSState))
-> IO WSState -> IO (Either SomeException WSState)
forall a b. (a -> b) -> a -> b
$ Text -> (Connection -> IO WSState) -> IO WSState
forall a. Text -> (Connection -> IO a) -> IO a
connect (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasEndpoint s a => Lens' s a
endpoint) ((Connection -> IO WSState) -> IO WSState)
-> (Connection -> IO WSState) -> IO WSState
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
            (VoiceWebsocketSendChan
libSends, ThreadId
sendTid) <- (VoiceWebsocketSendChan
 -> Chan Text -> IO (VoiceWebsocketSendChan, ThreadId))
-> Chan Text
-> VoiceWebsocketSendChan
-> IO (VoiceWebsocketSendChan, ThreadId)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Connection
-> VoiceWebsocketSendChan
-> Chan Text
-> IO (VoiceWebsocketSendChan, ThreadId)
setupSendLoop Connection
conn) Chan Text
log (VoiceWebsocketSendChan -> IO (VoiceWebsocketSendChan, ThreadId))
-> VoiceWebsocketSendChan -> IO (VoiceWebsocketSendChan, ThreadId)
forall a b. (a -> b) -> a -> b
$ WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     VoiceWebsocketSendChan WebsocketLaunchOpts VoiceWebsocketSendChan
-> VoiceWebsocketSendChan
forall s a. s -> Getting a s a -> a
^. ((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
 -> Const
      VoiceWebsocketSendChan
      (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> WebsocketLaunchOpts
-> Const VoiceWebsocketSendChan WebsocketLaunchOpts
forall s a. HasWsHandle s a => Lens' s a
wsHandle (((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
  -> Const
       VoiceWebsocketSendChan
       (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
 -> WebsocketLaunchOpts
 -> Const VoiceWebsocketSendChan WebsocketLaunchOpts)
-> ((VoiceWebsocketSendChan
     -> Const VoiceWebsocketSendChan VoiceWebsocketSendChan)
    -> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
    -> Const
         VoiceWebsocketSendChan
         (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> Getting
     VoiceWebsocketSendChan WebsocketLaunchOpts VoiceWebsocketSendChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceWebsocketSendChan
 -> Const VoiceWebsocketSendChan VoiceWebsocketSendChan)
-> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
-> Const
     VoiceWebsocketSendChan
     (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
forall s t a b. Field2 s t a b => Lens s t a b
_2

            Either Text WSState
result <- (IO (Either Text WSState) -> IO () -> IO (Either Text WSState))
-> IO () -> IO (Either Text WSState) -> IO (Either Text WSState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either Text WSState) -> IO () -> IO (Either Text WSState)
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (ThreadId -> IO ()
killThread ThreadId
sendTid) (IO (Either Text WSState) -> IO (Either Text WSState))
-> IO (Either Text WSState) -> IO (Either Text WSState)
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO WSState -> IO (Either Text WSState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO WSState -> IO (Either Text WSState))
-> ExceptT Text IO WSState -> IO (Either Text WSState)
forall a b. (a -> b) -> a -> b
$ do
                VoiceWebsocketReceivable
helloPacket <- IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text VoiceWebsocketReceivable)
 -> ExceptT Text IO VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$
                    ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
-> (ConnectionException -> Text)
-> Either ConnectionException VoiceWebsocketReceivable
-> Either Text VoiceWebsocketReceivable
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Failed to get Opcode 8 Hello: ") (Text -> Text)
-> (ConnectionException -> Text) -> ConnectionException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionException -> Text
forall a. Show a => a -> Text
tshow) (Either ConnectionException VoiceWebsocketReceivable
 -> Either Text VoiceWebsocketReceivable)
-> IO (Either ConnectionException VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn

                Int
interval <- IO (Either Text Int) -> ExceptT Text IO Int
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text Int) -> ExceptT Text IO Int)
-> IO (Either Text Int) -> ExceptT Text IO Int
forall a b. (a -> b) -> a -> b
$ Either Text Int -> IO (Either Text Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Int -> IO (Either Text Int))
-> Either Text Int -> IO (Either Text Int)
forall a b. (a -> b) -> a -> b
$
                    Text -> Maybe Int -> Either Text Int
forall a b. a -> Maybe b -> Either a b
maybeToRight (Text
"First packet not Opcode 8 Hello: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VoiceWebsocketReceivable -> Text
forall a. Show a => a -> Text
tshow VoiceWebsocketReceivable
helloPacket) (Maybe Int -> Either Text Int) -> Maybe Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$
                        VoiceWebsocketReceivable
helloPacket VoiceWebsocketReceivable
-> Getting (First Int) VoiceWebsocketReceivable Int -> Maybe Int
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Int) VoiceWebsocketReceivable Int
Prism' VoiceWebsocketReceivable Int
_Hello

                -- Create a thread to add heartbeating packets to the
                -- libSends Chan.
                ThreadId
heartGenTid <- IO ThreadId -> ExceptT Text IO ThreadId
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ThreadId -> ExceptT Text IO ThreadId)
-> IO ThreadId -> ExceptT Text IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendChan -> Int -> Chan Text -> IO ()
heartbeatLoop VoiceWebsocketSendChan
libSends Int
interval Chan Text
log

                (ExceptT Text IO WSState
 -> ExceptT Text IO () -> ExceptT Text IO WSState)
-> ExceptT Text IO ()
-> ExceptT Text IO WSState
-> ExceptT Text IO WSState
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT Text IO WSState
-> ExceptT Text IO () -> ExceptT Text IO WSState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
heartGenTid) (ExceptT Text IO WSState -> ExceptT Text IO WSState)
-> ExceptT Text IO WSState -> ExceptT Text IO WSState
forall a b. (a -> b) -> a -> b
$ do
                    -- Perform the Identify/Ready handshake
                    VoiceWebsocketReceivable
readyPacket <- IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text VoiceWebsocketReceivable)
 -> ExceptT Text IO VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$
                        ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
-> (ConnectionException -> Text)
-> Either ConnectionException VoiceWebsocketReceivable
-> Either Text VoiceWebsocketReceivable
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Failed to get Opcode 2 Ready: ") (Text -> Text)
-> (ConnectionException -> Text) -> ConnectionException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionException -> Text
forall a. Show a => a -> Text
tshow) (Either ConnectionException VoiceWebsocketReceivable
 -> Either Text VoiceWebsocketReceivable)
-> IO (Either ConnectionException VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        Connection
-> WebsocketLaunchOpts
-> IO (Either ConnectionException VoiceWebsocketReceivable)
performIdentification Connection
conn WebsocketLaunchOpts
opts

                    ReadyPayload
p <- IO (Either Text ReadyPayload) -> ExceptT Text IO ReadyPayload
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text ReadyPayload) -> ExceptT Text IO ReadyPayload)
-> IO (Either Text ReadyPayload) -> ExceptT Text IO ReadyPayload
forall a b. (a -> b) -> a -> b
$ Either Text ReadyPayload -> IO (Either Text ReadyPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ReadyPayload -> IO (Either Text ReadyPayload))
-> Either Text ReadyPayload -> IO (Either Text ReadyPayload)
forall a b. (a -> b) -> a -> b
$
                        Text -> Maybe ReadyPayload -> Either Text ReadyPayload
forall a b. a -> Maybe b -> Either a b
maybeToRight (Text
"First packet after Identify not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Opcode 2 Ready " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VoiceWebsocketReceivable -> Text
forall a. Show a => a -> Text
tshow VoiceWebsocketReceivable
readyPacket) (Maybe ReadyPayload -> Either Text ReadyPayload)
-> Maybe ReadyPayload -> Either Text ReadyPayload
forall a b. (a -> b) -> a -> b
$
                            VoiceWebsocketReceivable
readyPacket VoiceWebsocketReceivable
-> Getting
     (First ReadyPayload) VoiceWebsocketReceivable ReadyPayload
-> Maybe ReadyPayload
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First ReadyPayload) VoiceWebsocketReceivable ReadyPayload
Prism' VoiceWebsocketReceivable ReadyPayload
_Ready

                    MVar [Word8]
secretKey <- IO (MVar [Word8]) -> ExceptT Text IO (MVar [Word8])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (MVar [Word8]) -> ExceptT Text IO (MVar [Word8]))
-> IO (MVar [Word8]) -> ExceptT Text IO (MVar [Word8])
forall a b. (a -> b) -> a -> b
$ IO (MVar [Word8])
forall a. IO (MVar a)
newEmptyMVar
                    let udpLaunchOpts :: UDPLaunchOpts
udpLaunchOpts = UDPLaunchOpts :: Integer
-> Text
-> Integer
-> Text
-> (VoiceUDPReceiveChan, VoiceUDPSendChan)
-> MVar [Word8]
-> UDPLaunchOpts
UDPLaunchOpts
                            { uDPLaunchOptsSsrc :: Integer
uDPLaunchOptsSsrc      = ReadyPayload -> Integer
readyPayloadSSRC ReadyPayload
p
                            , uDPLaunchOptsIp :: Text
uDPLaunchOptsIp        = ReadyPayload -> Text
readyPayloadIP ReadyPayload
p
                            , uDPLaunchOptsPort :: Integer
uDPLaunchOptsPort      = ReadyPayload -> Integer
readyPayloadPort ReadyPayload
p
                            , uDPLaunchOptsMode :: Text
uDPLaunchOptsMode      = Text
"xsalsa20_poly1305"
                            , uDPLaunchOptsUdpHandle :: (VoiceUDPReceiveChan, VoiceUDPSendChan)
uDPLaunchOptsUdpHandle = WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     (VoiceUDPReceiveChan, VoiceUDPSendChan)
     WebsocketLaunchOpts
     (VoiceUDPReceiveChan, VoiceUDPSendChan)
-> (VoiceUDPReceiveChan, VoiceUDPSendChan)
forall s a. s -> Getting a s a -> a
^. Getting
  (VoiceUDPReceiveChan, VoiceUDPSendChan)
  WebsocketLaunchOpts
  (VoiceUDPReceiveChan, VoiceUDPSendChan)
forall s a. HasUdpHandle s a => Lens' s a
udpHandle
                            , uDPLaunchOptsSecretKey :: MVar [Word8]
uDPLaunchOptsSecretKey = MVar [Word8]
secretKey
                            -- TODO: support all encryption modes
                            }
                    -- We should be putting SSRC into the MVar to report back to
                    -- the websocket (TODO: why was this again), but we hold it off
                    -- until the ssrcCheck guard a few lines below.
                    IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ MVar UDPLaunchOpts -> (UDPLaunchOpts -> IO UDPLaunchOpts) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar UDPLaunchOpts
udpInfo (UDPLaunchOpts -> IO UDPLaunchOpts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UDPLaunchOpts -> IO UDPLaunchOpts)
-> (UDPLaunchOpts -> UDPLaunchOpts)
-> UDPLaunchOpts
-> IO UDPLaunchOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UDPLaunchOpts -> UDPLaunchOpts -> UDPLaunchOpts
forall a b. a -> b -> a
const UDPLaunchOpts
udpLaunchOpts)

                    -- Launch the UDP thread, automatically perform 
                    -- IP discovery, which will write the result
                    -- to the receiving Chan. We will pass not the MVar but
                    -- the raw options, since there's no writing to be done.

                    ThreadId
forkedId <- IO ThreadId -> ExceptT Text IO ThreadId
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ThreadId -> ExceptT Text IO ThreadId)
-> IO ThreadId -> ExceptT Text IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ UDPLaunchOpts -> Chan Text -> IO ()
launchUdp UDPLaunchOpts
udpLaunchOpts Chan Text
log
                    (ExceptT Text IO WSState
 -> ExceptT Text IO () -> ExceptT Text IO WSState)
-> ExceptT Text IO ()
-> ExceptT Text IO WSState
-> ExceptT Text IO WSState
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT Text IO WSState
-> ExceptT Text IO () -> ExceptT Text IO WSState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
forkedId) (ExceptT Text IO WSState -> ExceptT Text IO WSState)
-> ExceptT Text IO WSState -> ExceptT Text IO WSState
forall a b. (a -> b) -> a -> b
$ do
                        Weak ThreadId
udpTidWeak <- IO (Weak ThreadId) -> ExceptT Text IO (Weak ThreadId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak ThreadId) -> ExceptT Text IO (Weak ThreadId))
-> IO (Weak ThreadId) -> ExceptT Text IO (Weak ThreadId)
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
forkedId
                        IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Weak ThreadId) -> Weak ThreadId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     (MVar (Weak ThreadId)) WebsocketLaunchOpts (MVar (Weak ThreadId))
-> MVar (Weak ThreadId)
forall s a. s -> Getting a s a -> a
^. Getting
  (MVar (Weak ThreadId)) WebsocketLaunchOpts (MVar (Weak ThreadId))
forall s a. HasUdpTid s a => Lens' s a
udpTid) Weak ThreadId
udpTidWeak

                        VoiceUDPPacket
ipDiscovery <- IO VoiceUDPPacket -> ExceptT Text IO VoiceUDPPacket
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO VoiceUDPPacket -> ExceptT Text IO VoiceUDPPacket)
-> IO VoiceUDPPacket -> ExceptT Text IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ VoiceUDPReceiveChan -> IO VoiceUDPPacket
forall a. Chan a -> IO a
readChan (VoiceUDPReceiveChan -> IO VoiceUDPPacket)
-> VoiceUDPReceiveChan -> IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     VoiceUDPReceiveChan WebsocketLaunchOpts VoiceUDPReceiveChan
-> VoiceUDPReceiveChan
forall s a. s -> Getting a s a -> a
^. ((VoiceUDPReceiveChan, VoiceUDPSendChan)
 -> Const
      VoiceUDPReceiveChan (VoiceUDPReceiveChan, VoiceUDPSendChan))
-> WebsocketLaunchOpts
-> Const VoiceUDPReceiveChan WebsocketLaunchOpts
forall s a. HasUdpHandle s a => Lens' s a
udpHandle (((VoiceUDPReceiveChan, VoiceUDPSendChan)
  -> Const
       VoiceUDPReceiveChan (VoiceUDPReceiveChan, VoiceUDPSendChan))
 -> WebsocketLaunchOpts
 -> Const VoiceUDPReceiveChan WebsocketLaunchOpts)
-> ((VoiceUDPReceiveChan
     -> Const VoiceUDPReceiveChan VoiceUDPReceiveChan)
    -> (VoiceUDPReceiveChan, VoiceUDPSendChan)
    -> Const
         VoiceUDPReceiveChan (VoiceUDPReceiveChan, VoiceUDPSendChan))
-> Getting
     VoiceUDPReceiveChan WebsocketLaunchOpts VoiceUDPReceiveChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceUDPReceiveChan
 -> Const VoiceUDPReceiveChan VoiceUDPReceiveChan)
-> (VoiceUDPReceiveChan, VoiceUDPSendChan)
-> Const
     VoiceUDPReceiveChan (VoiceUDPReceiveChan, VoiceUDPSendChan)
forall s t a b. Field1 s t a b => Lens s t a b
_1
                        (Integer
ssrcCheck, Text
ip, Integer
port) <- IO (Either Text (Integer, Text, Integer))
-> ExceptT Text IO (Integer, Text, Integer)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text (Integer, Text, Integer))
 -> ExceptT Text IO (Integer, Text, Integer))
-> IO (Either Text (Integer, Text, Integer))
-> ExceptT Text IO (Integer, Text, Integer)
forall a b. (a -> b) -> a -> b
$ Either Text (Integer, Text, Integer)
-> IO (Either Text (Integer, Text, Integer))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Integer, Text, Integer)
 -> IO (Either Text (Integer, Text, Integer)))
-> Either Text (Integer, Text, Integer)
-> IO (Either Text (Integer, Text, Integer))
forall a b. (a -> b) -> a -> b
$
                            Text
-> Maybe (Integer, Text, Integer)
-> Either Text (Integer, Text, Integer)
forall a b. a -> Maybe b -> Either a b
maybeToRight (Text
"First UDP Packet not IP Discovery " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VoiceUDPPacket -> Text
forall a. Show a => a -> Text
tshow VoiceUDPPacket
ipDiscovery) (Maybe (Integer, Text, Integer)
 -> Either Text (Integer, Text, Integer))
-> Maybe (Integer, Text, Integer)
-> Either Text (Integer, Text, Integer)
forall a b. (a -> b) -> a -> b
$
                                VoiceUDPPacket
ipDiscovery VoiceUDPPacket
-> Getting
     (First (Integer, Text, Integer))
     VoiceUDPPacket
     (Integer, Text, Integer)
-> Maybe (Integer, Text, Integer)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First (Integer, Text, Integer))
  VoiceUDPPacket
  (Integer, Text, Integer)
Prism' VoiceUDPPacket (Integer, Text, Integer)
_IPDiscovery

                        Bool -> ExceptT Text IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
ssrcCheck Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== UDPLaunchOpts
udpLaunchOpts UDPLaunchOpts -> Getting Integer UDPLaunchOpts Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer UDPLaunchOpts Integer
forall s a. HasSsrc s a => Lens' s a
ssrc)
                        IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ MVar Integer -> Integer -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting (MVar Integer) WebsocketLaunchOpts (MVar Integer)
-> MVar Integer
forall s a. s -> Getting a s a -> a
^. Getting (MVar Integer) WebsocketLaunchOpts (MVar Integer)
forall s a. HasSsrc s a => Lens' s a
ssrc) Integer
ssrcCheck

                        -- TODO: currently, we await the Opcode 4 SD right after
                        -- Select Protocol, blocking the start of heartbeats until
                        -- eventStream. This means there's a delay, so TODO to check
                        -- if this delay causes any problems. If it does, keep the
                        -- sending here, but receive the SD event in eventStream.
                        VoiceWebsocketReceivable
sessionDescPacket <- IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text VoiceWebsocketReceivable)
 -> ExceptT Text IO VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
-> ExceptT Text IO VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$
                            ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
-> (ConnectionException -> Text)
-> Either ConnectionException VoiceWebsocketReceivable
-> Either Text VoiceWebsocketReceivable
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Either ConnectionException VoiceWebsocketReceivable)
  (Either Text VoiceWebsocketReceivable)
  ConnectionException
  Text
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Failed to get Opcode 4 SD: ") (Text -> Text)
-> (ConnectionException -> Text) -> ConnectionException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionException -> Text
forall a. Show a => a -> Text
tshow) (Either ConnectionException VoiceWebsocketReceivable
 -> Either Text VoiceWebsocketReceivable)
-> IO (Either ConnectionException VoiceWebsocketReceivable)
-> IO (Either Text VoiceWebsocketReceivable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                Connection
-> Text
-> Integer
-> Text
-> IO (Either ConnectionException VoiceWebsocketReceivable)
sendSelectProtocol Connection
conn Text
ip Integer
port (UDPLaunchOpts
udpLaunchOpts UDPLaunchOpts -> Getting Text UDPLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text UDPLaunchOpts Text
forall s a. HasMode s a => Lens' s a
mode)

                        (Text
modeCheck, [Word8]
key) <- IO (Either Text (Text, [Word8])) -> ExceptT Text IO (Text, [Word8])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text (Text, [Word8]))
 -> ExceptT Text IO (Text, [Word8]))
-> IO (Either Text (Text, [Word8]))
-> ExceptT Text IO (Text, [Word8])
forall a b. (a -> b) -> a -> b
$ Either Text (Text, [Word8]) -> IO (Either Text (Text, [Word8]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Text, [Word8]) -> IO (Either Text (Text, [Word8])))
-> Either Text (Text, [Word8]) -> IO (Either Text (Text, [Word8]))
forall a b. (a -> b) -> a -> b
$
                            Text -> Maybe (Text, [Word8]) -> Either Text (Text, [Word8])
forall a b. a -> Maybe b -> Either a b
maybeToRight (Text
"First packet after Select Protocol " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                Text
"not Opcode 4 Session Description " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                VoiceWebsocketReceivable -> Text
forall a. Show a => a -> Text
tshow VoiceWebsocketReceivable
readyPacket) (Maybe (Text, [Word8]) -> Either Text (Text, [Word8]))
-> Maybe (Text, [Word8]) -> Either Text (Text, [Word8])
forall a b. (a -> b) -> a -> b
$
                                    VoiceWebsocketReceivable
sessionDescPacket VoiceWebsocketReceivable
-> Getting
     (First (Text, [Word8])) VoiceWebsocketReceivable (Text, [Word8])
-> Maybe (Text, [Word8])
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First (Text, [Word8])) VoiceWebsocketReceivable (Text, [Word8])
Prism' VoiceWebsocketReceivable (Text, [Word8])
_SessionDescription

                        Bool -> ExceptT Text IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
modeCheck Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== UDPLaunchOpts
udpLaunchOpts UDPLaunchOpts -> Getting Text UDPLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text UDPLaunchOpts Text
forall s a. HasMode s a => Lens' s a
mode)

                        IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ MVar [Word8] -> [Word8] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [Word8]
secretKey [Word8]
key

                        -- Move to eternal websocket event loop, mainly for the
                        -- heartbeats, but also for any user-generated packets.
                        IO WSState -> ExceptT Text IO WSState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WSState -> ExceptT Text IO WSState)
-> IO WSState -> ExceptT Text IO WSState
forall a b. (a -> b) -> a -> b
$ Connection
-> WebsocketLaunchOpts
-> Int
-> UDPLaunchOpts
-> VoiceWebsocketSendChan
-> Chan Text
-> IO WSState
eventStream Connection
conn WebsocketLaunchOpts
opts Int
interval UDPLaunchOpts
udpLaunchOpts VoiceWebsocketSendChan
libSends Chan Text
log

            case Either Text WSState
result of
                Left Text
reason -> Chan Text
log Chan Text -> Text -> IO ()
✍! Text
reason IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
                Right WSState
state -> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
state

        -- Connection is now closed.
        case Either SomeException WSState
next :: Either SomeException WSState of
            Left SomeException
e -> do
                Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"could not connect due to an exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    (SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e)
                VoiceWebsocketReceiveChan
-> Either VoiceWebsocketException VoiceWebsocketReceivable -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     VoiceWebsocketReceiveChan
     WebsocketLaunchOpts
     VoiceWebsocketReceiveChan
-> VoiceWebsocketReceiveChan
forall s a. s -> Getting a s a -> a
^. ((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
 -> Const
      VoiceWebsocketReceiveChan
      (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> WebsocketLaunchOpts
-> Const VoiceWebsocketReceiveChan WebsocketLaunchOpts
forall s a. HasWsHandle s a => Lens' s a
wsHandle (((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
  -> Const
       VoiceWebsocketReceiveChan
       (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
 -> WebsocketLaunchOpts
 -> Const VoiceWebsocketReceiveChan WebsocketLaunchOpts)
-> ((VoiceWebsocketReceiveChan
     -> Const VoiceWebsocketReceiveChan VoiceWebsocketReceiveChan)
    -> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
    -> Const
         VoiceWebsocketReceiveChan
         (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> Getting
     VoiceWebsocketReceiveChan
     WebsocketLaunchOpts
     VoiceWebsocketReceiveChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceWebsocketReceiveChan
 -> Const VoiceWebsocketReceiveChan VoiceWebsocketReceiveChan)
-> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
-> Const
     VoiceWebsocketReceiveChan
     (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
forall s t a b. Field1 s t a b => Lens s t a b
_1) (Either VoiceWebsocketException VoiceWebsocketReceivable -> IO ())
-> Either VoiceWebsocketException VoiceWebsocketReceivable -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketException
-> Either VoiceWebsocketException VoiceWebsocketReceivable
forall a b. a -> Either a b
Left (VoiceWebsocketException
 -> Either VoiceWebsocketException VoiceWebsocketReceivable)
-> VoiceWebsocketException
-> Either VoiceWebsocketException VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$
                    Text -> VoiceWebsocketException
VoiceWebsocketCouldNotConnect
                        Text
"could not connect due to an exception"
                WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
WSClosed Int
0 MVar UDPLaunchOpts
udpInfo
            Right WSState
n -> WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
n Int
0 MVar UDPLaunchOpts
udpInfo

    websocketFsm WSState
WSResume Int
retries MVar UDPLaunchOpts
udpInfo = do
        -- Use of tryAsync (unsafe, as it catches asynchronous exceptions) is
        -- justified here, since it will only log, then go to WSClosed.
        Either SomeException WSState
next <- IO WSState -> IO (Either SomeException WSState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
tryAsync (IO WSState -> IO (Either SomeException WSState))
-> IO WSState -> IO (Either SomeException WSState)
forall a b. (a -> b) -> a -> b
$ Text -> (Connection -> IO WSState) -> IO WSState
forall a. Text -> (Connection -> IO a) -> IO a
connect (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasEndpoint s a => Lens' s a
endpoint) ((Connection -> IO WSState) -> IO WSState)
-> (Connection -> IO WSState) -> IO WSState
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
            (VoiceWebsocketSendChan
libSends, ThreadId
sendTid) <- (VoiceWebsocketSendChan
 -> Chan Text -> IO (VoiceWebsocketSendChan, ThreadId))
-> Chan Text
-> VoiceWebsocketSendChan
-> IO (VoiceWebsocketSendChan, ThreadId)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Connection
-> VoiceWebsocketSendChan
-> Chan Text
-> IO (VoiceWebsocketSendChan, ThreadId)
setupSendLoop Connection
conn) Chan Text
log (VoiceWebsocketSendChan -> IO (VoiceWebsocketSendChan, ThreadId))
-> VoiceWebsocketSendChan -> IO (VoiceWebsocketSendChan, ThreadId)
forall a b. (a -> b) -> a -> b
$ WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     VoiceWebsocketSendChan WebsocketLaunchOpts VoiceWebsocketSendChan
-> VoiceWebsocketSendChan
forall s a. s -> Getting a s a -> a
^. ((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
 -> Const
      VoiceWebsocketSendChan
      (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> WebsocketLaunchOpts
-> Const VoiceWebsocketSendChan WebsocketLaunchOpts
forall s a. HasWsHandle s a => Lens' s a
wsHandle (((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
  -> Const
       VoiceWebsocketSendChan
       (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
 -> WebsocketLaunchOpts
 -> Const VoiceWebsocketSendChan WebsocketLaunchOpts)
-> ((VoiceWebsocketSendChan
     -> Const VoiceWebsocketSendChan VoiceWebsocketSendChan)
    -> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
    -> Const
         VoiceWebsocketSendChan
         (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> Getting
     VoiceWebsocketSendChan WebsocketLaunchOpts VoiceWebsocketSendChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceWebsocketSendChan
 -> Const VoiceWebsocketSendChan VoiceWebsocketSendChan)
-> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
-> Const
     VoiceWebsocketSendChan
     (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
forall s t a b. Field2 s t a b => Lens s t a b
_2
            Either ConnectionException VoiceWebsocketReceivable
helloPacket <- Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn
            case Either ConnectionException VoiceWebsocketReceivable
helloPacket of
                Left ConnectionException
e -> do
                    Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to get Opcode 8 Hello: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ConnectionException -> Text
forall a. Show a => a -> Text
tshow ConnectionException
e)
                    WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
                Right (Hello Int
interval) -> do
                    -- Create a thread to add heartbeating packets to the
                    -- libSends Chan.
                    ThreadId
heartGenTid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendChan -> Int -> Chan Text -> IO ()
heartbeatLoop VoiceWebsocketSendChan
libSends Int
interval Chan Text
log
                    -- Perform the Resume/Resumed handshake
                    Either ConnectionException VoiceWebsocketReceivable
resumedPacket <- Connection
-> WebsocketLaunchOpts
-> IO (Either ConnectionException VoiceWebsocketReceivable)
performResumption Connection
conn WebsocketLaunchOpts
opts
                    case Either ConnectionException VoiceWebsocketReceivable
resumedPacket of
                        Left ConnectionException
e -> do
                            Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to get Opcode 9 Resumed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ConnectionException -> Text
forall a. Show a => a -> Text
tshow ConnectionException
e)
                            WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
                        Right (VoiceWebsocketReceivable
Discord.Internal.Types.VoiceWebsocket.Resumed) -> do
                            -- use the previous UDP launch options since it's not resent
                            UDPLaunchOpts
udpLaunchOpts <- MVar UDPLaunchOpts -> IO UDPLaunchOpts
forall a. MVar a -> IO a
readMVar MVar UDPLaunchOpts
udpInfo
                            
                            -- Pass not the MVar but the raw options, since
                            -- there's no writing to be done.
                            IO WSState -> IO () -> IO WSState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (Connection
-> WebsocketLaunchOpts
-> Int
-> UDPLaunchOpts
-> VoiceWebsocketSendChan
-> Chan Text
-> IO WSState
eventStream Connection
conn WebsocketLaunchOpts
opts Int
interval UDPLaunchOpts
udpLaunchOpts VoiceWebsocketSendChan
libSends Chan Text
log) (IO () -> IO WSState) -> IO () -> IO WSState
forall a b. (a -> b) -> a -> b
$
                                (ThreadId -> IO ()
killThread ThreadId
heartGenTid IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
sendTid)
                        Right VoiceWebsocketReceivable
p -> do
                            Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"First packet after Resume not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                                Text
"Opcode 9 Resumed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (VoiceWebsocketReceivable -> Text
forall a. Show a => a -> Text
tshow VoiceWebsocketReceivable
p)
                            WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
                Right VoiceWebsocketReceivable
p -> do
                    Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"First packet not Opcode 8 Hello: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (VoiceWebsocketReceivable -> Text
forall a. Show a => a -> Text
tshow VoiceWebsocketReceivable
p)
                    WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed

        -- Connection is now closed.
        case Either SomeException WSState
next :: Either SomeException WSState of
            Left SomeException
_ -> do
                Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"could not resume, retrying after 5 seconds"
                Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
5 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))
                WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
WSResume (Int
retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MVar UDPLaunchOpts
udpInfo
            Right WSState
n -> WSState -> Int -> MVar UDPLaunchOpts -> IO ()
websocketFsm WSState
n Int
1 MVar UDPLaunchOpts
udpInfo

-- | Create the library-specific sending packets Chan, and then create the
-- thread for eternally sending contents in the said Chan, as well as the
-- user-generated packet Chan.
-- loop for
-- the websocket.
setupSendLoop
    :: Connection
    -- ^ Connection to use
    -> VoiceWebsocketSendChan
    -- ^ User generated packets to send in the Websocket
    -> Chan T.Text
    -- ^ Logging channel
    -> IO (VoiceWebsocketSendChan, ThreadId)
    -- ^ Chan to send library-specific packets in the Websocket, and the thread
    -- ID of the eternal sending thread (useful for killing it).
setupSendLoop :: Connection
-> VoiceWebsocketSendChan
-> Chan Text
-> IO (VoiceWebsocketSendChan, ThreadId)
setupSendLoop Connection
conn VoiceWebsocketSendChan
userSends Chan Text
log = do
    -- The following Chan will be used for accumulating library-generated
    -- WebSocket messages that we need to send to Discord, mostly for heartbeats.
    VoiceWebsocketSendChan
libSends <- IO VoiceWebsocketSendChan
forall a. IO (Chan a)
newChan
    -- Start said eternal sending fork, which will eternally send from library-
    -- generated and user-generated packets.
    ThreadId
sendLoopId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection
-> VoiceWebsocketSendChan
-> VoiceWebsocketSendChan
-> Chan Text
-> IO ()
sendableLoop Connection
conn VoiceWebsocketSendChan
libSends VoiceWebsocketSendChan
userSends Chan Text
log

    (VoiceWebsocketSendChan, ThreadId)
-> IO (VoiceWebsocketSendChan, ThreadId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceWebsocketSendChan
libSends, ThreadId
sendLoopId)

-- | Send the Opcode 0 Identify packet to Discord, and await the Opcode 2 Ready
-- payload, which contains the UDP connection info.
performIdentification
    :: Connection
    -> WebsocketLaunchOpts
    -> IO (Either ConnectionException VoiceWebsocketReceivable)
performIdentification :: Connection
-> WebsocketLaunchOpts
-> IO (Either ConnectionException VoiceWebsocketReceivable)
performIdentification Connection
conn WebsocketLaunchOpts
opts = do
    -- Send opcode 0 Identify
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (VoiceWebsocketSendable -> ByteString)
-> VoiceWebsocketSendable -> ByteString
forall a b. (a -> b) -> a -> b
$ IdentifyPayload -> VoiceWebsocketSendable
Identify (IdentifyPayload -> VoiceWebsocketSendable)
-> IdentifyPayload -> VoiceWebsocketSendable
forall a b. (a -> b) -> a -> b
$ IdentifyPayload :: GuildId -> GuildId -> Text -> Text -> IdentifyPayload
IdentifyPayload
        { identifyPayloadServerId :: GuildId
identifyPayloadServerId = (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting GuildId WebsocketLaunchOpts GuildId -> GuildId
forall s a. s -> Getting a s a -> a
^. Getting GuildId WebsocketLaunchOpts GuildId
forall s a. HasGuildId s a => Lens' s a
guildId)
        , identifyPayloadUserId :: GuildId
identifyPayloadUserId = (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting GuildId WebsocketLaunchOpts GuildId -> GuildId
forall s a. s -> Getting a s a -> a
^. Getting GuildId WebsocketLaunchOpts GuildId
forall s a. HasBotUserId s a => Lens' s a
botUserId)
        , identifyPayloadSessionId :: Text
identifyPayloadSessionId = (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasSessionId s a => Lens' s a
sessionId)
        , identifyPayloadToken :: Text
identifyPayloadToken = (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasToken s a => Lens' s a
token)
        }
        
    Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn

-- | Send the Opcode 7 Resume packet to Discord, and await the Opcode 9 Resumed
-- payload.
performResumption
    :: Connection
    -> WebsocketLaunchOpts
    -> IO (Either ConnectionException VoiceWebsocketReceivable)
performResumption :: Connection
-> WebsocketLaunchOpts
-> IO (Either ConnectionException VoiceWebsocketReceivable)
performResumption Connection
conn WebsocketLaunchOpts
opts = do
    -- Send opcode 7 Resume
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (VoiceWebsocketSendable -> ByteString)
-> VoiceWebsocketSendable -> ByteString
forall a b. (a -> b) -> a -> b
$
        GuildId -> Text -> Text -> VoiceWebsocketSendable
Resume (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting GuildId WebsocketLaunchOpts GuildId -> GuildId
forall s a. s -> Getting a s a -> a
^. Getting GuildId WebsocketLaunchOpts GuildId
forall s a. HasGuildId s a => Lens' s a
guildId) (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasSessionId s a => Lens' s a
sessionId) (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting Text WebsocketLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text WebsocketLaunchOpts Text
forall s a. HasToken s a => Lens' s a
token)
    
    Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn

-- | Send the Opcode 1 Select Protocol to Discord. Does not wait for a payload.
sendSelectProtocol
    :: Connection
    -> T.Text
    -> Integer
    -> T.Text
    -> IO (Either ConnectionException VoiceWebsocketReceivable)
sendSelectProtocol :: Connection
-> Text
-> Integer
-> Text
-> IO (Either ConnectionException VoiceWebsocketReceivable)
sendSelectProtocol Connection
conn Text
ip Integer
port Text
mode = do
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode (VoiceWebsocketSendable -> ByteString)
-> VoiceWebsocketSendable -> ByteString
forall a b. (a -> b) -> a -> b
$ SelectProtocolPayload -> VoiceWebsocketSendable
SelectProtocol (SelectProtocolPayload -> VoiceWebsocketSendable)
-> SelectProtocolPayload -> VoiceWebsocketSendable
forall a b. (a -> b) -> a -> b
$ 
        Text -> Text -> Integer -> Text -> SelectProtocolPayload
SelectProtocolPayload Text
"udp" Text
ip Integer
port Text
mode
    
    Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn

    -- We do not do getPayload here, since there's no guarantee the next
    -- received packet is an Opcode 4 Session Description, when heartbeats
    -- has began already.
    -- TODO: remove if the above is not a problem

-- | Get one packet from the Websocket Connection, parsing it into a
-- VoiceWebsocketReceivable using Aeson. If the packet is not validly
-- parsed, it will be a @Right (ParseError info)@.
getPayload
    :: Connection
    -> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload :: Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn = IO VoiceWebsocketReceivable
-> IO (Either ConnectionException VoiceWebsocketReceivable)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO VoiceWebsocketReceivable
 -> IO (Either ConnectionException VoiceWebsocketReceivable))
-> IO VoiceWebsocketReceivable
-> IO (Either ConnectionException VoiceWebsocketReceivable)
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 VoiceWebsocketReceivable
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
msg' of
        Right VoiceWebsocketReceivable
msg -> VoiceWebsocketReceivable -> IO VoiceWebsocketReceivable
forall (f :: * -> *) a. Applicative f => a -> f a
pure VoiceWebsocketReceivable
msg
        Left String
err  -> VoiceWebsocketReceivable -> IO VoiceWebsocketReceivable
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceWebsocketReceivable -> IO VoiceWebsocketReceivable)
-> VoiceWebsocketReceivable -> IO VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$ Text -> VoiceWebsocketReceivable
ParseError (Text -> VoiceWebsocketReceivable)
-> Text -> VoiceWebsocketReceivable
forall a b. (a -> b) -> a -> b
$ 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')

-- | Eternally send data from libSends and usrSends channels
sendableLoop
    :: Connection
    -> VoiceWebsocketSendChan
    -> VoiceWebsocketSendChan
    -> Chan T.Text
    -> IO ()
sendableLoop :: Connection
-> VoiceWebsocketSendChan
-> VoiceWebsocketSendChan
-> Chan Text
-> IO ()
sendableLoop Connection
conn VoiceWebsocketSendChan
libSends VoiceWebsocketSendChan
usrSends Chan Text
log = do
    -- Wait-time taken from discord-haskell/Internal.Gateway.EventLoop
    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)
    -- Get whichever possible, and send it
    VoiceWebsocketSendable
payload <- (VoiceWebsocketSendable -> VoiceWebsocketSendable)
-> (VoiceWebsocketSendable -> VoiceWebsocketSendable)
-> Either VoiceWebsocketSendable VoiceWebsocketSendable
-> VoiceWebsocketSendable
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either VoiceWebsocketSendable -> VoiceWebsocketSendable
forall a. a -> a
id VoiceWebsocketSendable -> VoiceWebsocketSendable
forall a. a -> a
id (Either VoiceWebsocketSendable VoiceWebsocketSendable
 -> VoiceWebsocketSendable)
-> IO (Either VoiceWebsocketSendable VoiceWebsocketSendable)
-> IO VoiceWebsocketSendable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO VoiceWebsocketSendable
-> IO VoiceWebsocketSendable
-> IO (Either VoiceWebsocketSendable VoiceWebsocketSendable)
forall a b. IO a -> IO b -> IO (Either a b)
race (VoiceWebsocketSendChan -> IO VoiceWebsocketSendable
forall a. Chan a -> IO a
readChan VoiceWebsocketSendChan
libSends) (VoiceWebsocketSendChan -> IO VoiceWebsocketSendable
forall a. Chan a -> IO a
readChan VoiceWebsocketSendChan
usrSends)
    -- log ✍ ("(send) " <> tshow payload) -- TODO: debug, remove.
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceWebsocketSendable -> ByteString
forall a. ToJSON a => a -> ByteString
encode VoiceWebsocketSendable
payload
    Connection
-> VoiceWebsocketSendChan
-> VoiceWebsocketSendChan
-> Chan Text
-> IO ()
sendableLoop Connection
conn VoiceWebsocketSendChan
libSends VoiceWebsocketSendChan
usrSends Chan Text
log

-- | Eternally send heartbeats through the libSends channel
heartbeatLoop
    :: VoiceWebsocketSendChan
    -> Int
    -- ^ milliseconds
    -> Chan T.Text
    -> IO ()
heartbeatLoop :: VoiceWebsocketSendChan -> Int -> Chan Text -> IO ()
heartbeatLoop VoiceWebsocketSendChan
libSends Int
interval Chan Text
log = do
    Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
        Int
time <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
        VoiceWebsocketSendChan -> VoiceWebsocketSendable -> IO ()
forall a. Chan a -> a -> IO ()
writeChan VoiceWebsocketSendChan
libSends (VoiceWebsocketSendable -> IO ())
-> VoiceWebsocketSendable -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> VoiceWebsocketSendable
Heartbeat (Int -> VoiceWebsocketSendable) -> Int -> VoiceWebsocketSendable
forall a b. (a -> b) -> a -> b
$ Int
time
        Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000

gatewayCheckerLoop
    :: Chan (Either GatewayException Event)
    -- ^ Gateway events
    -> MVar ()
    -- ^ Binary empty semaphore, set to () when gateway has reconnected
    -> Chan T.Text
    -- ^ log
    -> IO ()
gatewayCheckerLoop :: Chan (Either GatewayException Event)
-> MVar () -> Chan Text -> IO ()
gatewayCheckerLoop Chan (Either GatewayException Event)
gatewayEvents MVar ()
sem Chan Text
log = do
    Either GatewayException Event
top <- Chan (Either GatewayException Event)
-> IO (Either GatewayException Event)
forall a. Chan a -> IO a
readChan Chan (Either GatewayException Event)
gatewayEvents
    Chan Text
log Chan Text -> Text -> IO ()
✍ (Either GatewayException Event -> Text
forall a. Show a => a -> Text
tshow Either GatewayException Event
top)
    case Either GatewayException Event
top of
        Right (Discord.Internal.Types.Ready Int
_ User
_ [Channel]
_ [GuildUnavailable]
_ Text
_) -> do
            Chan Text
log Chan Text -> Text -> IO ()
✍ Text
"gateway ready detected, putting () in sem"
            MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
sem ()
            Chan (Either GatewayException Event)
-> MVar () -> Chan Text -> IO ()
gatewayCheckerLoop Chan (Either GatewayException Event)
gatewayEvents MVar ()
sem Chan Text
log
        Either GatewayException Event
_ -> Chan (Either GatewayException Event)
-> MVar () -> Chan Text -> IO ()
gatewayCheckerLoop Chan (Either GatewayException Event)
gatewayEvents MVar ()
sem Chan Text
log

-- | This function is the main event loop for the Websocket, after all initial
-- handshake stages (Hello and identification/resumption). It will continuously
-- read the top packet in the Websocket receives, and handle closures, and
-- packet responses (like heartbeat responses).
-- TODO: a separate ADT for this? what to call it
eventStream
    :: Connection
    -> WebsocketLaunchOpts
    -> Int
    -> UDPLaunchOpts
    -> VoiceWebsocketSendChan
    -> Chan T.Text
    -> IO WSState
eventStream :: Connection
-> WebsocketLaunchOpts
-> Int
-> UDPLaunchOpts
-> VoiceWebsocketSendChan
-> Chan Text
-> IO WSState
eventStream Connection
conn WebsocketLaunchOpts
opts Int
interval UDPLaunchOpts
udpLaunchOpts VoiceWebsocketSendChan
libSends Chan Text
log = do
    -- there has to be at least one packet every @interval@ milliseconds (which
    -- is the heartbeat response), so if we don't get that, it's a sign of
    -- the connection gone, we should reconnect. For a quick heuristic accounting
    -- for any network delays, allow for a tolerance of double the time.
    Maybe (Either ConnectionException VoiceWebsocketReceivable)
payload <- Int
-> IO (Either ConnectionException VoiceWebsocketReceivable)
-> IO (Maybe (Either ConnectionException VoiceWebsocketReceivable))
forall a. Int -> IO a -> IO (Maybe a)
doOrTimeout (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (IO (Either ConnectionException VoiceWebsocketReceivable)
 -> IO
      (Maybe (Either ConnectionException VoiceWebsocketReceivable)))
-> IO (Either ConnectionException VoiceWebsocketReceivable)
-> IO (Maybe (Either ConnectionException VoiceWebsocketReceivable))
forall a b. (a -> b) -> a -> b
$ Connection
-> IO (Either ConnectionException VoiceWebsocketReceivable)
getPayload Connection
conn
    -- log ✍ ("(recv) " <> tshow payload) -- TODO: debug, remove.
    case Maybe (Either ConnectionException VoiceWebsocketReceivable)
payload of
        Maybe (Either ConnectionException VoiceWebsocketReceivable)
Nothing -> do
            Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"connection timed out, trying to reconnect again."
            WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSResume
        -- Network-WebSockets, type ConnectionException
        Just (Left (CloseRequest Word16
code ByteString
str)) -> do
            -- Whether we resume or gracefully close depends on the close code,
            -- so offload the decision to the close code handler.
            Word16 -> ByteString -> IO WSState
handleClose Word16
code ByteString
str
        Just (Left ConnectionException
_) -> do
            Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"connection exception in eventStream, trying to reconnect."
            WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSResume
        Just (Right (HeartbeatAck Int
_)) ->
            Connection
-> WebsocketLaunchOpts
-> Int
-> UDPLaunchOpts
-> VoiceWebsocketSendChan
-> Chan Text
-> IO WSState
eventStream Connection
conn WebsocketLaunchOpts
opts Int
interval UDPLaunchOpts
udpLaunchOpts VoiceWebsocketSendChan
libSends Chan Text
log
        Just (Right VoiceWebsocketReceivable
receivable) -> do
            VoiceWebsocketReceiveChan
-> Either VoiceWebsocketException VoiceWebsocketReceivable -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (WebsocketLaunchOpts
opts WebsocketLaunchOpts
-> Getting
     VoiceWebsocketReceiveChan
     WebsocketLaunchOpts
     VoiceWebsocketReceiveChan
-> VoiceWebsocketReceiveChan
forall s a. s -> Getting a s a -> a
^. ((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
 -> Const
      VoiceWebsocketReceiveChan
      (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> WebsocketLaunchOpts
-> Const VoiceWebsocketReceiveChan WebsocketLaunchOpts
forall s a. HasWsHandle s a => Lens' s a
wsHandle (((VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
  -> Const
       VoiceWebsocketReceiveChan
       (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
 -> WebsocketLaunchOpts
 -> Const VoiceWebsocketReceiveChan WebsocketLaunchOpts)
-> ((VoiceWebsocketReceiveChan
     -> Const VoiceWebsocketReceiveChan VoiceWebsocketReceiveChan)
    -> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
    -> Const
         VoiceWebsocketReceiveChan
         (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan))
-> Getting
     VoiceWebsocketReceiveChan
     WebsocketLaunchOpts
     VoiceWebsocketReceiveChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceWebsocketReceiveChan
 -> Const VoiceWebsocketReceiveChan VoiceWebsocketReceiveChan)
-> (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
-> Const
     VoiceWebsocketReceiveChan
     (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)
forall s t a b. Field1 s t a b => Lens s t a b
_1) (VoiceWebsocketReceivable
-> Either VoiceWebsocketException VoiceWebsocketReceivable
forall a b. b -> Either a b
Right VoiceWebsocketReceivable
receivable)
            Connection
-> WebsocketLaunchOpts
-> Int
-> UDPLaunchOpts
-> VoiceWebsocketSendChan
-> Chan Text
-> IO WSState
eventStream Connection
conn WebsocketLaunchOpts
opts Int
interval UDPLaunchOpts
udpLaunchOpts VoiceWebsocketSendChan
libSends Chan Text
log

  where
    -- | Handle Websocket Close codes by logging appropriate messages and
    -- closing the connection.
    handleClose :: Word16 -> BL.ByteString -> IO WSState
    handleClose :: Word16 -> ByteString -> IO WSState
handleClose Word16
1000 ByteString
str = Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"websocket closed normally."
        IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
    handleClose Word16
4001 ByteString
str = Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"websocket closed due to unknown opcode"
        IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed
    handleClose Word16
4014 ByteString
str = Chan Text
log Chan Text -> Text -> IO ()
✍! (Text
"vc deleted, main gateway closed, or bot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"forcefully disconnected... Restarting voice.")
        IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSStart
    handleClose Word16
4015 ByteString
str = Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"server crashed on Discord side, resuming"
        IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSResume
    handleClose Word16
code ByteString
str = Chan Text -> Text -> IO ()
(✍!) Chan Text
log (Text
"connection closed with code: [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Word16 -> Text
forall a. Show a => a -> Text
tshow 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 -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
str))
        IO () -> IO WSState -> IO WSState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WSState -> IO WSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure WSState
WSClosed