calamity 0.1.5.1 → 0.1.6.0

raw patch · 8 files changed

+366/−238 lines, 8 filesdep +safe-exceptionsdep +unagi-chanPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: safe-exceptions, unagi-chan

API changes (from Hackage documentation)

Files

• README.md +1/−1
• calamity.cabal +4/−2
• src/Calamity/Client/Client.hs +88/−64
• src/Calamity/Client/ShardManager.hs +2/−2
• src/Calamity/Client/Types.hs +202/−105
• src/Calamity/Gateway/DispatchEvents.hs +5/−2
• src/Calamity/Gateway/Shard.hs +37/−47
• src/Calamity/Gateway/Types.hs +27/−15

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

@@ -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 <https://github.com/nitros12/calamity#readme> 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

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

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

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

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

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

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