packages feed

discord-haskell 1.8.9 → 1.9.0

raw patch · 16 files changed

+346/−279 lines, 16 files

Files

README.md view
@@ -43,7 +43,7 @@ ### Biggest TODOs  - [ ] APIv9-- [ ] rewrite eventloop [issue 70](https://github.com/aquarial/discord-haskell/issues/70)+- [x] rewrite eventloop [issue 70](https://github.com/aquarial/discord-haskell/issues/70) - [ ] Event type includes roles and other cached info - [ ] higher level bot interface? easier to add state and stuff
changelog.md view
@@ -6,6 +6,13 @@  ## master +## 1.9.0++Add [color attribute for CreateEmbed](https://github.com/aquarial/discord-haskell/issues/78)++Rewrite [EventLoop.hs](https://github.com/aquarial/discord-haskell/issues/70) to be easier to modify++Rename a bunch of internal handles so they have more consistent names  ## 1.8.9
discord-haskell.cabal view
@@ -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.9+version:             1.9.0 description:         Functions and data types to write discord bots.                      Official discord docs <https://discord.com/developers/docs/reference>.                      .
src/Discord.hs view
@@ -23,6 +23,7 @@ import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever) import Data.Aeson (FromJSON) import Data.Default (Default, def)+import Data.IORef (writeIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -43,6 +44,7 @@   , discordOnEvent :: Event -> DiscordHandler ()   , discordOnLog :: T.Text -> IO ()   , discordForkThreadForEvents :: Bool+  , discordGatewayIntent :: GatewayIntent   }  instance Default RunDiscordOpts where@@ -52,6 +54,7 @@                        , discordOnEvent = \_ -> pure ()                        , discordOnLog = \_ -> pure ()                        , discordForkThreadForEvents = True+                       , discordGatewayIntent = def                        }  runDiscord :: RunDiscordOpts -> IO T.Text@@ -60,7 +63,7 @@   logId <- liftIO $ startLogger (discordOnLog opts) log   (cache, cacheId) <- liftIO $ startCacheThread log   (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log-  (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) cache log+  (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log    libE <- newEmptyMVar @@ -70,10 +73,10 @@                              , discordHandleLog = log                              , discordHandleLibraryError = libE                              , discordHandleThreads =-                                 [ DiscordHandleThreadIdLogger logId-                                 , DiscordHandleThreadIdRest restId-                                 , DiscordHandleThreadIdCache cacheId-                                 , DiscordHandleThreadIdGateway gateId+                                 [ HandleThreadIdLogger logId+                                 , HandleThreadIdRest restId+                                 , HandleThreadIdCache cacheId+                                 , HandleThreadIdGateway gateId                                  ]                              } @@ -97,12 +100,9 @@    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 (gateChan (discordHandleGateway handle)))+                          (readChan (gatewayHandleEvents (discordHandleGateway handle)))              case next of                Left err -> libError err                Right (Right event) -> do@@ -139,22 +139,20 @@                         writeChan (discordHandleLog h) formaterr                         pure (Left (RestCallErrorCode 400 "Library Stopped Working" formaterr)) --- | Send a GatewaySendable, but not Heartbeat, Identify, or Resume+-- | Send a user GatewaySendable sendCommand :: GatewaySendable -> DiscordHandler () sendCommand e = do   h <- ask+  writeChan (gatewayHandleUserSendables (discordHandleGateway h)) e   case e of-    Heartbeat _ -> pure ()-    Identify {} -> pure ()-    Resume {} -> pure ()-    _ -> let sendChan (_, b, _) = b-         in writeChan (sendChan (discordHandleGateway h)) e+    UpdateStatus opts -> liftIO $ writeIORef (gatewayHandleLastStatus (discordHandleGateway h)) (Just opts)+    _ -> pure ()  -- | Access the current state of the gateway cache readCache :: DiscordHandler Cache readCache = do   h <- ask-  merr <- readMVar (snd (discordHandleCache h))+  merr <- readMVar (cacheHandleCache (discordHandleCache h))   case merr of     Left (c, _) -> pure c     Right c -> pure c@@ -167,10 +165,10 @@                  threadDelay (10^(6 :: Int) `div` 10)                  mapM_ (killThread . toId) (discordHandleThreads h)   where toId t = case t of-                   DiscordHandleThreadIdRest a -> a-                   DiscordHandleThreadIdGateway a -> a-                   DiscordHandleThreadIdCache a -> a-                   DiscordHandleThreadIdLogger a -> a+                   HandleThreadIdRest a -> a+                   HandleThreadIdGateway a -> a+                   HandleThreadIdCache a -> a+                   HandleThreadIdLogger a -> a  startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId startLogger handle logC = forkIO $ forever $
src/Discord/Handle.hs view
@@ -1,25 +1,25 @@ module Discord.Handle   ( DiscordHandle(..)-  , DiscordHandleThreadId(..)+  , HandleThreadId(..)   ) where  import Control.Concurrent (ThreadId, Chan, MVar) import qualified Data.Text as T -import Discord.Internal.Rest (DiscordHandleRestChan)-import Discord.Internal.Gateway (DiscordHandleGateway, DiscordHandleCache)+import Discord.Internal.Rest (RestChanHandle(..))+import Discord.Internal.Gateway (GatewayHandle(..), CacheHandle(..))  -- | Thread Ids marked by what type they are-data DiscordHandleThreadId = DiscordHandleThreadIdRest ThreadId-                           | DiscordHandleThreadIdCache ThreadId-                           | DiscordHandleThreadIdLogger ThreadId-                           | DiscordHandleThreadIdGateway ThreadId+data HandleThreadId = HandleThreadIdRest ThreadId+                      | HandleThreadIdCache ThreadId+                      | HandleThreadIdLogger ThreadId+                      | HandleThreadIdGateway ThreadId  data DiscordHandle = DiscordHandle-  { discordHandleRestChan :: DiscordHandleRestChan-  , discordHandleGateway :: DiscordHandleGateway-  , discordHandleCache :: DiscordHandleCache-  , discordHandleThreads :: [DiscordHandleThreadId]+  { discordHandleRestChan :: RestChanHandle+  , discordHandleGateway :: GatewayHandle+  , discordHandleCache :: CacheHandle+  , discordHandleThreads :: [HandleThreadId]   , discordHandleLog :: Chan T.Text   , discordHandleLibraryError :: MVar T.Text   }
src/Discord/Internal/Gateway.hs view
@@ -1,8 +1,8 @@ -- | Provides a rather raw interface to the websocket events --   through a real-time Chan module Discord.Internal.Gateway-  ( DiscordHandleGateway-  , DiscordHandleCache+  ( GatewayHandle(..)+  , CacheHandle(..)   , GatewayException(..)   , Cache(..)   , startCacheThread@@ -16,26 +16,30 @@ import Data.IORef (newIORef) import qualified Data.Text as T -import Discord.Internal.Types (Auth, Event, GatewaySendable)-import Discord.Internal.Gateway.EventLoop (connectionLoop, DiscordHandleGateway, GatewayException(..))-import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), DiscordHandleCache)+import Discord.Internal.Types (Auth, Event, GatewayIntent)+import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..))+import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..)) -startCacheThread :: Chan T.Text -> IO (DiscordHandleCache, ThreadId)+startCacheThread :: Chan T.Text -> IO (CacheHandle, ThreadId) startCacheThread log = do   events <- newChan :: IO (Chan (Either GatewayException Event))   cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache))-  tid <- forkIO $ cacheLoop (events, cache) log-  pure ((events, cache), tid)+  let cacheHandle = CacheHandle events cache+  tid <- forkIO $ cacheLoop cacheHandle log+  pure (cacheHandle, tid)  -- | Create a Chan for websockets. This creates a thread that --   writes all the received Events to the Chan-startGatewayThread :: Auth -> DiscordHandleCache -> Chan T.Text -> IO (DiscordHandleGateway, ThreadId)-startGatewayThread auth (_events, _) log = do-  events <- dupChan _events+startGatewayThread :: Auth -> GatewayIntent -> CacheHandle -> Chan T.Text -> IO (GatewayHandle, ThreadId)+startGatewayThread auth intent cacheHandle log = do+  events <- dupChan (cacheHandleEvents cacheHandle)   sends <- newChan   status <- newIORef Nothing-  tid <- forkIO $ connectionLoop auth (events, sends, status) log-  pure ((events, sends, status), tid)+  seqid <- newIORef 0+  seshid <- newIORef ""+  let gatewayHandle = GatewayHandle events sends status seqid seshid+  tid <- forkIO $ connectionLoop auth intent gatewayHandle log+  pure (gatewayHandle, tid)
src/Discord/Internal/Gateway/Cache.hs view
@@ -14,16 +14,19 @@ import Discord.Internal.Gateway.EventLoop  data Cache = Cache-            { _currentUser :: User-            , _dmChannels :: M.Map ChannelId Channel-            , _guilds :: M.Map GuildId (Guild, GuildInfo)-            , _channels :: M.Map ChannelId Channel-            } deriving (Show)+     { cacheCurrentUser :: User+     , cacheDMChannels :: M.Map ChannelId Channel+     , cacheGuilds :: M.Map GuildId (Guild, GuildInfo)+     , cacheChannels :: M.Map ChannelId Channel+     } deriving (Show) -type DiscordHandleCache = (Chan (Either GatewayException Event), MVar (Either (Cache, GatewayException) Cache))+data CacheHandle = CacheHandle+  { cacheHandleEvents :: Chan (Either GatewayException Event)+  , cacheHandleCache  :: MVar (Either (Cache, GatewayException) Cache)+  } -cacheLoop :: DiscordHandleCache -> Chan T.Text -> IO ()-cacheLoop (eventChan, cache) log = do+cacheLoop :: CacheHandle -> Chan T.Text -> IO ()+cacheLoop cacheHandle log = do       ready <- readChan eventChan       case ready of         Right (Ready _ user dmChannels _unavailableGuilds _) -> do@@ -35,6 +38,9 @@         Left e ->           writeChan log ("cache - stopping cache - gateway exception " <> T.pack (show e))   where+  cache     = cacheHandleCache cacheHandle+  eventChan = cacheHandleEvents cacheHandle+   loop :: IO ()   loop = forever $ do     eventOrExcept <- readChan eventChan@@ -52,19 +58,19 @@   --ChannelDelete Channel   GuildCreate guild info ->     let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info-        g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (_guilds minfo)+        g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (cacheGuilds minfo)         c = M.unionWith (\a _ -> a)                         (M.fromList [ (channelId ch, ch) | ch <- newChans ])-                        (_channels minfo)-    in minfo { _guilds = g, _channels = c }+                        (cacheChannels minfo)+    in minfo { cacheGuilds = g, cacheChannels = c }   --GuildUpdate guild -> do-  --  let g = M.insert (guildId guild) guild (_guilds minfo)-  --      m2 = minfo { _guilds = g }+  --  let g = M.insert (guildId guild) guild (cacheGuilds minfo)+  --      m2 = minfo { cacheGuilds = g }   --  putMVar cache m2   --GuildDelete guild -> do-  --  let g = M.delete (guildId guild) (_guilds minfo)-  --      c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (_channels minfo)-  --      m2 = minfo { _guilds = g, _channels = c }+  --  let g = M.delete (guildId guild) (cacheGuilds minfo)+  --      c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (cacheChannels minfo)+  --      m2 = minfo { cacheGuilds = g, cacheChannels = c }   --  putMVar cache m2   _ -> minfo
src/Discord/Internal/Gateway/EventLoop.hs view
@@ -7,12 +7,12 @@  import Prelude hiding (log) -import Control.Monad (forever)+import Control.Monad (forever, void) import Control.Monad.Random (getRandomR) import Control.Concurrent.Async (race) import Control.Concurrent.Chan import Control.Concurrent (threadDelay, killThread, forkIO)-import Control.Exception.Safe (try, finally, handle, SomeException)+import Control.Exception.Safe (try, finally, SomeException) import Data.IORef import Data.Aeson (eitherDecode, encode) import qualified Data.Text as T@@ -21,234 +21,209 @@  import Wuss (runSecureClient) import Network.WebSockets (ConnectionException(..), Connection,-                           receiveData, sendTextData)+                           receiveData, sendTextData, sendClose)  import Discord.Internal.Types ++data GatewayHandle = GatewayHandle+  { gatewayHandleEvents         :: Chan (Either GatewayException Event)+  , gatewayHandleUserSendables  :: Chan GatewaySendable+  , gatewayHandleLastStatus     :: IORef (Maybe UpdateStatusOpts)+  , gatewayHandleLastSequenceId :: IORef Integer+  , gatewayHandleSessionId      :: IORef T.Text+  }+ data GatewayException = GatewayExceptionCouldNotConnect T.Text                       | GatewayExceptionEventParseError T.Text T.Text                       | GatewayExceptionUnexpected GatewayReceivable T.Text                       | GatewayExceptionConnection ConnectionException T.Text   deriving (Show) -data ConnLoopState = ConnStart-                   | ConnClosed-                   | ConnReconnect Auth T.Text Integer++-- | State of the eventloop+data LoopState = LoopStart+               | LoopClosed+               | LoopReconnect   deriving Show --- | Securely run a connection IO action. Send a close on exception-connect :: (Connection -> IO a) -> IO a-connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json"+-- | Enough info for library to send info to discord.+data SendablesData = SendablesData+  { sendableConnection :: Connection+  , librarySendables :: Chan GatewaySendableInternal+  , startsendingUsers :: IORef Bool+  , heartbeatInterval :: Integer+  } -type DiscordHandleGateway = (Chan (Either GatewayException Event), Chan GatewaySendable, IORef (Maybe UpdateStatusOpts))+{-+Some quick documentation for some of the variables passed around: -connectionLoop :: Auth -> DiscordHandleGateway -> Chan T.Text -> IO ()-connectionLoop auth (events, userSend, lastStatus) log = loop ConnStart 0- where-  loop :: ConnLoopState -> Int -> IO ()-  loop s retries =-    case s of-      (ConnClosed) -> pure ()-      (ConnStart) -> do-          -- only try-catch an IO Error-          next <- try $ connect $ \conn -> do-            msg <- getPayload conn log-            case msg of-              Right (Hello interval) -> do-                sendTextData conn (encode (Identify auth False 50 (0, 1)))-                msg2 <- getPayload conn log-                case msg2 of-                  Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do-                    writeChan events (Right r)-                    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-                  Left (CloseRequest code _str) -> do writeChan log ("gateway - close " <> T.pack (show code))-                                                      threadDelay (3 * (10^(6 :: Int)))-                                                      pure ConnStart-                  Left ce -> do writeChan events (Left (GatewayExceptionConnection ce-                                                         "Response to Identify"))-                                pure ConnClosed-              Right m -> do writeChan log ("gateway - first message must be hello: " <> T.pack (show msg))-                            writeChan events (Left (GatewayExceptionUnexpected m-                                                      "Response to connecting must be hello"))-                            pure ConnClosed-              Left (CloseRequest code _str) -> do writeChan log ("gateway - close " <> T.pack (show code))-                                                  threadDelay (3 * (10^(6 :: Int)))-                                                  pure ConnStart-              Left ce -> do writeChan events (Left (GatewayExceptionConnection ce-                                                     "Response to connecting"))-                            pure ConnClosed-          case next :: Either SomeException ConnLoopState of-            Left _ -> do writeChan events (Left (GatewayExceptionCouldNotConnect-                                                  "SomeException in gateway Connection"))-                         loop ConnClosed 0-            Right n -> loop n 0+Auth                                                         needed to connect+GatewayIntent                                                needed to connect+GatewayHandle (eventsGifts,status,usersends,seq,sesh)        needed all over+log :: Chan (T.Text)                                         needed all over -      (ConnReconnect (Auth tok) seshID seqID) -> do-          next <- try $ connect $ \conn -> do-              sendTextData conn (encode (Resume tok seshID seqID))-              eitherPayload <- getPayload conn log-              case eitherPayload of-                  Right (Hello interval) ->-                      startEventStream (ConnData conn seshID auth events) interval seqID userSend lastStatus log-                  Right (InvalidSession retry) -> do-                      t <- getRandomR (1,5)-                      threadDelay (t * (10^(6 :: Int)))-                      pure $ if retry-                             then ConnReconnect (Auth tok) seshID seqID-                             else ConnStart-                  Right payload -> do-                      writeChan events (Left (GatewayExceptionUnexpected payload-                                               "Response to Resume must be Hello/Invalid Session"))-                      pure ConnClosed-                  Left (CloseRequest code _str) -> do-                      writeChan log ("gateway - retrying from " <> T.pack (show code))-                      threadDelay (3 * (10^(6 :: Int)))-                      pure (ConnReconnect (Auth tok) seshID seqID)-                  Left e -> do-                      writeChan events (Left (GatewayExceptionConnection e "Could not ConnReconnect"))-                      pure ConnClosed-          case next :: Either SomeException ConnLoopState of-            Left _ -> do t <- getRandomR (3,20)-                         threadDelay (t * (10^(6 :: Int)))-                         writeChan log ("gateway - trying to reconnect after " <> T.pack (show retries)-                                               <> " failures")-                         loop (ConnReconnect (Auth tok) seshID seqID) (retries + 1)-            Right n -> loop n 1+sendableConnection                                 set by setup,  need sendableLoop+librarySendables :: Chan (GatewaySendableInternal) set by setup,  need heartbeat+heartbeatInterval :: Int                           set by Hello,  need heartbeat +sequenceId :: Int id of last event received        set by Resume, need heartbeat and reconnect+sessionId :: Text                                  set by Ready,  need reconnect+-} -getPayloadTimeout :: Connection -> Int -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)-getPayloadTimeout conn interval log = do-  res <- race (threadDelay ((interval * 1000 * 3) `div` 2))-              (getPayload conn log)-  case res of-    Left () -> pure (Right Reconnect)-    Right other -> pure other+connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO ()+connectionLoop auth intent gatewayHandle log = outerloop LoopStart+  where -getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)-getPayload conn log = try $ do-  msg' <- receiveData conn-  case eitherDecode msg' of-    Right msg -> pure msg-    Left  err -> do writeChan log ("gateway - received parse Error - " <> T.pack err-                                      <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg'))-                    pure (ParseError (T.pack err))+  outerloop :: LoopState -> IO ()+  outerloop state = do+      mfirst <- firstmessage state+      case mfirst of+        Nothing -> pure ()+        Just first -> do+            next <- try (startconnectionpls first)+            case next :: Either SomeException LoopState of+              Left _ -> do t <- getRandomR (3,20)+                           threadDelay (t * (10^(6 :: Int)))+                           writeChan log ("gateway - trying to reconnect after failure(s)")+                           outerloop LoopReconnect+              Right n -> outerloop n -heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> IO ()-heartbeat send interval seqKey = do-  threadDelay (1 * 10^(6 :: Int))-  forever $ do-    num <- readIORef seqKey-    writeChan send (Heartbeat num)-    threadDelay (interval * 1000)+  firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal)+  firstmessage state =+    case state of+      LoopStart -> pure $ Just $ Identify auth intent (0, 1)+      LoopReconnect -> do seqId  <- readIORef (gatewayHandleLastSequenceId gatewayHandle)+                          seshId <- readIORef (gatewayHandleSessionId gatewayHandle)+                          if seshId == ""+                          then do writeChan log ("gateway - WARNING seshID was not set by READY?")+                                  pure $ Just $ Identify auth intent (0, 1)+                          else pure $ Just $ Resume auth seshId seqId+      LoopClosed -> pure Nothing --- | What we need to start an event stream-data ConnectionData = ConnData { connection :: Connection-                               , connSessionID :: T.Text-                               , connAuth :: Auth-                               , connChan :: Chan (Either GatewayException Event)-                               }+  startconnectionpls :: GatewaySendableInternal -> IO LoopState+  startconnectionpls first = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" $ \conn -> do+                      msg <- getPayload conn log+                      case msg of+                        Right (Hello interval) -> do -startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> IORef (Maybe UpdateStatusOpts) -> Chan T.Text -> IO ConnLoopState-startEventStream conndata interval seqN userSend status log = do-  writeChan log "startEventStream"-  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-    sendingUsers <- newIORef False-    sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends sendingUsers status log)-    heart <- forkIO $ heartbeat gateSends interval seqKey+                          internal <- newChan :: IO (Chan GatewaySendableInternal)+                          us <- newIORef False+                          -- start event loop+                          let sending = SendablesData conn internal us interval+                          sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log+                          heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle) -    finally (eventStream conndata seqKey interval gateSends sendingUsers log)-            (killThread heart >> killThread sendsId)+                          writeChan internal first+                          finally (runEventLoop gatewayHandle sending log)+                                  (killThread heart >> killThread sendsId)+                        _ -> do+                          writeChan log "gateway - WARNING could not connect. Expected hello"+                          sendClose conn ("expected hello" :: BL.ByteString)+                          void $ forever $ void (receiveData conn :: IO BL.ByteString)+                          -- > after sendClose you should call receiveDataMessage until+                          -- > it throws an exception+                          -- haskell websockets documentation+                          threadDelay (3 * (10^(6 :: Int)))+                          pure LoopStart  -eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable -> IORef Bool-                              -> Chan T.Text -> IO ConnLoopState-eventStream (ConnData conn seshID auth eventChan) seqKey interval send userSends log = loop+runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState+runEventLoop thehandle sendablesData log = do loop   where-  loop :: IO ConnLoopState+  eventChan = gatewayHandleEvents thehandle+   loop = do-    eitherPayload <- getPayloadTimeout conn interval log+    eitherPayload <- getPayloadTimeout sendablesData log     case eitherPayload :: Either ConnectionException GatewayReceivable of-      Left (CloseRequest code str) -> case code of-          -- see Discord and MDN documentation on gateway close event codes-          -- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes-          -- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties-          1000 -> ConnReconnect auth seshID <$> readIORef seqKey-          1001 -> ConnReconnect auth seshID <$> readIORef seqKey-          4000 -> ConnReconnect auth seshID <$> readIORef seqKey-          4006 -> pure ConnStart-          4007 -> ConnReconnect auth seshID <$> readIORef seqKey-          4014 -> ConnReconnect auth seshID <$> readIORef seqKey-          _ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str)-                                              "Normal event loop close request"))-                  pure ConnClosed-      Left _ -> ConnReconnect auth seshID <$> readIORef seqKey-      Right (Dispatch event sq) -> do writeIORef seqKey sq+      Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello")+                                    loop+      Right (Dispatch event sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq                                       writeChan eventChan (Right event)-                                      writeIORef userSends True+                                      case event of+                                        (Ready _ _ _ _ seshID) ->+                                            writeIORef (gatewayHandleSessionId thehandle) seshID+                                        _ -> writeIORef (startsendingUsers sendablesData) True                                       loop-      Right (HeartbeatRequest sq) -> do writeIORef seqKey sq-                                        writeChan send (Heartbeat sq)+      Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq+                                        writeChan (librarySendables sendablesData) (Heartbeat sq)                                         loop-      Right (Reconnect)      -> ConnReconnect auth seshID <$> readIORef seqKey-      Right (InvalidSession retry) -> if retry-                                      then ConnReconnect auth seshID <$> readIORef seqKey-                                      else pure ConnStart+      Right (Reconnect)      -> pure LoopReconnect+      Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart       Right (HeartbeatAck)   -> loop-      Right (Hello e) -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello e)-                                                             "Normal event loop"))-                            pure ConnClosed       Right (ParseError e) -> do writeChan eventChan (Left (GatewayExceptionEventParseError e                                                              "Normal event loop"))-                                 pure ConnClosed+                                 pure LoopClosed+      Left (CloseRequest code str) -> case code of+          -- see Discord and MDN documentation on gateway close event codes+          -- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes+          -- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties+          1000 -> pure LoopReconnect+          1001 -> pure LoopReconnect+          4000 -> pure LoopReconnect+          4006 -> pure LoopStart+          4007 -> pure LoopStart+          4014 -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello 0) $+                           "Tried to declare an unauthorized GatewayIntent. " <>+                           "Use the discord app manager to authorize by following: " <>+                           "https://github.com/aquarial/discord-haskell/issues/76"))+                     pure LoopClosed+          _ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str)+                                              "Unknown close code. Closing connection. Consider opening an issue with discord-haskell"))+                  pure LoopClosed+      Left _ -> pure LoopReconnect -data Sendables = Sendables {-  -- | Things the user wants to send. Doesn't reset on reconnect-    sendchan :: Chan GatewaySendable-  -- | Things the library needs to send. Resets to empty on reconnect-  , gatewaySends :: Chan GatewaySendable-  -- | If we're really authenticated yet-  , startSendingUser :: IORef Bool-  -- | the last sent status-  , sendslastStatus :: IORef (Maybe UpdateStatusOpts)-  -- | Log-  , sendlog :: Chan T.Text-  } +heartbeat :: SendablesData -> IORef Integer -> IO ()+heartbeat sendablesData seqKey = do+  threadDelay (3 * 10^(6 :: Int))+  forever $ do+    num <- readIORef seqKey+    writeChan (librarySendables sendablesData) (Heartbeat num)+    threadDelay (fromInteger (heartbeatInterval sendablesData * 1000))++getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)+getPayloadTimeout sendablesData log = do+  let interval = heartbeatInterval sendablesData+  res <- race (threadDelay (fromInteger ((interval * 1000 * 3) `div` 2)))+              (getPayload (sendableConnection sendablesData) log)+  case res of+    Left () -> pure (Right Reconnect)+    Right other -> pure other++getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable)+getPayload conn log = try $ do+  msg' <- receiveData conn+  case eitherDecode msg' of+    Right msg -> pure msg+    Left  err -> do writeChan log ("gateway - received parse Error - " <> T.pack err+                                      <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg'))+                    pure (ParseError (T.pack err))++ -- simple idea: send payloads from user/sys to connection -- has to be complicated though-sendableLoop :: Connection -> Sendables -> IO ()-sendableLoop conn sends = sendSysLoop+sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO ()+sendableLoop conn ghandle sendablesData _log = sendSysLoop   where   sendSysLoop = do       threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double)-      payload <- readChan (gatewaySends sends)+      payload <- readChan (librarySendables sendablesData)       sendTextData conn (encode payload)-      usersending <- readIORef (startSendingUser sends)+   -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload)))+      usersending <- readIORef (startsendingUsers sendablesData)       if not usersending       then sendSysLoop-      else do act <- readIORef (sendslastStatus sends)+      else do act <- readIORef (gatewayHandleLastStatus ghandle)               case act of Nothing -> pure ()                           Just opts -> sendTextData conn (encode (UpdateStatus opts))               sendUserLoop    sendUserLoop = do-      -- send a ~120 events a min by delaying+   -- 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 (sendchan sends)) (readChan (gatewaySends sends))-      sendTextData conn (encode payload)-      -- writeChan (sendlog sends) ("extrainfo - sending " <> T.pack (show payload))--      case payload of UpdateStatus opts -> writeIORef (sendslastStatus sends) (Just opts)-                      _ -> pure ()-+   -- payload :: Either GatewaySendableInternal GatewaySendable+      payload <- race (readChan (gatewayHandleUserSendables ghandle)) (readChan (librarySendables sendablesData))+      sendTextData conn (either encode encode payload)+   -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload)))       sendUserLoop
src/Discord/Internal/Rest.hs view
@@ -5,7 +5,7 @@ --   MVars for each call module Discord.Internal.Rest   ( module Discord.Internal.Types-  , DiscordHandleRestChan+  , RestChanHandle(..)   , Request(..)   , writeRestCall   , startRestThread@@ -24,20 +24,22 @@ import Discord.Internal.Types import Discord.Internal.Rest.HTTP -type DiscordHandleRestChan = Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString))+data RestChanHandle = RestChanHandle+      { restHandleChan :: Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString))+      }  -- | Starts the http request thread. Please only call this once-startRestThread :: Auth -> Chan T.Text -> IO (DiscordHandleRestChan, ThreadId)+startRestThread :: Auth -> Chan T.Text -> IO (RestChanHandle, ThreadId) startRestThread auth log = do   c <- newChan   tid <- forkIO $ restLoop auth c log-  pure (c, tid)+  pure (RestChanHandle c, tid)  -- | Execute a request blocking until a response is received-writeRestCall :: (Request (r a), FromJSON a) => DiscordHandleRestChan -> r a -> IO (Either RestCallInternalException a)+writeRestCall :: (Request (r a), FromJSON a) => RestChanHandle -> r a -> IO (Either RestCallInternalException a) writeRestCall c req = do   m <- newEmptyMVar-  writeChan c (majorRoute req, jsonRequest req, m)+  writeChan (restHandleChan c) (majorRoute req, jsonRequest req, m)   r <- readMVar m   pure $ case eitherDecode <$> r of     Right (Right o) -> Right o
src/Discord/Internal/Rest/Guild.hs view
@@ -183,7 +183,7 @@ data ModifyGuildRoleOpts = ModifyGuildRoleOpts   { modifyGuildRoleOptsName            :: Maybe T.Text   , modifyGuildRoleOptsPermissions     :: Maybe Integer-  , modifyGuildRoleOptsColor           :: Maybe Integer+  , modifyGuildRoleOptsColor           :: Maybe ColorInteger   , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool   , modifyGuildRoleOptsMentionable     :: Maybe Bool   } deriving (Show, Eq, Ord)
src/Discord/Internal/Rest/Prelude.hs view
@@ -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.9)"+  agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.9.0)"  -- Append to an URL infixl 5 //
src/Discord/Internal/Types/Embed.hs view
@@ -10,6 +10,8 @@ import qualified Data.Text as T import qualified Data.ByteString as B +import Discord.Internal.Types.Prelude+ createEmbed :: CreateEmbed -> Embed createEmbed CreateEmbed{..} =   let@@ -41,7 +43,7 @@            , embedFields      = createEmbedFields            , embedImage       = Just embedImage            , embedFooter      = Just embedFooter-           , embedColor       = Nothing+           , embedColor       = createEmbedColor            , embedTimestamp   = Nothing             -- can't set these@@ -62,7 +64,7 @@   , createEmbedImage       :: Maybe CreateEmbedImage   , createEmbedFooterText  :: T.Text   , createEmbedFooterIcon  :: Maybe CreateEmbedImage---, createEmbedColor       :: Maybe T.Text+  , createEmbedColor       :: Maybe ColorInteger --, createEmbedTimestamp   :: Maybe UTCTime   } deriving (Show, Eq, Ord) @@ -71,7 +73,7 @@   deriving (Show, Eq, Ord)  instance Default CreateEmbed where- def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing -- Nothing Nothing+ def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing  -- Nothing  -- | An embed attached to a message. data Embed = Embed@@ -83,8 +85,7 @@   , embedFields      :: [EmbedField]     -- ^ Fields of the embed   , embedImage       :: Maybe EmbedImage   , embedFooter      :: Maybe EmbedFooter--  , embedColor       :: Maybe Integer    -- ^ The embed color+  , embedColor       :: Maybe ColorInteger    -- ^ The embed color   , embedTimestamp   :: Maybe UTCTime    -- ^ The time of the embed content   , embedType        :: Maybe T.Text     -- ^ Type of embed (Always "rich" for users)   , embedVideo       :: Maybe EmbedVideo -- ^ Only present for "video" types
src/Discord/Internal/Types/Gateway.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE RecordWildCards #-}  -- | Data structures needed for interfacing with the Websocket --   Gateway@@ -12,6 +13,7 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Aeson import Data.Aeson.Types+import Data.Default (Default, def) import Data.Maybe (fromMaybe) import Data.Functor import Text.Read (readMaybe)@@ -19,22 +21,86 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Events --- | Represents data sent and received with Discord servers+-- | Sent by gateway data GatewayReceivable   = Dispatch Event Integer   | HeartbeatRequest Integer   | Reconnect   | InvalidSession Bool-  | Hello Int+  | Hello Integer   | HeartbeatAck   | ParseError T.Text   deriving (Show, Eq) -data GatewaySendable+-- | Sent to gateway by our library+data GatewaySendableInternal   = Heartbeat Integer-  | Identify Auth Bool Integer (Int, Int)-  | Resume T.Text T.Text Integer-  | RequestGuildMembers RequestGuildMembersOpts+  | Identify Auth GatewayIntent (Int, Int)+  | Resume Auth T.Text Integer+  deriving (Show, Eq, Ord)+++-- | https://discord.com/developers/docs/topics/gateway#list-of-intents+data GatewayIntent = GatewayIntent+  { gatewayIntentGuilds :: Bool+  , gatewayIntentMembers :: Bool+  , gatewayIntentBans :: Bool+  , gatewayIntentEmojis :: Bool+  , gatewayIntentIntegrations :: Bool+  , gatewayIntentWebhooks :: Bool+  , gatewayIntentInvites :: Bool+  , gatewayIntentVoiceStates :: Bool+  , gatewayIntentPrecenses :: Bool+  , gatewayIntentMessageChanges :: Bool+  , gatewayIntentMessageReactions :: Bool+  , gatewayIntentMessageTyping :: Bool+  , gatewayIntentDirectMessageChanges :: Bool+  , gatewayIntentDirectMessageReactions :: Bool+  , gatewayIntentDirectMessageTyping :: Bool+  } deriving (Show, Eq, Ord)++instance Default GatewayIntent where+  def = GatewayIntent { gatewayIntentGuilds                 = True+                      , gatewayIntentMembers                = False -- false+                      , gatewayIntentBans                   = True+                      , gatewayIntentEmojis                 = True+                      , gatewayIntentIntegrations           = True+                      , gatewayIntentWebhooks               = True+                      , gatewayIntentInvites                = True+                      , gatewayIntentVoiceStates            = True+                      , gatewayIntentPrecenses              = False  -- false+                      , gatewayIntentMessageChanges         = True+                      , gatewayIntentMessageReactions       = True+                      , gatewayIntentMessageTyping          = True+                      , gatewayIntentDirectMessageChanges   = True+                      , gatewayIntentDirectMessageReactions = True+                      , gatewayIntentDirectMessageTyping    = True+                      }++compileGatewayIntent :: GatewayIntent -> Int+compileGatewayIntent GatewayIntent{..} =+ sum $ [ if on then flag else 0+       | (flag, on) <- [ (2 ^  0, gatewayIntentGuilds)+                       , (2 ^  1, gatewayIntentMembers)+                       , (2 ^  2, gatewayIntentBans)+                       , (2 ^  3, gatewayIntentEmojis)+                       , (2 ^  4, gatewayIntentIntegrations)+                       , (2 ^  5, gatewayIntentWebhooks)+                       , (2 ^  6, gatewayIntentInvites)+                       , (2 ^  7, gatewayIntentVoiceStates)+                       , (2 ^  8, gatewayIntentPrecenses)+                       , (2 ^  9, gatewayIntentMessageChanges)+                       , (2 ^ 10, gatewayIntentMessageReactions)+                       , (2 ^ 11, gatewayIntentMessageTyping)+                       , (2 ^ 12, gatewayIntentDirectMessageChanges)+                       , (2 ^ 13, gatewayIntentDirectMessageReactions)+                       , (2 ^ 14, gatewayIntentDirectMessageTyping)+                       ]+       ]++-- | Sent to gateway by a user+data GatewaySendable+  = RequestGuildMembers RequestGuildMembersOpts   | UpdateStatus UpdateStatusOpts   | UpdateStatusVoice UpdateStatusVoiceOpts   deriving (Show, Eq, Ord)@@ -125,12 +191,13 @@ -- --       _  -> fail ("Unknown Sendable payload ID:" <> show op) -instance ToJSON GatewaySendable where+instance ToJSON GatewaySendableInternal where   toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ]-  toJSON (Identify token compress large shard) = object [+  toJSON (Identify token intent shard) = object [       "op" .= (2 :: Int)     , "d"  .= object [         "token" .= authToken token+      , "intents" .= compileGatewayIntent intent       , "properties" .= object [           "$os"                .= os         , "$browser"           .= ("discord-haskell" :: T.Text)@@ -138,11 +205,21 @@         , "$referrer"          .= (""                :: T.Text)         , "$referring_domain"  .= (""                :: T.Text)         ]-      , "compress" .= compress-      , "large_threshold" .= large+      , "compress" .= False+      , "large_threshold" .= (50 :: Int) -- stop sending offline members over 50       , "shard" .= shard       ]     ]+  toJSON (Resume token session seqId) = object [+      "op" .= (6 :: Int)+    , "d"  .= object [+        "token"      .= authToken token+      , "session_id" .= session+      , "seq"        .= seqId+      ]+    ]++instance ToJSON GatewaySendable where   toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [       "op" .= (3 :: Int)     , "d"  .= object [@@ -164,14 +241,6 @@       , "channel_id" .= channel       , "self_mute"  .= mute       , "self_deaf"  .= deaf-      ]-    ]-  toJSON (Resume token session seqId) = object [-      "op" .= (6 :: Int)-    , "d"  .= object [-        "token"      .= token-      , "session_id" .= session-      , "seq"        .= seqId       ]     ]   toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) =
src/Discord/Internal/Types/Guild.hs view
@@ -132,7 +132,7 @@     Role {         roleId      :: RoleId -- ^ The role id       , roleName    :: T.Text                    -- ^ The role name-      , roleColor   :: Integer                   -- ^ Integer representation of color code+      , roleColor   :: ColorInteger              -- ^ Integer representation of color code       , roleHoist   :: Bool                      -- ^ If the role is pinned in the user listing       , rolePos     :: Integer                   -- ^ Position of this role       , rolePerms   :: Integer                   -- ^ Permission bit set
src/Discord/Internal/Types/Prelude.hs view
@@ -64,3 +64,5 @@ -- | Default timestamp epochTime :: UTCTime epochTime = posixSecondsToUTCTime 0++type ColorInteger = Integer
src/Discord/Types.hs view
@@ -2,4 +2,7 @@   ( module Discord.Internal.Types   ) where -import Discord.Internal.Types+import Discord.Internal.Types hiding+    ( GatewaySendableInternal+    , GatewayReceivable+    )