{-# LANGUAGE ImportQualifiedPost #-}
{-|
Module      : Discord.Internal.Voice.UDPLoop
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 @launchUdp@, a function used to start a UDP socket and
perform initial handshaking with the Discord Voice UDP Endpoint. It will
continuously encrypt and send the OPUS voice packets as received through the
specified Chan. This function is called automatically by @launchWebsocket@.
-}
module Discord.Internal.Voice.UDPLoop
    ( launchUdp
    ) where

import Codec.Audio.Opus.Decoder
import Crypto.Saltine.Core.SecretBox
    ( Key(..)
    , Nonce(..)
    , secretboxOpen
    , secretbox
    )
import Crypto.Saltine.Class qualified as SC
import Control.Concurrent
    ( Chan
    , readChan
    , writeChan
    , MVar
    , readMVar
    , forkIO
    , killThread
    , threadDelay
    , myThreadId
    )
import Control.Concurrent.BoundedChan qualified as Bounded
import Control.Exception.Safe ( handle, SomeException, finally, try, bracket )
import Lens.Micro
import Control.Monad.IO.Class ( MonadIO )
import Data.Binary ( encode, decode )
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Builder
import Data.ByteString qualified as B
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time.Clock.POSIX
import Data.Time
import Data.Maybe ( fromJust )
import Data.Word ( Word8 )
import Network.Socket hiding ( socket )
import Network.Socket qualified as S ( socket )
import Network.Socket.ByteString.Lazy ( sendAll, recv )

import Discord.Internal.Types.VoiceCommon
import Discord.Internal.Types.VoiceUDP
import Discord.Internal.Voice.CommonUtils

data UDPState
    = UDPClosed
    | UDPStart
    | UDPReconnect

-- | 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 udpError 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 UDP Error - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
log)

-- Alias for opening a UDP socket connection using the Discord endpoint.
runUDPClient :: AddrInfo -> (Socket -> IO a) -> IO a
runUDPClient :: AddrInfo -> (Socket -> IO a) -> IO a
runUDPClient AddrInfo
addr Socket -> IO a
things = IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
    Socket -> IO ()
close ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
        Socket -> SockAddr -> IO ()
Network.Socket.connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
        Socket -> IO a
things Socket
sock

-- | Starts the UDP connection, performs IP discovery, writes the result to the
-- receivables channel, and then starts an eternal loop of sending and receiving
-- packets.
launchUdp :: UDPLaunchOpts -> Chan T.Text -> IO ()
launchUdp :: UDPLaunchOpts -> Chan Text -> IO ()
launchUdp UDPLaunchOpts
opts Chan Text
log = UDPState -> Int -> IO ()
loop UDPState
UDPStart Int
0
  where
    loop :: UDPState -> Int -> IO ()
    loop :: UDPState -> Int -> IO ()
loop UDPState
UDPClosed Int
retries = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    loop UDPState
UDPStart Int
retries = do
        Either SomeException UDPState
next <- IO UDPState -> IO (Either SomeException UDPState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO UDPState -> IO (Either SomeException UDPState))
-> IO UDPState -> IO (Either SomeException UDPState)
forall a b. (a -> b) -> a -> b
$ do
            let hints :: AddrInfo
hints = AddrInfo
defaultHints
                    { addrSocketType :: SocketType
addrSocketType = SocketType
Datagram
                    -- TIL while developing: Stream: TCP, Datagram: UDP
                    }
            AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo
                (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints)
                (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ UDPLaunchOpts
opts UDPLaunchOpts -> Getting Text UDPLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text UDPLaunchOpts Text
forall s a. HasIp s a => Lens' s a
ip)
                (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ UDPLaunchOpts
opts UDPLaunchOpts -> Getting Integer UDPLaunchOpts Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer UDPLaunchOpts Integer
forall s a. HasPort s a => Lens' s a
port)

            AddrInfo -> (Socket -> IO UDPState) -> IO UDPState
forall a. AddrInfo -> (Socket -> IO a) -> IO a
runUDPClient AddrInfo
addr ((Socket -> IO UDPState) -> IO UDPState)
-> (Socket -> IO UDPState) -> IO UDPState
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
                -- Connection succeded. Otherwise an Exception is propagated
                -- in the IO monad.
                Chan Text
log Chan Text -> Text -> IO ()
✍ Text
"UDP Connection initialised."

                -- Perform IP discovery
                -- https://discord.com/developers/docs/topics/voice-connections#ip-discovery
                Socket -> ByteString -> IO ()
sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VoiceUDPPacket -> ByteString
forall a. Binary a => a -> ByteString
encode (VoiceUDPPacket -> ByteString) -> VoiceUDPPacket -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Text -> Integer -> VoiceUDPPacket
IPDiscovery (UDPLaunchOpts
opts 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) Text
"" Integer
0
                VoiceUDPPacket
msg <- ByteString -> VoiceUDPPacket
forall a. Binary a => ByteString -> a
decode (ByteString -> VoiceUDPPacket)
-> IO ByteString -> IO VoiceUDPPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int64 -> IO ByteString
recv Socket
sock Int64
74
                Chan VoiceUDPPacket -> VoiceUDPPacket -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (UDPLaunchOpts
opts UDPLaunchOpts
-> Getting
     (Chan VoiceUDPPacket) UDPLaunchOpts (Chan VoiceUDPPacket)
-> Chan VoiceUDPPacket
forall s a. s -> Getting a s a -> a
^. ((Chan VoiceUDPPacket, VoiceUDPSendChan)
 -> Const
      (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts
forall s a. HasUdpHandle s a => Lens' s a
udpHandle (((Chan VoiceUDPPacket, VoiceUDPSendChan)
  -> Const
       (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
 -> UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts)
-> ((Chan VoiceUDPPacket
     -> Const (Chan VoiceUDPPacket) (Chan VoiceUDPPacket))
    -> (Chan VoiceUDPPacket, VoiceUDPSendChan)
    -> Const
         (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> Getting
     (Chan VoiceUDPPacket) UDPLaunchOpts (Chan VoiceUDPPacket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chan VoiceUDPPacket
 -> Const (Chan VoiceUDPPacket) (Chan VoiceUDPPacket))
-> (Chan VoiceUDPPacket, VoiceUDPSendChan)
-> Const
     (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan)
forall s t a b. Field1 s t a b => Lens s t a b
_1) VoiceUDPPacket
msg

                UDPConn -> Chan Text -> IO UDPState
startForks (UDPLaunchOpts -> Socket -> UDPConn
UDPConn UDPLaunchOpts
opts Socket
sock) Chan Text
log

        case Either SomeException UDPState
next :: Either SomeException UDPState 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 start UDP conn due to an exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                UDPState -> Int -> IO ()
loop UDPState
UDPClosed Int
0
            Right UDPState
n -> UDPState -> Int -> IO ()
loop UDPState
n Int
0

    loop UDPState
UDPReconnect Int
retries = do
        -- No need to perform IP discovery.
        Either SomeException UDPState
next <- IO UDPState -> IO (Either SomeException UDPState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO UDPState -> IO (Either SomeException UDPState))
-> IO UDPState -> IO (Either SomeException UDPState)
forall a b. (a -> b) -> a -> b
$ do
            let hints :: AddrInfo
hints = AddrInfo
defaultHints
                    { addrSocketType :: SocketType
addrSocketType = SocketType
Datagram
                    }
            AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo
                (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints)
                (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ UDPLaunchOpts
opts UDPLaunchOpts -> Getting Text UDPLaunchOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text UDPLaunchOpts Text
forall s a. HasIp s a => Lens' s a
ip)
                (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ UDPLaunchOpts
opts UDPLaunchOpts -> Getting Integer UDPLaunchOpts Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer UDPLaunchOpts Integer
forall s a. HasPort s a => Lens' s a
port)

            AddrInfo -> (Socket -> IO UDPState) -> IO UDPState
forall a. AddrInfo -> (Socket -> IO a) -> IO a
runUDPClient AddrInfo
addr ((Socket -> IO UDPState) -> IO UDPState)
-> (Socket -> IO UDPState) -> IO UDPState
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
                -- Connection succeded. Otherwise an Exception is propagated
                -- in the IO monad.
                Chan Text
log Chan Text -> Text -> IO ()
✍ Text
"UDP Connection re-initialised."
                UDPConn -> Chan Text -> IO UDPState
startForks (UDPLaunchOpts -> Socket -> UDPConn
UDPConn UDPLaunchOpts
opts Socket
sock) Chan Text
log

        case Either SomeException UDPState
next :: Either SomeException UDPState of
            Left SomeException
e -> do
                Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"could not reconnect to UDP, will restart in 10 secs."
                Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
10 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))
                UDPState -> Int -> IO ()
loop UDPState
UDPReconnect (Int
retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Right UDPState
n -> UDPState -> Int -> IO ()
loop UDPState
n Int
1

-- | Starts the sendable loop in another thread, and starts the receivable
-- loop in the current thread. Once receivable is closed, closes sendable and
-- exits. Reconnects if a temporary IO exception occured.
startForks
    :: UDPConn
    -> Chan T.Text
    -> IO UDPState
startForks :: UDPConn -> Chan Text -> IO UDPState
startForks UDPConn
conn Chan Text
log = do
    POSIXTime
currentTime <- IO POSIXTime
getPOSIXTime
    ThreadId
sendLoopId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ UDPConn -> Chan Text -> Integer -> Integer -> POSIXTime -> IO ()
sendableLoop UDPConn
conn Chan Text
log Integer
0 Integer
0 POSIXTime
currentTime

    -- write five frames of silence initially
    -- TODO: check if this is needed (is the 5 frames only for between voice,
    -- or also at the beginning like it is now?)
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> [IO ()]
forall a. Int -> a -> [a]
replicate Int
5 (IO () -> [IO ()]) -> IO () -> [IO ()]
forall a b. (a -> b) -> a -> b
$ VoiceUDPSendChan -> ByteString -> IO ()
forall a. BoundedChan a -> a -> IO ()
Bounded.writeChan (UDPConn
conn UDPConn
-> Getting VoiceUDPSendChan UDPConn VoiceUDPSendChan
-> VoiceUDPSendChan
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> UDPConn -> Const VoiceUDPSendChan UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
 -> UDPConn -> Const VoiceUDPSendChan UDPConn)
-> ((VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
    -> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> Getting VoiceUDPSendChan UDPConn VoiceUDPSendChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chan VoiceUDPPacket, VoiceUDPSendChan)
 -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts
forall s a. HasUdpHandle s a => Lens' s a
udpHandle (((Chan VoiceUDPPacket, VoiceUDPSendChan)
  -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
 -> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> ((VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
    -> (Chan VoiceUDPPacket, VoiceUDPSendChan)
    -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> (VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
-> UDPLaunchOpts
-> Const VoiceUDPSendChan UDPLaunchOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
-> (Chan VoiceUDPPacket, VoiceUDPSendChan)
-> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan)
forall s t a b. Field2 s t a b => Lens s t a b
_2) ByteString
"\248\255\254"

    IO UDPState -> IO () -> IO UDPState
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (UDPConn -> Chan Text -> IO ()
receivableLoop UDPConn
conn Chan Text
log IO () -> IO UDPState -> IO UDPState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UDPState -> IO UDPState
forall (f :: * -> *) a. Applicative f => a -> f a
pure UDPState
UDPClosed)
        (ThreadId -> IO ()
killThread ThreadId
sendLoopId)

-- | Eternally receive a packet from the socket (max length 999, so practically
-- never fails). Decrypts audio data as necessary, and writes it to the
-- receivables channel.
receivableLoop
    :: UDPConn
    -> Chan T.Text
    -> IO ()
receivableLoop :: UDPConn -> Chan Text -> IO ()
receivableLoop UDPConn
conn Chan Text
log = do
    -- max length has to be specified but is irrelevant since it is so big
    VoiceUDPPacket
msg'' <- ByteString -> VoiceUDPPacket
forall a. Binary a => ByteString -> a
decode (ByteString -> VoiceUDPPacket)
-> IO ByteString -> IO VoiceUDPPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int64 -> IO ByteString
recv (UDPConn
conn UDPConn -> Getting Socket UDPConn Socket -> Socket
forall s a. s -> Getting a s a -> a
^. Getting Socket UDPConn Socket
forall s a. HasSocket s a => Lens' s a
socket) Int64
999
    -- decrypt any encrypted audio packets to plain SpeakingData
    VoiceUDPPacket
msg' <- case VoiceUDPPacket
msg'' of
        SpeakingDataEncrypted ByteString
header ByteString
og -> do
            [Word8]
byteKey <- MVar [Word8] -> IO [Word8]
forall a. MVar a -> IO a
readMVar (UDPConn
conn UDPConn
-> Getting (MVar [Word8]) UDPConn (MVar [Word8]) -> MVar [Word8]
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> UDPConn -> Const (MVar [Word8]) UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
 -> UDPConn -> Const (MVar [Word8]) UDPConn)
-> ((MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
    -> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> Getting (MVar [Word8]) UDPConn (MVar [Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
-> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts
forall s a. HasSecretKey s a => Lens' s a
secretKey)
            let nonce :: ByteString
nonce = ByteString -> ByteString
createNonceFromHeader ByteString
header
            let deciphered :: Maybe ByteString
deciphered = [Word8] -> ByteString -> ByteString -> Maybe ByteString
decrypt [Word8]
byteKey ByteString
nonce (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
og
            case Maybe ByteString
deciphered of
                Maybe ByteString
Nothing -> do
                    Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"could not decipher audio message!"
                    VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceUDPPacket -> IO VoiceUDPPacket)
-> VoiceUDPPacket -> IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> VoiceUDPPacket
MalformedPacket (ByteString -> VoiceUDPPacket) -> ByteString -> VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BL.append (ByteString -> ByteString
BL.fromStrict ByteString
header) ByteString
og
                Just ByteString
x  -> VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceUDPPacket -> IO VoiceUDPPacket)
-> VoiceUDPPacket -> IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> VoiceUDPPacket
SpeakingData ByteString
x
        SpeakingDataEncryptedExtra ByteString
header ByteString
og -> do
            -- Almost similar, but remove first 8 bytes of decoded audio
            [Word8]
byteKey <- MVar [Word8] -> IO [Word8]
forall a. MVar a -> IO a
readMVar (UDPConn
conn UDPConn
-> Getting (MVar [Word8]) UDPConn (MVar [Word8]) -> MVar [Word8]
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> UDPConn -> Const (MVar [Word8]) UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
 -> UDPConn -> Const (MVar [Word8]) UDPConn)
-> ((MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
    -> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> Getting (MVar [Word8]) UDPConn (MVar [Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
-> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts
forall s a. HasSecretKey s a => Lens' s a
secretKey)
            let nonce :: ByteString
nonce = ByteString -> ByteString
createNonceFromHeader ByteString
header
            let deciphered :: Maybe ByteString
deciphered = [Word8] -> ByteString -> ByteString -> Maybe ByteString
decrypt [Word8]
byteKey ByteString
nonce (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
og
            case Maybe ByteString
deciphered of
                Maybe ByteString
Nothing -> do
                    Chan Text
log Chan Text -> Text -> IO ()
✍! Text
"could not decipher audio message!"
                    VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceUDPPacket -> IO VoiceUDPPacket)
-> VoiceUDPPacket -> IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> VoiceUDPPacket
MalformedPacket (ByteString -> VoiceUDPPacket) -> ByteString -> VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BL.append (ByteString -> ByteString
BL.fromStrict ByteString
header) ByteString
og
                Just ByteString
x  -> VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VoiceUDPPacket -> IO VoiceUDPPacket)
-> VoiceUDPPacket -> IO VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ ByteString -> VoiceUDPPacket
SpeakingData (ByteString -> VoiceUDPPacket) -> ByteString -> VoiceUDPPacket
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
8 ByteString
x
        VoiceUDPPacket
other -> VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure VoiceUDPPacket
other

    -- log ✍ (tshow msg') -- TODO: debug, remove.
    -- decode speaking data's OPUS to raw PCM
    VoiceUDPPacket
msg <- case VoiceUDPPacket
msg' of
        SpeakingData ByteString
bytes -> ByteString -> VoiceUDPPacket
SpeakingData (ByteString -> VoiceUDPPacket)
-> IO ByteString -> IO VoiceUDPPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO ByteString
decodeOpusData ByteString
bytes
        VoiceUDPPacket
other -> VoiceUDPPacket -> IO VoiceUDPPacket
forall (f :: * -> *) a. Applicative f => a -> f a
pure VoiceUDPPacket
other

    Chan VoiceUDPPacket -> VoiceUDPPacket -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (UDPConn
conn UDPConn
-> Getting (Chan VoiceUDPPacket) UDPConn (Chan VoiceUDPPacket)
-> Chan VoiceUDPPacket
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts)
-> UDPConn -> Const (Chan VoiceUDPPacket) UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts)
 -> UDPConn -> Const (Chan VoiceUDPPacket) UDPConn)
-> Getting
     (Chan VoiceUDPPacket) UDPLaunchOpts (Chan VoiceUDPPacket)
-> Getting (Chan VoiceUDPPacket) UDPConn (Chan VoiceUDPPacket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chan VoiceUDPPacket, VoiceUDPSendChan)
 -> Const
      (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts
forall s a. HasUdpHandle s a => Lens' s a
udpHandle (((Chan VoiceUDPPacket, VoiceUDPSendChan)
  -> Const
       (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
 -> UDPLaunchOpts -> Const (Chan VoiceUDPPacket) UDPLaunchOpts)
-> ((Chan VoiceUDPPacket
     -> Const (Chan VoiceUDPPacket) (Chan VoiceUDPPacket))
    -> (Chan VoiceUDPPacket, VoiceUDPSendChan)
    -> Const
         (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> Getting
     (Chan VoiceUDPPacket) UDPLaunchOpts (Chan VoiceUDPPacket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chan VoiceUDPPacket
 -> Const (Chan VoiceUDPPacket) (Chan VoiceUDPPacket))
-> (Chan VoiceUDPPacket, VoiceUDPSendChan)
-> Const
     (Chan VoiceUDPPacket) (Chan VoiceUDPPacket, VoiceUDPSendChan)
forall s t a b. Field1 s t a b => Lens s t a b
_1) VoiceUDPPacket
msg
    UDPConn -> Chan Text -> IO ()
receivableLoop UDPConn
conn Chan Text
log

-- | Appends 12 empty bytes to form the 24-byte nonce for the secret box.
createNonceFromHeader :: B.ByteString -> B.ByteString
createNonceFromHeader :: ByteString -> ByteString
createNonceFromHeader ByteString
h = ByteString -> ByteString -> ByteString
B.append ByteString
h (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> [ByteString]
forall a. Int -> a -> [a]
replicate Int
12 (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
0

-- | Eternally send the top packet in the sendable packet Chan. It assumes that
-- it is already OPUS-encoded. The function will encrypt it using the syncKey.
sendableLoop
    :: UDPConn
    -> Chan T.Text
    -- ^ Logs
    -> Integer
    -- ^ Sequence number, modulo 65535
    -> Integer
    -- ^ Timestamp number, modulo 4294967295
    -> POSIXTime
    -> IO ()
sendableLoop :: UDPConn -> Chan Text -> Integer -> Integer -> POSIXTime -> IO ()
sendableLoop UDPConn
conn Chan Text
log Integer
sequence Integer
timestamp POSIXTime
startTime = do
    -- Immediately send the first packet available
    Maybe ByteString
mbOpusBytes <- VoiceUDPSendChan -> IO (Maybe ByteString)
forall a. BoundedChan a -> IO (Maybe a)
Bounded.tryReadChan (VoiceUDPSendChan -> IO (Maybe ByteString))
-> VoiceUDPSendChan -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ UDPConn
conn UDPConn
-> Getting VoiceUDPSendChan UDPConn VoiceUDPSendChan
-> VoiceUDPSendChan
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> UDPConn -> Const VoiceUDPSendChan UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
 -> UDPConn -> Const VoiceUDPSendChan UDPConn)
-> ((VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
    -> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> Getting VoiceUDPSendChan UDPConn VoiceUDPSendChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chan VoiceUDPPacket, VoiceUDPSendChan)
 -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts
forall s a. HasUdpHandle s a => Lens' s a
udpHandle (((Chan VoiceUDPPacket, VoiceUDPSendChan)
  -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
 -> UDPLaunchOpts -> Const VoiceUDPSendChan UDPLaunchOpts)
-> ((VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
    -> (Chan VoiceUDPPacket, VoiceUDPSendChan)
    -> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan))
-> (VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
-> UDPLaunchOpts
-> Const VoiceUDPSendChan UDPLaunchOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoiceUDPSendChan -> Const VoiceUDPSendChan VoiceUDPSendChan)
-> (Chan VoiceUDPPacket, VoiceUDPSendChan)
-> Const VoiceUDPSendChan (Chan VoiceUDPPacket, VoiceUDPSendChan)
forall s t a b. Field2 s t a b => Lens s t a b
_2
    case Maybe ByteString
mbOpusBytes of
        Maybe ByteString
Nothing -> do
            -- nothing could be read, so wait 20ms (no dynamic calculation
            -- required, because nothing demands accurate real-time)
            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 -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
20 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
3 :: Int)
            POSIXTime
currentTime <- IO POSIXTime
getPOSIXTime
            UDPConn -> Chan Text -> Integer -> Integer -> POSIXTime -> IO ()
sendableLoop UDPConn
conn Chan Text
log Integer
sequence Integer
timestamp POSIXTime
currentTime
        Just ByteString
opusBytes -> do
            let header :: ByteString
header = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ VoiceUDPPacketHeader -> ByteString
forall a. Binary a => a -> ByteString
encode (VoiceUDPPacketHeader -> ByteString)
-> VoiceUDPPacketHeader -> ByteString
forall a b. (a -> b) -> a -> b
$
                    Word8
-> Word8 -> Word16 -> Word32 -> Word32 -> VoiceUDPPacketHeader
Header Word8
0x80 Word8
0x78 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sequence) (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
timestamp) (Word32 -> VoiceUDPPacketHeader) -> Word32 -> VoiceUDPPacketHeader
forall a b. (a -> b) -> a -> b
$
                        Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32) -> Integer -> Word32
forall a b. (a -> b) -> a -> b
$ UDPConn
conn UDPConn -> Getting Integer UDPConn Integer -> Integer
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const Integer UDPLaunchOpts)
-> UDPConn -> Const Integer UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const Integer UDPLaunchOpts)
 -> UDPConn -> Const Integer UDPConn)
-> Getting Integer UDPLaunchOpts Integer
-> Getting Integer UDPConn Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Integer UDPLaunchOpts Integer
forall s a. HasSsrc s a => Lens' s a
ssrc
            let nonce :: ByteString
nonce = ByteString -> ByteString
createNonceFromHeader ByteString
header
            [Word8]
byteKey <- MVar [Word8] -> IO [Word8]
forall a. MVar a -> IO a
readMVar (MVar [Word8] -> IO [Word8]) -> MVar [Word8] -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ UDPConn
conn UDPConn
-> Getting (MVar [Word8]) UDPConn (MVar [Word8]) -> MVar [Word8]
forall s a. s -> Getting a s a -> a
^. (UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> UDPConn -> Const (MVar [Word8]) UDPConn
forall s a. HasLaunchOpts s a => Lens' s a
launchOpts ((UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
 -> UDPConn -> Const (MVar [Word8]) UDPConn)
-> ((MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
    -> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts)
-> Getting (MVar [Word8]) UDPConn (MVar [Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar [Word8] -> Const (MVar [Word8]) (MVar [Word8]))
-> UDPLaunchOpts -> Const (MVar [Word8]) UDPLaunchOpts
forall s a. HasSecretKey s a => Lens' s a
secretKey
            let encryptedOpus :: ByteString
encryptedOpus = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString -> ByteString -> ByteString
encrypt [Word8]
byteKey ByteString
nonce ByteString
opusBytes

            -- send the header and the encrypted opus data
            Socket -> ByteString -> IO ()
sendAll (UDPConn
conn UDPConn -> Getting Socket UDPConn Socket -> Socket
forall s a. s -> Getting a s a -> a
^. Getting Socket UDPConn Socket
forall s a. HasSocket s a => Lens' s a
socket) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
                VoiceUDPPacket -> ByteString
forall a. Binary a => a -> ByteString
encode (VoiceUDPPacket -> ByteString) -> VoiceUDPPacket -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> VoiceUDPPacket
SpeakingDataEncrypted ByteString
header ByteString
encryptedOpus

            -- wait a biiit less than 20ms before sending the next packet
            -- logic taken from discord.py discord/player.py L595
            let theoreticalNextTime :: POSIXTime
theoreticalNextTime = POSIXTime
startTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ (POSIXTime
20 POSIXTime -> POSIXTime -> POSIXTime
forall a. Fractional a => a -> a -> a
/ POSIXTime
1000)
            POSIXTime
currentTime <- IO POSIXTime
getPOSIXTime
            Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> POSIXTime -> Int
forall a b. (a -> b) -> a -> b
$ (POSIXTime -> POSIXTime -> POSIXTime
forall a. Ord a => a -> a -> a
max POSIXTime
0 (POSIXTime -> POSIXTime) -> POSIXTime -> POSIXTime
forall a b. (a -> b) -> a -> b
$ POSIXTime
theoreticalNextTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
currentTime) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
10POSIXTime -> Int -> POSIXTime
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)
            UDPConn -> Chan Text -> Integer -> Integer -> POSIXTime -> IO ()
sendableLoop UDPConn
conn Chan Text
log
                (Integer
sequence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
0xFFFF) (Integer
timestamp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
48Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
20 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
0xFFFFFFFF) POSIXTime
theoreticalNextTime

-- | Decrypt a sound packet using the provided Discord key and header nonce. The
-- argument is strict because it has to be strict when passed to Saltine anyway,
-- and having the same type signature leaves room for the caller to choose.
--
-- This does no error handling on misformatted key/nonce since this function is
-- only used in contexts where we are guaranteed they are valid.
decrypt :: [Word8] -> B.ByteString -> B.ByteString -> Maybe B.ByteString
decrypt :: [Word8] -> ByteString -> ByteString -> Maybe ByteString
decrypt [Word8]
byteKey ByteString
byteNonce ByteString
og = Key -> Nonce -> ByteString -> Maybe ByteString
secretboxOpen Key
key Nonce
nonce ByteString
og
  where
    key :: Key
key = Maybe Key -> Key
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Key -> Key) -> Maybe Key -> Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Key
forall a. IsEncoding a => ByteString -> Maybe a
SC.decode (ByteString -> Maybe Key) -> ByteString -> Maybe Key
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack [Word8]
byteKey
    nonce :: Nonce
nonce = Maybe Nonce -> Nonce
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Nonce -> Nonce) -> Maybe Nonce -> Nonce
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Nonce
forall a. IsEncoding a => ByteString -> Maybe a
SC.decode ByteString
byteNonce

-- | Encrypt a strict sound packet using the provided Discord key and header
-- nonce. The argument is strict because it has to be converted to strict
-- before passing onto Saltine anyway, and it leaves room for the caller of the
-- function to choose which laziness to use.
--
-- As with decryption, this function does no error handling on the format of the
-- key and nonce (key = 32 bytes, nonce = 24 bytes).
encrypt :: [Word8] -> B.ByteString -> B.ByteString -> B.ByteString
encrypt :: [Word8] -> ByteString -> ByteString -> ByteString
encrypt [Word8]
byteKey ByteString
byteNonce ByteString
og = Key -> Nonce -> ByteString -> ByteString
secretbox Key
key Nonce
nonce ByteString
og
  where
    key :: Key
key = Maybe Key -> Key
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Key -> Key) -> Maybe Key -> Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Key
forall a. IsEncoding a => ByteString -> Maybe a
SC.decode (ByteString -> Maybe Key) -> ByteString -> Maybe Key
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack [Word8]
byteKey
    nonce :: Nonce
nonce = Maybe Nonce -> Nonce
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Nonce -> Nonce) -> Maybe Nonce -> Nonce
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Nonce
forall a. IsEncoding a => ByteString -> Maybe a
SC.decode ByteString
byteNonce

decodeOpusData :: B.ByteString -> IO B.ByteString
decodeOpusData :: ByteString -> IO ByteString
decodeOpusData ByteString
bytes = do
    let deCfg :: DecoderConfig
deCfg = SamplingRate -> Bool -> DecoderConfig
mkDecoderConfig SamplingRate
opusSR48k Bool
True
    let deStreamCfg :: DecoderStreamConfig
deStreamCfg = DecoderConfig -> Int -> Int -> DecoderStreamConfig
mkDecoderStreamConfig DecoderConfig
deCfg (Int
48Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
20) Int
0
    Decoder
decoder <- DecoderConfig -> IO Decoder
forall cfg (m :: * -> *).
(HasDecoderConfig cfg, MonadIO m) =>
cfg -> m Decoder
opusDecoderCreate DecoderConfig
deCfg
    ByteString
decoded <- Decoder -> DecoderStreamConfig -> ByteString -> IO ByteString
forall cfg (m :: * -> *).
(HasDecoderStreamConfig cfg, MonadIO m) =>
Decoder -> cfg -> ByteString -> m ByteString
opusDecode Decoder
decoder DecoderStreamConfig
deStreamCfg ByteString
bytes
    ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded