diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -4,7 +4,11 @@ Discord API changes, so use the most recent version at all times +## 1.8.2 +Added 'Competing' activity https://github.com/aquarial/discord-haskell/issues/61 + +Resend the last Activity settings on Resume fixing https://github.com/aquarial/discord-haskell/issues/60 ## 1.8.1 Added `MessageReaction` to Message https://github.com/aquarial/discord-haskell/issues/56 diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 1.8.1 +version: 1.8.2 description: Functions and data types to write discord bots. Official discord docs . . diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -36,6 +36,17 @@ startHandler = do Right partialGuilds <- restCall R.GetCurrentUserGuilds + let activity = Activity { activityName = "ping-pong" + , activityType = ActivityTypeGame + , activityUrl = Nothing + } + let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = UpdateStatusOnline + , updateStatusOptsAFK = False + } + sendCommand (UpdateStatus opts) + forM_ partialGuilds $ \pg -> do Right guild <- restCall $ R.GetGuild (partialGuildId pg) Right chans <- restCall $ R.GetGuildChannels (guildId guild) diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -97,9 +97,12 @@ libError :: T.Text -> IO T.Text libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg + gateChan :: DiscordHandleGateway -> Chan (Either GatewayException Event) + gateChan (a, _, _) = a -- only used right below in loop + loop :: IO T.Text loop = do next <- race (readMVar (discordHandleLibraryError handle)) - (readChan (fst (discordHandleGateway handle))) + (readChan (gateChan (discordHandleGateway handle))) case next of Left err -> libError err Right (Right event) -> do @@ -144,7 +147,8 @@ Heartbeat _ -> pure () Identify {} -> pure () Resume {} -> pure () - _ -> writeChan (snd (discordHandleGateway h)) e + _ -> let sendChan (_, b, _) = b + in writeChan (sendChan (discordHandleGateway h)) e -- | Access the current state of the gateway cache readCache :: DiscordHandler Cache diff --git a/src/Discord/Internal/Gateway.hs b/src/Discord/Internal/Gateway.hs --- a/src/Discord/Internal/Gateway.hs +++ b/src/Discord/Internal/Gateway.hs @@ -13,6 +13,7 @@ import Prelude hiding (log) import Control.Concurrent.Chan (newChan, dupChan, Chan) import Control.Concurrent (forkIO, ThreadId, newEmptyMVar, MVar) +import Data.IORef (newIORef) import qualified Data.Text as T import Discord.Internal.Types (Auth, Event, GatewaySendable) @@ -32,8 +33,9 @@ startGatewayThread auth (_events, _) log = do events <- dupChan _events sends <- newChan - tid <- forkIO $ connectionLoop auth (events, sends) log - pure ((events, sends), tid) + status <- newIORef Nothing + tid <- forkIO $ connectionLoop auth (events, sends, status) log + pure ((events, sends, status), tid) diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs --- a/src/Discord/Internal/Gateway/EventLoop.hs +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -40,10 +40,10 @@ connect :: (Connection -> IO a) -> IO a connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" -type DiscordHandleGateway = (Chan (Either GatewayException Event), Chan GatewaySendable) +type DiscordHandleGateway = (Chan (Either GatewayException Event), Chan GatewaySendable, IORef (Maybe UpdateStatusOpts)) connectionLoop :: Auth -> DiscordHandleGateway -> Chan T.Text -> IO () -connectionLoop auth (events, userSend) log = loop ConnStart 0 +connectionLoop auth (events, userSend, lastStatus) log = loop ConnStart 0 where loop :: ConnLoopState -> Int -> IO () loop s retries = @@ -60,7 +60,7 @@ case msg2 of Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do writeChan events (Right r) - startEventStream (ConnData conn seshID auth events) interval 0 userSend log + startEventStream (ConnData conn seshID auth events) interval 0 userSend lastStatus log Right m -> do writeChan events (Left (GatewayExceptionUnexpected m "Response to Identify must be Ready")) pure ConnClosed @@ -86,7 +86,7 @@ eitherPayload <- getPayload conn log case eitherPayload of Right (Hello interval) -> - startEventStream (ConnData conn seshID auth events) interval seqID userSend log + startEventStream (ConnData conn seshID auth events) interval seqID userSend lastStatus log Right (InvalidSession retry) -> do t <- getRandomR (1,5) threadDelay (t * (10^(6 :: Int))) @@ -145,15 +145,15 @@ , connChan :: Chan (Either GatewayException Event) } -startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> Chan T.Text -> IO ConnLoopState -startEventStream conndata interval seqN userSend log = do +startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> IORef (Maybe UpdateStatusOpts) -> Chan T.Text -> IO ConnLoopState +startEventStream conndata interval seqN userSend status log = do seqKey <- newIORef seqN let err :: SomeException -> IO ConnLoopState err e = do writeChan log ("gateway - eventStream error: " <> T.pack (show e)) ConnReconnect (connAuth conndata) (connSessionID conndata) <$> readIORef seqKey handle err $ do gateSends <- newChan - sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends) + sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends status) heart <- forkIO $ heartbeat gateSends interval seqKey finally (eventStream conndata seqKey interval gateSends log) @@ -198,17 +198,29 @@ "Normal event loop")) pure ConnClosed -data Sendables = Sendables { -- | Things the user wants to send. Doesn't reset on reconnect - userSends :: Chan GatewaySendable -- ^ Things the user wants to send - -- | Things the library needs to send. Resets to empty on reconnect - , gatewaySends :: Chan GatewaySendable - } +data Sendables = Sendables { + -- | Things the user wants to send. Doesn't reset on reconnect + userSends :: Chan GatewaySendable + -- | Things the library needs to send. Resets to empty on reconnect + , gatewaySends :: Chan GatewaySendable + -- | Last thing the user set as status. Send it again on start + , lastActivity :: IORef (Maybe UpdateStatusOpts) + } sendableLoop :: Connection -> Sendables -> IO () -sendableLoop conn sends = forever $ do - -- send a ~120 events a min by delaying - threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) - let e :: Either GatewaySendable GatewaySendable -> GatewaySendable - e = either id id - payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) - sendTextData conn (encode payload) +sendableLoop conn sends = do activity <- readIORef (lastActivity sends) + case activity of Just a -> sendTextData conn (encode (UpdateStatus a)) + Nothing -> pure () + loop + where + loop = forever $ do + -- send a ~120 events a min by delaying + threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) + let e :: Either GatewaySendable GatewaySendable -> GatewaySendable + e = either id id + payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) + sendTextData conn (encode payload) + + case payload of + UpdateStatus a -> writeIORef (lastActivity sends) (Just a) + _ -> pure () diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -29,7 +29,7 @@ where -- | https://discord.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.8.1)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.8.2)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs --- a/src/Discord/Internal/Types/Gateway.hs +++ b/src/Discord/Internal/Types/Gateway.hs @@ -71,9 +71,15 @@ data ActivityType = ActivityTypeGame | ActivityTypeStreaming | ActivityTypeListening - | ActivityTypeWatching - deriving (Show, Eq, Ord, Enum) + | ActivityTypeCompeting + deriving (Show, Eq, Ord) +activityTypeId :: ActivityType -> Int +activityTypeId a = case a of ActivityTypeGame -> 0 + ActivityTypeStreaming -> 1 + ActivityTypeListening -> 2 + ActivityTypeCompeting -> 5 + data UpdateStatusType = UpdateStatusOnline | UpdateStatusDoNotDisturb | UpdateStatusAwayFromKeyboard @@ -145,7 +151,7 @@ , "status" .= statusString status , "game" .= (game <&> \a -> object [ "name" .= activityName a - , "type" .= (fromEnum $ activityType a :: Int) + , "type" .= activityTypeId (activityType a) , "url" .= activityUrl a ]) ]