discord-haskell 1.8.1 → 1.8.2

raw patch · 8 files changed

+67/−28 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• discord-haskell.cabal +1/−1
• examples/ping-pong.hs +11/−0
• src/Discord.hs +6/−2
• src/Discord/Internal/Gateway.hs +4/−2
• src/Discord/Internal/Gateway/EventLoop.hs +31/−19
• src/Discord/Internal/Rest/Prelude.hs +1/−1
• src/Discord/Internal/Types/Gateway.hs +9/−3

@@ -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

@@ -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 <https://discord.com/developers/docs/reference>.                      .

@@ -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)

@@ -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

@@ -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)   

@@ -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 ()

@@ -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 //

@@ -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                               ])       ]