discord-haskell-voice (empty) → 2.2.0
raw patch · 15 files changed
+2723/−0 lines, 15 filesdep +BoundedChandep +aesondep +async
Dependencies added: BoundedChan, aeson, async, base, binary, bytestring, conduit, discord-haskell, discord-haskell-voice, lens, mtl, network, optparse-applicative, opus, process, safe-exceptions, saltine, stm, stm-containers, text, time, unliftio, websockets, wuss
Files
- ChangeLog.md +28/−0
- LICENSE +21/−0
- README.md +98/−0
- discord-haskell-voice.cabal +131/−0
- examples/BasicMusicBot.hs +141/−0
- examples/JoinAllVC.hs +60/−0
- src/Discord/Internal/Types/VoiceCommon.hs +205/−0
- src/Discord/Internal/Types/VoiceUDP.hs +110/−0
- src/Discord/Internal/Types/VoiceWebsocket.hs +199/−0
- src/Discord/Internal/Voice.hs +724/−0
- src/Discord/Internal/Voice/CommonUtils.hs +55/−0
- src/Discord/Internal/Voice/UDPLoop.hs +295/−0
- src/Discord/Internal/Voice/WebsocketLoop.hs +440/−0
- src/Discord/Voice.hs +91/−0
- src/Discord/Voice/Conduit.hs +125/−0
+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,98 @@+# discord-haskell-voice+++++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
+ discord-haskell-voice.cabal view
@@ -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. <https://github.com/yutotakano/discord-haskell-voice>+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
+ examples/BasicMusicBot.hs view
@@ -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")
+ examples/JoinAllVC.hs view
@@ -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
+ src/Discord/Internal/Types/VoiceCommon.hs view
@@ -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)
+ src/Discord/Internal/Types/VoiceUDP.hs view
@@ -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)
+ src/Discord/Internal/Types/VoiceWebsocket.hs view
@@ -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)
+ src/Discord/Internal/Voice.hs view
@@ -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
+ src/Discord/Internal/Voice/CommonUtils.hs view
@@ -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
+ src/Discord/Internal/Voice/UDPLoop.hs view
@@ -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
+ src/Discord/Internal/Voice/WebsocketLoop.hs view
@@ -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
+ src/Discord/Voice.hs view
@@ -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.++-}
+ src/Discord/Voice/Conduit.hs view
@@ -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)