diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -110,7 +110,7 @@ main = do token <- view packed <$> getEnv "BOT_TOKEN" P.runFinal . P.embedToFinal . handleFailByPrinting . runCounterAtomic . runCacheInMemory . runMetricsNoop - $ runBotIO (BotToken token) $ react @"messagecreate" $ \msg -> handleFailByLogging $ do + $ runBotIO (BotToken token) $ react @'MessageCreateEvt $ \msg -> handleFailByLogging $ do when (msg ^. #content == "!count") $ replicateM_ 3 $ do val <- getCounter info $ "the counter is: " <> showt val diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 486875ebdeafb710d8f23e4c4e501e85fa1ba7a0fbd9b4730097390055cfb514 +-- hash: ff41b2035734187fe33f9394cd057e7ad8f187dc4e297c846472c876600e2d45 name: calamity -version: 0.1.5.1 +version: 0.1.6.0 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -137,6 +137,7 @@ , polysemy >=1.3 && <2 , polysemy-plugin >=0.2 && <0.3 , reflection >=2.1 && <3 + , safe-exceptions >=0.1 && <2 , scientific >=0.3 && <0.4 , stm >=2.5 && <3 , stm-chans >=3.0 && <4 @@ -145,6 +146,7 @@ , text-show >=3.8 && <4 , time >=1.8 && <1.11 , typerep-map >=0.3 && <0.4 + , unagi-chan >=0.4 && <0.5 , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.13 , websockets >=0.12 && <0.13 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -3,9 +3,14 @@ -- | The client module Calamity.Client.Client ( Client(..) + , CalamityEvent(Dispatch, ShutDown) , react , runBotIO - , stopBot ) where + , stopBot + , sendPresence + , events + , fire + , customEvt ) where import Calamity.Cache.Eff import Calamity.Client.ShardManager @@ -23,6 +28,7 @@ import Calamity.Types.Snowflake import Calamity.Types.Token +import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Lens @@ -32,16 +38,15 @@ import Data.Dynamic import Data.Foldable import Data.Maybe +import Data.Proxy import Data.Time.Clock.POSIX import Data.Traversable -import qualified Data.TypeRepMap as TM +import Data.Typeable import qualified DiPolysemy as Di import Fmt -import GHC.TypeLits - import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P @@ -49,7 +54,6 @@ import qualified Polysemy.Fail as P import qualified Polysemy.Reader as P - timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) timeA m = do start <- P.embed getPOSIXTime @@ -64,13 +68,14 @@ shards' <- newTVarIO [] numShards' <- newEmptyMVar rlState' <- newRateLimitState - eventQueue' <- newTQueueIO + (inc, outc) <- newChan pure $ Client shards' numShards' token rlState' - eventQueue' + inc + outc runBotIO :: (P.Members '[P.Embed IO, P.Final IO, P.Fail, CacheEff, MetricEff] r, Typeable r) => Token -> SetupEff r -> P.Sem r () runBotIO token setup = do @@ -82,39 +87,66 @@ clientLoop finishUp -react :: forall (s :: Symbol) r. (KnownSymbol s, BotC r, EHType' s ~ Dynamic, Typeable (EHType s (P.Sem r))) => EHType s (P.Sem r) -> P.Sem r () -react f = - let handlers = EventHandlers . TM.one $ EH @s [toDyn f] - in P.atomicModify (handlers <>) +react :: forall s r. (BotC r, InsertEventHandler s (P.Sem r)) => EHType s (P.Sem r) -> P.Sem r () +react handler = let handlers = makeEventHandlers (Proxy @s) (Proxy @(P.Sem r)) handler + in P.atomicModify (handlers <>) +fire :: BotC r => CalamityEvent -> P.Sem r () +fire e = do + inc <- P.asks (^. #eventsIn) + P.embed $ writeChan inc e + +-- | Build a Custom CalamityEvent +customEvt :: forall s a. (Typeable s, Typeable a) => a -> CalamityEvent +customEvt x = Custom (typeRep $ Proxy @s) (toDyn x) + +events :: BotC r => P.Sem r (OutChan CalamityEvent) +events = do + inc <- P.asks (^. #eventsIn) + P.embed $ dupChan inc + +sendPresence :: BotC r => StatusUpdateData -> P.Sem r () +sendPresence s = do + shards <- P.asks (^. #shards) >>= P.embed . readTVarIO + for_ shards $ \(inc, _) -> + P.embed $ writeChan inc (SendPresence s) + stopBot :: BotC r => P.Sem r () stopBot = do debug "stopping bot" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO - for_ shards $ \shard -> - P.embed . atomically $ writeTQueue (shard ^. _1 . #cmdQueue) ShutDownShard - eventQueue <- P.asks (^. #eventQueue) - P.embed . atomically $ writeTQueue eventQueue ShutDown + for_ shards $ \(inc, _) -> + P.embed $ writeChan inc ShutDownShard + inc <- P.asks (^. #eventsIn) + P.embed $ writeChan inc ShutDown finishUp :: BotC r => P.Sem r () finishUp = do debug "finishing up" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO - for_ shards $ \shard -> void . P.await $ (shard ^. _2) + for_ shards $ \(_, shardThread) -> P.await shardThread debug "bot has stopped" -- | main loop of the client, handles fetching the next event, processing the event -- and invoking it's handler functions clientLoop :: BotC r => P.Sem r () clientLoop = do - evtQueue <- P.asks (^. #eventQueue) + outc <- P.asks (^. #eventsOut) void . P.runError . forever $ do - evt' <- P.embed . atomically $ readTQueue evtQueue + evt' <- P.embed $ readChan outc case evt' of - DispatchData' evt -> P.raise $ handleEvent evt - ShutDown -> P.throw () + Dispatch evt -> P.raise $ handleEvent evt + Custom s d -> handleCustomEvent s d + ShutDown -> P.throw () debug "leaving client loop" +handleCustomEvent :: forall r. BotC r => TypeRep -> Dynamic -> P.Sem r () +handleCustomEvent s d = do + debug "handling a custom event" + eventHandlers <- P.atomicGet + + for_ (getCustomEventHandlers s (dynTypeRep d) eventHandlers) (\h -> fromJust . fromDynamic @(P.Sem r ()) $ dynApp h d) + handleEvent :: BotC r => DispatchData -> P.Sem r () handleEvent data' = do debug "handling an event" @@ -143,40 +175,32 @@ -- `r` where we handle events be: `(P.Error a ': r)`, which will make stuff explode when we unwrap the -- event handlers -unwrapEvent :: forall s r. - (KnownSymbol s, EHType' s ~ Dynamic, Typeable r, Typeable (EHType s (P.Sem r))) - => EventHandlers - -> [EHType s (P.Sem r)] -unwrapEvent (EventHandlers eh) = map (fromJust . fromDynamic) . unwrapEventHandler @s . fromJust - $ (TM.lookup eh :: Maybe (EventHandler s)) --- where unwrapEach handler = --- let msg = "wanted: " <> show (typeRep $ Proxy @r) <> ", got: " <> show (dynTypeRep handler) --- in unwrapEvt msg . fromDynamic $ handler - handleEvent' :: BotC r => EventHandlers -> DispatchData -> P.Sem (P.Fail ': r) [P.Sem r ()] handleEvent' eh evt@(Ready rd@ReadyData {}) = do updateCache evt - pure $ map ($ rd) (unwrapEvent @"ready" eh) + pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh) +handleEvent' _ Resumed = pure [] + handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do updateCache evt Just newChan <- DMChannel' <<$>> getDM (getID chan) - pure $ map ($ newChan) (unwrapEvent @"channelcreate" eh) + pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do updateCache evt Just guild <- getGuild (getID chan) Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan) - pure $ map ($ newChan) (unwrapEvent @"channelcreate" eh) + pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do Just oldChan <- DMChannel' <<$>> getDM (getID chan) updateCache evt Just newChan <- DMChannel' <<$>> getDM (getID chan) - pure $ map (\f -> f oldChan newChan) (unwrapEvent @"channelupdate" eh) + pure $ map (\f -> f oldChan newChan) (getEventHandlers @'ChannelUpdateEvt eh) handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do Just oldGuild <- getGuild (getID chan) @@ -184,74 +208,74 @@ updateCache evt Just newGuild <- getGuild (getID chan) Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan) - pure $ map (\f -> f oldChan newChan) (unwrapEvent @"channelupdate" eh) + pure $ map (\f -> f oldChan newChan) (getEventHandlers @'ChannelUpdateEvt eh) handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do Just oldGuild <- getGuild (getID chan) Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan) updateCache evt - pure $ map (\f -> f oldChan) (unwrapEvent @"channeldelete" eh) + pure $ map (\f -> f oldChan) (getEventHandlers @'ChannelDeleteEvt eh) handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do Just oldChan <- DMChannel' <<$>> getDM (getID chan) updateCache evt - pure $ map (\f -> f oldChan) (unwrapEvent @"channeldelete" eh) + pure $ map (\f -> f oldChan) (getEventHandlers @'ChannelDeleteEvt eh) -- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do -- chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just) -- <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just) --- pure $ map (\f -> f chan lastPinTimestamp) (unwrapEvent @"channelpinsupdate" eh) +-- pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh) handleEvent' eh evt@(GuildCreate guild) = do isNew <- isUnavailableGuild (getID guild) updateCache evt Just guild <- getGuild (getID guild) - pure $ map (\f -> f guild isNew) (unwrapEvent @"guildcreate" eh) + pure $ map (\f -> f guild isNew) (getEventHandlers @'GuildCreateEvt eh) handleEvent' eh evt@(GuildUpdate guild) = do Just oldGuild <- getGuild (getID guild) updateCache evt Just newGuild <- getGuild (getID guild) - pure $ map (\f -> f oldGuild newGuild) (unwrapEvent @"guildupdate" eh) + pure $ map (\f -> f oldGuild newGuild) (getEventHandlers @'GuildUpdateEvt eh) -- NOTE: Guild will be deleted in the new cache if unavailable was false handleEvent' eh evt@(GuildDelete UnavailableGuild { id, unavailable }) = do Just oldGuild <- getGuild id updateCache evt - pure $ map (\f -> f oldGuild unavailable) (unwrapEvent @"guilddelete" eh) + pure $ map (\f -> f oldGuild unavailable) (getEventHandlers @'GuildDeleteEvt eh) handleEvent' eh evt@(GuildBanAdd BanData { guildID, user }) = do Just guild <- getGuild guildID updateCache evt - pure $ map (\f -> f guild user) (unwrapEvent @"guildbanadd" eh) + pure $ map (\f -> f guild user) (getEventHandlers @'GuildBanAddEvt eh) handleEvent' eh evt@(GuildBanRemove BanData { guildID, user }) = do Just guild <- getGuild guildID updateCache evt - pure $ map (\f -> f guild user) (unwrapEvent @"guildbanremove" eh) + pure $ map (\f -> f guild user) (getEventHandlers @'GuildBanRemoveEvt eh) -- NOTE: we fire this event using the guild data with old emojis handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = do Just guild <- getGuild guildID updateCache evt - pure $ map (\f -> f guild emojis) (unwrapEvent @"guildemojisupdate" eh) + pure $ map (\f -> f guild emojis) (getEventHandlers @'GuildEmojisUpdateEvt eh) handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData { guildID }) = do updateCache evt Just guild <- getGuild guildID - pure $ map ($ guild) (unwrapEvent @"guildintegrationsupdate" eh) + pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh) handleEvent' eh evt@(GuildMemberAdd member) = do updateCache evt Just guild <- getGuild (getID member) Just member <- pure $ guild ^. #members . at (getID member) - pure $ map ($ member) (unwrapEvent @"guildmemberadd" eh) + pure $ map ($ member) (getEventHandlers @'GuildMemberAddEvt eh) handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData { user, guildID }) = do Just guild <- getGuild guildID Just member <- pure $ guild ^. #members . at (getID user) updateCache evt - pure $ map ($ member) (unwrapEvent @"guildmemberremove" eh) + pure $ map ($ member) (getEventHandlers @'GuildMemberRemoveEvt eh) handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData { user, guildID }) = do Just oldGuild <- getGuild guildID @@ -259,19 +283,19 @@ updateCache evt Just newGuild <- getGuild guildID Just newMember <- pure $ newGuild ^. #members . at (getID user) - pure $ map (\f -> f oldMember newMember) (unwrapEvent @"guildmemberupdate" eh) + pure $ map (\f -> f oldMember newMember) (getEventHandlers @'GuildMemberUpdateEvt eh) handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do updateCache evt Just guild <- getGuild guildID let members' = guild ^.. #members . foldMap (at . getID) members . _Just - pure $ map (\f -> f guild members') (unwrapEvent @"guildmemberschunk" eh) + pure $ map (\f -> f guild members') (getEventHandlers @'GuildMembersChunkEvt eh) handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do updateCache evt Just guild <- getGuild guildID Just role' <- pure $ guild ^. #roles . at (getID role) - pure $ map (\f -> f guild role') (unwrapEvent @"guildrolecreate" eh) + pure $ map (\f -> f guild role') (getEventHandlers @'GuildRoleCreateEvt eh) handleEvent' eh evt@(GuildRoleUpdate GuildRoleData { guildID, role }) = do Just oldGuild <- getGuild guildID @@ -279,50 +303,50 @@ updateCache evt Just newGuild <- getGuild guildID Just newRole <- pure $ newGuild ^. #roles . at (getID role) - pure $ map (\f -> f newGuild oldRole newRole) (unwrapEvent @"guildroleupdate" eh) + pure $ map (\f -> f newGuild oldRole newRole) (getEventHandlers @'GuildRoleUpdateEvt eh) handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = do Just guild <- getGuild guildID Just role <- pure $ guild ^. #roles . at roleID updateCache evt - pure $ map (\f -> f guild role) (unwrapEvent @"guildroledelete" eh) + pure $ map (\f -> f guild role) (getEventHandlers @'GuildRoleDeleteEvt eh) handleEvent' eh evt@(MessageCreate msg) = do messagesReceived <- registerCounter "messages_received" mempty void $ addCounter 1 messagesReceived updateCache evt - pure $ map ($ msg) (unwrapEvent @"messagecreate" eh) + pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) handleEvent' eh evt@(MessageUpdate msg) = do Just oldMsg <- getMessage (getID msg) updateCache evt Just newMsg <- getMessage (getID msg) - pure $ map (\f -> f oldMsg newMsg) (unwrapEvent @"messageupdate" eh) + pure $ map (\f -> f oldMsg newMsg) (getEventHandlers @'MessageUpdateEvt eh) handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do Just oldMsg <- getMessage id updateCache evt - pure $ map ($ oldMsg) (unwrapEvent @"messagedelete" eh) + pure $ map ($ oldMsg) (getEventHandlers @'MessageDeleteEvt eh) handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do messages <- catMaybes <$> mapM getMessage ids updateCache evt - join <$> for messages (\msg -> pure $ map ($ msg) (unwrapEvent @"messagedelete" eh)) + join <$> for messages (\msg -> pure $ map ($ msg) (getEventHandlers @'MessageDeleteEvt eh)) handleEvent' eh evt@(MessageReactionAdd reaction) = do updateCache evt Just msg <- getMessage (getID reaction) - pure $ map (\f -> f msg reaction) (unwrapEvent @"messagereactionadd" eh) + pure $ map (\f -> f msg reaction) (getEventHandlers @'MessageReactionAddEvt eh) handleEvent' eh evt@(MessageReactionRemove reaction) = do Just msg <- getMessage (getID reaction) updateCache evt - pure $ map (\f -> f msg reaction) (unwrapEvent @"messagereactionremove" eh) + pure $ map (\f -> f msg reaction) (getEventHandlers @'MessageReactionRemoveEvt eh) handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do Just msg <- getMessage messageID updateCache evt - pure $ map ($ msg) (unwrapEvent @"messagereactionremoveall" eh) + pure $ map ($ msg) (getEventHandlers @'MessageReactionRemoveAllEvt eh) handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do Just oldGuild <- getGuild guildID @@ -331,9 +355,9 @@ Just newGuild <- getGuild guildID Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID) let userUpdates = if oldMember ^. #user /= newMember ^. #user - then map (\f -> f (oldMember ^. #user) (newMember ^. #user)) (unwrapEvent @"userupdate" eh) + then map (\f -> f (oldMember ^. #user) (newMember ^. #user)) (getEventHandlers @'UserUpdateEvt eh) else mempty - pure $ userUpdates <> map (\f -> f oldMember newMember) (unwrapEvent @"guildmemberupdate" eh) + pure $ userUpdates <> map (\f -> f oldMember newMember) (getEventHandlers @'GuildMemberUpdateEvt eh) handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp }) = case guildID of @@ -341,16 +365,16 @@ Just guild <- getGuild gid Just member <- pure $ guild ^. #members . at (coerceSnowflake userID) Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID) - pure $ map (\f -> f chan (Just member) timestamp) (unwrapEvent @"typingstart" eh) + pure $ map (\f -> f chan (Just member) timestamp) (getEventHandlers @'TypingStartEvt eh) Nothing -> do Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID) - pure $ map (\f -> f chan Nothing timestamp) (unwrapEvent @"typingstart" eh) + pure $ map (\f -> f chan Nothing timestamp) (getEventHandlers @'TypingStartEvt eh) handleEvent' eh evt@(UserUpdate _) = do Just oldUser <- getBotUser updateCache evt Just newUser <- getBotUser - pure $ map (\f -> f oldUser newUser) (unwrapEvent @"userupdate" eh) + pure $ map (\f -> f oldUser newUser) (getEventHandlers @'UserUpdateEvt eh) handleEvent' _ e = fail $ "Unhandled event: " <> show e diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs --- a/src/Calamity/Client/ShardManager.hs +++ b/src/Calamity/Client/ShardManager.hs @@ -31,7 +31,7 @@ when hasShards $ fail "don't use shardBot on an already running bot." token <- P.asks Calamity.Client.Types.token - eventQueue <- P.asks eventQueue + inc <- P.asks (^. #eventsIn) Right gateway <- invoke GetGatewayBot @@ -42,7 +42,7 @@ info $ "Number of shards: " +| numShards' |+ "" shards <- for [0 .. numShards' - 1] $ \id -> - newShard host id numShards' token eventQueue + newShard host id numShards' token inc P.embed . atomically $ writeTVar shardsVar shards diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -4,16 +4,19 @@ , BotC , SetupEff , EHType - , EHType' , EventHandlers(..) - , EventHandler(..) ) where + , EventHandler(..) + , InsertEventHandler(..) + , GetEventHandlers(..) + , EventType(..) + , getCustomEventHandlers ) where -import Calamity.Metrics.Eff import Calamity.Cache.Eff -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Shard +import Calamity.Gateway.DispatchEvents ( CalamityEvent(..), ReadyData ) +import Calamity.Gateway.Types ( ControlMessage ) import Calamity.HTTP.Internal.Types import Calamity.LogEff +import Calamity.Metrics.Eff import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User @@ -21,19 +24,23 @@ import Calamity.Types.UnixTimestamp import Control.Concurrent.Async +import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar -import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Data.Default.Class import Data.Dynamic +import Data.Functor +import qualified Data.HashMap.Lazy as LH +import Data.Maybe import Data.Time import qualified Data.TypeRepMap as TM import Data.TypeRepMap ( TypeRepMap, WrapTypeable(..) ) +import Data.Typeable +import Data.Void import GHC.Exts ( fromList ) import GHC.Generics -import qualified GHC.TypeLits as TL import qualified Polysemy as P import qualified Polysemy.Async as P @@ -41,11 +48,12 @@ import qualified Polysemy.Reader as P data Client = Client - { shards :: TVar [(Shard, Async (Maybe ()))] + { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] , numShards :: MVar Int , token :: Token , rlState :: RateLimitState - , eventQueue :: TQueue DispatchMessage + , eventsIn :: InChan CalamityEvent + , eventsOut :: OutChan CalamityEvent } deriving ( Generic ) @@ -56,109 +64,146 @@ type SetupEff r = P.Sem (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) () -type family EHType d m where - EHType "ready" m = ReadyData -> m () - EHType "channelcreate" m = Channel -> m () - EHType "channelupdate" m = Channel -> Channel -> m () - EHType "channeldelete" m = Channel -> m () - EHType "channelpinsupdate" m = Channel -> Maybe UTCTime -> m () - EHType "guildcreate" m = Guild -> Bool -> m () - EHType "guildupdate" m = Guild -> Guild -> m () - EHType "guilddelete" m = Guild -> Bool -> m () - EHType "guildbanadd" m = Guild -> User -> m () - EHType "guildbanremove" m = Guild -> User -> m () - EHType "guildemojisupdate" m = Guild -> [Emoji] -> m () - EHType "guildintegrationsupdate" m = Guild -> m () - EHType "guildmemberadd" m = Member -> m () - EHType "guildmemberremove" m = Member -> m () - EHType "guildmemberupdate" m = Member -> Member -> m () - EHType "guildmemberschunk" m = Guild -> [Member] -> m () - EHType "guildrolecreate" m = Guild -> Role -> m () - EHType "guildroleupdate" m = Guild -> Role -> Role -> m () - EHType "guildroledelete" m = Guild -> Role -> m () - EHType "messagecreate" m = Message -> m () - EHType "messageupdate" m = Message -> Message -> m () - EHType "messagedelete" m = Message -> m () - EHType "messagedeletebulk" m = [Message] -> m () - EHType "messagereactionadd" m = Message -> Reaction -> m () - EHType "messagereactionremove" m = Message -> Reaction -> m () - EHType "messagereactionremoveall" m = Message -> m () - EHType "typingstart" m = Channel -> Maybe Member -> UnixTimestamp -> m () - EHType "userupdate" m = User -> User -> m () - EHType s _ = TL.TypeError ('TL.Text "Unknown event name: " 'TL.:<>: 'TL.ShowType s) - -- EHType "voicestateupdate" = VoiceStateUpdateData -> EventM () - -- EHType "voiceserverupdate" = VoiceServerUpdateData -> EventM () - -- EHType "webhooksupdate" = WebhooksUpdateData -> EventM () +-- | A Data Kind used to fire custom events +data EventType + = ReadyEvt + | ChannelCreateEvt + | ChannelUpdateEvt + | ChannelDeleteEvt + | ChannelpinsUpdateEvt + | GuildCreateEvt + | GuildUpdateEvt + | GuildDeleteEvt + | GuildBanAddEvt + | GuildBanRemoveEvt + | GuildEmojisUpdateEvt + | GuildIntegrationsUpdateEvt + | GuildMemberAddEvt + | GuildMemberRemoveEvt + | GuildMemberUpdateEvt + | GuildMembersChunkEvt + | GuildRoleCreateEvt + | GuildRoleUpdateEvt + | GuildRoleDeleteEvt + | MessageCreateEvt + | MessageUpdateEvt + | MessageDeleteEvt + | MessageDeleteBulkEvt + | MessageReactionAddEvt + | MessageReactionRemoveEvt + | MessageReactionRemoveAllEvt + | TypingStartEvt + | UserUpdateEvt + | forall s a. CustomEvt s a -type family EHType' d where - EHType' "ready" = Dynamic - EHType' "channelcreate" = Dynamic - EHType' "channelupdate" = Dynamic - EHType' "channeldelete" = Dynamic - EHType' "channelpinsupdate" = Dynamic - EHType' "guildcreate" = Dynamic - EHType' "guildupdate" = Dynamic - EHType' "guilddelete" = Dynamic - EHType' "guildbanadd" = Dynamic - EHType' "guildbanremove" = Dynamic - EHType' "guildemojisupdate" = Dynamic - EHType' "guildintegrationsupdate" = Dynamic - EHType' "guildmemberadd" = Dynamic - EHType' "guildmemberremove" = Dynamic - EHType' "guildmemberupdate" = Dynamic - EHType' "guildmemberschunk" = Dynamic - EHType' "guildrolecreate" = Dynamic - EHType' "guildroleupdate" = Dynamic - EHType' "guildroledelete" = Dynamic - EHType' "messagecreate" = Dynamic - EHType' "messageupdate" = Dynamic - EHType' "messagedelete" = Dynamic - EHType' "messagedeletebulk" = Dynamic - EHType' "messagereactionadd" = Dynamic - EHType' "messagereactionremove" = Dynamic - EHType' "messagereactionremoveall" = Dynamic - EHType' "typingstart" = Dynamic - EHType' "userupdate" = Dynamic - EHType' s = TL.TypeError ('TL.Text "Unknown event name: " 'TL.:<>: 'TL.ShowType s) +type family EHType (d :: EventType) m where + EHType 'ReadyEvt m = ReadyData -> m () + EHType 'ChannelCreateEvt m = Channel -> m () + EHType 'ChannelUpdateEvt m = Channel -> Channel -> m () + EHType 'ChannelDeleteEvt m = Channel -> m () + EHType 'ChannelpinsUpdateEvt m = Channel -> Maybe UTCTime -> m () + EHType 'GuildCreateEvt m = Guild -> Bool -> m () + EHType 'GuildUpdateEvt m = Guild -> Guild -> m () + EHType 'GuildDeleteEvt m = Guild -> Bool -> m () + EHType 'GuildBanAddEvt m = Guild -> User -> m () + EHType 'GuildBanRemoveEvt m = Guild -> User -> m () + EHType 'GuildEmojisUpdateEvt m = Guild -> [Emoji] -> m () + EHType 'GuildIntegrationsUpdateEvt m = Guild -> m () + EHType 'GuildMemberAddEvt m = Member -> m () + EHType 'GuildMemberRemoveEvt m = Member -> m () + EHType 'GuildMemberUpdateEvt m = Member -> Member -> m () + EHType 'GuildMembersChunkEvt m = Guild -> [Member] -> m () + EHType 'GuildRoleCreateEvt m = Guild -> Role -> m () + EHType 'GuildRoleUpdateEvt m = Guild -> Role -> Role -> m () + EHType 'GuildRoleDeleteEvt m = Guild -> Role -> m () + EHType 'MessageCreateEvt m = Message -> m () + EHType 'MessageUpdateEvt m = Message -> Message -> m () + EHType 'MessageDeleteEvt m = Message -> m () + EHType 'MessageDeleteBulkEvt m = [Message] -> m () + EHType 'MessageReactionAddEvt m = Message -> Reaction -> m () + EHType 'MessageReactionRemoveEvt m = Message -> Reaction -> m () + EHType 'MessageReactionRemoveAllEvt m = Message -> m () + EHType 'TypingStartEvt m = Channel -> Maybe Member -> UnixTimestamp -> m () + EHType 'UserUpdateEvt m = User -> User -> m () + EHType ('CustomEvt s a) m = a -> m () +type family EHType' (d :: EventType) where + EHType' 'ReadyEvt = Dynamic + EHType' 'ChannelCreateEvt = Dynamic + EHType' 'ChannelUpdateEvt = Dynamic + EHType' 'ChannelDeleteEvt = Dynamic + EHType' 'ChannelpinsUpdateEvt = Dynamic + EHType' 'GuildCreateEvt = Dynamic + EHType' 'GuildUpdateEvt = Dynamic + EHType' 'GuildDeleteEvt = Dynamic + EHType' 'GuildBanAddEvt = Dynamic + EHType' 'GuildBanRemoveEvt = Dynamic + EHType' 'GuildEmojisUpdateEvt = Dynamic + EHType' 'GuildIntegrationsUpdateEvt = Dynamic + EHType' 'GuildMemberAddEvt = Dynamic + EHType' 'GuildMemberRemoveEvt = Dynamic + EHType' 'GuildMemberUpdateEvt = Dynamic + EHType' 'GuildMembersChunkEvt = Dynamic + EHType' 'GuildRoleCreateEvt = Dynamic + EHType' 'GuildRoleUpdateEvt = Dynamic + EHType' 'GuildRoleDeleteEvt = Dynamic + EHType' 'MessageCreateEvt = Dynamic + EHType' 'MessageUpdateEvt = Dynamic + EHType' 'MessageDeleteEvt = Dynamic + EHType' 'MessageDeleteBulkEvt = Dynamic + EHType' 'MessageReactionAddEvt = Dynamic + EHType' 'MessageReactionRemoveEvt = Dynamic + EHType' 'MessageReactionRemoveAllEvt = Dynamic + EHType' 'TypingStartEvt = Dynamic + EHType' 'UserUpdateEvt = Dynamic + EHType' ('CustomEvt _ _) = Dynamic + newtype EventHandlers = EventHandlers (TypeRepMap EventHandler) -newtype EventHandler d = EH - { unwrapEventHandler :: [EHType' d] +type family EHStorageType t where + EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [Dynamic]) + EHStorageType t = [EHType' t] + +newtype EventHandler t = EH + { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t } - deriving newtype ( Semigroup, Monoid ) +instance Semigroup (EventHandler t) where + EH a <> EH b = EH $ a <> b + +instance Monoid (EventHandler t) where + mempty = EH mempty + instance Default EventHandlers where - def = EventHandlers $ fromList [ WrapTypeable $ EH @"ready" [] - , WrapTypeable $ EH @"channelcreate" [] - , WrapTypeable $ EH @"channelupdate" [] - , WrapTypeable $ EH @"channeldelete" [] - , WrapTypeable $ EH @"channelpinsupdate" [] - , WrapTypeable $ EH @"guildcreate" [] - , WrapTypeable $ EH @"guildupdate" [] - , WrapTypeable $ EH @"guilddelete" [] - , WrapTypeable $ EH @"guildbanadd" [] - , WrapTypeable $ EH @"guildbanremove" [] - , WrapTypeable $ EH @"guildemojisupdate" [] - , WrapTypeable $ EH @"guildintegrationsupdate" [] - , WrapTypeable $ EH @"guildmemberadd" [] - , WrapTypeable $ EH @"guildmemberremove" [] - , WrapTypeable $ EH @"guildmemberupdate" [] - , WrapTypeable $ EH @"guildrolecreate" [] - , WrapTypeable $ EH @"guildroleupdate" [] - , WrapTypeable $ EH @"guildroledelete" [] - , WrapTypeable $ EH @"messagecreate" [] - , WrapTypeable $ EH @"messageupdate" [] - , WrapTypeable $ EH @"messagedelete" [] - , WrapTypeable $ EH @"messagedeletebulk" [] - , WrapTypeable $ EH @"messagereactionadd" [] - , WrapTypeable $ EH @"messagereactionremove" [] - , WrapTypeable $ EH @"messagereactionremoveall" [] - , WrapTypeable $ EH @"typingstart" [] - , WrapTypeable $ EH @"userupdate" [] - -- , WrapTypeable $ EH m @"voicestateupdate" [] - -- , WrapTypeable $ EH m @"voiceserverupdate" [] - -- , WrapTypeable $ EH m @"webhooksupdate" [] + def = EventHandlers $ fromList [ WrapTypeable $ EH @'ReadyEvt [] + , WrapTypeable $ EH @'ChannelCreateEvt [] + , WrapTypeable $ EH @'ChannelUpdateEvt [] + , WrapTypeable $ EH @'ChannelDeleteEvt [] + , WrapTypeable $ EH @'ChannelpinsUpdateEvt [] + , WrapTypeable $ EH @'GuildCreateEvt [] + , WrapTypeable $ EH @'GuildUpdateEvt [] + , WrapTypeable $ EH @'GuildDeleteEvt [] + , WrapTypeable $ EH @'GuildBanAddEvt [] + , WrapTypeable $ EH @'GuildBanRemoveEvt [] + , WrapTypeable $ EH @'GuildEmojisUpdateEvt [] + , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt [] + , WrapTypeable $ EH @'GuildMemberAddEvt [] + , WrapTypeable $ EH @'GuildMemberRemoveEvt [] + , WrapTypeable $ EH @'GuildMemberUpdateEvt [] + , WrapTypeable $ EH @'GuildMembersChunkEvt [] + , WrapTypeable $ EH @'GuildRoleCreateEvt [] + , WrapTypeable $ EH @'GuildRoleUpdateEvt [] + , WrapTypeable $ EH @'GuildRoleDeleteEvt [] + , WrapTypeable $ EH @'MessageCreateEvt [] + , WrapTypeable $ EH @'MessageUpdateEvt [] + , WrapTypeable $ EH @'MessageDeleteEvt [] + , WrapTypeable $ EH @'MessageDeleteBulkEvt [] + , WrapTypeable $ EH @'MessageReactionAddEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveAllEvt [] + , WrapTypeable $ EH @'TypingStartEvt [] + , WrapTypeable $ EH @'UserUpdateEvt [] + , WrapTypeable $ EH @('CustomEvt Void Void) LH.empty ] instance Semigroup EventHandlers where @@ -166,3 +211,55 @@ instance Monoid EventHandlers where mempty = def + +-- not sure what to think of this + +type family EHInstanceSelector (d :: EventType) :: Bool where + EHInstanceSelector ('CustomEvt _ _) = 'True + EHInstanceSelector _ = 'False + +class InsertEventHandler a m where + makeEventHandlers :: Proxy a -> Proxy m -> EHType a m -> EventHandlers + +instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a m) => InsertEventHandler a m where + makeEventHandlers = makeEventHandlers' (Proxy @flag) + +class InsertEventHandler' (flag :: Bool) a m where + makeEventHandlers' :: Proxy flag -> Proxy a -> Proxy m -> EHType a m -> EventHandlers + +instance (Typeable a, Typeable s, Typeable (EHType ('CustomEvt s a) m)) + => InsertEventHandler' 'True ('CustomEvt s a) m where + makeEventHandlers' _ _ _ handler = EventHandlers . TM.one $ EH @('CustomEvt Void Void) + (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [toDyn handler])) + +instance (Typeable s, EHStorageType s ~ [Dynamic], Typeable (EHType s m)) => InsertEventHandler' 'False s m where + makeEventHandlers' _ _ _ handler = EventHandlers . TM.one $ EH @s [toDyn handler] + + +class GetEventHandlers a m where + getEventHandlers :: EventHandlers -> [EHType a m] + +instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a m) => GetEventHandlers a m where + getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @m) (Proxy @flag) + +class GetEventHandlers' (flag :: Bool) a m where + getEventHandlers' :: Proxy a -> Proxy m -> Proxy flag -> EventHandlers -> [EHType a m] + +instance (Typeable a, Typeable s, Typeable (EHType ('CustomEvt s a) m)) => GetEventHandlers' 'True ('CustomEvt s a) m where + getEventHandlers' _ _ _ (EventHandlers handlers) = + let handlerMap = unwrapEventHandler @('CustomEvt Void Void) $ fromJust + (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Void))) + in concat $ LH.lookup (typeRep $ Proxy @s) handlerMap >>= LH.lookup (typeRep $ Proxy @a) <&> map + (fromJust . fromDynamic) + +instance (Typeable s, Typeable (EHType s m), EHStorageType s ~ [Dynamic]) => GetEventHandlers' 'False s m where + getEventHandlers' _ _ _ (EventHandlers handlers) = + let theseHandlers = unwrapEventHandler @s $ fromJust (TM.lookup handlers :: Maybe (EventHandler s)) + in map (fromJust . fromDynamic) theseHandlers + + +getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic] +getCustomEventHandlers s a (EventHandlers handlers) = + let handlerMap = unwrapEventHandler @('CustomEvt Void Void) $ fromJust + (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Void))) + in concat $ LH.lookup s handlerMap >>= LH.lookup a diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs --- a/src/Calamity/Gateway/DispatchEvents.hs +++ b/src/Calamity/Gateway/DispatchEvents.hs @@ -17,14 +17,17 @@ import Calamity.Types.UnixTimestamp import Data.Aeson +import Data.Dynamic import Data.Text.Lazy ( Text ) import Data.Time +import Data.Typeable import Data.Vector.Unboxed ( Vector ) import GHC.Generics -data DispatchMessage - = DispatchData' DispatchData +data CalamityEvent + = Dispatch DispatchData + | Custom TypeRep Dynamic | ShutDown deriving ( Show, Generic ) diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs --- a/src/Calamity/Gateway/Shard.hs +++ b/src/Calamity/Gateway/Shard.hs @@ -15,6 +15,7 @@ import Control.Concurrent import Control.Concurrent.Async +import qualified Control.Concurrent.Chan.Unagi as UC import Control.Concurrent.STM import Control.Concurrent.STM.TBMQueue import Control.Exception @@ -25,6 +26,7 @@ import qualified Data.Aeson as A import Data.Functor import Data.Maybe +import Data.IORef import Data.Text.Lazy ( Text, stripPrefix ) import Data.Text.Lazy.Lens import Data.Void @@ -42,7 +44,7 @@ import qualified Polysemy.AtomicState as P import qualified Polysemy.Error as P import qualified Polysemy.Resource as P - +import qualified Control.Exception.Safe as Ex import Prelude hiding ( error ) import TextShow @@ -80,21 +82,21 @@ -> Int -> Int -> Token - -> TQueue DispatchMessage - -> Sem r (Shard, Async (Maybe ())) -newShard gateway id count token evtQueue = do - (shard, stateVar) <- P.embed $ mdo - cmdQueue' <- newTQueueIO - stateVar <- newTVarIO (newShardState shard) - let shard = Shard id count gateway evtQueue cmdQueue' stateVar (rawToken token) - pure (shard, stateVar) + -> UC.InChan CalamityEvent + -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) +newShard gateway id count token evtIn = do + (cmdIn, stateVar) <- P.embed $ mdo + (cmdIn, cmdOut) <- UC.newChan + stateVar <- newIORef $ newShardState shard + let shard = Shard id count gateway evtIn cmdOut stateVar (rawToken token) + pure (cmdIn, stateVar) - let runShard = P.runAtomicStateTVar stateVar shardLoop + let runShard = P.runAtomicStateIORef stateVar shardLoop let action = attr "shard-id" id . push "calamity-shard" $ runShard thread' <- P.async action - pure (shard, thread') + pure (cmdIn, thread') sendToWs :: ShardC r => SentDiscordMessage -> Sem r () sendToWs data' = do @@ -110,17 +112,6 @@ fromEitherVoid (Left a) = a fromEitherVoid (Right a) = absurd a -- yeet --- | Catches ws close events and decides if we can restart or not -checkWSClose :: IO a -> IO (Either ControlMessage a) -checkWSClose m = (Right <$> m) `catch` \case - e@(CloseRequest code _) -> do - print e - if code `elem` [1000, 4004, 4010, 4011] - then pure . Left $ ShutDownShard - else pure . Left $ RestartShard - - e -> throwIO e - tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool tryWriteTBMQueue' q v = do v' <- tryWriteTBMQueue q v @@ -141,18 +132,23 @@ controlStream :: Shard -> TBMQueue ShardMsg -> IO () controlStream shard outqueue = inner where - q = shard ^. #cmdQueue + q = shard ^. #cmdOut inner = do - v <- atomically $ readTQueue q + v <- UC.readChan q r <- atomically $ tryWriteTBMQueue' outqueue (Control v) when r inner - discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO] r => Connection -> TBMQueue ShardMsg -> Sem r () + handleWSException :: SomeException -> IO (Either ControlMessage a) + handleWSException e = pure $ case fromException e of + Just (CloseRequest code _) + | code `elem` [1000, 4004, 4010, 4011] -> + Left ShutDownShard + _ -> Left RestartShard + + discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () discordStream ws outqueue = inner where inner = do - msg <- P.embed . checkWSClose $ receiveData ws - - -- trace $ "Received from stream: "+||msg||+"" + msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException case msg of Left c -> @@ -168,15 +164,11 @@ pure True when r inner - -- mergedStream :: Log -> Shard -> Connection -> ExceptT ShardException ShardM ShardMsg - -- mergedStream logEnv shard ws = - -- liftIO (fromEither <$> race (controlStream shard) (discordStream logEnv ws)) - -- | The outer loop, sets up the ws conn, etc handles reconnecting and such -- Currently if this goes to the error path we just exit the forever loop -- and the shard stops, maybe we might want to do some extra logic to reboot -- the shard, or maybe force a resharding - outerloop :: ShardC r => Sem r (Either ShardException ()) + outerloop :: ShardC r => Sem r (Either ShardFlowControl ()) outerloop = P.runError . forever $ do shard :: Shard <- P.atomicGets (^. #shardS) let host = shard ^. #gateway @@ -187,17 +179,17 @@ innerLoopVal <- websocketToIO $ runWebsocket host' "/?v=7&encoding=json" innerloop case innerLoopVal of - ShardExcShutDown -> do + ShardFlowShutDown -> do info "Shutting down shard" - P.throw ShardExcShutDown + P.throw ShardFlowShutDown - ShardExcRestart -> + ShardFlowRestart -> info "Restaring shard" -- we restart normally when we loop -- | The inner loop, handles receiving a message from discord or a command message -- and then decides what to do with it - innerloop :: ShardC r => Connection -> Sem r ShardException + innerloop :: ShardC r => Connection -> Sem r ShardFlowControl innerloop ws = do debug "Entering inner loop of shard" @@ -232,7 +224,7 @@ receivedMessages <- registerCounter "received_messages" [("shard", showt $ shard ^. #shardID)] - result <- P.runResource $ P.bracket (P.embed $ newTBMQueueIO 1) + result <- P.resourceToIOFinal $ P.bracket (P.embed $ newTBMQueueIO 1) (P.embed . atomically . closeTBMQueue) (\q -> do debug "handling events now" @@ -251,9 +243,9 @@ pure result -- | Handlers for each message, not sure what they'll need to do exactly yet - handleMsg :: (ShardC r, P.Member (P.Error ShardException) r) => ShardMsg -> Sem r () + handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () handleMsg (Discord msg) = case msg of - Dispatch sn data' -> do + EvtDispatch sn data' -> do -- trace $ "Handling event: ("+||data'||+")" P.atomicModify (#seqNum ?~ sn) @@ -264,9 +256,7 @@ _ -> pure () shard <- P.atomicGets (^. #shardS) - P.embed . atomically $ writeTQueue (shard ^. #evtQueue) (DispatchData' data') - -- sn' <- P.atomicGets (^. #seqNum) - -- trace $ "Done handling event, seq is now: "+||sn'||+"" + P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch data') HeartBeatReq -> do debug "Received heartbeat request" @@ -274,7 +264,7 @@ Reconnect -> do debug "Being asked to restart by Discord" - P.throw ShardExcRestart + P.throw ShardFlowRestart InvalidSession resumable -> do if resumable @@ -285,7 +275,7 @@ P.embed $ threadDelay (15 * 1000 * 1000) else info "Received resumable invalid session" - P.throw ShardExcRestart + P.throw ShardFlowRestart Hello interval -> do info $ "Received hello, beginning to heartbeat at an interval of "+|interval|+"ms" @@ -300,8 +290,8 @@ debug $ "Sending presence: ("+||data'||+")" sendToWs $ StatusUpdate data' - RestartShard -> P.throw ShardExcRestart - ShutDownShard -> P.throw ShardExcShutDown + RestartShard -> P.throw ShardFlowRestart + ShutDownShard -> P.throw ShardFlowShutDown startHeartBeatLoop :: ShardC r => Int -> Sem r () startHeartBeatLoop interval = do diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs --- a/src/Calamity/Gateway/Types.hs +++ b/src/Calamity/Gateway/Types.hs @@ -1,5 +1,19 @@ -- | Types for shards -module Calamity.Gateway.Types where +module Calamity.Gateway.Types + ( ShardC + , ShardMsg(..) + , ReceivedDiscordMessage(..) + , SentDiscordMessage(..) + , DispatchType(..) + , IdentifyData(..) + , StatusUpdateData(..) + , ResumeData(..) + , RequestGuildMembersData(..) + , IdentifyProps(..) + , ControlMessage(..) + , ShardFlowControl(..) + , Shard(..) + , ShardState(..) ) where import Calamity.Gateway.DispatchEvents import Calamity.Internal.AesonThings @@ -10,13 +24,12 @@ import Calamity.Types.Snowflake import Control.Concurrent.Async -import Control.Concurrent.STM.TQueue -import Control.Concurrent.STM.TVar -import Control.Exception +import Control.Concurrent.Chan.Unagi import Data.Aeson import qualified Data.Aeson.Types as AT import Data.Generics.Labels () +import Data.IORef import Data.Maybe import Data.Text.Lazy ( Text ) @@ -28,8 +41,8 @@ import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P -type ShardC r = P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO, - P.Async, MetricEff] r +type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO, + P.Async, MetricEff] r) data ShardMsg = Discord ReceivedDiscordMessage @@ -37,7 +50,7 @@ deriving ( Show, Generic ) data ReceivedDiscordMessage - = Dispatch Int !DispatchData + = EvtDispatch Int !DispatchData | HeartBeatReq | Reconnect | InvalidSession Bool @@ -53,7 +66,7 @@ d <- v .: "d" t <- v .: "t" s <- v .: "s" - Dispatch s <$> parseDispatchData t d + EvtDispatch s <$> parseDispatchData t d 1 -> pure HeartBeatReq @@ -231,19 +244,18 @@ | SendPresence StatusUpdateData deriving ( Show ) -data ShardException - = ShardExcRestart - | ShardExcShutDown +data ShardFlowControl + = ShardFlowRestart + | ShardFlowShutDown deriving ( Show ) - deriving anyclass Exception data Shard = Shard { shardID :: Int , shardCount :: Int , gateway :: Text - , evtQueue :: TQueue DispatchMessage - , cmdQueue :: TQueue ControlMessage - , shardState :: TVar ShardState + , evtIn :: InChan CalamityEvent + , cmdOut :: OutChan ControlMessage + , shardState :: IORef ShardState , token :: Text } deriving ( Generic )