diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,28 @@ +# Changelog for discord-haskell-voice + +## Unreleased changes + +## 2.2.0 + +- Change the definition of `Voice` from a type alias exposing dangerous internal handles, to a newtype wrapper. This also changes the definition of `liftDiscord` to maintain identical behaviour. +- Update `discord-haskell` dependency to 1.11.0 + +## 2.1.0 + +- Removed `updateSpeakingStatus` from the publicly exported function list for `Discord.Voice`. + +## 2.0.0 + +- Rewrite the entire library (see #1). +- Introduce the `Voice` monad, and all functions in it: `join`, `play`, and all other variants of `play`. +- Add `lens` as a dependency for internal library use. +- Add `conduit` as the main method of piping and transforming audio on the fly. +- Remove all previous functions: `joinVoice`, `leaveVoice`, `playPCM`, etc. +- Add package documentation to public modules, and make sure the abstraction layer is solid (don't export useless internals). +- Rename the JoinSpecificVC example to BasicMusicBot and add a `bot volume` command to change the volume. + +## 0.0.1 + +- Initial release. +- Implement `joinVoice`, `leaveVoice`, etc and use `DiscordVoiceHandle` to maintain a reference to the voice handle. +- Add JoinAllVC and JoinSpecificVC as example usages of the library. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Yuto Takano + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,98 @@ +# discord-haskell-voice + +![hackage version](https://img.shields.io/badge/Hackage-unreleased-5e5184) +![discord-haskell version dependency](https://img.shields.io/badge/discord--haskell%20ver.-1.11.0-lightblue) + +Welcome to `discord-haskell-voice`! This library provides you with a high-level +interface for interacting with Discord's Voice API, building on top of the +[`discord-haskell`](https://hackage.haskell.org/package/discord-haskell) library +by Karl. + +For a quick intuitive introduction to what this library enables you to do, see +the following snippet of code: + +```hs +rickroll :: Channel -> DiscordHandler () +rickroll c@(ChannelVoice {}) = do + void $ runVoice $ do + join (channelGuild c) (channelId c) + playYouTube "https://www.youtube.com/watch?v=dQw4w9WgXcQ" +``` + +The library actively uses and supports conduit, which enables you to write +something like the following as well! + +```hs +rickrollHalfVolume :: Channel -> DiscordHandler () +rickrollHalfVolume c@(ChannelVoice {}) = do + void $ runVoice $ do + join (channelGuild c) (channelId c) + let halfAmplitude = awaitForever $ \current -> + yield $ round $ fromIntegral current * 0.5 + playYouTube' "rickroll" $ packInt16C .| halfAmplitude .| unpackInt16C + liftIO $ print "finished playing!" +``` + +## Requirements + +- The library uses [`saltine`](https://github.com/tel/saltine) for encryption +and decryption of audio packets. This requires the appropriate libraries to be +installed on your system. See their README for information. +- The library requires Opus libraries to be installed on your system. The +`libopus-dev` package available on package repositories should be sufficient +on most \*nix systems. Windows is unexplored yet (WSL works). +- If you are to use any variants of `playFile`, `playYouTube`, you will need +FFmpeg installed. To specify a custom executable name, see the `-With` function +variants. +- If you are to use any variants of `playYouTube`, you will additionally need +youtube-dl installed. This is used to get the stream URL to pass to FFmpeg. To +specify a custom executable name, use `playYouTubeWith`. + +## Features + +What is supported: + +- Can join/leave Discord voice channels. It is possible to join multiple of them +simultaneously (one per sever) and stream different contents to each. +- It is also possible for many voice channels (across many servers) and play the +same content, radio/subscriber-style. +- You can play arbitrary PCM audio, arbitrary audio (with FFmpeg), and arbitrary +internet audio (with youtube-dl). +- You can transform audio arbitrarily using Conduit. +- As it streams content, the library /should/ use constant memory (unverified). +- OPUS encoding and specific implementation details such as handshakes and +encryption are done opaquely, and a nice abstraction layer is provided. + +What is not supported: + +- Decrypting audio packets sent from Discord (other people's voices), and +decoding them to PCM. + +See `examples/BasicMusicBot.hs` for a bot that uses many advanced features of +the library, including dynamically adjusting the stream audio using a TVar +(and allowing users to change the TVar using a `/volume` command). + +## Installation + +This library is not published on Hackage or Stackage yet. It is using an +unstable pinned version of the opus package, and until that is properly tested +I do not want to publish it. It is, however available as a package candidate +on Hackage (for viewing Haddock docs). + +With Stack, use the `extra-deps` field in your project `stack.yaml` to specify +the Git repo and the commit tag to use. + +With Cabal, use the `source-repository-package` stanza in your `cabal.project` +to specify the Git repo and the commit tag to use. + +## Documentation + +See the Haddock documentation on the [Hackage package candidate page](https://hackage.haskell.org/package/discord-haskell-voice-2.1.0/candidate). + +## Future Plans + +- Use `stm-conduit` and `stm` for a safer Chan? +- Look into SubprocessException seemingly never been thrown (e.g. when SIGINT +is signalled to the libarry while FFmpeg is running) +- Consider, document, and improve the distinction of errors (VoiceError) vs +exceptions, and note down why any choices are made diff --git a/discord-haskell-voice.cabal b/discord-haskell-voice.cabal new file mode 100644 --- /dev/null +++ b/discord-haskell-voice.cabal @@ -0,0 +1,131 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: discord-haskell-voice +version: 2.2.0 +synopsis: Voice support for discord-haskell. +description: Supplementary library to discord-haskell. See the project README on GitHub for more information. +category: Network +homepage: https://github.com/yutotakano/discord-haskell-voice#readme +bug-reports: https://github.com/yutotakano/discord-haskell-voice/issues +author: Yuto Takano +maintainer: moa17stock@gmail.com +copyright: 2021 Yuto Takano +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/yutotakano/discord-haskell-voice + +library + exposed-modules: + Discord.Voice + Discord.Voice.Conduit + Discord.Internal.Types.VoiceCommon + Discord.Internal.Types.VoiceUDP + Discord.Internal.Types.VoiceWebsocket + Discord.Internal.Voice + Discord.Internal.Voice.CommonUtils + Discord.Internal.Voice.UDPLoop + Discord.Internal.Voice.WebsocketLoop + other-modules: + Paths_discord_haskell_voice + hs-source-dirs: + src + default-extensions: + OverloadedStrings + build-depends: + BoundedChan ==1.0.3.0 + , aeson ==1.5.6.0 + , async >=2.2.3 && <2.4 + , base >=4.7 && <5 + , binary ==0.8.* + , bytestring >=0.10.12.0 && <0.11 + , conduit ==1.3.4.1 + , discord-haskell ==1.11.0 + , lens >=4.19.2 && <5 + , mtl ==2.2.2 + , network >=3.1.1.1 && <3.2 + , opus ==0.1.0.0 + , process >=1.6.9.0 && <1.7 + , safe-exceptions >=0.1.7.1 && <0.1.8 + , saltine >=0.1.1.1 && <0.2 + , text >=1.2.4.1 && <2 + , time >=1.9.3 && <=1.13 + , unliftio >=0.2.18 && <0.3 + , websockets >=0.12.7.2 && <0.12.8 + , wuss >=1.1.18 && <=1.2 + default-language: Haskell2010 + +executable basic-music-bot + main-is: examples/BasicMusicBot.hs + other-modules: + Paths_discord_haskell_voice + default-extensions: + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + BoundedChan ==1.0.3.0 + , aeson ==1.5.6.0 + , async >=2.2.3 && <2.4 + , base >=4.7 && <5 + , binary ==0.8.* + , bytestring >=0.10.12.0 && <0.11 + , conduit ==1.3.4.1 + , discord-haskell ==1.11.0 + , discord-haskell-voice + , lens >=4.19.2 && <5 + , mtl ==2.2.2 + , network >=3.1.1.1 && <3.2 + , optparse-applicative >=0.15.1.0 && <0.17 + , opus ==0.1.0.0 + , process >=1.6.9.0 && <1.7 + , safe-exceptions >=0.1.7.1 && <0.1.8 + , saltine >=0.1.1.1 && <0.2 + , stm >=2.5.0.0 && <2.5.1 + , stm-containers ==1.2 + , text >=1.2.4.1 && <2 + , time >=1.9.3 && <=1.13 + , unliftio >=0.2.18 && <0.3 + , websockets >=0.12.7.2 && <0.12.8 + , wuss >=1.1.18 && <=1.2 + default-language: Haskell2010 + +executable join-all-on-start + main-is: examples/JoinAllVC.hs + other-modules: + Paths_discord_haskell_voice + default-extensions: + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + BoundedChan ==1.0.3.0 + , aeson ==1.5.6.0 + , async >=2.2.3 && <2.4 + , base >=4.7 && <5 + , binary ==0.8.* + , bytestring >=0.10.12.0 && <0.11 + , conduit ==1.3.4.1 + , discord-haskell ==1.11.0 + , discord-haskell-voice + , lens >=4.19.2 && <5 + , mtl ==2.2.2 + , network >=3.1.1.1 && <3.2 + , opus ==0.1.0.0 + , process >=1.6.9.0 && <1.7 + , safe-exceptions >=0.1.7.1 && <0.1.8 + , saltine >=0.1.1.1 && <0.2 + , text >=1.2.4.1 && <2 + , time >=1.9.3 && <=1.13 + , unliftio >=0.2.18 && <0.3 + , websockets >=0.12.7.2 && <0.12.8 + , wuss >=1.1.18 && <=1.2 + default-language: Haskell2010 diff --git a/examples/BasicMusicBot.hs b/examples/BasicMusicBot.hs new file mode 100644 --- /dev/null +++ b/examples/BasicMusicBot.hs @@ -0,0 +1,141 @@ +module Main where + +import Conduit +import Control.Concurrent.STM.TVar +import Control.Monad ( when + , guard + , void + , forever + ) +import Data.List ( intercalate + ) +import Data.Maybe ( fromJust + ) +import qualified Data.Text.IO as TIO +import qualified Data.Text as T +import qualified StmContainers.Map as M +import qualified Discord.Requests as R +import Discord.Types +import Discord.Voice +import Discord.Voice.Conduit +import Discord +import Options.Applicative +import UnliftIO ( liftIO + , atomically + ) + +data BotAction + = JoinVoice ChannelId + | LeaveVoice ChannelId + | PlayVoice String + | ChangeVolume Int + deriving ( Read ) + +data GuildContext = GuildContext + { songQueries :: [String] + , volume :: TVar Int -- volume + , leaveFunc :: Voice () -- function to leave voice channel + } + +parser :: ParserInfo BotAction +parser = info + ( helper <*> subparser + ( command "join" + ( flip info (progDesc "Join a voice channel") $ + JoinVoice <$> + argument auto (metavar "CHANID" <> help "Voice Channel ID")) + <> command "leave" + ( flip info (progDesc "Leave a voice channel") $ + LeaveVoice <$> + argument auto (metavar "CHANID" <> help "Voice Channel ID")) + <> command "play" + ( flip info (progDesc "Queue something to play!") $ + PlayVoice . intercalate " " <$> + some (argument str (metavar "QUERY" <> help "Search query/URL"))) + <> command "volume" + ( flip info (progDesc "Change the volume for this server!") $ + ChangeVolume <$> + argument auto (metavar "VOLUME" <> help "Integer volume")) + ) + ) fullDesc + +main :: IO () +main = do + tok <- TIO.readFile "./examples/auth-token.secret" + + queries <- M.newIO + t <- runDiscord $ def + { discordToken = tok + , discordOnStart = pure () + , discordOnEnd = liftIO $ putStrLn "Ended" + , discordOnEvent = eventHandler queries + , discordOnLog = \s -> TIO.putStrLn s + } + putStrLn "Exiting..." + +eventHandler :: M.Map String GuildContext -> Event -> DiscordHandler () +eventHandler contexts (MessageCreate msg) = case messageGuildId msg of + Nothing -> pure () + Just gid -> do + -- the message was sent in a server + let args = map T.unpack $ T.words $ messageContent msg + case args of + ("bot":_) -> case (execParserPure defaultPrefs parser $ tail args) of + Success x -> handleCommand contexts msg gid x + Failure failure -> + void $ restCall $ R.CreateMessage (messageChannelId msg) $ T.pack $ + fst $ renderFailure failure "bot" + _ -> pure () +eventHandler _ _ = pure () + +handleCommand :: M.Map String GuildContext -> Message -> GuildId -> BotAction -> DiscordHandler () +handleCommand contexts msg gid (JoinVoice cid) = do + result <- runVoice $ do + leave <- join gid cid + volume <- liftIO $ newTVarIO 100 + liftDiscord $ atomically $ M.insert (GuildContext [] volume leave) (show gid) contexts + -- Forever, read the top of the queue and play it. + forever $ do + context <- liftDiscord $ atomically $ M.lookup (show gid) contexts + case context of + Nothing -> pure () + Just (GuildContext [] _ _) -> pure () + Just (GuildContext (x:xs) _ _) -> do + liftDiscord $ atomically $ M.insert (GuildContext xs volume leave) (show gid) contexts + let adjustVolume = awaitForever $ \current -> do + v' <- liftIO $ readTVarIO volume + yield $ round $ fromIntegral current * (fromIntegral v' / 100) + playYouTube' x $ packInt16C .| adjustVolume .| unpackInt16C + + case result of + Left e -> liftIO $ print e >> pure () + Right _ -> pure () + +handleCommand contexts msg gid (LeaveVoice cid) = do + context <- atomically $ M.lookup (show gid) contexts + case context of + Nothing -> pure () + Just (GuildContext _ _ leave) -> do + void $ atomically $ M.delete (show gid) contexts + void $ runVoice leave + +handleCommand contexts msg gid (PlayVoice q) = do + resultQueue <- atomically $ do + context <- M.lookup (show gid) contexts + case context of + Nothing -> pure [] + Just (GuildContext xs v leave) -> do + M.insert (GuildContext (xs ++ [q]) v leave) (show gid) contexts + pure $ xs ++ [q] + void $ restCall $ R.CreateMessage (messageChannelId msg) $ case resultQueue of + [] -> T.pack $ "Can't play something when I'm not in a voice channel!" + xs -> T.pack $ "Queued for playback: " <> show resultQueue + +handleCommand contexts msg gid (ChangeVolume amount) = do + context <- atomically $ M.lookup (show gid) contexts + case context of + Nothing -> pure () + Just (GuildContext q v l) -> do + atomically $ swapTVar v amount + void $ restCall $ R.CreateMessage (messageChannelId msg) $ + (T.pack $ "Volume set to " <> show amount <> " / 100") diff --git a/examples/JoinAllVC.hs b/examples/JoinAllVC.hs new file mode 100644 --- /dev/null +++ b/examples/JoinAllVC.hs @@ -0,0 +1,60 @@ +module Main where + +import Control.Monad ( forM_ + , forever + , void + ) +import Control.Monad.Trans ( lift ) +import Conduit +import qualified Data.Text.IO as TIO +import Discord +import Discord.Voice +import qualified Discord.Requests as R +import Discord.Types +import UnliftIO ( liftIO + ) +import Control.Concurrent + +main :: IO () +main = do + tok <- TIO.readFile "./examples/production.secret" + + t <- runDiscord $ def + { discordToken = tok + , discordOnStart = startHandler + , discordOnEnd = liftIO $ putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s + } + putStrLn "Finished!" + +eventHandler :: Event -> DiscordHandler () +eventHandler event = pure () + +startHandler :: DiscordHandler () +startHandler = do + Right partialGuilds <- restCall R.GetCurrentUserGuilds + + result <- runVoice $ do + forM_ partialGuilds $ \pg -> do + Right guild <- liftDiscord $ restCall $ R.GetGuild (partialGuildId pg) + Right chans <- liftDiscord $ restCall $ R.GetGuildChannels (guildId guild) + + case filter isVoiceChannel chans of + (c:_) -> void $ join (guildId guild) (channelId c) + _ -> pure () + + -- play something, then sit around in silence for 30 seconds + playYouTube "https://www.youtube.com/watch?v=dQw4w9WgXcQ" + liftIO $ threadDelay $ 30 * 1000 * 1000 + + liftIO $ print result + pure () + +isTextChannel :: Channel -> Bool +isTextChannel (ChannelText {}) = True +isTextChannel _ = False + +isVoiceChannel :: Channel -> Bool +isVoiceChannel (ChannelVoice {}) = True +isVoiceChannel _ = False diff --git a/src/Discord/Internal/Types/VoiceCommon.hs b/src/Discord/Internal/Types/VoiceCommon.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/VoiceCommon.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-| +Module : Discord.Internal.Types.VoiceCommon +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 defines the types for handles, errors, base monads, and other types +applicable to both the UPD and Websocket components of the Voice API. Many of +the structures defined in this module have Lenses derived for them using +Template Haskell. +-} +module Discord.Internal.Types.VoiceCommon where + +import Control.Concurrent ( Chan, MVar, ThreadId ) +import Control.Concurrent.BoundedChan qualified as Bounded +import Control.Exception.Safe ( Exception, MonadMask, MonadCatch, MonadThrow ) +import Control.Lens ( makeFields ) +import Control.Monad.Except +import Control.Monad.Reader +import Data.ByteString qualified as B +import Data.Text qualified as T +import Data.Word ( Word8 ) +import GHC.Weak ( Weak ) +import Network.Socket +import Network.WebSockets ( ConnectionException, Connection ) + +import Discord +import Discord.Types +import Discord.Internal.Gateway.EventLoop ( GatewayException(..) ) +import Discord.Internal.Types.VoiceUDP +import Discord.Internal.Types.VoiceWebsocket + +-- | @Voice@ is a newtype Monad containing a composition of ReaderT and ExceptT +-- transformers over the @DiscordHandler@ monad. It holds references to +-- voice connections/threads. The content of the reader handle is strictly +-- internal and is hidden deliberately behind the newtype wrapper. +-- +-- Developer Note: ExceptT is on the base rather than ReaderT, so that when a +-- critical exception/error occurs in @Voice@, it can propagate down the +-- transformer stack, kill the threads referenced in the Reader state as +-- necessary, and halt the entire computation and return to @DiscordHandler@. +-- If ExceptT were on top of ReaderT, then errors would be swallowed before it +-- propagates below ReaderT, and the monad would not halt there, continuing +-- computation with an unstable state. +newtype Voice a = Voice + { unVoice :: ReaderT DiscordBroadcastHandle (ExceptT VoiceError DiscordHandler) a + } deriving + ( Functor + , Applicative + , Monad + , MonadIO + -- ^ MonadIO gives the ability to perform 'liftIO'. + , MonadReader DiscordBroadcastHandle + -- ^ MonadReader is for internal use, to read the held broadcast handle. + , MonadError VoiceError + -- ^ MonadError is for internal use, to propagate errors. + , MonadFail + -- ^ MonadFail is for internal use, identical in function to the MonadFail + -- instance of ReaderT. + , MonadThrow + -- ^ MonadThrow, MonadCatch, and MonadMask are for internal use, to utilise + -- exception handling functions like @bracket@. + , MonadCatch + , MonadMask + ) + +-- | @VoiceError@ represents the potential errors when initialising a voice +-- connection. It does /not/ account for errors that occur after the initial +-- handshake (technically, because they are in IO and not ExceptT). +data VoiceError + = VoiceNotAvailable + | NoServerAvailable + | InvalidPayloadOrder + deriving (Show, Eq) + +-- | @SubprocessException@ is an Exception that may be thrown when a subprocess +-- such as FFmpeg encounters an error. +-- +-- TODO: This has never actually been seen, so it's untested whether it works. +data SubprocessException = SubprocessException String deriving (Eq, Show) +instance Exception SubprocessException + +-- | @DiscordVoiceHandle@ represents the handles for a single voice connection +-- (to a specific voice channel). +-- +-- Lenses are defined for this type using Template Haskell. +data DiscordVoiceHandle = DiscordVoiceHandle + { discordVoiceHandleGuildId :: GuildId + -- ^ The guild id of the voice channel. + , discordVoiceHandleChannelId :: ChannelId + -- ^ The channel id of the voice channel. + , discordVoiceHandleWebsocket :: (Weak ThreadId, (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan)) + -- ^ The websocket thread id and handle. + , discordVoiceHandleUdp :: (Weak ThreadId, (VoiceUDPReceiveChan, VoiceUDPSendChan)) + -- ^ The UDP thread id and handle. + , discordVoiceHandleSsrc :: Integer + -- ^ The SSRC of the voice connection, specified by Discord. This is + -- required in the packet sent when updating the Speaking indicator, so is + -- maintained in this handle. + } + +-- | @DiscordBroadcastHandle@ represents a "stream" or a "broadcast", which is +-- a mutable list of voice connection handles that share the same audio stream. +-- +-- Lenses are defined for this type using Template Haskell. +data DiscordBroadcastHandle = DiscordBroadcastHandle + { discordBroadcastHandleVoiceHandles :: MVar [DiscordVoiceHandle] + -- ^ The list of voice connection handles. + , discordBroadcastHandleMutEx :: MVar () + -- ^ The mutex used to synchronize access to the list of voice connection + } + +-- | Deprecated. +-- TODO: remove, unused +data VoiceWebsocketException + = VoiceWebsocketCouldNotConnect T.Text + | VoiceWebsocketEventParseError T.Text + | VoiceWebsocketUnexpected VoiceWebsocketReceivable T.Text + | VoiceWebsocketConnection ConnectionException T.Text + deriving (Show) + +type VoiceWebsocketReceiveChan = + Chan (Either VoiceWebsocketException VoiceWebsocketReceivable) + +type VoiceWebsocketSendChan = Chan VoiceWebsocketSendable + +type VoiceUDPReceiveChan = Chan VoiceUDPPacket + +type VoiceUDPSendChan = Bounded.BoundedChan B.ByteString + +-- | @WebsocketLaunchOpts@ represents all the data necessary to start a +-- Websocket connection to Discord's Voice Gateway. +-- +-- Lenses are defined for this type using Template Haskell. +data WebsocketLaunchOpts = WebsocketLaunchOpts + { websocketLaunchOptsBotUserId :: UserId + , websocketLaunchOptsSessionId :: T.Text + , websocketLaunchOptsToken :: T.Text + , websocketLaunchOptsGuildId :: GuildId + , websocketLaunchOptsEndpoint :: T.Text + , websocketLaunchOptsWsHandle :: (VoiceWebsocketReceiveChan, VoiceWebsocketSendChan) + , websocketLaunchOptsUdpTid :: MVar (Weak ThreadId) + , websocketLaunchOptsUdpHandle :: (VoiceUDPReceiveChan, VoiceUDPSendChan) + , websocketLaunchOptsSsrc :: MVar Integer + } + +-- | @WebsocketConn@ represents an active connection to Discord's Voice Gateway +-- websocket, and contains the Connection as well as the options that launched +-- it. +-- +-- Lenses are defined for this type using Template Haskell. +data WebsocketConn = WebsocketConn + { websocketConnConnection :: Connection + , websocketConnLaunchOpts :: WebsocketLaunchOpts + } + +-- | @UDPLaunchOpts@ represents all the data necessary to start a UDP connection +-- to Discord. Field names for this ADT are cased weirdly because I want to keep +-- the "UDP" part uppercase in the type and data constructor. Since field +-- accessors are rarely used anyway (lenses are preferred instead), we can +-- write the field prefixes as "uDP" and take advantage of Lenses as normal. +-- +-- Lenses are defined for this type using Template Haskell. +data UDPLaunchOpts = UDPLaunchOpts + { uDPLaunchOptsSsrc :: Integer + , uDPLaunchOptsIp :: T.Text + , uDPLaunchOptsPort :: Integer + , uDPLaunchOptsMode :: T.Text + , uDPLaunchOptsUdpHandle :: (VoiceUDPReceiveChan, VoiceUDPSendChan) + , uDPLaunchOptsSecretKey :: MVar [Word8] + } + +-- | @UDPConn@ represents an active UDP connection to Discord, and contains the +-- Socket as well as the options that launched it. +-- +-- Lenses are defined for this type using Template Haskell. +data UDPConn = UDPConn + { uDPConnLaunchOpts :: UDPLaunchOpts + , uDPConnSocket :: Socket + } + +$(makeFields ''DiscordVoiceHandle) +$(makeFields ''DiscordBroadcastHandle) +$(makeFields ''WebsocketLaunchOpts) +$(makeFields ''WebsocketConn) +$(makeFields ''UDPLaunchOpts) +$(makeFields ''UDPConn) diff --git a/src/Discord/Internal/Types/VoiceUDP.hs b/src/Discord/Internal/Types/VoiceUDP.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/VoiceUDP.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-| +Module : Discord.Internal.Types.VoiceUDP +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 defines basic types for the communication packets in the Discord +Voice UDP socket. Binary instances are defined for the header and the body +payload, as according to the official Discord documentation for v4 of the gateway. + +Prisms are defined using TemplateHaskell for VoiceUDPPacket. +-} +module Discord.Internal.Types.VoiceUDP where + +import Control.Lens ( makePrisms ) +import Data.Binary.Get +import Data.Binary.Put +import Data.Binary +import Data.ByteString.Lazy qualified as BL +import Data.ByteString qualified as B +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +data VoiceUDPPacket + = IPDiscovery Integer T.Text Integer + -- ^ ssrc, ip, port + | SpeakingData B.ByteString + | SpeakingDataEncrypted B.ByteString BL.ByteString + -- ^ header, and encrypted audio bytes + | SpeakingDataEncryptedExtra B.ByteString BL.ByteString + -- ^ header, and encrypted audio bytes with extended header inside + | UnknownPacket BL.ByteString + | MalformedPacket BL.ByteString + deriving (Show, Eq) + +data VoiceUDPPacketHeader + = Header Word8 Word8 Word16 Word32 Word32 + +instance Binary VoiceUDPPacketHeader where + get = do + ver <- getWord8 + pl <- getWord8 + seq <- getWord16be + timestamp <- getWord32be + ssrc <- getWord32be + pure $ Header ver pl seq timestamp ssrc + put (Header ver pl seq timestamp ssrc) = do + putWord8 ver + putWord8 pl + putWord16be seq + putWord32be timestamp + putWord32be ssrc + +instance Binary VoiceUDPPacket where + get = do + flags <- lookAhead getWord8 + case flags of + 0x0 -> do + _ <- getWord16be + _ <- getWord16be + ssrc <- toInteger <$> getWord32be + ip <- TE.decodeUtf8 . B.takeWhile (/= 0) <$> getByteString 64 + port <- toInteger <$> getWord16be + pure $ IPDiscovery ssrc ip port + 0x80 -> do + -- Receiving audio is undocumented but should be pretty much + -- the same as sending, according to several GitHub issues. + header <- getByteString 12 + a <- getRemainingLazyByteString + pure $ SpeakingDataEncrypted header a + 0x90 -> do + -- undocumented, but it seems to also be audio data + -- When it is 0x90, the encrypted spoken data contains an + -- extended header (0x90 is sent from Chromium on browser Discord + -- but 0x80 is from Desktop Discord) + -- + -- https://github.com/bwmarrin/discordgo/issues/423 + -- https://github.com/discord/discord-api-docs/issues/231 + header <- getByteString 12 + a <- getRemainingLazyByteString + pure $ SpeakingDataEncryptedExtra header a + other -> do + a <- getRemainingLazyByteString + pure $ UnknownPacket a + put (IPDiscovery ssrc ip port) = do + putWord16be 1 -- 1 is request, 2 is response + putWord16be 70 -- specified in docs + putWord32be $ fromIntegral ssrc + putLazyByteString $ BL.replicate 64 0 -- 64 empty bytes + putWord16be $ fromIntegral port + put (SpeakingDataEncrypted header a) = do + putByteString header + putLazyByteString a + put (MalformedPacket a) = putLazyByteString a + +$(makePrisms ''VoiceUDPPacket) diff --git a/src/Discord/Internal/Types/VoiceWebsocket.hs b/src/Discord/Internal/Types/VoiceWebsocket.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/VoiceWebsocket.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-| +Module : Discord.Internal.Types.VoiceWebsocket +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 defines basic types for the communication packets in the Discord +Voice Gateway. Some ToJSON and FromJSON instances are defined, as according to +the official Discord documentation for v4 of the gateway. + +Prisms are defined using TemplateHaskell for VoiceWebsocketReceivable. +-} +module Discord.Internal.Types.VoiceWebsocket where + +import Control.Applicative ( (<|>) ) +import Control.Lens ( makePrisms ) +import Data.Aeson +import Data.Aeson.Types +import Data.Text qualified as T +import Data.ByteString qualified as B +import Data.Word ( Word8 ) + +import Discord.Internal.Types.Prelude + +data VoiceWebsocketReceivable + = Ready ReadyPayload -- Opcode 2 + | SessionDescription T.Text [Word8] -- Opcode 4 + | SpeakingR SpeakingPayload -- Opcode 5 + | HeartbeatAck Int -- Opcode 6 + | Hello Int -- Opcode 8 + -- ^ Int because this is heartbeat, and threadDelay uses it + | Resumed -- Opcode 9 + | ClientDisconnect UserId -- Opcode 13 + | UnknownOPCode Integer Object -- Opcode unknown + | ParseError T.Text -- Internal use + | Reconnect -- Internal use + deriving (Show, Eq) + +data VoiceWebsocketSendable + = Identify IdentifyPayload -- Opcode 0 + | SelectProtocol SelectProtocolPayload -- Opcode 1 + | Heartbeat Int -- Opcode 3 + -- ^ Int because threadDelay uses it + | Speaking SpeakingPayload -- Opcode 5 + | Resume GuildId T.Text T.Text -- Opcode 7 + deriving (Show, Eq) + +data ReadyPayload = ReadyPayload + { readyPayloadSSRC :: Integer -- contains the 32-bit SSRC identifier + , readyPayloadIP :: T.Text + , readyPayloadPort :: Integer + , readyPayloadModes :: [T.Text] + -- , readyPayloadHeartbeatInterval <- This should not be used, as per Discord documentation + } + deriving (Show, Eq) + +data SpeakingPayload = SpeakingPayload + { speakingPayloadMicrophone :: Bool + , speakingPayloadSoundshare :: Bool + , speakingPayloadPriority :: Bool + , speakingPayloadDelay :: Integer + , speakingPayloadSSRC :: Integer + } + deriving (Show, Eq) + +data IdentifyPayload = IdentifyPayload + { identifyPayloadServerId :: GuildId + , identifyPayloadUserId :: UserId + , identifyPayloadSessionId :: T.Text + , identifyPayloadToken :: T.Text + } + deriving (Show, Eq) + +data SelectProtocolPayload = SelectProtocolPayload + { selectProtocolPayloadProtocol :: T.Text + , selectProtocolPayloadIP :: T.Text + , selectProtocolPayloadPort :: Integer + , selectProtocolPayloadMode :: T.Text + } + deriving (Show, Eq) + +instance FromJSON VoiceWebsocketReceivable where + parseJSON = withObject "payload" $ \o -> do + op <- o .: "op" :: Parser Integer + case op of + 2 -> do + od <- o .: "d" + ssrc <- od .: "ssrc" + ip <- od .: "ip" + port <- od .: "port" + modes <- od .: "modes" + pure $ Ready $ ReadyPayload ssrc ip port modes + 4 -> do + od <- o .: "d" + mode <- od .: "mode" + secretKey <- od .: "secret_key" + pure $ SessionDescription mode secretKey + 5 -> do + od <- o .: "d" + speaking <- + -- speaking field can be a number or a boolean. + -- This is undocumented in the docs. God, discord. + (od .: "speaking" :: Parser Int) <|> + (do + s <- od .: "speaking" :: Parser Bool + case s of + True -> pure 1 + False -> pure 0 + ) + + let (priority, rest1) = speaking `divMod` 4 + let (soundshare, rest2) = rest1 `divMod` 2 + let microphone = rest2 + delay <- od .:? "delay" .!= 0 + -- The delay key is not present when we receive this data, but + -- present when we send it, I think? not documented anywhere. + ssrc <- od .: "ssrc" + pure $ SpeakingR $ SpeakingPayload + { speakingPayloadMicrophone = toEnum microphone + , speakingPayloadSoundshare = toEnum soundshare + , speakingPayloadPriority = toEnum priority + , speakingPayloadDelay = delay + , speakingPayloadSSRC = ssrc + } + 6 -> do + od <- o .: "d" + pure $ HeartbeatAck od + 8 -> do + od <- o .: "d" + interval <- od .: "heartbeat_interval" + pure $ Hello interval + 9 -> pure Resumed + 13 -> do + od <- o .: "d" + uid <- od .: "user_id" + pure $ ClientDisconnect uid + _ -> pure $ UnknownOPCode op o + +instance ToJSON VoiceWebsocketSendable where + toJSON (Identify payload) = object + [ "op" .= (0 :: Int) + , "d" .= object + [ "server_id" .= identifyPayloadServerId payload + , "user_id" .= identifyPayloadUserId payload + , "session_id" .= identifyPayloadSessionId payload + , "token" .= identifyPayloadToken payload + ] + ] + toJSON (SelectProtocol payload) = object + [ "op" .= (1 :: Int) + , "d" .= object + [ "protocol" .= selectProtocolPayloadProtocol payload + , "data" .= object + [ "address" .= selectProtocolPayloadIP payload + , "port" .= selectProtocolPayloadPort payload + , "mode" .= selectProtocolPayloadMode payload + ] + ] + ] + toJSON (Heartbeat i) = object + [ "op" .= (3 :: Int) + , "d" .= i + ] + toJSON (Speaking payload) = object + [ "op" .= (5 :: Int) + , "d" .= object + [ "speaking" .= + ( fromEnum (speakingPayloadMicrophone payload) + + fromEnum (speakingPayloadSoundshare payload) * 2 + + fromEnum (speakingPayloadPriority payload) * 4 + ) + , "delay" .= speakingPayloadDelay payload + , "ssrc" .= speakingPayloadSSRC payload + ] + ] + toJSON (Resume gid session token) = object + [ "op" .= (7 :: Int) + , "d" .= object + [ "server_id" .= gid + , "session_id" .= session + , "token" .= token + ] + ] + +$(makePrisms ''VoiceWebsocketReceivable) diff --git a/src/Discord/Internal/Voice.hs b/src/Discord/Internal/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Voice.hs @@ -0,0 +1,724 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-| +Module : Discord.Internal.Voice +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 is the internal entry point into @discord-haskell-voice@. Any use of +this module (or other Internal modules) is discouraged. Please see "Discord.Voice" +for the public interface. +-} +module Discord.Internal.Voice where + +import Codec.Audio.Opus.Encoder +import Conduit +import Control.Concurrent.Async ( race ) +import Control.Concurrent + ( ThreadId + , myThreadId + , threadDelay + , killThread + , forkIO + , mkWeakThreadId + , Chan + , dupChan + , newChan + , readChan + , writeChan + , MVar + , newEmptyMVar + , newMVar + , readMVar + , putMVar + , withMVar + , tryPutMVar + , modifyMVar_ + ) +import Control.Concurrent.BoundedChan qualified as Bounded +import Control.Exception.Safe ( finally, bracket, throwTo, catch, throwIO ) +import Control.Lens +import Control.Monad.Reader ( ask, liftIO, runReaderT ) +import Control.Monad.Except ( runExceptT, throwError ) +import Control.Monad.Trans ( lift ) +import Control.Monad ( when, void ) +import Data.Aeson +import Data.Aeson.Types ( parseMaybe ) +import Data.ByteString qualified as B +import Data.Foldable ( traverse_ ) +import Data.List ( partition ) +import Data.Maybe ( fromJust ) +import Data.Text qualified as T +import GHC.Weak ( deRefWeak, Weak ) +import System.Exit ( ExitCode(..) ) +import System.IO ( hClose, hGetContents, hWaitForInput, hIsOpen ) +import System.IO.Error ( isEOFError ) +import System.Process +import UnliftIO qualified as UnliftIO + +import Discord ( DiscordHandler, sendCommand, readCache ) +import Discord.Handle ( discordHandleGateway, discordHandleLog ) +import Discord.Internal.Gateway.Cache ( Cache(..) ) +import Discord.Internal.Gateway.EventLoop + ( GatewayException(..) + , GatewayHandle(..) + ) +import Discord.Internal.Types + ( GuildId + , ChannelId + , UserId + , User(..) + , GatewaySendable(..) + , UpdateStatusVoiceOpts(..) + , EventInternalParse (..) + ) +import Discord.Internal.Types.VoiceCommon +import Discord.Internal.Types.VoiceWebsocket + ( VoiceWebsocketSendable(Speaking) + , SpeakingPayload(..) + ) +import Discord.Internal.Voice.CommonUtils +import Discord.Internal.Voice.WebsocketLoop + +-- | Send a Gateway Websocket Update Voice State command (Opcode 4). Used to +-- indicate that the client voice status (deaf/mute) as well as the channel +-- they are active on. +-- This is not in the Voice monad because it has to be used after all voice +-- actions end, to quit the voice channels. It also has no benefit, since it +-- would cause extra transformer wrapping/unwrapping. +updateStatusVoice + :: GuildId + -- ^ Id of Guild + -> Maybe ChannelId + -- ^ Id of the voice channel client wants to join (Nothing if disconnecting) + -> Bool + -- ^ Whether the client muted + -> Bool + -- ^ Whether the client deafened + -> DiscordHandler () +updateStatusVoice a b c d = sendCommand $ UpdateStatusVoice $ UpdateStatusVoiceOpts a b c d + +-- | @liftDiscord@ lifts a computation in DiscordHandler into a computation in +-- Voice. This is useful for performing DiscordHandler actions inside the +-- Voice monad. +-- +-- Usage: +-- +-- @ +-- runVoice $ do +-- join (read "123456789012345") (read "67890123456789012") +-- liftDiscord $ void $ restCall $ R.CreateMessage (read "2938481828383") "Joined!" +-- liftIO $ threadDelay 5e6 +-- playYouTube "Rate of Reaction of Sodium Hydroxide and Hydrochloric Acid" +-- liftDiscord $ void $ restCall $ R.CreateMessage (read "2938481828383") "Finished!" +-- void $ restCall $ R.CreateMessage (read "2938481828383") "Finished all voice actions!" +-- @ +-- +liftDiscord :: DiscordHandler a -> Voice a +liftDiscord = Voice . lift . lift + +-- | Execute the voice actions stored in the Voice monad. +-- +-- A single mutex and sending packet channel is used throughout all voice +-- connections within the actions, which enables multi-channel broadcasting. +-- The following demonstrates how a single playback is streamed to multiple +-- connections. +-- +-- @ +-- runVoice $ do +-- join (read "123456789012345") (read "67890123456789012") +-- join (read "098765432123456") (read "12345698765456709") +-- playYouTube "https://www.youtube.com/watch?v=dQw4w9WgXcQ" +-- @ +-- +-- The return type of @runVoice@ represents result status of the voice computation. +-- It is isomorphic to @Maybe@, but the use of Either explicitly denotes that +-- the correct\/successful\/"Right" behaviour is (), and that the potentially- +-- existing value is of failure. +runVoice :: Voice () -> DiscordHandler (Either VoiceError ()) +runVoice action = do + voiceHandles <- liftIO $ newMVar [] + mutEx <- liftIO $ newMVar () + + let initialState = DiscordBroadcastHandle voiceHandles mutEx + + result <- finally (runExceptT $ flip runReaderT initialState $ unVoice $ action) $ do + -- Wrap cleanup action in @finally@ to ensure we always close the + -- threads even if an exception occurred. + finalState <- liftIO $ readMVar voiceHandles + + -- Unfortunately, the following updateStatusVoice doesn't always run + -- when we have entered this @finally@ block through a SIGINT or other + -- asynchronous exception. The reason is that sometimes, the + -- discord-haskell websocket sendable thread is killed before this. + -- There is no way to prevent it, so as a consequence, the bot may + -- linger in the voice call for a few minutes after the bot program is + -- killed. + mapMOf_ (traverse . guildId) (\x -> updateStatusVoice x Nothing False False) finalState + mapMOf_ (traverse . websocket . _1) (liftIO . killWkThread) finalState + + pure result + +-- | Join a specific voice channel, given the Guild and Channel ID of the voice +-- channel. Since the Channel ID is globally unique, there is theoretically no +-- need to specify the Guild ID, but it is provided until discord-haskell fully +-- caches the mappings internally. +-- +-- This function returns a Voice action that, when executed, will leave the +-- joined voice channel. For example: +-- +-- @ +-- runVoice $ do +-- leave <- join (read "123456789012345") (read "67890123456789012") +-- playYouTube "https://www.youtube.com/watch?v=dQw4w9WgXcQ" +-- leave +-- @ +-- +-- The above use is not meaningful in practice, since @runVoice@ will perform +-- the appropriate cleanup and leaving as necessary at the end of all actions. +-- However, it may be useful to interleave @leave@ with other Voice actions. +-- +-- Since the @leave@ function will gracefully do nothing if the voice connection +-- is already severed, it is safe to escape this function from the Voice monad +-- and use it in a different context. That is, the following is allowed and +-- is encouraged if you are building a @\/leave@ command of any sort: +-- +-- @ +-- -- On \/play +-- runVoice $ do +-- leave <- join (read "123456789012345") (read "67890123456789012") +-- liftIO $ putMVar futureLeaveFunc leave +-- forever $ +-- playYouTube "https://www.youtube.com/watch?v=dQw4w9WgXcQ" +-- +-- -- On \/leave, from a different thread +-- leave <- liftIO $ takeMVar futureLeaveFunc +-- runVoice leave +-- @ +-- +-- The above will join a voice channel, play a YouTube video, but immediately +-- quit and leave the channel when the @\/leave@ command is received, regardless +-- of the playback status. +join :: GuildId -> ChannelId -> Voice (Voice ()) +join guildId channelId = do + h <- liftDiscord ask + -- Duplicate the event channel, so we can read without taking data from event handlers + events <- liftIO $ dupChan $ gatewayHandleEvents $ discordHandleGateway h + + -- To join a voice channel, we first need to send Voice State Update (Opcode + -- 4) to the gateway, which will then send us two responses, Dispatch Event + -- (Voice State Update) and Dispatch Event (Voice Server Update). + liftDiscord $ updateStatusVoice guildId (Just channelId) False False + + (liftIO . doOrTimeout 5000) (waitForVoiceStatusServerUpdate events) >>= \case + Nothing -> do + -- did not respond in time: no permission? or discord offline? + throwError VoiceNotAvailable + Just (_, _, _, Nothing) -> do + -- If endpoint is null, according to Docs, no servers are available. + throwError NoServerAvailable + Just (sessionId, token, guildId, Just endpoint) -> do + -- create the sending and receiving channels for Websocket + wsChans <- liftIO $ (,) <$> newChan <*> newChan + -- thread id and handles for UDP. 100 packets will contain 2 + -- seconds worth of 20ms audio. Each packet (20ms) contains + -- (48000 / 1000 * 20 =) 960 frames, for which each frame has + -- 2 channels and 16 bits (2 bytes) in each channel. So, the total + -- amount of memory required for each BoundedChan is 2*2*960*100= + -- 384 kB (kilobytes). + udpChans <- liftIO $ (,) <$> newChan <*> Bounded.newBoundedChan 100 + udpTidM <- liftIO newEmptyMVar + -- ssrc to be filled in during initial handshake + ssrcM <- liftIO $ newEmptyMVar + + uid <- userId . cacheCurrentUser <$> (liftDiscord readCache) + let wsOpts = WebsocketLaunchOpts uid sessionId token guildId endpoint + wsChans udpTidM udpChans ssrcM + + -- fork a thread to start the websocket thread in the DiscordHandler + -- monad using the current Reader state. Not much of a problem + -- since many of the fields are mutable references. + wsTid <- liftIO $ forkIO $ launchWebsocket wsOpts $ discordHandleLog h + + wsTidWeak <- liftIO $ mkWeakThreadId wsTid + + -- TODO: check if readMVar ever blocks if the UDP thread fails to + -- launch. Handle somehow? Perhaps with exception throwTo? + udpTid <- liftIO $ readMVar udpTidM + ssrc <- liftIO $ readMVar ssrcM + + -- modify the current Voice monad state to add the newly created + -- UDP and Websocket handles (a handle consists of thread id and + -- send/receive channels). + voiceState <- ask + -- Add the new voice handles to the list of handles + liftIO $ modifyMVar_ (voiceState ^. voiceHandles) $ \handles -> do + let newHandle = DiscordVoiceHandle guildId channelId + (wsTidWeak, wsChans) (udpTid, udpChans) ssrc + pure (newHandle : handles) + + -- Give back a function used for leaving this voice channel. + pure $ do + liftDiscord $ updateStatusVoice guildId Nothing False False + liftIO $ killWkThread wsTidWeak + where + -- | Continuously take the top item in the gateway event channel until both + -- Dispatch Event VOICE_STATE_UPDATE and Dispatch Event VOICE_SERVER_UPDATE + -- are received. + -- + -- The order is undefined in docs, so this function will block until both + -- are received in any order. + waitForVoiceStatusServerUpdate + :: Chan (Either GatewayException EventInternalParse) + -> IO (T.Text, T.Text, GuildId, Maybe T.Text) + waitForVoiceStatusServerUpdate = loopForBothEvents Nothing Nothing + + loopForBothEvents + :: Maybe T.Text + -> Maybe (T.Text, GuildId, Maybe T.Text) + -> Chan (Either GatewayException EventInternalParse) + -> IO (T.Text, T.Text, GuildId, Maybe T.Text) + loopForBothEvents (Just a) (Just (b, c, d)) events = pure (a, b, c, d) + loopForBothEvents mb1 mb2 events = readChan events >>= \case + -- Parse UnknownEvent, which are events not handled by discord-haskell. + Right (InternalUnknownEvent "VOICE_STATE_UPDATE" obj) -> do + -- Conveniently, we can just pass the result of parseMaybe + -- back recursively. + let sessionId = flip parseMaybe obj $ \o -> do + o .: "session_id" + loopForBothEvents sessionId mb2 events + Right (InternalUnknownEvent "VOICE_SERVER_UPDATE" obj) -> do + let result = flip parseMaybe obj $ \o -> do + token <- o .: "token" + guildId <- o .: "guild_id" + endpoint <- o .: "endpoint" + pure (token, guildId, endpoint) + loopForBothEvents mb1 result events + _ -> loopForBothEvents mb1 mb2 events + +-- | Helper function to update the speaking indicator for the bot. Setting the +-- microphone status to True is required for Discord to transmit the bot's +-- voice to other clients. It is done automatically in all of the @play*@ +-- functions, so there should be no use for this function in practice. +-- +-- Note: Soundshare and priority are const as False in the payload because I +-- don't see bots needing them. If and when required, add Bool signatures to +-- this function. +updateSpeakingStatus :: Bool -> Voice () +updateSpeakingStatus micStatus = do + h <- (^. voiceHandles) <$> ask + handles <- liftIO $ readMVar h + flip (mapMOf_ traverse) handles $ \handle -> + liftIO $ writeChan (handle ^. websocket . _2 . _2) $ Speaking $ SpeakingPayload + { speakingPayloadMicrophone = micStatus + , speakingPayloadSoundshare = False + , speakingPayloadPriority = False + , speakingPayloadDelay = 0 + , speakingPayloadSSRC = handle ^. ssrc + } + +-- | @play source@ plays some sound from the conduit @source@, provided in the +-- form of 16-bit Little Endian PCM. The use of Conduit allows you to perform +-- arbitrary lazy transformations of audio data, using all the advantages that +-- Conduit brings. As the base monad for the Conduit is @ResourceT DiscordHandler@, +-- you can access any DiscordHandler effects (through @lift@) or IO effects +-- (through @liftIO@) in the conduit as well. +-- +-- For a more specific interface that is easier to use, see the 'playPCMFile', +-- 'playFile', and 'playYouTube' functions. +-- +-- @ +-- import Conduit ( sourceFile ) +-- +-- runVoice $ do +-- join gid cid +-- play $ sourceFile ".\/audio\/example.pcm" +-- @ +play :: ConduitT () B.ByteString (ResourceT DiscordHandler) () -> Voice () +play source = do + h <- ask + dh <- liftDiscord ask + handles <- liftIO $ readMVar $ h ^. voiceHandles + + updateSpeakingStatus True + liftDiscord $ UnliftIO.withMVar (h ^. mutEx) $ \_ -> do + runConduitRes $ source .| encodeOpusC .| sinkHandles handles + updateSpeakingStatus False + where + sinkHandles + :: [DiscordVoiceHandle] + -> ConduitT B.ByteString Void (ResourceT DiscordHandler) () + sinkHandles handles = getZipSink $ + traverse_ (ZipSink . sinkChan . view (udp . _2 . _2)) handles + + sinkChan + :: Bounded.BoundedChan B.ByteString + -> ConduitT B.ByteString Void (ResourceT DiscordHandler) () + sinkChan chan = await >>= \case + Nothing -> pure () + Just bs -> do + liftIO $ Bounded.writeChan chan bs + sinkChan chan + +-- | @encodeOpusC@ is a conduit that splits the ByteString into chunks of +-- (frame size * no of channels * 16/8) bytes, and encodes each chunk into +-- OPUS format. ByteStrings are made of CChars (Int8)s, but the data is 16-bit +-- so this is why we multiply by two to get the right amount of bytes instead of +-- prematurely cutting off at the half-way point. +encodeOpusC :: ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () +encodeOpusC = chunksOfCE (48*20*2*2) .| do + encoder <- liftIO $ opusEncoderCreate enCfg + loop encoder + where + enCfg = _EncoderConfig # (opusSR48k, True, app_audio) + -- 1275 is the max bytes an opus 20ms frame can have + streamCfg = _StreamConfig # (enCfg, 48*20, 1276) + loop encoder = await >>= \case + Nothing -> do + -- Send at least 5 blank frames (20ms * 5 = 100 ms) + let frame = B.pack $ concat $ replicate 1280 [0xF8, 0xFF, 0xFE] + encoded <- liftIO $ opusEncode encoder streamCfg frame + yield encoded + yield encoded + yield encoded + yield encoded + yield encoded + Just frame -> do + -- encode the audio + encoded <- liftIO $ opusEncode encoder streamCfg frame + -- send it + yield encoded + loop encoder + +-- | @playPCMFile file@ plays the sound stored in the file located at @file@, +-- provided it is in the form of 16-bit Little Endian PCM. @playPCMFile@ is +-- defined as a handy alias for the following: +-- +-- > playPCMFile ≡ play . sourceFile +-- +-- For a variant of this function that allows arbitrary transformations of the +-- audio data through a conduit component, see 'playPCMFile''. +-- +-- To play any other format, it will need to be transcoded using FFmpeg. See +-- 'playFile' for such usage. +playPCMFile + :: FilePath + -- ^ The path to the PCM file to play + -> Voice () +playPCMFile = play . sourceFile + +-- | @playPCMFile' file processor@ plays the sound stored in the file located at +-- @file@, provided it is in the form of 16-bit Little Endian PCM. Audio data +-- will be passed through the @processor@ conduit component, allowing arbitrary +-- transformations to audio data before playback. @playPCMFile'@ is defined as +-- the following: +-- +-- > playPCMFile' file processor ≡ play $ sourceFile file .| processor +-- +-- For a variant of this function with no processing, see 'playPCMFile'. +-- +-- To play any other format, it will need to be transcoded using FFmpeg. See +-- 'playFile' for such usage. +playPCMFile' + :: FilePath + -- ^ The path to the PCM file to play + -> ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () + -- ^ Any processing that needs to be done on the audio data + -> Voice () +playPCMFile' fp processor = play $ sourceFile fp .| processor + +-- | @playFile file@ plays the sound stored in the file located at @file@. It +-- supports any format supported by FFmpeg by transcoding it, which means it can +-- play a wide range of file types. This function expects "@ffmpeg@" to be +-- available in the system PATH. +-- +-- For a variant that allows you to specify the executable and/or any arguments, +-- see 'playFileWith'. +-- +-- For a variant of this function that allows arbitrary transformations of the +-- audio data through a conduit component, see 'playFile''. +-- +-- If the file is already known to be in 16-bit little endian PCM, using +-- 'playPCMFile' is much more efficient as it does not go through FFmpeg. +playFile + :: FilePath + -- ^ The path to the audio file to play + -> Voice () +playFile fp = playFile' fp (awaitForever yield) + +-- | @playFile' file processor@ plays the sound stored in the file located at +-- @file@. It supports any format supported by FFmpeg by transcoding it, which +-- means it can play a wide range of file types. This function expects +-- "@ffmpeg@" to be available in the system PATH. Audio data will be passed +-- through the @processor@ conduit component, allowing arbitrary transformations +-- to audio data before playback. +-- +-- For a variant that allows you to specify the executable and/or any arguments, +-- see 'playFileWith''. +-- +-- For a variant of this function with no processing, see 'playFile'. +-- +-- If the file is already known to be in 16-bit little endian PCM, using +-- 'playPCMFile'' is much more efficient as it does not go through FFmpeg. +playFile' + :: FilePath + -- ^ The path to the audio file to play + -> ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () + -- ^ Any processing that needs to be done on the audio data + -> Voice () +playFile' fp = playFileWith' "ffmpeg" defaultFFmpegArgs fp + +-- | @defaultFFmpegArgs@ is a generator function for the default FFmpeg +-- arguments used when streaming audio into 16-bit little endian PCM on stdout. +-- +-- This function takes in the input file path as an argument, because FFmpeg +-- arguments are position sensitive in relation to the placement of @-i@. +-- +-- It is defined semantically as: +-- +-- > defaultFFmpegArgs FILE ≡ "-i FILE -f s16le -ar 48000 -ac 2 -loglevel warning pipe:1" +defaultFFmpegArgs :: FilePath -> [String] +defaultFFmpegArgs fp = + [ "-i", fp + , "-f", "s16le" + , "-ar", "48000" + , "-ac", "2" + , "-loglevel", "warning" + , "pipe:1" + ] + +-- | @playFileWith exe args file@ plays the sound stored in the file located at +-- @file@, using the specified FFmpeg executable @exe@ and an argument generator +-- function @args@ (see @defaultFFmpegArgs@ for the default). It supports any +-- format supported by FFmpeg by transcoding it, which means it can play a wide +-- range of file types. +-- +-- For a variant of this function that uses the "@ffmpeg@" executable in your +-- PATH automatically, see 'playFile'. +-- +-- For a variant of this function that allows arbitrary transformations of the +-- audio data through a conduit component, see 'playFileWith''. +-- +-- If the file is known to be in 16-bit little endian PCM, using 'playPCMFile' +-- is more efficient as it does not go through FFmpeg. +playFileWith + :: String + -- ^ The name of the FFmpeg executable + -> (String -> [String]) + -- ^ FFmpeg argument generator function, given the filepath + -> FilePath + -- ^ The path to the audio file to play + -> Voice () +playFileWith exe args fp = playFileWith' exe args fp (awaitForever yield) + +-- | @playFileWith' exe args file processor@ plays the sound stored in the file +-- located at @file@, using the specified FFmpeg executable @exe@ and an +-- argument generator function @args@ (see @defaultFFmpegArgs@ for the default). +-- It supports any format supported by FFmpeg by transcoding it, which means it +-- can play a wide range of file types. Audio data will be passed through the +-- @processor@ conduit component, allowing arbitrary transformations to audio +-- data before playback. +-- +-- For a variant of this function that uses the "@ffmpeg@" executable in your +-- PATH automatically, see 'playFile''. +-- +-- For a variant of this function with no processing, see 'playFileWith'. +-- +-- If the file is known to be in 16-bit little endian PCM, using 'playPCMFile'' +-- is more efficient as it does not go through FFmpeg. +playFileWith' + :: String + -- ^ The name of the FFmpeg executable + -> (String -> [String]) + -- ^ FFmpeg argument generator function, given the filepath + -> String + -- ^ The path to the audio file to play + -> ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () + -- ^ Any processing that needs to be done on the audio data + -> Voice () +playFileWith' exe argsGen path processor = do + let args = argsGen path + -- NOTE: We use CreatePipe for the stdout handle of ffmpeg, but a preexisting + -- handle for stderr. This is because we want to retain the stderr output + -- when ffmpeg has exited with an error code, and capture it before manually + -- closing the handle. Otherwise, the stderr of ffmpeg may be lost. Using + -- a preexisting handle for stdout is however, avoided, because createProcess_ + -- does not automatically close UseHandles when done, while conduit's + -- sourceHandle will patiently wait and block forever for the handle to close. + -- We may use createProcess (notice the lack of underscore) to automatically + -- close the UseHandles passed into it, but then we 1. lose the error output + -- for stderr, and 2. there have been frequent occasions of ffmpeg trying to + -- write to the closed pipe, causing a "broken pipe" fatal error. We want to + -- therefore make sure that even if that happens, the error is captured and + -- stored. Perhaps this explanation makes no sense, but I have suffered too + -- long on this problem (of calling a subprocess, streaming its output, + -- storing its errors, and making sure they gracefully kill themselves upon + -- the parent thread being killed) and I am hoping that this is something + -- I don't have to touch again. + (errorReadEnd, errorWriteEnd) <- liftIO $ createPipe + (a, Just stdout, c, ph) <- liftIO $ createProcess_ "the ffmpeg process" (proc exe args) + { std_out = CreatePipe + , std_err = UseHandle errorWriteEnd + } + -- We maintain a forked thread that constantly monitors the stderr output, + -- and if it sees an error, it kills the ffmpeg process so it doesn't block + -- (sometimes ffmpeg outputs a fatal error but still tries to continue, + -- especially during streams), and then rethrows the error as a + -- SubprocessException to the parent (this) thread. The idea is for the + -- @bracket@ to handle it, properly clean up any remnants, then rethrow it + -- further up so that user code can handle it, or let it propagate to + -- the "discord-haskell encountered an exception" handler. However in + -- practice, I have not seen this exception appear in the logs even once, + -- even when the preceding putStrLn executes. + myTid <- liftIO myThreadId + bracket (liftIO $ forkIO $ do + thereIsAnError <- hWaitForInput errorReadEnd (-1) `catch` \e -> + if isEOFError e then return False else throwIO e + when thereIsAnError $ do + exitCode <- terminateProcess ph >> waitForProcess ph + case exitCode of + ExitSuccess -> do + putStrLn "ffmpeg exited successfully" + pure () + ExitFailure i -> do + err <- hGetContents errorReadEnd + exitCode <- terminateProcess ph >> waitForProcess ph + putStrLn $ "ffmpeg exited with code " ++ show exitCode ++ ": " ++ err + throwTo myTid $ SubprocessException err + ) (\tid -> do + liftIO $ cleanupProcess (a, Just stdout, c, ph) + liftIO $ killThread tid + ) $ const $ play $ sourceHandle stdout .| processor + liftIO $ hClose errorReadEnd >> hClose errorWriteEnd + +-- | @playYouTube query@ plays the first result of searching @query@ on YouTube. +-- If a direct video URL is given, YouTube will always return that as the first +-- result, which means @playYouTube@ also supports playing links. It supports +-- all videos, by automatically transcoding to PCM using FFmpeg. Since it +-- streams the data instead of downloading it first, it can play live videos as +-- well. This function expects "@ffmpeg@" and "@youtube-dl@" to be available in +-- the system PATH. +-- +-- For a variant that allows you to specify the executable and/or any arguments, +-- see 'playYouTubeWith'. +-- +-- For a variant of this function that allows arbitrary transformations of the +-- audio data through a conduit component, see 'playYouTube''. +playYouTube + :: String + -- ^ Search query (or video URL) + -> Voice () +playYouTube query = playYouTube' query (awaitForever yield) + +-- | @playYouTube' query processor@ plays the first result of searching @query@ +-- on YouTube. If a direct video URL is given, YouTube will always return that +-- as the first result, which means @playYouTube@ also supports playing links. +-- It supports all videos, by automatically transcoding to PCM using FFmpeg. +-- Since it streams the data instead of downloading it first, it can play live +-- videos as well. This function expects "@ffmpeg@" and "@youtube-dl@" to be +-- available in the system PATH. Audio data will be passed through the +-- @processor@ conduit component, allowing arbitrary transformations to audio +-- data before playback. +-- +-- For a variant that allows you to specify the executable and/or any arguments, +-- see 'playYouTubeWith''. +-- +-- For a variant of this function with no processing, see 'playYouTube'. +playYouTube' + :: String + -- ^ Search query (or video URL) + -> ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () + -- ^ Any processing that needs to be done on the audio data + -> Voice () +playYouTube' query processor = + let + customArgGen url = + [ "-reconnect", "1" + , "-reconnect_streamed", "1" + , "-reconnect_delay_max", "2" + ] <> defaultFFmpegArgs url + in + playYouTubeWith' "ffmpeg" customArgGen "youtube-dl" query processor + +-- | @playYouTubeWith fexe fargs yexe query@ plays the first result of searching +-- @query@ on YouTube, using the specified @youtube-dl@ executable @yexe@, +-- FFmpeg executable @fexe@ and an argument generator function @fargs@ (see +-- @defaultFFmpegArgs@ for the default). If a direct video URL is given, YouTube +-- will always return that as the first result, which means @playYouTube@ also +-- supports playing links. It supports all videos, by automatically transcoding +-- to PCM using FFmpeg. Since it streams the data instead of downloading it +-- first, it can play live videos as well. +-- +-- For a variant of this function that uses the "@ffmpeg@" executable and +-- "@youtube-dl@" executable in your PATH automatically, see 'playYouTube'. +-- +-- For a variant of this function that allows arbitrary transformations of the +-- audio data through a conduit component, see 'playYouTubeWith''. +playYouTubeWith + :: String + -- ^ The name of the FFmpeg executable + -> (String -> [String]) + -- ^ FFmpeg argument generator function, given the URL + -> String + -- ^ The name of the youtube-dl executable + -> String + -- ^ The search query (or video URL) + -> Voice () +playYouTubeWith fexe fargsGen yexe query = playYouTubeWith' fexe fargsGen yexe query (awaitForever yield) + +-- | @playYouTubeWith' fexe fargs yexe query processor@ plays the first result +-- of searching @query@ on YouTube, using the specified @youtube-dl@ executable +-- @yexe@, FFmpeg executable @fexe@ and an argument generator function @fargs@ +-- (see @defaultFFmpegArgs@ for the default). If a direct video URL is given, +-- YouTube will always return that as the first result, which means +-- @playYouTube@ also supports playing links. It supports all videos, by +-- automatically transcoding to PCM using FFmpeg. Since it streams the data +-- instead of downloading it first, it can play live videos as well. Audio data +-- will be passed through the @processor@ conduit component, allowing arbitrary +-- transformations to audio data before playback. +-- +-- For a variant of this function that uses the "@ffmpeg@" executable and +-- "@youtube-dl@" executable in your PATH automatically, see 'playYouTube''. +-- +-- For a variant of this function with no processing, see 'playYouTubeWith'. +playYouTubeWith' + :: String + -- ^ The name of the FFmpeg executable + -> (String -> [String]) + -- ^ The arguments to pass to FFmpeg + -> String + -- ^ The name of the youtube-dl executable + -> String + -- ^ The search query (or video URL) + -> ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () + -- ^ Any processing that needs to be done on the audio data + -> Voice () +playYouTubeWith' fexe fargsGen yexe query processor = do + extractedInfo <- liftIO $ withCreateProcess (proc yexe + [ "-j" + , "--default-search", "ytsearch" + , "--format", "bestaudio/best" + , query + ]) { std_out = CreatePipe } $ \stdin (Just stdout) stderr ph -> + B.hGetContents stdout + + let perhapsUrl = do + result <- decodeStrict extractedInfo + flip parseMaybe result $ \obj -> obj .: "url" + case perhapsUrl of + -- no matching url found + Nothing -> pure () + Just url -> playFileWith' fexe fargsGen url processor diff --git a/src/Discord/Internal/Voice/CommonUtils.hs b/src/Discord/Internal/Voice/CommonUtils.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Voice/CommonUtils.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-| +Module : Discord.Internal.Voice.CommonUtils +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 useful utility functions used in discord-haskell-voice. +-} +module Discord.Internal.Voice.CommonUtils where + +import Control.Concurrent +import Control.Concurrent.Async ( race ) +import Control.Lens +import Data.Text qualified as T +import Data.Time.Clock.POSIX +import Data.Time +import GHC.Weak + +-- | @tshow@ is a shorthand alias for @T.pack . show@. +tshow :: Show a => a -> T.Text +tshow = T.pack . show + +-- | @maybeToRight@ puts the maybe value into the right hand side of the Either, +-- with a default value provided for the Left as the first argument. +maybeToRight :: a -> Maybe b -> Either a b +maybeToRight a = maybe (Left a) Right + +-- | @doOrTimeout@ performs an IO action for a maximum of @millisec@ milliseconds. +doOrTimeout :: Int -> IO a -> IO (Maybe a) +doOrTimeout millisec longAction = (^? _Right) <$> race waitSecs longAction + where + waitSecs :: IO (Maybe b) + waitSecs = threadDelay (millisec * 10^(3 :: Int)) >> pure Nothing + +-- | @killWkThread@ kills a thread referenced by Weak ThreadId. If the thread is +-- no longer alive (that is, if @deRefWeak@ is Nothing), this function will do +-- nothing. +killWkThread :: Weak ThreadId -> IO () +killWkThread tid = deRefWeak tid >>= \case + Nothing -> pure () + Just x -> killThread x diff --git a/src/Discord/Internal/Voice/UDPLoop.hs b/src/Discord/Internal/Voice/UDPLoop.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Voice/UDPLoop.hs @@ -0,0 +1,295 @@ +{-# 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 Control.Lens +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 () +logChan ✍ log = do + t <- formatTime defaultTimeLocale "%F %T %q" <$> getCurrentTime + tid <- myThreadId + writeChan logChan $ (T.pack t) <> " " <> (tshow tid) <> " " <> log + +-- | A variant of (✍) that prepends the udpError text. +(✍!) :: Chan T.Text -> T.Text -> IO () +logChan ✍! log = logChan ✍ ("!!! Voice UDP Error - " <> log) + +-- Alias for opening a UDP socket connection using the Discord endpoint. +runUDPClient :: AddrInfo -> (Socket -> IO a) -> IO a +runUDPClient addr things = bracket + (S.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + close $ \sock -> do + Network.Socket.connect sock $ addrAddress addr + things 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 opts log = loop UDPStart 0 + where + loop :: UDPState -> Int -> IO () + loop UDPClosed retries = pure () + loop UDPStart retries = do + next <- try $ do + let hints = defaultHints + { addrSocketType = Datagram + -- TIL while developing: Stream: TCP, Datagram: UDP + } + addr:_ <- getAddrInfo + (Just hints) + (Just $ T.unpack $ opts ^. ip) + (Just $ show $ opts ^. port) + + runUDPClient addr $ \sock -> do + -- Connection succeded. Otherwise an Exception is propagated + -- in the IO monad. + log ✍ "UDP Connection initialised." + + -- Perform IP discovery + -- https://discord.com/developers/docs/topics/voice-connections#ip-discovery + sendAll sock $ encode $ IPDiscovery (opts ^. ssrc) "" 0 + msg <- decode <$> recv sock 74 + writeChan (opts ^. udpHandle . _1) msg + + startForks (UDPConn opts sock) log + + case next :: Either SomeException UDPState of + Left e -> do + (✍!) log $ "could not start UDP conn due to an exception: " <> + (T.pack $ show e) + loop UDPClosed 0 + Right n -> loop n 0 + + loop UDPReconnect retries = do + -- No need to perform IP discovery. + next <- try $ do + let hints = defaultHints + { addrSocketType = Datagram + } + addr:_ <- getAddrInfo + (Just hints) + (Just $ T.unpack $ opts ^. ip) + (Just $ show $ opts ^. port) + + runUDPClient addr $ \sock -> do + -- Connection succeded. Otherwise an Exception is propagated + -- in the IO monad. + log ✍ "UDP Connection re-initialised." + startForks (UDPConn opts sock) log + + case next :: Either SomeException UDPState of + Left e -> do + log ✍! "could not reconnect to UDP, will restart in 10 secs." + threadDelay $ 10 * (10^(6 :: Int)) + loop UDPReconnect (retries + 1) + Right n -> loop n 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 conn log = do + currentTime <- getPOSIXTime + sendLoopId <- forkIO $ sendableLoop conn log 0 0 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?) + sequence_ $ replicate 5 $ Bounded.writeChan (conn ^. launchOpts . udpHandle . _2) "\248\255\254" + + finally (receivableLoop conn log >> pure UDPClosed) + (killThread 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 conn log = do + -- max length has to be specified but is irrelevant since it is so big + msg'' <- decode <$> recv (conn ^. socket) 999 + -- decrypt any encrypted audio packets to plain SpeakingData + msg' <- case msg'' of + SpeakingDataEncrypted header og -> do + byteKey <- readMVar (conn ^. launchOpts . secretKey) + let nonce = createNonceFromHeader header + let deciphered = decrypt byteKey nonce $ BL.toStrict og + case deciphered of + Nothing -> do + log ✍! "could not decipher audio message!" + pure $ MalformedPacket $ BL.append (BL.fromStrict header) og + Just x -> pure $ SpeakingData x + SpeakingDataEncryptedExtra header og -> do + -- Almost similar, but remove first 8 bytes of decoded audio + byteKey <- readMVar (conn ^. launchOpts . secretKey) + let nonce = createNonceFromHeader header + let deciphered = decrypt byteKey nonce $ BL.toStrict og + case deciphered of + Nothing -> do + log ✍! "could not decipher audio message!" + pure $ MalformedPacket $ BL.append (BL.fromStrict header) og + Just x -> pure $ SpeakingData $ B.drop 8 x + other -> pure other + + -- log ✍ (tshow msg') -- TODO: debug, remove. + -- decode speaking data's OPUS to raw PCM + msg <- case msg' of + SpeakingData bytes -> SpeakingData <$> decodeOpusData bytes + other -> pure other + + writeChan (conn ^. launchOpts . udpHandle . _1) msg + receivableLoop conn log + +-- | Appends 12 empty bytes to form the 24-byte nonce for the secret box. +createNonceFromHeader :: B.ByteString -> B.ByteString +createNonceFromHeader h = B.append h $ B.concat $ replicate 12 $ B.singleton 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 conn log sequence timestamp startTime = do + -- Immediately send the first packet available + mbOpusBytes <- Bounded.tryReadChan $ conn ^. launchOpts . udpHandle . _2 + case mbOpusBytes of + Nothing -> do + -- nothing could be read, so wait 20ms (no dynamic calculation + -- required, because nothing demands accurate real-time) + threadDelay $ round $ 20 * 10^(3 :: Int) + currentTime <- getPOSIXTime + sendableLoop conn log sequence timestamp currentTime + Just opusBytes -> do + let header = BL.toStrict $ encode $ + Header 0x80 0x78 (fromIntegral sequence) (fromIntegral timestamp) $ + fromIntegral $ conn ^. launchOpts . ssrc + let nonce = createNonceFromHeader header + byteKey <- readMVar $ conn ^. launchOpts . secretKey + let encryptedOpus = BL.fromStrict $ encrypt byteKey nonce opusBytes + + -- send the header and the encrypted opus data + sendAll (conn ^. socket) $ + encode $ SpeakingDataEncrypted header encryptedOpus + + -- wait a biiit less than 20ms before sending the next packet + -- logic taken from discord.py discord/player.py L595 + let theoreticalNextTime = startTime + (20 / 1000) + currentTime <- getPOSIXTime + threadDelay $ round $ (max 0 $ theoreticalNextTime - currentTime) * 10^(6 :: Int) + sendableLoop conn log + (sequence + 1 `mod` 0xFFFF) (timestamp + 48*20 `mod` 0xFFFFFFFF) 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 byteKey byteNonce og = secretboxOpen key nonce og + where + key = fromJust $ SC.decode $ B.pack byteKey + nonce = fromJust $ SC.decode 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 byteKey byteNonce og = secretbox key nonce og + where + key = fromJust $ SC.decode $ B.pack byteKey + nonce = fromJust $ SC.decode byteNonce + +decodeOpusData :: B.ByteString -> IO B.ByteString +decodeOpusData bytes = do + let deCfg = _DecoderConfig # (opusSR48k, True) + let deStreamCfg = _DecoderStreamConfig # (deCfg, 48*20, 0) + decoder <- opusDecoderCreate deCfg + decoded <- opusDecode decoder deStreamCfg bytes + pure decoded diff --git a/src/Discord/Internal/Voice/WebsocketLoop.hs b/src/Discord/Internal/Voice/WebsocketLoop.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Voice/WebsocketLoop.hs @@ -0,0 +1,440 @@ +{-# 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 Show + +-- | A custom logging function that writes the date/time and the thread ID. +(✍) :: Chan T.Text -> T.Text -> IO () +logChan ✍ log = do + t <- formatTime defaultTimeLocale "%F %T %q" <$> getCurrentTime + tid <- myThreadId + writeChan logChan $ (T.pack t) <> " " <> (tshow tid) <> " " <> log + +-- | A variant of (✍) that prepends the wsError text. +(✍!) :: Chan T.Text -> T.Text -> IO () +logChan ✍! log = logChan ✍ ("!!! Voice Websocket Error - " <> 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 endpoint = runSecureClient url port "/?v=4" + where + url = (T.unpack . T.takeWhile (/= ':')) endpoint + port = (read . T.unpack . T.takeWhileEnd (/= ':')) 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 opts log = do + -- Keep an MVar (only for use in this function), to store the UDP launch + -- options across Resume events. + udpOpts <- newMVar undefined + websocketFsm WSStart 0 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 WSClosed retries udpInfo = 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 WSStart retries udpInfo = do + -- Use of tryAsync (unsafe, as it catches asynchronous exceptions) is + -- justified here, since it will only log, then go to WSClosed. + next <- tryAsync $ connect (opts ^. endpoint) $ \conn -> do + (libSends, sendTid) <- flip (setupSendLoop conn) log $ opts ^. wsHandle . _2 + + result <- flip finally (killThread sendTid) $ runExceptT $ do + helloPacket <- ExceptT $ + over _Left ((<> "Failed to get Opcode 8 Hello: ") . tshow) <$> + getPayload conn + + interval <- ExceptT $ pure $ + maybeToRight ("First packet not Opcode 8 Hello: " <> tshow helloPacket) $ + helloPacket ^? _Hello + + -- Create a thread to add heartbeating packets to the + -- libSends Chan. + heartGenTid <- lift $ forkIO $ heartbeatLoop libSends interval log + + flip finally (lift $ killThread heartGenTid) $ do + -- Perform the Identify/Ready handshake + readyPacket <- ExceptT $ + over _Left ((<> "Failed to get Opcode 2 Ready: ") . tshow) <$> + performIdentification conn opts + + p <- ExceptT $ pure $ + maybeToRight ("First packet after Identify not " <> "Opcode 2 Ready " <> tshow readyPacket) $ + readyPacket ^? _Ready + + secretKey <- lift $ newEmptyMVar + let udpLaunchOpts = UDPLaunchOpts + { uDPLaunchOptsSsrc = readyPayloadSSRC p + , uDPLaunchOptsIp = readyPayloadIP p + , uDPLaunchOptsPort = readyPayloadPort p + , uDPLaunchOptsMode = "xsalsa20_poly1305" + , uDPLaunchOptsUdpHandle = opts ^. udpHandle + , uDPLaunchOptsSecretKey = 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. + lift $ modifyMVar_ udpInfo (pure . const 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. + + forkedId <- lift $ forkIO $ launchUdp udpLaunchOpts log + flip finally (lift $ killThread forkedId) $ do + udpTidWeak <- liftIO $ mkWeakThreadId forkedId + lift $ putMVar (opts ^. udpTid) udpTidWeak + + ipDiscovery <- lift $ readChan $ opts ^. udpHandle . _1 + (ssrcCheck, ip, port) <- ExceptT $ pure $ + maybeToRight ("First UDP Packet not IP Discovery " <> tshow ipDiscovery) $ + ipDiscovery ^? _IPDiscovery + + guard (ssrcCheck == udpLaunchOpts ^. ssrc) + lift $ putMVar (opts ^. ssrc) 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. + sessionDescPacket <- ExceptT $ + over _Left ((<> "Failed to get Opcode 4 SD: ") . tshow) <$> + sendSelectProtocol conn ip port (udpLaunchOpts ^. mode) + + (modeCheck, key) <- ExceptT $ pure $ + maybeToRight ("First packet after Select Protocol " <> + "not Opcode 4 Session Description " <> + tshow readyPacket) $ + sessionDescPacket ^? _SessionDescription + + guard (modeCheck == udpLaunchOpts ^. mode) + + lift $ putMVar secretKey key + + -- Move to eternal websocket event loop, mainly for the + -- heartbeats, but also for any user-generated packets. + lift $ eventStream conn opts interval udpLaunchOpts libSends log + + case result of + Left reason -> log ✍! reason >> pure WSClosed + Right state -> pure state + + -- Connection is now closed. + case next :: Either SomeException WSState of + Left e -> do + (✍!) log $ "could not connect due to an exception: " <> + (tshow e) + writeChan (opts ^. wsHandle . _1) $ Left $ + VoiceWebsocketCouldNotConnect + "could not connect due to an exception" + websocketFsm WSClosed 0 udpInfo + Right n -> websocketFsm n 0 udpInfo + + websocketFsm WSResume retries udpInfo = do + -- Use of tryAsync (unsafe, as it catches asynchronous exceptions) is + -- justified here, since it will only log, then go to WSClosed. + next <- tryAsync $ connect (opts ^. endpoint) $ \conn -> do + (libSends, sendTid) <- flip (setupSendLoop conn) log $ opts ^. wsHandle . _2 + helloPacket <- getPayload conn + case helloPacket of + Left e -> do + (✍!) log $ "Failed to get Opcode 8 Hello: " <> (tshow e) + pure WSClosed + Right (Hello interval) -> do + -- Create a thread to add heartbeating packets to the + -- libSends Chan. + heartGenTid <- forkIO $ heartbeatLoop libSends interval log + -- Perform the Resume/Resumed handshake + resumedPacket <- performResumption conn opts + case resumedPacket of + Left e -> do + (✍!) log $ "Failed to get Opcode 9 Resumed: " <> (tshow e) + pure WSClosed + Right (Discord.Internal.Types.VoiceWebsocket.Resumed) -> do + -- use the previous UDP launch options since it's not resent + udpLaunchOpts <- readMVar udpInfo + + -- Pass not the MVar but the raw options, since + -- there's no writing to be done. + finally (eventStream conn opts interval udpLaunchOpts libSends log) $ + (killThread heartGenTid >> killThread sendTid) + Right p -> do + (✍!) log $ "First packet after Resume not " <> + "Opcode 9 Resumed: " <> (tshow p) + pure WSClosed + Right p -> do + (✍!) log $ "First packet not Opcode 8 Hello: " <> (tshow p) + pure WSClosed + + -- Connection is now closed. + case next :: Either SomeException WSState of + Left _ -> do + (✍!) log $ "could not resume, retrying after 5 seconds" + threadDelay $ 5 * (10^(6 :: Int)) + websocketFsm WSResume (retries + 1) udpInfo + Right n -> websocketFsm n 1 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 conn userSends log = do + -- The following Chan will be used for accumulating library-generated + -- WebSocket messages that we need to send to Discord, mostly for heartbeats. + libSends <- newChan + -- Start said eternal sending fork, which will eternally send from library- + -- generated and user-generated packets. + sendLoopId <- forkIO $ sendableLoop conn libSends userSends log + + pure (libSends, 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 conn opts = do + -- Send opcode 0 Identify + sendTextData conn $ encode $ Identify $ IdentifyPayload + { identifyPayloadServerId = (opts ^. guildId) + , identifyPayloadUserId = (opts ^. botUserId) + , identifyPayloadSessionId = (opts ^. sessionId) + , identifyPayloadToken = (opts ^. token) + } + + getPayload conn + +-- | Send the Opcode 7 Resume packet to Discord, and await the Opcode 9 Resumed +-- payload. +performResumption + :: Connection + -> WebsocketLaunchOpts + -> IO (Either ConnectionException VoiceWebsocketReceivable) +performResumption conn opts = do + -- Send opcode 7 Resume + sendTextData conn $ encode $ + Resume (opts ^. guildId) (opts ^. sessionId) (opts ^. token) + + getPayload 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 conn ip port mode = do + sendTextData conn $ encode $ SelectProtocol $ + SelectProtocolPayload "udp" ip port mode + + getPayload 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 conn = try $ do + msg' <- receiveData conn + case eitherDecode msg' of + Right msg -> pure msg + Left err -> pure $ ParseError $ T.pack err + <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg') + +-- | Eternally send data from libSends and usrSends channels +sendableLoop + :: Connection + -> VoiceWebsocketSendChan + -> VoiceWebsocketSendChan + -> Chan T.Text + -> IO () +sendableLoop conn libSends usrSends log = do + -- Wait-time taken from discord-haskell/Internal.Gateway.EventLoop + threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) + -- Get whichever possible, and send it + payload <- either id id <$> race (readChan libSends) (readChan usrSends) + -- log ✍ ("(send) " <> tshow payload) -- TODO: debug, remove. + sendTextData conn $ encode payload + sendableLoop conn libSends usrSends log + +-- | Eternally send heartbeats through the libSends channel +heartbeatLoop + :: VoiceWebsocketSendChan + -> Int + -- ^ milliseconds + -> Chan T.Text + -> IO () +heartbeatLoop libSends interval log = do + threadDelay $ 1 * 10^(6 :: Int) + forever $ do + time <- round <$> getPOSIXTime + writeChan libSends $ Heartbeat $ time + threadDelay $ interval * 1000 + +-- | 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 conn opts interval udpLaunchOpts libSends 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. + payload <- doOrTimeout (interval * 2) $ getPayload conn + -- log ✍ ("(recv) " <> tshow payload) -- TODO: debug, remove. + case payload of + Nothing -> do + log ✍! "connection timed out, trying to reconnect again." + pure WSResume + -- Network-WebSockets, type ConnectionException + Just (Left (CloseRequest code str)) -> do + -- Whether we resume or gracefully close depends on the close code, + -- so offload the decision to the close code handler. + handleClose code str + Just (Left _) -> do + log ✍! "connection exception in eventStream, trying to reconnect." + pure WSResume + Just (Right (HeartbeatAck _)) -> + eventStream conn opts interval udpLaunchOpts libSends log + Just (Right receivable) -> do + writeChan (opts ^. wsHandle . _1) (Right receivable) + eventStream conn opts interval udpLaunchOpts libSends log + + where + -- | Handle Websocket Close codes by logging appropriate messages and + -- closing the connection. + handleClose :: Word16 -> BL.ByteString -> IO WSState + handleClose 1000 str = log ✍! "websocket closed normally." + >> pure WSClosed + handleClose 4001 str = log ✍! "websocket closed due to unknown opcode" + >> pure WSClosed + handleClose 4014 str = log ✍! ("vc deleted, main gateway closed, or bot " <> + "forcefully disconnected... Restarting voice.") + >> pure WSStart + handleClose 4015 str = log ✍! "server crashed on Discord side, resuming" + >> pure WSResume + handleClose code str = (✍!) log ("connection closed with code: [" <> + tshow code <> "] " <> (TE.decodeUtf8 $ BL.toStrict str)) + >> pure WSClosed diff --git a/src/Discord/Voice.hs b/src/Discord/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Voice.hs @@ -0,0 +1,91 @@ +{-| +Module : Discord.Voice +Description : Voice support for discord-haskell! +Copyright : (c) Yuto Takano (2021) +License : MIT +Maintainer : moa17stock@gmail.com + +Welcome to @discord-haskell-voice@! This library provides you with a high-level +interface for interacting with Discord's Voice API, building on top of the +@[discord-haskell](https://hackage.haskell.org/package/discord-haskell)@ library +by Karl. + +For a quick intuitive introduction to what this library enables you to do, see +the following snippet of code: + +@ +rickroll :: 'Channel' -> 'DiscordHandler' () +rickroll c@(ChannelVoice {}) = do + result <- runVoice $ do + join (channelGuild c) (channelId c) + playYouTube \"https:\/\/www.youtube.com\/watch?v=dQw4w9WgXcQ\" + + case result of + Left err -> liftIO $ print err + Right _ -> pure () +@ + +We can see that this library introduces a dedicated monad for voice operations, +which opaquely guarantees that you won't accidentally keep hold of a closed +voice connection, or try to use it after a network error had occurred. + +You'll also see further down the docs, that you can use +@[conduit](https://hackage.haskell.org/package/conduit)@ to stream arbitrary +ByteString data as audio, as well as manipulate and transform streams using its +interface. This is quite a powerful feature! + +Let's dive in :) +-} +module Discord.Voice + ( + -- * Monad for Voice Operations + Voice + , runVoice + , liftDiscord + -- * Joining a Voice Channel + , join + -- * Play Some Audio + , play + -- ** More Accessible Variants + -- $moreAccessibleVariants + , playPCMFile + , playPCMFile' + , playFile + , playFile' + , playFileWith + , playFileWith' + , playYouTube + , playYouTube' + , defaultFFmpegArgs + ) where + +import Discord.Internal.Types.VoiceCommon +import Discord.Internal.Voice + +{- $moreAccessibleVariants + +While 'play' is the most fundamental way to play audio, it is often inconvenient +to write a Conduit, especially if you want to perform common actions like +streaming YouTube audio, or playing arbitrary audio files in arbitrary formats. +This is why we provide a number of more accessible variants of 'play', which +provide a more convenient interface to playing your favourite media. + +Some of the functions in this section are marked with an apostrophe, which +indicate that they accept a Conduit processor as an argument to manipulate the +audio stream on the fly (such as changing volume). + +The following table gives a comparative overview of all the functions provided +in this module for playing audio: + ++-------------------------+--------------------+------------------+-------------------------------+-------------------------------------+ +| Variant \\ Audio Source | ByteString Conduit | PCM Encoded File | Arbitrary Audio File | YouTube Search/Video | ++=========================+====================+==================+=============+=================+================+====================+ +| Basic | 'play' | 'playPCMFile' | 'playFile' | 'playFileWith' | 'playYouTube' | 'playYouTubeWith' | ++-------------------------+--------------------+------------------+-------------+-----------------+----------------+--------------------+ +| Post-process audio | - | 'playPCMFile'' | 'playFile'' | 'playFileWith'' | 'playYouTube'' | 'playYouTubeWith'' | ++-------------------------+--------------------+------------------+-------------+-----------------+----------------+--------------------+ + +The functions that end with @-With@ accept arguments to specify executable names, +and in the case of FFmpeg, any arguments to FFmpeg. + +-} diff --git a/src/Discord/Voice/Conduit.hs b/src/Discord/Voice/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Voice/Conduit.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-| +Module : Discord.Voice.Conduit +Description : Convenient Conduits for transforming voice data +Copyright : (c) Yuto Takano (2021) +License : MIT +Maintainer : moa17stock@gmail.com + +This module provides convenient Conduits (see the @conduit@ package for an +introduction to conduits, but essentially streaming pipes) for transforming +audio data, to be used with the apostrophe-marked functions in "Discord.Voice". + +The apostrophe-marked functions, such as 'playFile'', take as argument a +Conduit of the following type: + +@ +ConduitT B.ByteString B.ByteString (ResourceT DiscordHandler) () +@ + +That is, the Conduit's needs to take @ByteString@ values from the upstream and +give to the downstream, @ByteString@s. This ByteString is formatted according to +a 16-bit signed little-endian representation of PCM data, with a sample rate of +48kHz. Since ByteStrings are stored as 'Word8' (8-bits) internally, this module +provides conduits to pack every two bytes into a single signed 16-bit 'Int16', +and vice versa. See 'packInt16C' and 'unpackInt16C'. + +Since the audio data is stereo, there are also conduits provided that pack to +and unpack from tuples of @(left, right) :: (Int16, Int16)@ values. + +These enable us to have an easier type signature to work with when performing +arithmetics on audio data: + +@ +yourConduit :: ConduitT Int16 Int16 (ResourceT DiscordHandler) () + +playYouTube' "never gonna give you up" $ packInt16C .| yourConduit .| unpackInt16C +@ + +Despite the pack/unpack being a common pattern, unfortunately due to library +design, it is not the default behaviour for apostrophe-marked functions (the +reason being that the non-apostrophe-marked-functions are simply aliases for +the apostrophe ones but with a @awaitForever yield@ conduit; this means adding +pack/unpack to the apostrophe versions would slow down the streaming of +untransformed data). + +An example usage of these conduits is: + +@ +runVoice $ do + join (read "123456789012345") (read "67890123456789012") + playFile' "Lost in the Woods.mp3" $ packTo16CT .| toMono .| packFrom16CT +@ +-} +module Discord.Voice.Conduit + ( + -- * Conduits to transform ByteString into workable Int16 data + packInt16C + , packInt16CT + , unpackInt16C + , unpackInt16CT + -- * Common audio operations exemplars (see source for inspiration) + , toMono + ) +where + +import Conduit +import Data.Bits ( shiftL, shiftR, (.|.) ) +import Data.ByteString qualified as B +import Data.Int ( Int16 ) +import Data.Word ( Word16, Word8 ) +import Discord + +-- | A conduit that transforms 16-bit signed little-endian PCM ByteString to +-- streams of Int16 values. The Int16 values are in the range [-32768, 32767] +-- and alternate between left and right channels (stereo audio). See +-- 'packInt16CT' for a version that produces tuples for both channels. +packInt16C :: ConduitT B.ByteString Int16 (ResourceT DiscordHandler) () +packInt16C = chunksOfExactlyCE 2 .| loop + where + loop = awaitForever $ \bytes -> do + let [b1, b2] = B.unpack bytes + -- little-endian arrangement + yield $ (fromIntegral $ (shiftL (fromIntegral b2 :: Word16) 8) .|. (fromIntegral b1 :: Word16) :: Int16) + +-- | A conduit that transforms streams of Int16 values to a ByteString, laid +-- out in 16-bit little-endian PCM format. Alternating inputs to this conduit +-- will be taken as left and right channels. See 'unpackInt16CT' for a version +-- that takes a stream of tuples of both channels. +unpackInt16C :: ConduitT Int16 B.ByteString (ResourceT DiscordHandler) () +unpackInt16C = awaitForever $ \i -> + yield $ B.pack + [ fromIntegral i :: Word8 + , fromIntegral $ shiftR (fromIntegral i :: Word16) 8 :: Word8 + ] + +-- | A conduit that transforms 16-bit signed little-endian PCM ByteString to +-- streams of (left, right)-tupled Int16 values. +packInt16CT :: ConduitT B.ByteString (Int16, Int16) (ResourceT DiscordHandler) () +packInt16CT = chunksOfExactlyCE 4 .| loop + where + loop = awaitForever $ \bytes -> do + let [b1, b2, b3, b4] = B.unpack bytes + -- little-endian arrangement + let left = (fromIntegral $ (shiftL (fromIntegral b2 :: Word16) 8) .|. (fromIntegral b1 :: Word16) :: Int16) + let right = (fromIntegral $ (shiftL (fromIntegral b4 :: Word16) 8) .|. (fromIntegral b3 :: Word16) :: Int16) + yield (left, right) + +-- | A conduit that transforms (left, right)-tupled Int16 values into 16-bit +-- signed little-endian PCM ByteString. +unpackInt16CT :: ConduitT (Int16, Int16) B.ByteString (ResourceT DiscordHandler) () +unpackInt16CT = awaitForever $ \(l, r) -> + yield $ B.pack + [ fromIntegral l :: Word8 + , fromIntegral $ shiftR (fromIntegral l :: Word16) 8 :: Word8 + , fromIntegral r :: Word8 + , fromIntegral $ shiftR (fromIntegral r :: Word16) 8 :: Word8 + ] + +-- | A conduit to transform stereo audio to mono audio by taking the average +-- of the left and right channel values. +toMono :: ConduitT (Int16, Int16) (Int16, Int16) (ResourceT DiscordHandler) () +toMono = awaitForever $ \(l, r) -> do + -- take the average of the left and right channels + let avg = l `div` 2 + r `div` 2 + yield (avg, avg)