diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,10 +2,15 @@ ## Unreleased changes +## 2.3.1 +- Update `discord-haskell` dependency bounds to `>= 1.12.0 && <= 1.14.0`. +- Use `UnliftIO.MVar` functions internally for MVar operations in `DiscordHandler` +- `IOException`s thrown by e.g. createProcess during `runVoice` are no longer caught and subdued - they are propagated to the user. + ## 2.3.0 -- Export `playYouTubeWith` and `playYoUTubeWith'` from `Discord.Voice`. +- Export `playYouTubeWith` and `playYouTubeWith'` from `Discord.Voice`. - Update `discord-haskell` dependency bounds to `>= 1.12.0 && <= 1.13.0`. - Migrate from `lens` to `microlens`, following the `opus` package doing the same. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # discord-haskell-voice [![hackage version](https://img.shields.io/hackage/v/discord-haskell-voice?color=%235e5184)](https://hackage.haskell.org/package/discord-haskell-voice) -[![discord-haskell version dependency](https://img.shields.io/badge/discord--haskell-%3E=1.12.0%20%26%26%20%3C=1.13.0-lightblue)](https://hackage.haskell.org/package/discord-haskell) +[![discord-haskell version dependency](https://img.shields.io/badge/discord--haskell-%3E=1.12.0%20%26%26%20%3C=1.14.0-lightblue)](https://hackage.haskell.org/package/discord-haskell) 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 @@ -81,31 +81,31 @@ To use it in your Cabal-based project, add `discord-haskell-voice` as a dependency in your `.cabal` file: -``` +```yaml # --- myproject.cabal build-depends: base >=4.7 && <5 - , discord-haskell ==1.13.0 - , discord-haskell-voice ==2.3.0 + , discord-haskell ==1.14.0 + , discord-haskell-voice ==2.3.1 ``` ### Stack To use it in your Stack-based project, add `discord-haskell-voice` in both your `package.yaml` and `stack.yaml` files (since this library is not available in Stackage for the same reason `discord-haskell` is not on Stackage) -``` +```yaml # --- stack.yaml extra-deps: -- discord-haskell-1.13.0 -- discord-haskell-voice-2.3.0 +- discord-haskell-1.14.0 +- discord-haskell-voice-2.3.1 ``` -``` +```yaml # --- package.yaml dependencies: - base >= 4.7 && < 5 -- discord-haskell == 1.13.0 -- discord-haskell-voice == 2.3.0 +- discord-haskell == 1.14.0 +- discord-haskell-voice == 2.3.1 ``` ## Documentation diff --git a/discord-haskell-voice.cabal b/discord-haskell-voice.cabal --- a/discord-haskell-voice.cabal +++ b/discord-haskell-voice.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: discord-haskell-voice -version: 2.3.0 +version: 2.3.1 synopsis: Voice support for discord-haskell. description: Supplementary library to discord-haskell. See the project README on GitHub for more information. category: Network @@ -50,7 +50,7 @@ , binary ==0.8.* , bytestring >=0.10.12.0 && <0.11 , conduit ==1.3.4.2 - , discord-haskell >=1.12.0 && <=1.13.0 + , discord-haskell >=1.12.0 && <=1.14.0 , microlens >=0.4.13.0 , microlens-th >=0.4.3.10 , mtl ==2.2.2 @@ -81,7 +81,7 @@ , binary ==0.8.* , bytestring >=0.10.12.0 && <0.11 , conduit ==1.3.4.2 - , discord-haskell >=1.12.0 && <=1.13.0 + , discord-haskell >=1.12.0 && <=1.14.0 , discord-haskell-voice , microlens >=0.4.13.0 , microlens-th >=0.4.3.10 @@ -116,7 +116,7 @@ , binary ==0.8.* , bytestring >=0.10.12.0 && <0.11 , conduit ==1.3.4.2 - , discord-haskell >=1.12.0 && <=1.13.0 + , discord-haskell >=1.12.0 && <=1.14.0 , discord-haskell-voice , microlens >=0.4.13.0 , microlens-th >=0.4.3.10 diff --git a/src/Discord/Internal/Voice.hs b/src/Discord/Internal/Voice.hs --- a/src/Discord/Internal/Voice.hs +++ b/src/Discord/Internal/Voice.hs @@ -39,17 +39,16 @@ , newChan , readChan , writeChan - , MVar + -- We prefer UnliftIO.MVar functions for most MVar-related operations in + -- DiscordHandler, but since the Voice monad doesn't have MonadUnliftIO + -- (because it has an ExceptT transformer), we use the default + -- Control.Concurrent.MVar functions there. , newEmptyMVar - , newMVar - , readMVar - , putMVar - , withMVar - , tryPutMVar , modifyMVar_ + , readMVar ) import Control.Concurrent.BoundedChan qualified as Bounded -import Control.Exception.Safe ( finally, bracket, throwTo, catch, throwIO ) +import Control.Exception.Safe ( bracket, throwTo, catch, throwIO ) import Lens.Micro import Lens.Micro.Extras (view) import Control.Monad.Reader ( ask, liftIO, runReaderT ) @@ -129,32 +128,36 @@ -- -- 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- +-- the correct\/successful\/'Right' behaviour is (), and that the potentially- -- existing value is of failure. +-- +-- This function may propagate and throw an 'IOException' if 'createProcess' +-- fails for e.g. ffmpeg or youtube-dl. runVoice :: Voice () -> DiscordHandler (Either VoiceError ()) runVoice action = do - voiceHandles <- liftIO $ newMVar [] - mutEx <- liftIO $ newMVar () + voiceHandles <- UnliftIO.newMVar [] + mutEx <- UnliftIO.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 + result <- runExceptT $ flip runReaderT initialState $ unVoice $ action - -- 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. - traverseOf_ (traverse . guildId) (\x -> updateStatusVoice x Nothing False False) finalState - traverseOf_ (traverse . websocket . _1) (liftIO . killWkThread) finalState + -- Wrap cleanup action in @finally@ to ensure we always close the + -- threads even if an exception occurred. + finalState <- UnliftIO.readMVar voiceHandles - pure result + -- 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. + traverseOf_ (traverse . guildId) (\x -> updateStatusVoice x Nothing False False) finalState + traverseOf_ (traverse . websocket . _1) (liftIO . killWkThread) finalState + return 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 @@ -206,7 +209,7 @@ -- (Voice State Update) and Dispatch Event (Voice Server Update). liftDiscord $ updateStatusVoice guildId (Just channelId) False False - (liftIO . doOrTimeout 5000) (waitForVoiceStatusServerUpdate events) >>= \case + (liftIO . timeoutMs 5000) (waitForVoiceStatusServerUpdate events) >>= \case Nothing -> do -- did not respond in time: no permission? or discord offline? throwError VoiceNotAvailable @@ -225,7 +228,7 @@ udpChans <- liftIO $ (,) <$> newChan <*> Bounded.newBoundedChan 100 udpTidM <- liftIO newEmptyMVar -- ssrc to be filled in during initial handshake - ssrcM <- liftIO $ newEmptyMVar + ssrcM <- liftIO newEmptyMVar uid <- userId . cacheCurrentUser <$> (liftDiscord readCache) let wsOpts = WebsocketLaunchOpts uid sessionId token guildId endpoint @@ -303,7 +306,7 @@ updateSpeakingStatus :: Bool -> Voice () updateSpeakingStatus micStatus = do h <- (^. voiceHandles) <$> ask - handles <- liftIO $ readMVar h + handles <- UnliftIO.readMVar h flip (traverseOf_ traverse) handles $ \handle -> liftIO $ writeChan (handle ^. websocket . _2 . _2) $ Speaking $ SpeakingPayload { speakingPayloadMicrophone = micStatus @@ -352,7 +355,7 @@ play source = do h <- ask dh <- liftDiscord ask - handles <- liftIO $ readMVar $ h ^. voiceHandles + handles <- UnliftIO.readMVar $ h ^. voiceHandles updateSpeakingStatus True liftDiscord $ UnliftIO.withMVar (h ^. mutEx) $ \_ -> do diff --git a/src/Discord/Internal/Voice/CommonUtils.hs b/src/Discord/Internal/Voice/CommonUtils.hs --- a/src/Discord/Internal/Voice/CommonUtils.hs +++ b/src/Discord/Internal/Voice/CommonUtils.hs @@ -29,6 +29,7 @@ import Data.Time.Clock.POSIX import Data.Time import GHC.Weak +import System.Timeout ( timeout ) -- | @tshow@ is a shorthand alias for @T.pack . show@. tshow :: Show a => a -> T.Text @@ -39,12 +40,9 @@ 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 +-- | @timeoutMs@ performs an IO action for a maximum of @millisec@ milliseconds. +timeoutMs :: Int -> IO a -> IO (Maybe a) +timeoutMs millisec = timeout (millisec * 10^(3 :: Int)) -- | @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 diff --git a/src/Discord/Internal/Voice/WebsocketLoop.hs b/src/Discord/Internal/Voice/WebsocketLoop.hs --- a/src/Discord/Internal/Voice/WebsocketLoop.hs +++ b/src/Discord/Internal/Voice/WebsocketLoop.hs @@ -398,7 +398,7 @@ -- 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 + payload <- timeoutMs (interval * 2) $ getPayload conn -- log ✍ ("(recv) " <> tshow payload) -- TODO: debug, remove. case payload of Nothing -> do