diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 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.9 +version: 1.9.0 description: Functions and data types to write discord bots. Official discord docs . . diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -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 $ diff --git a/src/Discord/Handle.hs b/src/Discord/Handle.hs --- a/src/Discord/Handle.hs +++ b/src/Discord/Handle.hs @@ -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 } 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 @@ -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) diff --git a/src/Discord/Internal/Gateway/Cache.hs b/src/Discord/Internal/Gateway/Cache.hs --- a/src/Discord/Internal/Gateway/Cache.hs +++ b/src/Discord/Internal/Gateway/Cache.hs @@ -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 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 @@ -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 diff --git a/src/Discord/Internal/Rest.hs b/src/Discord/Internal/Rest.hs --- a/src/Discord/Internal/Rest.hs +++ b/src/Discord/Internal/Rest.hs @@ -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 diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -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) 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.9)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.9.0)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Internal/Types/Embed.hs b/src/Discord/Internal/Types/Embed.hs --- a/src/Discord/Internal/Types/Embed.hs +++ b/src/Discord/Internal/Types/Embed.hs @@ -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 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 @@ -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)) = diff --git a/src/Discord/Internal/Types/Guild.hs b/src/Discord/Internal/Types/Guild.hs --- a/src/Discord/Internal/Types/Guild.hs +++ b/src/Discord/Internal/Types/Guild.hs @@ -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 diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs --- a/src/Discord/Internal/Types/Prelude.hs +++ b/src/Discord/Internal/Types/Prelude.hs @@ -64,3 +64,5 @@ -- | Default timestamp epochTime :: UTCTime epochTime = posixSecondsToUTCTime 0 + +type ColorInteger = Integer diff --git a/src/Discord/Types.hs b/src/Discord/Types.hs --- a/src/Discord/Types.hs +++ b/src/Discord/Types.hs @@ -2,4 +2,7 @@ ( module Discord.Internal.Types ) where -import Discord.Internal.Types +import Discord.Internal.Types hiding + ( GatewaySendableInternal + , GatewayReceivable + )