calamity 0.2.0.2 → 0.3.0.0

raw patch · 38 files changed

+2716/−1110 lines, 38 filesdep +randomPVP ok

version bump matches the API change (PVP)

Dependencies added: random

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +456/−440
• Calamity/Client/Types.hs +14/−10
• Calamity/Gateway/DispatchEvents.hs +2/−2
• Calamity/Gateway/Intents.hs +1/−0
• Calamity/Gateway/Shard.hs +1/−0
• Calamity/Gateway/Types.hs +7/−5
• Calamity/HTTP.hs +32/−26
• Calamity/HTTP/Channel.hs +71/−33
• Calamity/HTTP/Guild.hs +30/−10
• Calamity/HTTP/Interaction.hs +427/−0
• Calamity/HTTP/Internal/Ratelimit.hs +124/−114
• Calamity/HTTP/Internal/Request.hs +15/−15
• Calamity/HTTP/Internal/Route.hs +1/−1
• Calamity/HTTP/Webhook.hs +41/−15
• Calamity/Interactions.hs +64/−0
• Calamity/Interactions/Eff.hs +42/−0
• Calamity/Interactions/Utils.hs +199/−0
• Calamity/Interactions/View.hs +428/−0
• Calamity/Internal/AesonThings.hs +51/−41
• Calamity/Internal/Updateable.hs +0/−1
• Calamity/Internal/Utils.hs +28/−26
• Calamity/Types/Model/Channel.hs +4/−2
• Calamity/Types/Model/Channel/Attachment.hs +6/−4
• Calamity/Types/Model/Channel/Component.hs +252/−81
• Calamity/Types/Model/Channel/Guild/Category.hs-boot +0/−8
• Calamity/Types/Model/Channel/Guild/Text.hs +2/−2
• Calamity/Types/Model/Channel/Guild/Voice.hs +1/−1
• Calamity/Types/Model/Channel/Message.hs +10/−2
• Calamity/Types/Model/Channel/UpdatedMessage.hs +0/−3
• Calamity/Types/Model/Guild/Guild.hs +4/−4
• Calamity/Types/Model/Guild/Member.hs +0/−4
• Calamity/Types/Model/Guild/UnavailableGuild.hs +18/−14
• Calamity/Types/Model/Interaction.hs +87/−74
• Calamity/Types/Tellable.hs +98/−61
• Calamity/Types/TokenEff.hs +14/−0
• ChangeLog.md +28/−0
• README.md +146/−106
• calamity.cabal +12/−5

@@ -2,18 +2,18 @@  -- | The client module Calamity.Client.Client (-    react,-    runBotIO,-    runBotIO',-    runBotIO'',-    stopBot,-    sendPresence,-    events,-    fire,-    waitUntil,-    waitUntilM,-    CalamityEvent (Dispatch, ShutDown),-    customEvt,+  react,+  runBotIO,+  runBotIO',+  runBotIO'',+  stopBot,+  sendPresence,+  events,+  fire,+  waitUntil,+  waitUntilM,+  CalamityEvent (Dispatch, ShutDown),+  customEvt, ) where  import Calamity.Cache.Eff@@ -23,6 +23,7 @@ import Calamity.Gateway.Intents import Calamity.Gateway.Types import Calamity.HTTP.Internal.Ratelimit+import Calamity.Types.TokenEff import Calamity.Internal.ConstructorName import Calamity.Internal.RunIntoIO import qualified Calamity.Internal.SnowflakeMap as SM@@ -68,74 +69,88 @@  timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) timeA m = do-    start <- P.embed getPOSIXTime-    res <- m-    end <- P.embed getPOSIXTime-    let duration = fromRational . toRational $ end - start-    pure (duration, res)+  start <- P.embed getPOSIXTime+  res <- m+  end <- P.embed getPOSIXTime+  let duration = fromRational . toRational $ end - start+  pure (duration, res)  newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client newClient token initialDi = do-    shards' <- newTVarIO []-    numShards' <- newEmptyMVar-    rlState' <- newRateLimitState-    (inc, outc) <- newChan-    ehidCounter <- newIORef 0+  shards' <- newTVarIO []+  numShards' <- newEmptyMVar+  rlState' <- newRateLimitState+  (inc, outc) <- newChan+  ehidCounter <- newIORef 0 -    pure $-        Client-            shards'-            numShards'-            token-            rlState'-            inc-            outc-            ehidCounter-            initialDi+  pure $+    Client+      shards'+      numShards'+      token+      rlState'+      inc+      outc+      ehidCounter+      initialDi  -- | Create a bot, run your setup action, and then loop until the bot closes. runBotIO ::-    forall r a.-    (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) =>-    Token ->-    -- | The intents the bot should use-    Intents ->-    P.Sem (SetupEff r) a ->-    P.Sem r (Maybe StartupError)+  forall r a.+  (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) =>+  Token ->+  -- | The intents the bot should use+  Intents ->+  P.Sem (SetupEff r) a ->+  P.Sem r (Maybe StartupError) runBotIO token intents = runBotIO' token intents Nothing  resetDi :: BotC r => P.Sem r a -> P.Sem r a resetDi m = do-    initialDi <- P.asks (^. #initialDi)-    Di.local (`fromMaybe` initialDi) m+  initialDi <- P.asks (^. #initialDi)+  Di.local (`fromMaybe` initialDi) m +interpretRatelimitViaClient :: P.Member (P.Reader Client) r => P.Sem (RatelimitEff ': r) a -> P.Sem r a+interpretRatelimitViaClient =+  P.interpret+    ( \case+        GetRatelimitState -> P.asks (^. #rlState)+    )++interpretTokenViaClient :: P.Member (P.Reader Client) r => P.Sem (TokenEff ': r) a -> P.Sem r a+interpretTokenViaClient =+  P.interpret+    ( \case+        GetBotToken -> P.asks (^. #token)+    )+ {- | Create a bot, run your setup action, and then loop until the bot closes.   This version allows you to specify the initial status -} runBotIO' ::-    forall r a.-    (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) =>-    Token ->-    -- | The intents the bot should use-    Intents ->-    -- | The initial status to send to the gateway-    Maybe StatusUpdateData ->-    P.Sem (SetupEff r) a ->-    P.Sem r (Maybe StartupError)+  forall r a.+  (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) =>+  Token ->+  -- | The intents the bot should use+  Intents ->+  -- | The initial status to send to the gateway+  Maybe StatusUpdateData ->+  P.Sem (SetupEff r) a ->+  P.Sem r (Maybe StartupError) runBotIO' token intents status setup = do-    initialDi <- Di.fetch-    client <- P.embed $ newClient token initialDi-    handlers <- P.embed $ newTVarIO def-    P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do-        void $ Di.push "calamity-setup" setup-        r <- shardBot status intents-        case r of-            Left e -> pure (Just e)-            Right _ -> do-                Di.push "calamity-loop" clientLoop-                Di.push "calamity-stop" finishUp-                pure Nothing+  initialDi <- Di.fetch+  client <- P.embed $ newClient token initialDi+  handlers <- P.embed $ newTVarIO def+  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . interpretTokenViaClient . interpretRatelimitViaClient . Di.push "calamity" $ do+    void $ Di.push "calamity-setup" setup+    r <- shardBot status intents+    case r of+      Left e -> pure (Just e)+      Right _ -> do+        Di.push "calamity-loop" clientLoop+        Di.push "calamity-stop" finishUp+        pure Nothing  {- | Create a bot, run your setup action, and then loop until the bot closes. @@ -143,8 +158,8 @@  handle the @'P.AtomicState' 'EventHandlers'@ yourself. -} runBotIO'' ::-    forall r a.-    (P.Members+  forall r a.+  ( P.Members       '[ LogEff        , MetricEff        , CacheEff@@ -154,26 +169,27 @@        , P.Final IO        , P.Async        ]- r) =>-    Token ->-    -- | The intents the bot should use-    Intents ->-    -- | The initial status to send to the gateway-    Maybe StatusUpdateData ->-    P.Sem (P.Reader Client ': r) a ->-    P.Sem r (Maybe StartupError)+      r+  ) =>+  Token ->+  -- | The intents the bot should use+  Intents ->+  -- | The initial status to send to the gateway+  Maybe StatusUpdateData ->+  P.Sem (RatelimitEff ': TokenEff ': P.Reader Client ': r) a ->+  P.Sem r (Maybe StartupError) runBotIO'' token intents status setup = do-    initialDi <- Di.fetch-    client <- P.embed $ newClient token initialDi-    P.runReader client . Di.push "calamity" $ do-        void $ Di.push "calamity-setup" setup-        r <- shardBot status intents-        case r of-            Left e -> pure (Just e)-            Right _ -> do-                Di.push "calamity-loop" clientLoop-                Di.push "calamity-stop" finishUp-                pure Nothing+  initialDi <- Di.fetch+  client <- P.embed $ newClient token initialDi+  P.runReader client . interpretTokenViaClient . interpretRatelimitViaClient . Di.push "calamity" $ do+    void $ Di.push "calamity-setup" setup+    r <- shardBot status intents+    case r of+      Left e -> pure (Just e)+      Right _ -> do+        Di.push "calamity-loop" clientLoop+        Di.push "calamity-stop" finishUp+        pure Nothing  {- | Register an event handler, returning an action that removes the event handler from the bot. @@ -207,17 +223,17 @@  which will result in errors about parameter counts mismatching. -} react ::-    forall (s :: EventType) r.-    (BotC r, ReactConstraints s) =>-    (EHType s -> (P.Sem r) ()) ->-    P.Sem r (P.Sem r ())+  forall (s :: EventType) r.+  (BotC r, ReactConstraints s) =>+  (EHType s -> (P.Sem r) ()) ->+  P.Sem r (P.Sem r ()) react handler = do-    handler' <- bindSemToIO handler-    ehidC <- P.asks (^. #ehidCounter)-    id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))-    let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')-    P.atomicModify (handlers <>)-    pure $ removeHandler @s id'+  handler' <- bindSemToIO handler+  ehidC <- P.asks (^. #ehidCounter)+  id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))+  let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')+  P.atomicModify (handlers <>)+  pure $ removeHandler @s id'  removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r () removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id')@@ -234,8 +250,8 @@ -} fire :: BotC r => CalamityEvent -> P.Sem r () fire e = do-    inc <- P.asks (^. #eventsIn)-    P.embed $ writeChan inc e+  inc <- P.asks (^. #eventsIn)+  P.embed $ writeChan inc e  {- | Build a Custom CalamityEvent @@ -253,8 +269,8 @@ -- | Get a copy of the event stream. events :: BotC r => P.Sem r (OutChan CalamityEvent) events = do-    inc <- P.asks (^. #eventsIn)-    P.embed $ dupChan inc+  inc <- P.asks (^. #eventsIn)+  P.embed $ dupChan inc  {- | Wait until an event satisfying a condition happens, then returns its  parameters.@@ -283,21 +299,21 @@  @ -} waitUntil ::-    forall (s :: EventType) r.-    (BotC r, ReactConstraints s) =>-    (EHType s -> Bool) ->-    P.Sem r (EHType s)+  forall (s :: EventType) r.+  (BotC r, ReactConstraints s) =>+  (EHType s -> Bool) ->+  P.Sem r (EHType s) waitUntil f = P.resourceToIOFinal $ do-    result <- P.embed newEmptyMVar-    P.bracket-        (P.raise $ react @s (checker result))-        P.raise-        (const . P.embed $ takeMVar result)+  result <- P.embed newEmptyMVar+  P.bracket+    (P.raise $ react @s (checker result))+    P.raise+    (const . P.embed $ takeMVar result)   where     checker :: MVar (EHType s) -> EHType s -> P.Sem r ()     checker result args = do-        when (f args) $ do-            P.embed $ putMVar result args+      when (f args) $ do+        P.embed $ putMVar result args  {- | Wait until an event satisfying a condition happens, then returns its  parameters@@ -324,135 +340,135 @@  @ -} waitUntilM ::-    forall (s :: EventType) r.-    (BotC r, ReactConstraints s) =>-    (EHType s -> P.Sem r Bool) ->-    P.Sem r (EHType s)+  forall (s :: EventType) r.+  (BotC r, ReactConstraints s) =>+  (EHType s -> P.Sem r Bool) ->+  P.Sem r (EHType s) waitUntilM f = P.resourceToIOFinal $ do-    result <- P.embed newEmptyMVar-    P.bracket-        (P.raise $ react @s (checker result))-        P.raise-        (const . P.embed $ takeMVar result)+  result <- P.embed newEmptyMVar+  P.bracket+    (P.raise $ react @s (checker result))+    P.raise+    (const . P.embed $ takeMVar result)   where     checker :: MVar (EHType s) -> EHType s -> P.Sem r ()     checker result args = do-        res <- f args-        when res $ do-            P.embed $ putMVar result args+      res <- f args+      when res $ do+        P.embed $ putMVar result args  -- | Set the bot's presence on all shards. 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)+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \(inc, _) ->+    P.embed $ writeChan inc (SendPresence s)  -- | Initiate shutting down the bot. stopBot :: BotC r => P.Sem r () stopBot = do-    debug "stopping bot"-    inc <- P.asks (^. #eventsIn)-    P.embed $ writeChan inc ShutDown+  debug "stopping bot"+  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 $ \(inc, _) ->-        P.embed $ writeChan inc ShutDownShard-    for_ shards $ \(_, shardThread) -> P.await shardThread-    debug "bot has stopped"+  debug "finishing up"+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \(inc, _) ->+    P.embed $ writeChan inc ShutDownShard+  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 its handler functions -} clientLoop :: BotC r => P.Sem r () clientLoop = do-    outc <- P.asks (^. #eventsOut)-    whileMFinalIO $ do-        !evt' <- P.embed $ readChan outc-        case evt' of-            Dispatch !sid !evt -> handleEvent sid evt >> pure True-            Custom d -> handleCustomEvent d >> pure True-            ShutDown -> pure False-    debug "leaving client loop"+  outc <- P.asks (^. #eventsOut)+  whileMFinalIO $ do+    !evt' <- P.embed $ readChan outc+    case evt' of+      Dispatch !sid !evt -> handleEvent sid evt >> pure True+      Custom d -> handleCustomEvent d >> pure True+      ShutDown -> pure False+  debug "leaving client loop"  handleCustomEvent :: forall a r. (Typeable a, BotC r) => a -> P.Sem r () handleCustomEvent d = do-    eventHandlers <- P.atomicGet+  eventHandlers <- P.atomicGet -    let handlers = getCustomEventHandlers @a eventHandlers+  let handlers = getCustomEventHandlers @a eventHandlers -    for_ handlers (\h -> P.async . P.embed $ h d)+  for_ handlers (\h -> P.async . P.embed $ h d)  catchAllLogging :: BotC r => P.Sem r () -> P.Sem r () catchAllLogging m = do-    r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m-    case r of-        Right _ -> pure ()-        Left e -> debug [fmt|got exception: {e:s}|]+  r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m+  case r of+    Right _ -> pure ()+    Left e -> debug [fmt|got exception: {e:s}|]  handleEvent :: BotC r => Int -> DispatchData -> P.Sem r () handleEvent shardID data' = do-    debug "handling an event"-    eventHandlers <- P.atomicGet-    actions <- P.runFail $ do-        evtCounter <- registerCounter "events_received" [("type", T.pack $ ctorName data'), ("shard", showt shardID)]-        void $ addCounter 1 evtCounter-        cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20 .. 100]-        (time, res) <- timeA . resetDi $ handleEvent' eventHandlers data'-        void $ observeHistogram time cacheUpdateHisto-        pure res+  debug [fmt|"handling an event: {ctorName data'}"|]+  eventHandlers <- P.atomicGet+  actions <- P.runFail $ do+    evtCounter <- registerCounter "events_received" [("type", T.pack $ ctorName data'), ("shard", showt shardID)]+    void $ addCounter 1 evtCounter+    cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20 .. 100]+    (time, res) <- timeA . resetDi $ handleEvent' eventHandlers data'+    void $ observeHistogram time cacheUpdateHisto+    pure res -    eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20 .. 100]+  eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20 .. 100] -    case actions of-        Right actions -> for_ actions $ \action -> P.async $ do-            (time, _) <- timeA . catchAllLogging $ P.embed action-            void $ observeHistogram time eventHandleHisto-        -- pattern match failures are usually stuff like events for uncached guilds, etc-        Left err -> debug [fmt|Failed handling actions for event: {err:s}|]+  case actions of+    Right actions -> for_ actions $ \action -> P.async $ do+      (time, _) <- timeA . catchAllLogging $ P.embed action+      void $ observeHistogram time eventHandleHisto+    -- pattern match failures are usually stuff like events for uncached guilds, etc+    Left err -> debug [fmt|Failed handling actions for event: {err:s}|]  handleEvent' ::-    BotC r =>-    EventHandlers ->-    DispatchData ->-    P.Sem (P.Fail ': r) [IO ()]-handleEvent' eh evt@(Ready rd@ReadyData{}) = do-    updateCache evt-    pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh)+  BotC r =>+  EventHandlers ->+  DispatchData ->+  P.Sem (P.Fail ': r) [IO ()]+handleEvent' eh evt@(Ready rd@ReadyData {}) = do+  updateCache evt+  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) (getEventHandlers @'ChannelCreateEvt eh)+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  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) (getEventHandlers @'ChannelCreateEvt eh)+  updateCache evt+  Just guild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan)+  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 ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do-    Just oldGuild <- getGuild (getID chan)-    Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)-    updateCache evt-    Just newGuild <- getGuild (getID chan)-    Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)-    pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  Just newGuild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)+  pure $ map ($ (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 ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do-    Just oldChan <- DMChannel' <<$>> getDM (getID chan)-    updateCache evt-    pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)  -- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do --   chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just)@@ -460,276 +476,276 @@ --   pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh)  handleEvent' eh evt@(GuildCreate guild) = do-    isNew <- not <$> isUnavailableGuild (getID guild)-    updateCache evt-    Just guild <- getGuild (getID guild)-    pure $-        map-            ($ (guild, if isNew then GuildCreateNew else GuildCreateAvailable))-            (getEventHandlers @'GuildCreateEvt eh)+  isNew <- not <$> isUnavailableGuild (getID guild)+  updateCache evt+  Just guild <- getGuild (getID guild)+  pure $+    map+      ($ (guild, if isNew then GuildCreateNew else GuildCreateAvailable))+      (getEventHandlers @'GuildCreateEvt eh) handleEvent' eh evt@(GuildUpdate guild) = do-    Just oldGuild <- getGuild (getID guild)-    updateCache evt-    Just newGuild <- getGuild (getID guild)-    pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @'GuildUpdateEvt eh)+  Just oldGuild <- getGuild (getID guild)+  updateCache evt+  Just newGuild <- getGuild (getID guild)+  pure $ map ($ (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-            ($ (oldGuild, if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved))-            (getEventHandlers @'GuildDeleteEvt eh)-handleEvent' eh evt@(GuildBanAdd BanData{guildID, user}) = do-    Just guild <- getGuild guildID-    updateCache evt-    pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh)-handleEvent' eh evt@(GuildBanRemove BanData{guildID, user}) = do-    Just guild <- getGuild guildID-    updateCache evt-    pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanRemoveEvt eh)+handleEvent' eh evt@(GuildDelete UnavailableGuild {id, unavailable}) = do+  Just oldGuild <- getGuild id+  updateCache evt+  pure $+    map+      ($ (oldGuild, if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved))+      (getEventHandlers @'GuildDeleteEvt eh)+handleEvent' eh evt@(GuildBanAdd BanData {guildID, user}) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh)+handleEvent' eh evt@(GuildBanRemove BanData {guildID, user}) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (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 ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh)-handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData{guildID}) = do-    updateCache evt-    Just guild <- getGuild guildID-    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) (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) (getEventHandlers @'GuildMemberRemoveEvt eh)-handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData{user, guildID}) = do-    Just oldGuild <- getGuild guildID-    Just oldMember <- pure $ oldGuild ^. #members . at (getID user)-    updateCache evt-    Just newGuild <- getGuild guildID-    Just newMember <- pure $ newGuild ^. #members . at (getID user)-    pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)-handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData{members, guildID}) = do-    updateCache evt-    Just guild <- getGuild guildID-    let memberIDs = map (getID @Member) members-    let members' = mapMaybe (\mid -> guild ^. #members . at mid) memberIDs-    pure $ map ($ (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 ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh)-handleEvent' eh evt@(GuildRoleUpdate GuildRoleData{guildID, role}) = do-    Just oldGuild <- getGuild guildID-    Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)-    updateCache evt-    Just newGuild <- getGuild guildID-    Just newRole <- pure $ newGuild ^. #roles . at (getID role)-    pure $ map ($ (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 ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh)+handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh)+handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData {guildID}) = do+  updateCache evt+  Just guild <- getGuild guildID+  pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh)+handleEvent' eh evt@(GuildMemberAdd gid member) = do+  updateCache evt+  Just guild <- getGuild gid+  Just member <- pure $ guild ^. #members . at (getID member)+  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) (getEventHandlers @'GuildMemberRemoveEvt eh)+handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData {user, guildID}) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (getID user)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (getID user)+  pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)+handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData {members, guildID}) = do+  updateCache evt+  Just guild <- getGuild guildID+  let memberIDs = map (getID @Member) members+  let members' = mapMaybe (\mid -> guild ^. #members . at mid) memberIDs+  pure $ map ($ (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 ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh)+handleEvent' eh evt@(GuildRoleUpdate GuildRoleData {guildID, role}) = do+  Just oldGuild <- getGuild guildID+  Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newRole <- pure $ newGuild ^. #roles . at (getID role)+  pure $ map ($ (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 ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh) handleEvent' eh (InviteCreate d) = do-    pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh)+  pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh) handleEvent' eh (InviteDelete d) = do-    pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh)+  pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh) handleEvent' eh evt@(MessageCreate msg user member) = do-    updateCache evt-    pure $ map ($ (msg, user, member)) (getEventHandlers @'MessageCreateEvt eh)+  updateCache evt+  pure $ map ($ (msg, user, member)) (getEventHandlers @'MessageCreateEvt eh) handleEvent' eh evt@(MessageUpdate msg user member) = do-    oldMsg <- getMessage (getID msg)-    updateCache evt-    newMsg <- getMessage (getID msg)-    let rawActions = map ($ (msg, user, member)) (getEventHandlers @'RawMessageUpdateEvt eh)-    let actions = case (oldMsg, newMsg) of-            (Just oldMsg', Just newMsg') ->-                map ($ (oldMsg', newMsg', user, member)) (getEventHandlers @'MessageUpdateEvt eh)-            _ -> []-    pure $ rawActions <> actions-handleEvent' eh evt@(MessageDelete MessageDeleteData{id}) = do-    oldMsg <- getMessage id-    updateCache evt-    let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh)-    let actions = case oldMsg of-            Just oldMsg' ->-                map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh)-            _ -> []-    pure $ rawActions <> actions-handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData{ids}) = do-    messages <- catMaybes <$> traverse getMessage ids-    updateCache evt-    let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh)-    let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh)-    pure $ rawActions <> actions+  oldMsg <- getMessage (getID msg)+  updateCache evt+  newMsg <- getMessage (getID msg)+  let rawActions = map ($ (msg, user, member)) (getEventHandlers @'RawMessageUpdateEvt eh)+  let actions = case (oldMsg, newMsg) of+        (Just oldMsg', Just newMsg') ->+          map ($ (oldMsg', newMsg', user, member)) (getEventHandlers @'MessageUpdateEvt eh)+        _ -> []+  pure $ rawActions <> actions+handleEvent' eh evt@(MessageDelete MessageDeleteData {id}) = do+  oldMsg <- getMessage id+  updateCache evt+  let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh)+  let actions = case oldMsg of+        Just oldMsg' ->+          map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh)+        _ -> []+  pure $ rawActions <> actions+handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData {ids}) = do+  messages <- catMaybes <$> traverse getMessage ids+  updateCache evt+  let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh)+  let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh)+  pure $ rawActions <> actions handleEvent' eh evt@(MessageReactionAdd reaction) = do-    updateCache evt-    msg <- getMessage (getID reaction)-    user <- getUser (getID reaction)-    chan <- case reaction ^. #guildID of-        Just _ -> do-            chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)-            pure (GuildChannel' <$> chan)-        Nothing -> do-            chan <- getDM (coerceSnowflake $ getID @Channel reaction)-            pure (DMChannel' <$> chan)-    let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh)-    let actions = case (msg, user, chan) of-            (Just msg', Just user', Just chan') ->-                map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionAddEvt eh)-            _ -> []-    pure $ rawActions <> actions+  updateCache evt+  msg <- getMessage (getID reaction)+  user <- getUser (getID reaction)+  chan <- case reaction ^. #guildID of+    Just _ -> do+      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+      pure (GuildChannel' <$> chan)+    Nothing -> do+      chan <- getDM (coerceSnowflake $ getID @Channel reaction)+      pure (DMChannel' <$> chan)+  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh)+  let actions = case (msg, user, chan) of+        (Just msg', Just user', Just chan') ->+          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionAddEvt eh)+        _ -> []+  pure $ rawActions <> actions handleEvent' eh evt@(MessageReactionRemove reaction) = do-    msg <- getMessage (getID reaction)-    updateCache evt-    user <- getUser (getID reaction)-    chan <- case reaction ^. #guildID of-        Just _ -> do-            chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)-            pure (GuildChannel' <$> chan)-        Nothing -> do-            chan <- getDM (coerceSnowflake $ getID @Channel reaction)-            pure (DMChannel' <$> chan)-    let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh)-    let actions = case (msg, user, chan) of-            (Just msg', Just user', Just chan') ->-                map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionRemoveEvt eh)-            _ -> []-    pure $ rawActions <> actions-handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData{messageID}) = do-    msg <- getMessage messageID-    updateCache evt-    let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh)-    let actions = case msg of-            Just msg' ->-                map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh)-            _ -> []-    pure $ rawActions <> actions-handleEvent' eh evt@(PresenceUpdate PresenceUpdateData{userID, presence = Presence{guildID}}) = do-    Just oldGuild <- getGuild guildID-    Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)-    updateCache evt-    Just newGuild <- getGuild guildID-    Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)-    let oldUser :: User = upcast oldMember-        newUser :: User = upcast newMember-        userUpdates =-            if oldUser /= newUser-                then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)-                else mempty-    pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)-handleEvent' eh (TypingStart TypingStartData{channelID, guildID, userID, timestamp = UnixTimestamp timestamp}) =-    case guildID of-        Just gid -> do-            Just guild <- getGuild gid-            Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)-            pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)-        Nothing -> do-            Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)-            pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)+  msg <- getMessage (getID reaction)+  updateCache evt+  user <- getUser (getID reaction)+  chan <- case reaction ^. #guildID of+    Just _ -> do+      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+      pure (GuildChannel' <$> chan)+    Nothing -> do+      chan <- getDM (coerceSnowflake $ getID @Channel reaction)+      pure (DMChannel' <$> chan)+  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh)+  let actions = case (msg, user, chan) of+        (Just msg', Just user', Just chan') ->+          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionRemoveEvt eh)+        _ -> []+  pure $ rawActions <> actions+handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) = do+  msg <- getMessage messageID+  updateCache evt+  let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh)+  let actions = case msg of+        Just msg' ->+          map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh)+        _ -> []+  pure $ rawActions <> actions+handleEvent' eh evt@(PresenceUpdate PresenceUpdateData {userID, presence = Presence {guildID}}) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)+  let oldUser :: User = upcast oldMember+      newUser :: User = upcast newMember+      userUpdates =+        if oldUser /= newUser+          then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)+          else mempty+  pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)+handleEvent' eh (TypingStart TypingStartData {channelID, guildID, userID, timestamp = UnixTimestamp timestamp}) =+  case guildID of+    Just gid -> do+      Just guild <- getGuild gid+      Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)+      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)+    Nothing -> do+      Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)+      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) handleEvent' eh evt@(UserUpdate _) = do-    Just oldUser <- getBotUser-    updateCache evt-    Just newUser <- getBotUser-    pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)-handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState{guildID = Just guildID}) = do-    oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID-    updateCache evt-    pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh)+  Just oldUser <- getBotUser+  updateCache evt+  Just newUser <- getBotUser+  pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)+handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState {guildID = Just guildID}) = do+  oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID+  updateCache evt+  pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh) handleEvent' eh evt@(InteractionCreate interaction) = do-    updateCache evt-    pure $ map ($ interaction) (getEventHandlers @'InteractionEvt eh)+  updateCache evt+  pure $ map ($ interaction) (getEventHandlers @'InteractionEvt eh) handleEvent' _ e = fail $ "Unhandled event: " <> show e  updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r ()-updateCache (Ready ReadyData{user, guilds}) = do-    setBotUser user-    for_ (map getID guilds) setUnavailableGuild+updateCache (Ready ReadyData {user, guilds}) = do+  setBotUser user+  for_ (map getID guilds) setUnavailableGuild updateCache Resumed = pure () updateCache (ChannelCreate (DMChannel' chan)) =-    setDM chan+  setDM chan updateCache (ChannelCreate (GuildChannel' chan)) =-    updateGuild (getID chan) (#channels %~ SM.insert chan)+  updateGuild (getID chan) (#channels %~ SM.insert chan) updateCache (ChannelUpdate (DMChannel' chan)) =-    updateDM (getID chan) (update chan)+  updateDM (getID chan) (update chan) updateCache (ChannelUpdate (GuildChannel' chan)) =-    updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan)+  updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan) updateCache (ChannelDelete (DMChannel' chan)) =-    delDM (getID chan)+  delDM (getID chan) updateCache (ChannelDelete (GuildChannel' chan)) =-    updateGuild (getID chan) (#channels %~ sans (getID chan))+  updateGuild (getID chan) (#channels %~ sans (getID chan)) updateCache (GuildCreate guild) = do-    isNew <- isUnavailableGuild (getID guild)-    when isNew $ delUnavailableGuild (getID guild)-    setGuild guild-    for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser+  isNew <- isUnavailableGuild (getID guild)+  when isNew $ delUnavailableGuild (getID guild)+  setGuild guild+  for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser updateCache (GuildUpdate guild) =-    updateGuild (getID guild) (update guild)-updateCache (GuildDelete UnavailableGuild{id, unavailable}) =-    if unavailable-        then setUnavailableGuild id-        else delGuild id-updateCache (GuildEmojisUpdate GuildEmojisUpdateData{guildID, emojis}) =-    updateGuild guildID (#emojis .~ SM.fromList emojis)-updateCache (GuildMemberAdd member) = do-    setUser (member ^. super)-    updateGuild (getID member) (#members . at (getID member) ?~ member)-updateCache (GuildMemberRemove GuildMemberRemoveData{guildID, user}) =-    updateGuild guildID (#members %~ sans (getID user))-updateCache (GuildMemberUpdate GuildMemberUpdateData{guildID, roles = AesonVector roles, user, nick}) = do-    setUser user-    updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick))-updateCache (GuildMembersChunk GuildMembersChunkData{members}) =-    traverse_ (updateCache . GuildMemberAdd) members-updateCache (GuildRoleCreate GuildRoleData{guildID, role}) =-    updateGuild guildID (#roles %~ SM.insert role)-updateCache (GuildRoleUpdate GuildRoleData{guildID, role}) =-    updateGuild guildID (#roles %~ SM.insert role)-updateCache (GuildRoleDelete GuildRoleDeleteData{guildID, roleID}) =-    updateGuild guildID (#roles %~ sans roleID)+  updateGuild (getID guild) (update guild)+updateCache (GuildDelete UnavailableGuild {id, unavailable}) =+  if unavailable+    then setUnavailableGuild id+    else delGuild id+updateCache (GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) =+  updateGuild guildID (#emojis .~ SM.fromList emojis)+updateCache (GuildMemberAdd gid member) = do+  setUser (member ^. super)+  updateGuild gid (#members . at (getID member) ?~ member)+updateCache (GuildMemberRemove GuildMemberRemoveData {guildID, user}) =+  updateGuild guildID (#members %~ sans (getID user))+updateCache (GuildMemberUpdate GuildMemberUpdateData {guildID, roles = AesonVector roles, user, nick}) = do+  setUser user+  updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick))+updateCache (GuildMembersChunk GuildMembersChunkData {guildID, members}) =+  traverse_ (updateCache . GuildMemberAdd guildID) members+updateCache (GuildRoleCreate GuildRoleData {guildID, role}) =+  updateGuild guildID (#roles %~ SM.insert role)+updateCache (GuildRoleUpdate GuildRoleData {guildID, role}) =+  updateGuild guildID (#roles %~ SM.insert role)+updateCache (GuildRoleDelete GuildRoleDeleteData {guildID, roleID}) =+  updateGuild guildID (#roles %~ sans roleID) updateCache (MessageCreate !msg !_ !_) =-    setMessage msg-    -- I think it's for the best not to cache things here, instead the end user-    -- can just cache manually which users and members they want+  setMessage msg+-- I think it's for the best not to cache things here, instead the end user+-- can just cache manually which users and members they want updateCache (MessageUpdate msg !_ !_) =-    updateMessage (getID msg) (update msg)-updateCache (MessageDelete MessageDeleteData{id}) = delMessage id-updateCache (MessageDeleteBulk MessageDeleteBulkData{ids}) =-    for_ ids delMessage+  updateMessage (getID msg) (update msg)+updateCache (MessageDelete MessageDeleteData {id}) = delMessage id+updateCache (MessageDeleteBulk MessageDeleteBulkData {ids}) =+  for_ ids delMessage updateCache (MessageReactionAdd reaction) = do-    isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser-    updateMessage-        (getID reaction)-        ( \m ->-            case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of-                [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]-                _ ->-                    m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-                        %~ (#count +~ 1) . (#me ||~ isMe)-        )+  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+  updateMessage+    (getID reaction)+    ( \m ->+        case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of+          [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]+          _ ->+            m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+              %~ (#count +~ 1) . (#me ||~ isMe)+    ) updateCache (MessageReactionRemove reaction) = do-    isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser-    updateMessage-        (getID reaction)-        ( \m ->-            m-                & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-                    %~ (#count -~ 1) . (#me &&~ not isMe)-                & #reactions %~ filter (\r -> r ^. #count /= 0)-        )-updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData{messageID}) =-    updateMessage messageID (#reactions .~ mempty)-updateCache (PresenceUpdate PresenceUpdateData{userID, presence}) =-    updateGuild (getID presence) (#presences . at userID ?~ presence)+  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+  updateMessage+    (getID reaction)+    ( \m ->+        m+          & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+            %~ (#count -~ 1) . (#me &&~ not isMe)+          & #reactions %~ filter (\r -> r ^. #count /= 0)+    )+updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) =+  updateMessage messageID (#reactions .~ mempty)+updateCache (PresenceUpdate PresenceUpdateData {userID, presence}) =+  updateGuild (getID presence) (#presences . at userID ?~ presence) updateCache (UserUpdate user) = setBotUser user -- we don't handle group channels currently updateCache (ChannelCreate (GroupChannel' _)) = pure ()@@ -744,16 +760,16 @@ updateCache (WebhooksUpdate _) = pure () updateCache (InviteCreate _) = pure () updateCache (InviteDelete _) = pure ()-updateCache (VoiceStateUpdate voiceState@V.VoiceState{guildID = Just guildID}) =-    updateGuild guildID (#voiceStates %~ updateVoiceStates)+updateCache (VoiceStateUpdate voiceState@V.VoiceState {guildID = Just guildID}) =+  updateGuild guildID (#voiceStates %~ updateVoiceStates)   where     updateVoiceStates [] = [voiceState]     updateVoiceStates (x : xs)-        | V.sessionID x == V.sessionID voiceState = voiceState : xs-        | otherwise = x : updateVoiceStates xs+      | V.sessionID x == V.sessionID voiceState = voiceState : xs+      | otherwise = x : updateVoiceStates xs  -- we don't handle voice server update and direct voice connections currently-updateCache (VoiceStateUpdate V.VoiceState{guildID = Nothing}) = pure ()+updateCache (VoiceStateUpdate V.VoiceState {guildID = Nothing}) = pure () updateCache (VoiceServerUpdate _) = pure () -- we don't update the cache from interactions -- TODO: should we?

@@ -19,16 +19,19 @@ import Calamity.Cache.Eff import Calamity.Gateway.DispatchEvents (CalamityEvent (..), InviteCreateData, InviteDeleteData, ReactionEvtData, ReadyData) import Calamity.Gateway.Types (ControlMessage)+import Calamity.HTTP.Internal.Ratelimit import Calamity.HTTP.Internal.Types import Calamity.Metrics.Eff import Calamity.Types.LogEff import Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.UpdatedMessage import Calamity.Types.Model.Guild+import Calamity.Types.Model.Interaction (Interaction) import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake import Calamity.Types.Token+import Calamity.Types.TokenEff import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar@@ -36,24 +39,23 @@ import Data.Default.Class import Data.Dynamic import Data.IORef+import Data.Kind (Type) import Data.Maybe import Data.Time import Data.TypeRepMap (TypeRepMap, WrapTypeable (..)) import qualified Data.TypeRepMap as TM import Data.Typeable+import Data.Void (Void)+import qualified Df1+import qualified Di.Core as DC import GHC.Exts (fromList) import GHC.Generics import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P import qualified Polysemy.Reader as P-import qualified Df1-import qualified Di.Core as DC import TextShow import qualified TextShow.Generic as TSG-import Data.Kind (Type)-import Data.Void (Void)-import Calamity.Types.Model.Interaction (Interaction)  data Client = Client   { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))]@@ -73,6 +75,8 @@       '[ LogEff        , MetricEff        , CacheEff+       , RatelimitEff+       , TokenEff        , P.Reader Client        , P.AtomicState EventHandlers        , P.Embed IO@@ -83,7 +87,7 @@   )  -- | A concrete effect stack used inside the bot-type SetupEff r = (P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)+type SetupEff r = (RatelimitEff ': TokenEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)  {- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't  worry about these since they are satisfied for any type @s@ can be@@ -94,7 +98,7 @@   )  newtype StartupError = StartupError String-  deriving (Show)+  deriving stock (Show)  -- | A Data Kind used to fire custom events data EventType@@ -240,7 +244,7 @@ newtype CustomEHTypeStorage (a :: Type) = CustomEHTypeStorage   { unwrapCustomEHTypeStorage :: [EventHandlerWithID (a -> IO ())]   }-  deriving newtype ( Monoid, Semigroup )+  deriving newtype (Monoid, Semigroup)  type family EHStorageType (t :: EventType) where   EHStorageType ( 'CustomEvt _) = TypeRepMap CustomEHTypeStorage@@ -289,7 +293,7 @@         , WrapTypeable $ EH @'TypingStartEvt []         , WrapTypeable $ EH @'UserUpdateEvt []         , WrapTypeable $ EH @'InteractionEvt []-        , WrapTypeable $ EH @('CustomEvt Void) TM.empty+        , WrapTypeable $ EH @( 'CustomEvt Void) TM.empty         ]  instance Semigroup EventHandlers where@@ -316,7 +320,7 @@ class InsertEventHandler' (flag :: Bool) a where   makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers -instance forall (x :: Type). (Typeable (EHType ('CustomEvt x))) => InsertEventHandler' 'True ( 'CustomEvt x) where+instance forall (x :: Type). (Typeable (EHType ( 'CustomEvt x))) => InsertEventHandler' 'True ( 'CustomEvt x) where   makeEventHandlers' _ _ id' handler =     EventHandlers . TM.one $       EH @( 'CustomEvt Void)

@@ -49,7 +49,7 @@     | GuildBanRemove !BanData     | GuildEmojisUpdate !GuildEmojisUpdateData     | GuildIntegrationsUpdate !GuildIntegrationsUpdateData-    | GuildMemberAdd !Member+    | GuildMemberAdd !(Snowflake Guild) !Member     | GuildMemberRemove !GuildMemberRemoveData     | GuildMemberUpdate !GuildMemberUpdateData     | GuildMembersChunk !GuildMembersChunkData@@ -131,7 +131,7 @@          members' <- do             members' <- v .: "members"-            traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members'+            traverse (parseJSON . Object) members'          pure $ GuildMembersChunkData guildID members' 

@@ -48,6 +48,7 @@     , ("intentDirectMessages", 1 `shiftL` 12)     , ("intentDirectMessageReactions", 1 `shiftL` 13)     , ("intentDirectMessageTyping", 1 `shiftL` 14)+    , ("intentGuildScheduledEvents", 1 `shiftL` 16)     ]  ) 

@@ -184,6 +184,7 @@           whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|])           P.embed . atomically $ writeTBMQueue outqueue (Control c)         Right msg' -> do+          -- debug [fmt|Got msg: {msg'}|]           let decoded = A.eitherDecode msg'           r <- case decoded of             Right a ->

@@ -104,7 +104,9 @@ parseDispatchData GUILD_BAN_REMOVE data'            = GuildBanRemove <$> parseJSON data' parseDispatchData GUILD_EMOJIS_UPDATE data'         = GuildEmojisUpdate <$> parseJSON data' parseDispatchData GUILD_INTEGRATIONS_UPDATE data'   = GuildIntegrationsUpdate <$> parseJSON data'-parseDispatchData GUILD_MEMBER_ADD data'            = GuildMemberAdd <$> parseJSON data'+parseDispatchData GUILD_MEMBER_ADD data'            = do+  guildID <- withObject "GuildMemberAdd.guild_id" (.: "guild_id") data'+  GuildMemberAdd guildID <$> parseJSON data' parseDispatchData GUILD_MEMBER_REMOVE data'         = GuildMemberRemove <$> parseJSON data' parseDispatchData GUILD_MEMBER_UPDATE data'         = GuildMemberUpdate <$> parseJSON data' parseDispatchData GUILD_MEMBERS_CHUNK data'         = GuildMembersChunk <$> parseJSON data'@@ -118,8 +120,7 @@   let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do                                          userObject :: Object <- o .: "author"                                          memberObject :: Object <- o .: "member"-                                         guildID :: String <- o .: "guild_id"-                                         parseJSON $ Object (memberObject <> "user" .= userObject <> "guild_id" .= guildID)) data'+                                         parseJSON $ Object (memberObject <> "user" .= userObject)) data'    let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author"   pure $ MessageCreate message user member@@ -128,8 +129,7 @@   let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do                                          userObject :: Object <- o .: "author"                                          memberObject :: Object <- o .: "member"-                                         guildID :: String <- o .: "guild_id"-                                         parseJSON $ Object (memberObject <> "user" .= userObject <> "guild_id" .= guildID)) data'+                                         parseJSON $ Object (memberObject <> "user" .= userObject)) data'   let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author"   pure $ MessageUpdate message user member parseDispatchData MESSAGE_DELETE data'              = MessageDelete <$> parseJSON data'@@ -143,6 +143,7 @@ parseDispatchData VOICE_STATE_UPDATE data'          = VoiceStateUpdate <$> parseJSON data' parseDispatchData VOICE_SERVER_UPDATE data'         = VoiceServerUpdate <$> parseJSON data' parseDispatchData WEBHOOKS_UPDATE data'             = WebhooksUpdate <$> parseJSON data'+parseDispatchData INTERACTION_CREATE data'          = InteractionCreate <$> parseJSON data'  data SentDiscordMessage   = StatusUpdate StatusUpdateData@@ -216,6 +217,7 @@   | VOICE_STATE_UPDATE   | VOICE_SERVER_UPDATE   | WEBHOOKS_UPDATE+  | INTERACTION_CREATE   deriving ( Show, Eq, Enum, Generic )   deriving anyclass ( ToJSON, FromJSON ) 

@@ -1,31 +1,37 @@ -- | Combined http request stuff-module Calamity.HTTP-    ( invoke-    , module Calamity.HTTP.AuditLog-    , module Calamity.HTTP.Channel-    , module Calamity.HTTP.Emoji-    , module Calamity.HTTP.Guild-    , module Calamity.HTTP.Invite-    , module Calamity.HTTP.MiscRoutes-    , module Calamity.HTTP.User-    , module Calamity.HTTP.Reason-    , module Calamity.HTTP.Internal.Types-    , module Calamity.HTTP.Webhook-    -- * HTTP-    -- $httpDocs-    ) where+module Calamity.HTTP (+  invoke,+  module Calamity.HTTP.AuditLog,+  module Calamity.HTTP.Channel,+  module Calamity.HTTP.Emoji,+  module Calamity.HTTP.Guild,+  module Calamity.HTTP.Invite,+  module Calamity.HTTP.Interaction,+  module Calamity.HTTP.MiscRoutes,+  module Calamity.HTTP.User,+  module Calamity.HTTP.Reason,+  module Calamity.HTTP.Webhook,+  module Calamity.HTTP.Internal.Types,+  RatelimitEff (..),+  TokenEff (..),+  -- * HTTP+  -- $httpDocs+) where -import           Calamity.HTTP.AuditLog-import           Calamity.HTTP.Channel-import           Calamity.HTTP.Emoji-import           Calamity.HTTP.Guild-import           Calamity.HTTP.Internal.Request ( invoke )-import           Calamity.HTTP.Internal.Types   ( RestError )-import           Calamity.HTTP.Invite-import           Calamity.HTTP.MiscRoutes-import           Calamity.HTTP.Reason-import           Calamity.HTTP.User-import           Calamity.HTTP.Webhook+import Calamity.HTTP.AuditLog+import Calamity.HTTP.Channel+import Calamity.HTTP.Emoji+import Calamity.HTTP.Guild+import Calamity.HTTP.Interaction+import Calamity.HTTP.Internal.Ratelimit (RatelimitEff (..))+import Calamity.HTTP.Internal.Request (invoke)+import Calamity.HTTP.Internal.Types (RestError)+import Calamity.HTTP.Invite+import Calamity.HTTP.MiscRoutes+import Calamity.HTTP.Reason+import Calamity.HTTP.User+import Calamity.HTTP.Webhook+import Calamity.Types.TokenEff (TokenEff (..))  -- $httpDocs --

@@ -1,12 +1,14 @@ -- | Channel endpoints module Calamity.HTTP.Channel (   ChannelRequest (..),+  CreateMessageAttachment (..),   CreateMessageOptions (..),   EditMessageData (..),   editMessageContent,-  editMessageEmbed,+  editMessageEmbeds,   editMessageFlags,   editMessageAllowedMentions,+  editMessageComponents,   ChannelUpdate (..),   AllowedMentionType (..),   AllowedMentions (..),@@ -21,7 +23,10 @@ import Calamity.HTTP.Internal.Route import Calamity.Internal.AesonThings import Calamity.Types.Model.Channel-import Calamity.Types.Model.Guild+import Calamity.Types.Model.Guild.Emoji (RawEmoji (..))+import Calamity.Types.Model.Guild.Invite (Invite)+import Calamity.Types.Model.Guild.Overwrite (Overwrite)+import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake import Control.Lens hiding ((.=))@@ -29,27 +34,57 @@ import qualified Data.Aeson.KeyMap as K import Data.ByteString.Lazy (ByteString) import Data.Default.Class-import Data.Generics.Product.Subtype (upcast)+import Data.Maybe (fromMaybe) import Data.Text (Text)-import qualified Data.Text as S+import qualified Data.Text as T import Data.Word import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime+import PyF import TextShow +data CreateMessageAttachment = CreateMessageAttachment+  { filename :: Text+  , description :: Maybe Text+  , content :: ByteString+  }+  deriving (Show, Generic)+ data CreateMessageOptions = CreateMessageOptions   { content :: Maybe Text   , nonce :: Maybe Text   , tts :: Maybe Bool-  , file :: Maybe (Text, ByteString)-  , embed :: Maybe Embed+  , attachments :: Maybe [CreateMessageAttachment]+  , embeds :: Maybe [Embed]   , allowedMentions :: Maybe AllowedMentions   , messageReference :: Maybe MessageReference+  , components :: Maybe [Component]   }   deriving (Show, Generic, Default) +data CreateMessageAttachmentJson = CreateMessageAttachmentJson+  { id :: Int+  , filename :: Text+  , description :: Maybe Text+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson++data CreateMessageJson = CreateMessageJson+  { content :: Maybe Text+  , nonce :: Maybe Text+  , tts :: Maybe Bool+  , embeds :: Maybe [Embed]+  , allowedMentions :: Maybe AllowedMentions+  , messageReference :: Maybe MessageReference+  , components :: Maybe [Component]+  , attachments :: Maybe [CreateMessageAttachmentJson]+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateMessageJson+ data AllowedMentionType   = AllowedMentionRoles   | AllowedMentionUsers@@ -80,17 +115,6 @@ instance Monoid AllowedMentions where   mempty = def -data CreateMessageJson = CreateMessageJson-  { content :: Maybe Text-  , nonce :: Maybe Text-  , tts :: Maybe Bool-  , embed :: Maybe Embed-  , allowedMentions :: Maybe AllowedMentions-  , messageReference :: Maybe MessageReference-  }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateMessageJson- {- | Parameters to the Edit Message endpoint.   Use the provided methods (@editMessageX@) to create a value with the@@ -108,8 +132,8 @@ editMessageContent :: Maybe Text -> EditMessageData editMessageContent v = EditMessageData $ K.fromList [("content", toJSON v)] -editMessageEmbed :: Maybe Embed -> EditMessageData-editMessageEmbed v = EditMessageData $ K.fromList [("embed", toJSON v)]+editMessageEmbeds :: [Embed] -> EditMessageData+editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", toJSON v)]  editMessageFlags :: Maybe Word64 -> EditMessageData editMessageFlags v = EditMessageData $ K.fromList [("flags", toJSON v)]@@ -117,6 +141,9 @@ editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", toJSON v)] +editMessageComponents :: [Component] -> EditMessageData+editMessageComponents v = EditMessageData $ K.fromList [("components", toJSON v)]+ data ChannelUpdate = ChannelUpdate   { name :: Maybe Text   , position :: Maybe Int@@ -306,17 +333,28 @@     baseRoute cid // S "recipients" // ID @User       & giveID uid       & buildRoute--  action (CreateMessage _ o@CreateMessageOptions{file = Nothing}) =-    postWith'-      (ReqBodyJson . upcast @CreateMessageJson $ o)-  action (CreateMessage _ cm@CreateMessageOptions{file = Just f}) = \u o -> do-    let filePart =-          (partLBS @IO "file" (snd f))-            { partFilename = Just (S.unpack $ fst f)-            , partContentType = Just (defaultMimeLookup $ fst f)+  action (CreateMessage _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)             }-    body <- reqBodyMultipart [filePart, partLBS "payload_json" (encode . upcast @CreateMessageJson $ cm)]+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        jsonBody =+          CreateMessageJson+            { content = cm ^. #content+            , nonce = cm ^. #nonce+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , messageReference = cm ^. #messageReference+            , components = cm ^. #components+            , attachments = attachments+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)     postWith' body u o   action (CrosspostMessage _ _) = postEmpty   action (GetChannel _) = getWith@@ -330,10 +368,10 @@     getWithP ("after" =: a <> "limit" =:? (l ^? _Just . #limit))   action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just . #limit))   action (GetMessage _ _) = getWith-  action CreateReaction{} = putEmpty-  action DeleteOwnReaction{} = deleteWith-  action DeleteUserReaction{} = deleteWith-  action (GetReactions _ _ _ GetReactionsOptions{before, after, limit}) =+  action CreateReaction {} = putEmpty+  action DeleteOwnReaction {} = deleteWith+  action DeleteUserReaction {} = deleteWith+  action (GetReactions _ _ _ GetReactionsOptions {before, after, limit}) =     getWithP       ( "before" =:? (fromSnowflake <$> before)           <> "after" =:? (fromSnowflake <$> after)

@@ -101,6 +101,12 @@   }   deriving (Show, Generic, Default) +data SearchMembersOptions = SearchMembersOptions+  { limit :: Maybe Integer+  , query :: Text+  }+  deriving (Show, Generic)+ data AddGuildMemberData = AddGuildMemberData   { accessToken :: Text   , nick :: Maybe Text@@ -140,6 +146,13 @@ modifyGuildMemberChannelID :: Maybe (Snowflake VoiceChannel) -> ModifyGuildMemberData modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", toJSON v)] +data GetGuildBansOptions = GetGuildBansOptions+  { limit :: Maybe Int+  , before :: Maybe Int+  , after :: Maybe Int+  }+  deriving (Show, Generic, Default)+ data CreateGuildBanData = CreateGuildBanData   { deleteMessageDays :: Maybe Integer   , reason :: Maybe Text@@ -192,13 +205,14 @@   ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest ()   GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member   ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member]+  SearchGuildMembers :: HasID Guild g => g -> SearchMembersOptions -> GuildRequest [Member]   AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member)   ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest ()   ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest ()   AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()   RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()   RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()-  GetGuildBans :: HasID Guild g => g -> GuildRequest [BanData]+  GetGuildBans :: HasID Guild g => g -> GetGuildBansOptions -> GuildRequest [BanData]   GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData   CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest ()   RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()@@ -248,6 +262,9 @@   route (ListGuildMembers (getID -> gid) _) =     baseRoute gid // S "members"       & buildRoute+  route (SearchGuildMembers (getID -> gid) _) =+    baseRoute gid // S "members" // S "search"+      & buildRoute   route (AddGuildMember (getID -> gid) (getID @User -> uid) _) =     baseRoute gid // S "members" // ID @User       & giveID uid@@ -273,7 +290,7 @@     baseRoute gid // S "members" // ID @User       & giveID uid       & buildRoute-  route (GetGuildBans (getID -> gid)) =+  route (GetGuildBans (getID -> gid) _) =     baseRoute gid // S "bans"       & buildRoute   route (GetGuildBan (getID -> gid) (getID @User -> uid)) =@@ -326,20 +343,25 @@   action (CreateGuildChannel _ o) = postWith' (ReqBodyJson o)   action (ModifyGuildChannelPositions _ o) = postWith' (ReqBodyJson o)   action (GetGuildMember _ _) = getWith-  action (ListGuildMembers _ ListMembersOptions{limit, after}) =+  action (ListGuildMembers _ ListMembersOptions {limit, after}) =     getWithP       ("limit" =:? limit <> "after" =:? (fromSnowflake <$> after))+  action (SearchGuildMembers _ SearchMembersOptions {limit, query}) =+    getWithP+      ("limit" =:? limit <> "query" =: query)   action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o)   action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o)   action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick])-  action AddGuildMemberRole{} = putEmpty-  action RemoveGuildMemberRole{} = deleteWith+  action AddGuildMemberRole {} = putEmpty+  action RemoveGuildMemberRole {} = deleteWith   action (RemoveGuildMember _ _) = deleteWith-  action (GetGuildBans _) = getWith+  action (GetGuildBans _ GetGuildBansOptions {limit, before, after}) =+    getWithP+      ("limit" =:? limit <> "before" =:? before <> "after" =:? after)   action (GetGuildBan _ _) = getWith-  action (CreateGuildBan _ _ CreateGuildBanData{deleteMessageDays, reason}) =+  action (CreateGuildBan _ _ CreateGuildBanData {deleteMessageDays}) =     putEmptyP-      ("delete-message-days" =:? deleteMessageDays <> "reason" =:? reason)+      ("delete_message_days" =:? deleteMessageDays)   action (RemoveGuildBan _ _) = deleteWith   action (GetGuildRoles _) = getWith   action (CreateGuildRole _ o) = postWith' (ReqBodyJson o)@@ -353,6 +375,4 @@    -- this is a bit of a hack   -- TODO: add something to allow for contextual parsing-  modifyResponse (GetGuildMember (getID @Guild -> gid) _) = _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid)-  modifyResponse (ListGuildMembers (getID @Guild -> gid) _) = values . _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid)   modifyResponse _ = Prelude.id

@@ -0,0 +1,427 @@+-- | Interaction endpoints+module Calamity.HTTP.Interaction (+  InteractionRequest (..),+  InteractionCallbackMessageOptions (..),+  InteractionCallbackAutocomplete (..),+  InteractionCallbackAutocompleteChoice (..),+  InteractionCallbackModal (..),+) where++import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..))+import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Channel.Component (Component, CustomID)+import Calamity.Types.Model.Channel.Embed (Embed)+import Calamity.Types.Model.Channel.Message (Message)+import Calamity.Types.Model.Interaction+import Calamity.Types.Snowflake+import Control.Lens hiding ((.=))+import Data.Aeson+import Data.Bits (shiftL, (.|.))+import Data.Default.Class+import qualified Data.HashMap.Strict as H+import Data.Maybe (fromMaybe)+import Data.Monoid (First (First, getFirst))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics+import Network.HTTP.Client.MultipartFormData+import Network.HTTP.Req+import Network.Mime+import PyF+import TextShow+import qualified TextShow.Generic as TSG++data InteractionCallback = InteractionCallback+  { type_ :: InteractionCallbackType+  , data_ :: Maybe Value+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON InteractionCallback++data InteractionCallbackMessageOptions = InteractionCallbackMessageOptions+  { tts :: Maybe Bool+  , content :: Maybe Text+  , embeds :: Maybe [Embed]+  , allowedMentions :: Maybe AllowedMentions+  , ephemeral :: Maybe Bool+  , suppressEmbeds :: Maybe Bool+  , components :: Maybe [Component]+  , attachments :: Maybe [CreateMessageAttachment]+  }+  deriving (Show, Generic, Default)++data CreateMessageAttachmentJson = CreateMessageAttachmentJson+  { id :: Int+  , filename :: Text+  , description :: Maybe Text+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson++data CreateResponseMessageJson = CreateResponseMessageJson+  { tts :: Maybe Bool+  , content :: Maybe Text+  , embeds :: Maybe [Embed]+  , allowedMentions :: Maybe AllowedMentions+  , flags :: Maybe Int+  , components :: Maybe [Component]+  , attachments :: Maybe [CreateMessageAttachmentJson]+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateResponseMessageJson++newtype InteractionCallbackAutocomplete = InteractionCallbackAutocomplete+  { choices :: [InteractionCallbackAutocompleteChoice]+  }+  deriving stock (Show, Generic)+  deriving (ToJSON) via CalamityJSON InteractionCallbackAutocomplete++data InteractionCallbackAutocompleteChoice = InteractionCallbackAutocompleteChoice+  { name :: Text+  , nameLocalizations :: H.HashMap Text Text+  , -- | Either text or numeric+    value :: Value+  }+  deriving stock (Show, Generic)+  deriving (ToJSON) via CalamityJSON InteractionCallbackAutocompleteChoice++data InteractionCallbackModal = InteractionCallbackModal+  { customID :: CustomID+  , title :: Text+  , components :: [Component]+  }+  deriving stock (Show, Generic)+  deriving (ToJSON) via CalamityJSON InteractionCallbackModal++data InteractionCallbackType+  = PongType+  | ChannelMessageWithSourceType+  | DeferredChannelMessageWithSourceType+  | DeferredUpdateMessageType+  | UpdateMessageType+  | ApplicationCommandAutocompleteResultType+  | ModalType+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric InteractionCallbackType++instance ToJSON InteractionCallbackType where+  toEncoding ty = toEncoding @Int $ case ty of+    PongType -> 1+    ChannelMessageWithSourceType -> 4+    DeferredChannelMessageWithSourceType -> 5+    DeferredUpdateMessageType -> 6+    UpdateMessageType -> 7+    ApplicationCommandAutocompleteResultType -> 8+    ModalType -> 9++data InteractionRequest a where+  CreateResponseMessage ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    InteractionCallbackMessageOptions ->+    InteractionRequest ()+  -- | Ack an interaction and defer the response+  --+  -- This route triggers the 'thinking' message+  CreateResponseDefer ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    -- | Ephemeral+    Bool ->+    InteractionRequest ()+  -- | Ack an interaction and defer the response+  --+  -- This route is only usable by component interactions, and doesn't trigger a+  -- 'thinking' message+  CreateResponseDeferComponent ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    InteractionRequest ()+  CreateResponseUpdate ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    InteractionCallbackMessageOptions ->+    InteractionRequest ()+  CreateResponseAutocomplete ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    InteractionCallbackAutocomplete ->+    InteractionRequest ()+  CreateResponseModal ::+    (HasID Interaction i) =>+    i ->+    InteractionToken ->+    InteractionCallbackModal ->+    InteractionRequest ()+  GetOriginalInteractionResponse ::+    (HasID Application i) =>+    i ->+    InteractionToken ->+    InteractionRequest Message+  EditOriginalInteractionResponse ::+    (HasID Application i) =>+    i ->+    InteractionToken ->+    InteractionCallbackMessageOptions ->+    InteractionRequest Message+  DeleteOriginalInteractionResponse ::+    (HasID Application i) =>+    i ->+    InteractionToken ->+    InteractionRequest ()+  CreateFollowupMessage ::+    (HasID Application i) =>+    i ->+    InteractionToken ->+    InteractionCallbackMessageOptions ->+    InteractionRequest ()+  GetFollowupMessage ::+    (HasID Application i, HasID Message m) =>+    i ->+    m ->+    InteractionToken ->+    InteractionRequest Message+  EditFollowupMessage ::+    (HasID Application i, HasID Message m) =>+    i ->+    m ->+    InteractionToken ->+    InteractionCallbackMessageOptions ->+    InteractionRequest ()+  DeleteFollowupMessage ::+    (HasID Application i, HasID Message m) =>+    i ->+    m ->+    InteractionToken ->+    InteractionRequest ()++baseRoute :: Snowflake Application -> InteractionToken -> RouteBuilder _+baseRoute id (InteractionToken token) =+  mkRouteBuilder // S "webhooks" // ID @Application // S token+    & giveID id++foo :: Maybe a -> Maybe a -> (a -> a -> a) -> Maybe a+foo (Just x) (Just y) f = Just (f x y)+foo x y _ = getFirst $ First x <> First y++instance Request (InteractionRequest a) where+  type Result (InteractionRequest a) = a++  route (CreateResponseDefer (getID @Interaction -> iid) (InteractionToken token) _) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (CreateResponseDeferComponent (getID @Interaction -> iid) (InteractionToken token)) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (CreateResponseMessage (getID @Interaction -> iid) (InteractionToken token) _) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (CreateResponseUpdate (getID @Interaction -> iid) (InteractionToken token) _) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (CreateResponseAutocomplete (getID @Interaction -> iid) (InteractionToken token) _) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (CreateResponseModal (getID @Interaction -> iid) (InteractionToken token) _) =+    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"+      & giveID iid+      & buildRoute+  route (GetOriginalInteractionResponse (getID @Application -> aid) token) =+    baseRoute aid token // S "messages" // S "@original" & buildRoute+  route (EditOriginalInteractionResponse (getID @Application -> aid) token _) =+    baseRoute aid token // S "messages" // S "@original" & buildRoute+  route (DeleteOriginalInteractionResponse (getID @Application -> aid) token) =+    baseRoute aid token // S "messages" // S "@original" & buildRoute+  route (CreateFollowupMessage (getID @Application -> aid) token _) =+    baseRoute aid token & buildRoute+  route (GetFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token) =+    baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute+  route (EditFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token _) =+    baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute+  route (DeleteFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token) =+    baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute++  action (CreateResponseDefer _ _ ephemeral) =+    let jsonBody =+          InteractionCallback+            { type_ = DeferredChannelMessageWithSourceType+            , data_ = if ephemeral then Just . object $ [("flags", Number 64)] else Nothing+            }+     in postWith' (ReqBodyJson jsonBody)+  action (CreateResponseDeferComponent _ _) =+    let jsonBody =+          InteractionCallback+            { type_ = DeferredUpdateMessageType+            , data_ = Nothing+            }+     in postWith' (ReqBodyJson jsonBody)+  action (CreateResponseMessage _ _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral+        suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds+        flags = foo ephemeral suppressEmbeds (.|.)+        jsonData =+          CreateResponseMessageJson+            { content = cm ^. #content+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , components = cm ^. #components+            , attachments = attachments+            , flags = flags+            }+        jsonBody =+          InteractionCallback+            { type_ = ChannelMessageWithSourceType+            , data_ = Just . toJSON $ jsonData+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    postWith' body u o+  action (CreateResponseUpdate _ _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral+        suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds+        flags = foo ephemeral suppressEmbeds (.|.)+        jsonData =+          CreateResponseMessageJson+            { content = cm ^. #content+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , components = cm ^. #components+            , attachments = attachments+            , flags = flags+            }+        jsonBody =+          InteractionCallback+            { type_ = UpdateMessageType+            , data_ = Just . toJSON $ jsonData+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    postWith' body u o+  action (CreateResponseAutocomplete _ _ ao) =+    let jsonBody =+          InteractionCallback+            { type_ = ApplicationCommandAutocompleteResultType+            , data_ = Just . toJSON $ ao+            }+     in postWith' (ReqBodyJson jsonBody)+  action (CreateResponseModal _ _ mo) =+    let jsonBody =+          InteractionCallback+            { type_ = ModalType+            , data_ = Just . toJSON $ mo+            }+     in postWith' (ReqBodyJson jsonBody)+  action (GetOriginalInteractionResponse _ _) = getWith+  action (EditOriginalInteractionResponse _ _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral+        suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds+        flags = foo ephemeral suppressEmbeds (.|.)+        jsonData =+          CreateResponseMessageJson+            { content = cm ^. #content+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , components = cm ^. #components+            , attachments = attachments+            , flags = flags+            }+        jsonBody =+          InteractionCallback+            { type_ = UpdateMessageType+            , data_ = Just . toJSON $ jsonData+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    patchWith' body u o+  action (DeleteOriginalInteractionResponse _ _) = deleteWith+  action (CreateFollowupMessage _ _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral+        suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds+        flags = foo ephemeral suppressEmbeds (.|.)+        jsonData =+          CreateResponseMessageJson+            { content = cm ^. #content+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , components = cm ^. #components+            , attachments = attachments+            , flags = flags+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files)+    postWith' body u o+  action GetFollowupMessage {} = getWith+  action (EditFollowupMessage _ _ _ cm) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..]+        attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments+        ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral+        suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds+        flags = foo ephemeral suppressEmbeds (.|.)+        jsonData =+          CreateResponseMessageJson+            { content = cm ^. #content+            , tts = cm ^. #tts+            , embeds = cm ^. #embeds+            , allowedMentions = cm ^. #allowedMentions+            , components = cm ^. #components+            , attachments = attachments+            , flags = flags+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files)+    patchWith' body u o+  action DeleteFollowupMessage {} = deleteWith

@@ -1,13 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Module containing ratelimit stuff module Calamity.HTTP.Internal.Ratelimit (-    newRateLimitState,-    doRequest,+  newRateLimitState,+  doRequest,+  RatelimitEff (..),+  getRatelimitState, ) where -import Calamity.Client.Types (BotC) import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types import Calamity.Internal.Utils+import Calamity.Types.LogEff+import Calamity.Types.TokenEff import Control.Applicative import Control.Concurrent import Control.Concurrent.Event (Event)@@ -27,13 +32,18 @@ import Network.HTTP.Client (responseStatus) import Network.HTTP.Req import Network.HTTP.Types-import Polysemy (Sem)+import Polysemy (Sem, makeSem) import qualified Polysemy as P import PyF import qualified StmContainers.Map as SC import Prelude hiding (error) import qualified Prelude +data RatelimitEff m a where+  GetRatelimitState :: RatelimitEff m RateLimitState++makeSem ''RatelimitEff+ newRateLimitState :: IO RateLimitState newRateLimitState = RateLimitState <$> SC.newIO <*> SC.newIO <*> E.newSet @@ -73,23 +83,23 @@       SC.insert bs b $ buckets s       SC.insert b h $ bucketKeys s       pure bs- where-  mergeStates :: BucketState -> BucketState -> BucketState-  mergeStates old new =-    new-      { ongoing = old ^. #ongoing-      , -- we only ignore the previous 'remaining' if we've not reset yet and the-        -- reset time has changed-        remaining =-          if isJust (old ^. #resetTime) && (old ^. #resetKey /= new ^. #resetKey)-            then min (old ^. #remaining) (new ^. #remaining)-            else new ^. #remaining-      , -- only take the new resetTime if it actually changed-        resetTime =-          if old ^. #resetKey /= new ^. #resetKey-            then new ^. #resetTime-            else old ^. #resetTime-      }+  where+    mergeStates :: BucketState -> BucketState -> BucketState+    mergeStates old new =+      new+        { ongoing = old ^. #ongoing+        , -- we only ignore the previous 'remaining' if we've not reset yet and the+          -- reset time has changed+          remaining =+            if isJust (old ^. #resetTime) && old ^. #resetKey /= new ^. #resetKey+              then min (old ^. #remaining) (new ^. #remaining)+              else new ^. #remaining+        , -- only take the new resetTime if it actually changed+          resetTime =+            if old ^. #resetKey /= new ^. #resetKey+              then new ^. #resetTime+              else old ^. #resetTime+        }  resetBucket :: Bucket -> STM () resetBucket bucket =@@ -101,7 +111,7 @@     )  canResetBucketNow :: UTCTime -> BucketState -> Bool-canResetBucketNow _ BucketState{ongoing} | ongoing > 0 = False+canResetBucketNow _ BucketState {ongoing} | ongoing > 0 = False -- don't allow resetting the bucket if there's ongoing requests, we'll wait -- until another request finishes and updates the counter canResetBucketNow now bs = case bs ^. #resetTime of@@ -112,7 +122,7 @@ -- canResetBucket bs = isNothing $ bs ^. #startedWaitingTime  shouldWaitForUnlock :: BucketState -> Bool-shouldWaitForUnlock BucketState{remaining = 0, ongoing} = ongoing > 0+shouldWaitForUnlock BucketState {remaining = 0, ongoing} = ongoing > 0 shouldWaitForUnlock _ = False  data WaitDelay@@ -128,69 +138,69 @@ -- | Maybe wait for a bucket, updating its state to say we used it useBucketOnce :: Bucket -> IO () useBucketOnce bucket = go 0- where-  go :: Int -> IO ()-  go tries = do-    now <- getCurrentTime-    mWaitDelay <- atomically $ do-      s <- readTVar $ bucket ^. #state+  where+    go :: Int -> IO ()+    go tries = do+      now <- getCurrentTime+      mWaitDelay <- atomically $ do+        s <- readTVar $ bucket ^. #state -      -- -- [0]-      -- -- if there are ongoing requests, wait for them to finish and deliver-      -- -- truth on the current ratelimit state-      when-        (shouldWaitForUnlock s)-        retry+        -- -- [0]+        -- -- if there are ongoing requests, wait for them to finish and deliver+        -- -- truth on the current ratelimit state+        when+          (shouldWaitForUnlock s)+          retry -      -- if there are no ongoing requests, and the bucket reset time has lapsed,-      -- we can just reset the bucket.-      ---      -- if we've already reset the bucket then there should be an ongoing-      -- request so we'll just end up waiting for that to finish-      when-        (canResetBucketNow now s)-        (resetBucket bucket)+        -- if there are no ongoing requests, and the bucket reset time has lapsed,+        -- we can just reset the bucket.+        --+        -- if we've already reset the bucket then there should be an ongoing+        -- request so we'll just end up waiting for that to finish+        when+          (canResetBucketNow now s)+          (resetBucket bucket) -      s <- readTVar $ bucket ^. #state+        s <- readTVar $ bucket ^. #state -      if s ^. #remaining - s ^. #ongoing > 0-        then do-          -- there are tokens remaining for us to use-          modifyTVar'-            (bucket ^. #state)-            ( (#remaining -~ 1)-                . (#ongoing +~ 1)-            )-          pure GoNow-        else do-          -- the bucket has expired, there are no ongoing requests because of-          -- [0] wait and then retry after we can unlock the bucket-          pure (intoWaitDelay $ s ^. #resetTime)+        if s ^. #remaining - s ^. #ongoing > 0+          then do+            -- there are tokens remaining for us to use+            modifyTVar'+              (bucket ^. #state)+              ( (#remaining -~ 1)+                  . (#ongoing +~ 1)+              )+            pure GoNow+          else do+            -- the bucket has expired, there are no ongoing requests because of+            -- [0] wait and then retry after we can unlock the bucket+            pure (intoWaitDelay $ s ^. #resetTime) -    -- putStrLn (show now <> ": Using bucket, waiting until: " <> show mWaitDelay <> ", uses: " <> show s <> ", " <> inf)+      -- putStrLn (show now <> ": Using bucket, waiting until: " <> show mWaitDelay <> ", uses: " <> show s <> ", " <> inf) -    case mWaitDelay of-      WaitUntil waitUntil -> do-        if waitUntil < now-          then threadDelayMS 20-          else -- if the reset is in the past, we're fucked-            threadDelayUntil waitUntil-        -- if we needed to sleep, go again so that multiple concurrent requests-        -- don't exceed the bucket, to ensure we don't sit in a loop if a-        -- request dies on us, bail out after 50 loops-        if tries < 50-          then go (tries + 1)-          else pure () -- print "bailing after number of retries"-      WaitRetrySoon -> do-        threadDelayMS 20-        if tries < 50-          then go (tries + 1)-          else pure () -- print "bailing after number of retries"-      GoNow -> do-        -- print "ok going forward with request"-        pure ()+      case mWaitDelay of+        WaitUntil waitUntil -> do+          if waitUntil < now+            then threadDelayMS 20+            else -- if the reset is in the past, we're fucked+              threadDelayUntil waitUntil+          -- if we needed to sleep, go again so that multiple concurrent requests+          -- don't exceed the bucket, to ensure we don't sit in a loop if a+          -- request dies on us, bail out after 50 loops+          if tries < 50+            then go (tries + 1)+            else pure () -- print "bailing after number of retries"+        WaitRetrySoon -> do+          threadDelayMS 20+          if tries < 50+            then go (tries + 1)+            else pure () -- print "bailing after number of retries"+        GoNow -> do+          -- print "ok going forward with request"+          pure () -doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType+doDiscordRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => IO LbsResponse -> Sem r DiscordResponseType doDiscordRequest r = do   r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException)   case r'' of@@ -225,33 +235,33 @@ -- | Parse a ratelimit header returning when it unlocks parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime parseRateLimitHeader now r = computedEnd <|> end- where-  computedEnd :: Maybe UTCTime-  computedEnd = flip addUTCTime now <$> resetAfter+  where+    computedEnd :: Maybe UTCTime+    computedEnd = flip addUTCTime now <$> resetAfter -  resetAfter :: Maybe NominalDiffTime-  resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just . _Double+    resetAfter :: Maybe NominalDiffTime+    resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just . _Double -  end :: Maybe UTCTime-  end =-    posixSecondsToUTCTime . realToFrac-      <$> responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double+    end :: Maybe UTCTime+    end =+      posixSecondsToUTCTime . realToFrac+        <$> responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double  buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey- where-  remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just . _Integral-  limit = responseHeader r "X-RateLimit-Limit" ^? _Just . _Integral-  resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just . _Double-  resetTime = parseRateLimitHeader now r-  bs = BucketState resetTime <$> resetKey <*> remaining <*> limit <*> pure 0-  bucketKey = responseHeader r "X-RateLimit-Bucket"+  where+    remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just . _Integral+    limit = responseHeader r "X-RateLimit-Limit" ^? _Just . _Integral+    resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just . _Double+    resetTime = parseRateLimitHeader now r+    bs = BucketState resetTime <$> resetKey <*> remaining <*> limit <*> pure 0+    bucketKey = responseHeader r "X-RateLimit-Bucket"  -- | Parse the retry after field, returning when to retry parseRetryAfter :: UTCTime -> Value -> UTCTime parseRetryAfter now r = addUTCTime retryAfter now- where-  retryAfter = realToFrac $ r ^?! key "retry_after" . _Double+  where+    retryAfter = realToFrac $ r ^?! key "retry_after" . _Double  isGlobal :: Value -> Bool isGlobal r = r ^? key "global" . _Bool == Just True@@ -263,27 +273,27 @@   | RGood b  retryRequest ::-  BotC r =>+  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>   -- | number of retries   Int ->   -- | action to perform   Sem r (ShouldRetry a b) ->   Sem r (Either a b) retryRequest maxRetries action = retryInner 0- where-  retryInner numRetries = do-    res <- action-    case res of-      Retry r | numRetries > maxRetries -> do-        debug [fmt|Request failed after {maxRetries} retries|]-        pure $ Left r-      Retry _ ->-        retryInner (numRetries + 1)-      RFail r -> do-        debug "Request failed due to error response"-        pure $ Left r-      RGood r ->-        pure $ Right r+  where+    retryInner numRetries = do+      res <- action+      case res of+        Retry r | numRetries > maxRetries -> do+          debug [fmt|Request failed after {maxRetries} retries|]+          pure $ Left r+        Retry _ ->+          retryInner (numRetries + 1)+        RFail r -> do+          debug "Request failed due to error response"+          pure $ Left r+        RGood r ->+          pure $ Right r  threadDelayMS :: Int -> IO () threadDelayMS ms = threadDelay (1000 * ms)@@ -300,7 +310,7 @@  -- Run a single request doSingleRequest ::-  BotC r =>+  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>   RateLimitState ->   Route ->   -- | Global lock@@ -395,7 +405,7 @@         _ -> debug "unknown ratelimit"       pure $ RFail (HTTPError c $ decode v) -doRequest :: BotC r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)+doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlstate route action =   retryRequest     5

@@ -16,37 +16,31 @@   (=:?), ) where -import Calamity.Client.Types import Calamity.HTTP.Internal.Ratelimit import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types import Calamity.Metrics.Eff+import Calamity.Types.LogEff (LogEff) import Calamity.Types.Token-+import Calamity.Types.TokenEff import Control.Lens import Control.Monad- import Data.Aeson hiding (Options) import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T import qualified Data.Text.Encoding as TS- import DiPolysemy hiding (debug, error, info)- import Network.HTTP.Req-import Web.HttpApiData--import Polysemy (Sem) import qualified Polysemy as P import qualified Polysemy.Error as P-import qualified Polysemy.Reader as P+import Web.HttpApiData -throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> Sem r a+throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> P.Sem r a throwIfLeft (Right a) = pure a throwIfLeft (Left e) = P.throw (InternalClientError . T.pack $ e) -extractRight :: P.Member (P.Error e) r => Either e a -> Sem r a+extractRight :: P.Member (P.Error e) r => Either e a -> P.Sem r a extractRight (Left e) = P.throw e extractRight (Right a) = pure a @@ -69,10 +63,16 @@   modifyResponse :: a -> Value -> Value   modifyResponse _ = id -invoke :: (BotC r, Request a, ReadResponse (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a))+invoke ::+  ( P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r+  , Request a+  , ReadResponse (Calamity.HTTP.Internal.Request.Result a)+  ) =>+  a ->+  P.Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) invoke a = do-  rlState' <- P.asks (^. #rlState)-  token' <- P.asks (^. #token)+  rlState' <- getRatelimitState+  token' <- getBotToken    let route' = route a @@ -141,4 +141,4 @@  (=:?) :: ToHttpApiData a => T.Text -> Maybe a -> Option 'Https n =:? (Just x) = n =: x-n =:? Nothing = mempty+_ =:? Nothing = mempty

@@ -165,7 +165,7 @@ routeKey Route {key, channelID, guildID} = (key, channelID, guildID)  baseURL :: Url 'Https-baseURL = https "discord.com" /: "api" /: "v9"+baseURL = https "discord.com" /: "api" /: "v10"  buildRoute   :: forall (reqs :: [(RequirementType, RouteRequirement)])

@@ -6,26 +6,23 @@   ExecuteWebhookOptions (..), ) where +import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Internal.AesonThings import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Snowflake- import Control.Lens hiding ((.=))- import Data.Aeson-import Data.ByteString.Lazy (ByteString) import Data.Default.Class-import Data.Generics.Product.Subtype (upcast) import Data.Text (Text)-+import qualified Data.Text as T import GHC.Generics--import Network.HTTP.Req- import Network.HTTP.Client.MultipartFormData+import Network.HTTP.Req+import Network.Mime+import PyF  data CreateWebhookData = CreateWebhookData   { username :: Maybe Text@@ -47,20 +44,33 @@ data ExecuteWebhookOptions = ExecuteWebhookOptions   { wait :: Maybe Bool   , content :: Maybe Text-  , file :: Maybe ByteString+  , attachments :: [CreateMessageAttachment]   , embeds :: Maybe [Embed]   , username :: Maybe Text   , avatarUrl :: Maybe Text+  , allowedMentions :: Maybe AllowedMentions   , tts :: Maybe Bool+  , components :: [Component]   }   deriving (Show, Generic, Default) +data CreateMessageAttachmentJson = CreateMessageAttachmentJson+  { id :: Int+  , filename :: Text+  , description :: Maybe Text+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson+ data ExecuteWebhookJson = ExecuteWebhookJson   { content :: Maybe Text   , embeds :: Maybe [Embed]   , username :: Maybe Text   , avatarUrl :: Maybe Text   , tts :: Maybe Bool+  , attachments :: [CreateMessageAttachmentJson]+  , allowedMentions :: Maybe AllowedMentions+  , components :: [Component]   }   deriving (Show, Generic)   deriving (ToJSON) via CalamityJSON ExecuteWebhookJson@@ -126,10 +136,26 @@   action (ModifyWebhookToken _ _ o) = patchWith' $ ReqBodyJson o   action (DeleteWebhook _) = deleteWith   action (DeleteWebhookToken _ _) = deleteWith-  action (ExecuteWebhook _ _ o@ExecuteWebhookOptions{file = Nothing}) =-    postWithP'-      (ReqBodyJson . upcast @ExecuteWebhookJson $ o)-      ("wait" =:? (o ^. #wait))-  action (ExecuteWebhook _ _ wh@ExecuteWebhookOptions{file = Just f}) = \u o -> do-    body <- reqBodyMultipart [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ wh)]+  action (ExecuteWebhook _ _ wh) = \u o -> do+    let filePart CreateMessageAttachment {filename, content} n =+          (partLBS @IO [fmt|files[{n}]|] content)+            { partFilename = Just (T.unpack filename)+            , partContentType = Just (defaultMimeLookup filename)+            }+        attachmentPart CreateMessageAttachment {filename, description} n =+          CreateMessageAttachmentJson n filename description+        files = zipWith filePart (wh ^. #attachments) [(0 :: Int) ..]+        attachments = zipWith attachmentPart (wh ^. #attachments) [0 ..]+        jsonBody =+          ExecuteWebhookJson+            { content = wh ^. #content+            , username = wh ^. #username+            , avatarUrl = wh ^. #avatarUrl+            , tts = wh ^. #tts+            , embeds = wh ^. #embeds+            , allowedMentions = wh ^. #allowedMentions+            , components = wh ^. #components+            , attachments = attachments+            }+    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)     postWithP' body ("wait" =:? (wh ^. #wait)) u o

@@ -0,0 +1,64 @@+-- | Calamity Interaction views+module Calamity.Interactions (+  module Calamity.Interactions.View,+  module Calamity.Interactions.Utils,+  module Calamity.Interactions.Eff,++  -- * Interactions and Views+  -- $viewDocs+) where++import Calamity.Interactions.Eff+import Calamity.Interactions.Utils+import Calamity.Interactions.View++{- $viewDocs++ This module contains functions and types related to handling discord interactions.++ The data models for components can be found in "Calamity.Types.Model.Channel.Component"++ ==== Examples++ Displaying a 'View'++ @+ {-# LANGUAGE ApplicativeDo #-}++ let view = 'row' $ do+       a <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "defer"+       b <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "deferEph"+       c <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "deferComp"+       d <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "modal"+       pure (a, b, c, d)++     modalView = do+       a <- 'textInput' 'Calamity.Types.Model.Channel.Component.TextInputShort' "a"+       b <- 'textInput' 'Calamity.Types.Model.Channel.Component.TextInputParagraph' "b"+       pure (a, b)+ in 'runView' view ('Calamity.tell' ctx) $ \\(a, b, c, d) -> do+      'Control.Monad.when' a $ do+        'Control.Monad.void' 'defer'+        'Polysemy.embed' $ threadDelay 1000000+        'Control.Monad.void' $ 'followUp' \@'Data.Text.Text' "lol"++      'Control.Monad.when' b $ do+        'Control.Monad.void' 'deferEphemeral'+        'Polysemy.embed' $ threadDelay 1000000+        'Control.Monad.void' $ 'followUpEphemeral' \@'Data.Text.Text' "lol"++      'Control.Monad.when' c $ do+        'Control.Monad.void' 'deferComponent'+        'Polysemy.embed' $ threadDelay 1000000+        'Control.Monad.void' $ 'followUp' \@'Data.Text.Text' "lol"++      'Control.Monad.when' d $ do+        'Control.Monad.void' . 'Polysemy.Async.async' $ do+          'runView' modalView ('Control.Monad.void' . 'pushModal' "lol") $ \(a, b) -> do+            'Polysemy.embed' $ print (a, b)+            'Control.Monad.void' $ 'respond' ("Thanks: " <> a <> " " <> b)+            'endView' ()++      pure ()+ @+-}

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Effect for working with an interaction+module Calamity.Interactions.Eff (+  InteractionEff (..),+  getInteraction,+  getInteractionID,+  getApplicationID,+  getInteractionToken,+  getInteractionUser,+) where++import Calamity.Types.Model.Interaction+import Calamity.Types.Model.User (User)+import Calamity.Types.Snowflake+import Control.Applicative ((<|>))+import Control.Lens ((^.), (^?), _Just)+import Data.Maybe (fromJust)+import Polysemy+import qualified Polysemy as P++data InteractionEff m a where+  GetInteraction :: InteractionEff m Interaction++makeSem ''InteractionEff++getInteractionID :: P.Member InteractionEff r => P.Sem r (Snowflake Interaction)+getInteractionID = (^. #id) <$> getInteraction++getApplicationID :: P.Member InteractionEff r => P.Sem r (Snowflake Application)+getApplicationID = (^. #applicationID) <$> getInteraction++getInteractionToken :: P.Member InteractionEff r => P.Sem r InteractionToken+getInteractionToken = (^. #token) <$> getInteraction++getInteractionUser :: P.Member InteractionEff r => P.Sem r (Snowflake User)+getInteractionUser = do+  int <- getInteraction+  let uid = int ^? #user . _Just . #id+      mid = int ^? #member . _Just . #id+  pure . fromJust $ uid <|> mid+

@@ -0,0 +1,199 @@+-- | Interaction related utilities+module Calamity.Interactions.Utils (+  respond,+  respondEphemeral,+  followUp,+  followUpEphemeral,+  edit,+  defer,+  deferEphemeral,+  deferComponent,+  pushModal,+  userLocalState,+) where++import Calamity.HTTP+import Calamity.Interactions.Eff (InteractionEff, getInteractionID, getInteractionToken, getInteractionUser, getApplicationID)+import Calamity.Metrics.Eff (MetricEff)+import Calamity.Types.LogEff (LogEff)+import Calamity.Types.Model.Channel.Component (Component (ActionRow'))+import Calamity.Types.Model.User (User)+import Calamity.Types.Snowflake (Snowflake)+import Calamity.Types.Tellable+import Control.Lens ((^.))+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import qualified Polysemy as P+import qualified Polysemy.State as P+import System.Random (getStdRandom, uniform)++{- | Provide local state semantics to a running view, the state is keyed to the+ user invoking the interaction+-}+userLocalState ::+  forall r s a.+  P.Member InteractionEff r =>+  -- | Initial state+  s ->+  P.Sem (P.State s ': r) a ->+  P.Sem r a+userLocalState s =+  P.evalState H.empty+    . P.reinterpret @(P.State s) @(P.State (H.HashMap (Snowflake User) s))+      ( \case+          P.Get -> do+            uid <- getInteractionUser+            P.gets (H.lookupDefault s uid)+          P.Put s -> do+            uid <- getInteractionUser+            P.modify' (H.insert uid s)+      )++-- | Respond to an interaction with a globally visible message+respond :: forall t r.+  (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) =>+  t ->+  P.Sem r (Either RestError ())+respond (runToMessage -> msg) =+  let opts =+        InteractionCallbackMessageOptions+          { tts = msg ^. #tts+          , content = msg ^. #content+          , embeds = msg ^. #embeds+          , allowedMentions = msg ^. #allowedMentions+          , ephemeral = Just False+          , suppressEmbeds = Just False+          , components = msg ^. #components+          , attachments = msg ^. #attachments+          }+   in do+        interactionID <- getInteractionID+        interactionToken <- getInteractionToken+        invoke $ CreateResponseMessage interactionID interactionToken opts++-- | Respond to an interaction with an ephemeral message+respondEphemeral :: forall t r.+  (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) =>+  t ->+  P.Sem r (Either RestError ())+respondEphemeral (runToMessage -> msg) =+  let opts =+        InteractionCallbackMessageOptions+          { tts = msg ^. #tts+          , content = msg ^. #content+          , embeds = msg ^. #embeds+          , allowedMentions = msg ^. #allowedMentions+          , ephemeral = Just True+          , suppressEmbeds = Just False+          , components = msg ^. #components+          , attachments = msg ^. #attachments+          }+   in do+        interactionID <- getInteractionID+        interactionToken <- getInteractionToken+        invoke $ CreateResponseMessage interactionID interactionToken opts++-- | Respond to an interaction by editing the message that triggered the interaction+edit :: forall t r.+  (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) =>+  t ->+  P.Sem r (Either RestError ())+edit (runToMessage -> msg) =+  let opts =+        InteractionCallbackMessageOptions+          { tts = msg ^. #tts+          , content = msg ^. #content+          , embeds = msg ^. #embeds+          , allowedMentions = msg ^. #allowedMentions+          , ephemeral = Nothing+          , suppressEmbeds = Nothing+          , components = msg ^. #components+          , attachments = msg ^. #attachments+          }+   in do+        interactionID <- getInteractionID+        interactionToken <- getInteractionToken+        invoke $ CreateResponseUpdate interactionID interactionToken opts++-- | Create a follow up response to an interaction+followUp :: forall t r.+  (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) =>+  t ->+  P.Sem r (Either RestError ())+followUp (runToMessage -> msg) =+  let opts =+        InteractionCallbackMessageOptions+          { tts = msg ^. #tts+          , content = msg ^. #content+          , embeds = msg ^. #embeds+          , allowedMentions = msg ^. #allowedMentions+          , ephemeral = Nothing+          , suppressEmbeds = Nothing+          , components = msg ^. #components+          , attachments = msg ^. #attachments+          }+   in do+        applicationID <- getApplicationID+        interactionToken <- getInteractionToken+        invoke $ CreateFollowupMessage applicationID interactionToken opts++-- | Create an ephemeral follow up response to an interaction+followUpEphemeral :: forall t r.+  (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) =>+  t ->+  P.Sem r (Either RestError ())+followUpEphemeral (runToMessage -> msg) =+  let opts =+        InteractionCallbackMessageOptions+          { tts = msg ^. #tts+          , content = msg ^. #content+          , embeds = msg ^. #embeds+          , allowedMentions = msg ^. #allowedMentions+          , ephemeral = Just True+          , suppressEmbeds = Nothing+          , components = msg ^. #components+          , attachments = msg ^. #attachments+          }+   in do+        applicationID <- getApplicationID+        interactionToken <- getInteractionToken+        invoke $ CreateFollowupMessage applicationID interactionToken opts++-- | Defer an interaction and show a loading state, use @followUp@ later on+defer :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+defer = do+  interactionID <- getInteractionID+  interactionToken <- getInteractionToken+  invoke $ CreateResponseDefer interactionID interactionToken False++-- | Defer an interaction and show an ephemeral loading state, use @followUp@+-- later on+deferEphemeral :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+deferEphemeral = do+  interactionID <- getInteractionID+  interactionToken <- getInteractionToken+  invoke $ CreateResponseDefer interactionID interactionToken True++-- | Defer operation+deferComponent :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+deferComponent = do+  interactionID <- getInteractionID+  interactionToken <- getInteractionToken+  invoke $ CreateResponseDeferComponent interactionID interactionToken++fixupActionRow :: Component -> Component+fixupActionRow r@(ActionRow' _) = r+fixupActionRow x = ActionRow' [x]++{- | Push a modal as a response to an interaction++ You should probably use this with 'Calamity.Interaction.View.runView'+-}+pushModal :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => Text -> [Component] -> P.Sem r (Either RestError ())+pushModal title c = do+  -- we don't actually use the custom id of the modal. the custom ids of the+  -- sub-components are enough to disambiguate+  cid <- P.embed $ getStdRandom uniform+  interactionID <- getInteractionID+  interactionToken <- getInteractionToken+  invoke . CreateResponseModal interactionID interactionToken $ InteractionCallbackModal cid title (map fixupActionRow c)

@@ -0,0 +1,428 @@+{-# LANGUAGE TemplateHaskell #-}++module Calamity.Interactions.View (+  ViewEff (..),+  endView,+  replaceView,+  getSendResponse,+  View,+  row,+  runView,+  runViewInstance,+  button,+  button',+  select,+  select',+  textInput,+  textInput',+  deleteInitialMsg,+  instantiateView,+) where++import Calamity.Client.Client (react)+import Calamity.Client.Types (BotC, EventType (InteractionEvt))+import Calamity.HTTP.Channel (ChannelRequest (DeleteMessage))+import Calamity.HTTP.Internal.Ratelimit (RatelimitEff)+import Calamity.HTTP.Internal.Request (invoke)+import Calamity.Interactions.Eff (InteractionEff (..))+import Calamity.Internal.AesonThings+import Calamity.Metrics.Eff (MetricEff)+import Calamity.Types.LogEff (LogEff)+import Calamity.Types.Model.Channel.Component (CustomID)+import qualified Calamity.Types.Model.Channel.Component as C+import Calamity.Types.Model.Channel.Message (Message)+import Calamity.Types.Model.Interaction+import Calamity.Types.TokenEff (TokenEff)+import qualified Control.Concurrent.STM as STM+import Control.Lens ((.~), (?~), (^.), (^..), _1, _2, _3, _Just)+import Control.Monad (guard, void)+import qualified Data.Aeson+import Data.Aeson.Lens (AsValue (_Array), key)+import qualified Data.List+import qualified Data.Set as S+import Data.Text (Text)+import GHC.Generics (Generic)+import qualified GHC.TypeLits as E+import qualified Polysemy as P+import qualified Polysemy.Resource as P+import qualified Polysemy.State as P+import System.Random++data ViewComponent a = ViewComponent+  { component :: C.Component+  , parse :: Interaction -> ExtractResult a+  }++instance Functor ViewComponent where+  fmap f ViewComponent {component, parse} = ViewComponent {component, parse = fmap f . parse}++{- | A view containing one or more components++ This has an applicative interface to allow for easy composition of+ components.+-}+data View a+  = NilView a+  | SingView (forall g. RandomGen g => g -> (ViewComponent a, g))+  | RowView (View a)+  | forall x. MultView (View (x -> a)) (View x)++{- | Convert a 'View' such that it renders as a row.++ Note: nested rows are not allowed by discord, along with further restrictions+ listed here:+ https://discord.com/developers/docs/interactions/message-components+-}+row :: View a -> View a+row = RowView++instance Functor View where+  fmap f (NilView x) = NilView (f x)+  fmap f (SingView x) = SingView (\r -> let (x', r') = x r in (f <$> x', r'))+  fmap f (RowView x) = RowView (fmap f x)+  fmap f (MultView x y) = MultView (fmap (f .) x) y++instance Applicative View where+  pure = NilView+  (<*>) = MultView++type MonadViewMessage =+  'E.ShowType View+    'E.:<>: 'E.Text " doesn't have a Monad instance as we need to be able to inspect the contained components"+    'E.:$$: 'E.Text "If you haven't already, enable ApplicativeDo"+    'E.:$$: 'E.Text "Also, make sure you use lazy patterns: ~(a, b) instead of (a, b)"+    'E.:$$: 'E.Text "Refer to https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/applicative_do.html"++instance E.TypeError MonadViewMessage => Monad View where+  (>>=) = undefined -- unreachable++data ExtractOkType+  = -- | At least one value has been extracted+    SomeExtracted+  | -- | No values have been extracted, we shouldn't trigger the callback+    NoneExtracted+  deriving (Show)++instance Semigroup ExtractOkType where+  SomeExtracted <> _ = SomeExtracted+  _ <> SomeExtracted = SomeExtracted+  _ <> _ = NoneExtracted++data ExtractResult a+  = -- | Extraction succeeded in some way+    ExtractOk ExtractOkType a+  | -- | Bail out from parsing this interaction for the current view+    ExtractFail+  deriving (Show, Functor)++instance Applicative ExtractResult where+  pure = ExtractOk SomeExtracted++  ExtractOk ta f <*> ExtractOk tb x = ExtractOk (ta <> tb) $ f x+  _ <*> _ = ExtractFail++data ViewInstance a = ViewInstance+  { -- customIDS :: Set C.CustomID ,+    extract :: Interaction -> ExtractResult a+  , rendered :: [C.Component]+  }++data ViewEff ret inp sendResp m a where+  -- | Mark the view as finished and set the return value.+  --+  -- This doesn't trigger the immediate exit from the code it is used in, the+  -- view will exit before it would wait for the next event.+  EndView :: ret -> ViewEff ret inp sendResp m ()+  -- | Given a view and a way to display the rendered view to discord, show the+  -- view and start tracking the new view+  --+  -- This works for both message components and modals+  ReplaceView :: View inp -> ([C.Component] -> m ()) -> ViewEff ret inp sendResp m ()+  -- | Get the result of the action that sent a value+  GetSendResponse :: ViewEff ret inp sendResp m sendResp++P.makeSem ''ViewEff++extractCustomID :: Interaction -> Maybe CustomID+extractCustomID Interaction {data_, type_} = do+  guard $ type_ == MessageComponentType+  data' <- data_+  data' ^. #customID++guardComponentType :: Interaction -> C.ComponentType -> Maybe ()+guardComponentType Interaction {data_} expected = do+  data' <- data_+  guard $ data' ^. #componentType == Just expected++extractOkFromMaybe :: Maybe a -> ExtractResult (Maybe a)+extractOkFromMaybe (Just a) = ExtractOk SomeExtracted (Just a)+extractOkFromMaybe Nothing = ExtractOk NoneExtracted Nothing++extractOkFromBool :: Bool -> ExtractResult Bool+extractOkFromBool True = ExtractOk SomeExtracted True+extractOkFromBool False = ExtractOk NoneExtracted False++{- | Construct a 'View' containing a 'C.Button' with the given style and label++ Other fields of 'C.Button' default to 'Nothing'+-}+button :: C.ButtonStyle -> Text -> View Bool+button s l = button' ((#style .~ s) . (#label ?~ l))++{- | Construct a 'View' containing a 'C.Button', then modify the component with+   the passed mapping function++ The 'C.Button' passed to the mapping function will have a style of+ 'C.ButtonPrimary', other fields will be 'Nothing'+-}+button' :: (C.Button -> C.Button) -> View Bool+button' f = SingView $ \g ->+  let (cid, g') = uniform g+      comp = C.Button' . f $ C.button C.ButtonPrimary cid+      parse' int =+        Just True+          == ( do+                customID <- extractCustomID int+                guardComponentType int C.ButtonType+                pure $ customID == cid+             )+      parse = extractOkFromBool . parse'+   in (ViewComponent comp parse, g')++{- | Construct a 'View' containing a 'C.Select' with the given list of values++ Each element of the passed options list is used as both the display+ 'C.SelectOption.label' and 'C.SelectOption.value', use 'select'' if you+ desire more control+-}+select :: [Text] -> View (Maybe Text)+select opts = ensureOne <$> select' (map (\x -> C.sopt x x) opts) Prelude.id+  where+    ensureOne :: Maybe [Text] -> Maybe Text+    ensureOne mx = do+      o <- mx+      guard $ length o == 1+      case o of+        [x] -> Just x+        _ -> Nothing++{- | Construct a 'View' containing a 'C.Select' with the given options, then+ modify the component with the passed mapping function+-}+select' :: [C.SelectOption] -> (C.Select -> C.Select) -> View (Maybe [Text])+select' opts f = SingView $ \g ->+  let (cid, g') = uniform g+      comp = f $ C.select opts cid+      finalValues = S.fromList $ comp ^.. #options . traverse . #value+      parse int = extractOkFromMaybe $ do+        customID <- extractCustomID int+        guard $ customID == cid+        guardComponentType int C.SelectType+        values <- int ^. #data_ . _Just . #values+        let values' = S.fromList values+        guard $ S.isSubsetOf values' finalValues+        pure values+   in (ViewComponent (C.Select' comp) parse, g')++data TextInputDecoded = TextInputDecoded+  { value :: Maybe Text+  , customID :: CustomID+  }+  deriving (Show, Generic)+  deriving (Data.Aeson.FromJSON) via CalamityJSON TextInputDecoded++parseTextInput :: CustomID -> Interaction -> ExtractResult (Maybe Text)+parseTextInput cid int = extractOkFromMaybe $ do+  components <- int ^. #data_ . _Just . #components+  -- currently, each text input is a singleton actionrow containing a single textinput component++  let textInputs = components ^.. traverse . key "components" . _Array . traverse+      inputs' :: Data.Aeson.Result [TextInputDecoded] = traverse Data.Aeson.fromJSON textInputs++  inputs <- case inputs' of+    Data.Aeson.Success x -> pure x+    Data.Aeson.Error _ -> Nothing++  thisValue <- Data.List.find ((== cid) . (^. #customID)) inputs++  thisValue ^. #value++{- | Construct a 'View' containing a 'C.TextInput' with the given style and label++ All other fields of 'C.TextInput' default to 'Nothing'++ This view ensures that a value was passed for an input+-}+textInput ::+  C.TextInputStyle ->+  -- | Label+  Text ->+  View Text+textInput s l = SingView $ \g ->+  let (cid, g') = uniform g+      comp = C.TextInput' $ C.textInput s l cid+      parse = ensure <$> parseTextInput cid+   in (ViewComponent comp parse, g')+  where+    ensure (ExtractOk v (Just x)) = ExtractOk v x+    ensure _ = ExtractFail++{- | Construct a 'View' containing a 'C.TextInput' with the given style and label,+   then modify the component with the passed mapping function+-}+textInput' ::+  C.TextInputStyle ->+  -- | Label+  Text ->+  (C.TextInput -> C.TextInput) ->+  View (Maybe Text)+textInput' s l f = SingView $ \g ->+  let (cid, g') = uniform g+      comp = C.TextInput' . f $ C.textInput s l cid+      parse = parseTextInput cid+   in (ViewComponent comp parse, g')++-- componentIDS :: C.Component -> S.Set CustomID+-- componentIDS (C.ActionRow' coms) = S.unions $ map componentIDS coms+-- componentIDS (C.Button' C.Button {customID}) = S.singleton customID+-- componentIDS (C.LinkButton' _) = S.empty+-- componentIDS (C.Select' C.Select {customID}) = S.singleton customID+-- componentIDS (C.TextInput' C.TextInput {customID}) = S.singleton customID++-- | Generate a 'ViewInstance' of a 'View' by filling in 'CustomID's with random values+instantiateView :: RandomGen g => g -> View a -> (ViewInstance a, g)+instantiateView g v =+  case v of+    NilView x -> (ViewInstance (const $ ExtractOk SomeExtracted x) [], g)+    SingView f ->+      let (ViewComponent c p, g') = f g+          i = ViewInstance p [c]+       in (i, g')+    RowView x ->+      let (v'@ViewInstance {rendered}, g') = instantiateView g x+       in (v' {rendered = [C.ActionRow' rendered]}, g')+    MultView a b ->+      let (ViewInstance ia ra, g') = instantiateView g a+          (ViewInstance ib rb, g'') = instantiateView g' b+          inv i = ia i <*> ib i+       in (ViewInstance inv (ra <> rb), g'')++-- | Delete the initial message containing components+deleteInitialMsg :: (BotC r, P.Member (ViewEff a inp (Either e Message)) r) => P.Sem r ()+deleteInitialMsg = do+  ini <- getSendResponse+  case ini of+    Right m ->+      void . invoke $ DeleteMessage m m+    Left _ -> pure ()++-- | Run a 'View', returning the value passed to 'endView'+--+-- This function will not return until 'endView' is used inside the view.+-- If you want it to run in the background, consider using "Polysemy.Async".+--+-- This is async exception safe, you can use libraries such as+-- [polysemy-conc](https://hackage.haskell.org/package/polysemy-conc) to stop+-- views after a timeout.+runView ::+  BotC r =>+  -- | The initial view to render+  View inp ->+  -- | A function to send the rendered view (i.e. as a message or a modal)+  ([C.Component] -> P.Sem r sendResp) ->+  -- | Your callback effect.+  --+  -- local state semantics are preserved between calls here, you can keep state around+  (inp -> P.Sem (InteractionEff ': ViewEff a inp sendResp ': r) ()) ->+  P.Sem r a+runView v sendRendered m = do+  inst@ViewInstance {rendered} <- getStdRandom (`instantiateView` v)+  r <- sendRendered rendered+  runViewInstance r inst m++{- | Run a prerendered 'View', returning the value passed to 'endView'++ This function won't send the view, you should do that yourself+-}+runViewInstance ::+  BotC r =>+  -- | An initial value to act as the value of @GetSendResponse@+  --+  -- If you just sent a message, probably pass that+  sendResp ->+  -- | The initial view to run+  ViewInstance inp ->+  -- | Your callback effect.+  --+  -- In here you get access to the 'InteractionEff' and 'ViewEff' effects.+  --+  -- local state semantics are preserved between calls here, you can keep state around+  (inp -> P.Sem (InteractionEff ': ViewEff a inp sendResp ': r) ()) ->+  P.Sem r a+runViewInstance initSendResp inst m = P.resourceToIOFinal $ do+  eventIn <- P.embed STM.newTQueueIO++  P.bracket+    (P.raise $ react @'InteractionEvt (P.embed . sender eventIn))+    P.raise+    ( \_ -> do+        P.raise $ innerLoop initSendResp inst eventIn m+    )+  where+    interpretInteraction ::+      forall r.+      Interaction ->+      P.Sem (InteractionEff ': r) () ->+      P.Sem r ()+    interpretInteraction int =+      P.interpret+        ( \case+            GetInteraction -> pure int+        )++    interpretView ::+      forall r ret inp sendResp.+      P.Member (P.Embed IO) r =>+      P.Sem (ViewEff ret inp sendResp ': r) () ->+      P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) ()+    interpretView =+      P.reinterpretH+        ( \case+            EndView x -> P.modify' (_1 ?~ x) >>= P.pureT+            ReplaceView v m -> do+              inst@ViewInstance {rendered} <- P.embed $ getStdRandom (`instantiateView` v)+              P.modify' (_2 .~ inst)+              P.runTSimple $ m rendered+            GetSendResponse -> P.gets (^. _3) >>= P.pureT+        )++    innerLoop ::+      forall r ret inp sendResp.+      P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r =>+      sendResp ->+      ViewInstance inp ->+      STM.TQueue Interaction ->+      (inp -> P.Sem (InteractionEff ': ViewEff ret inp sendResp ': r) ()) ->+      P.Sem r ret+    innerLoop initialSendResp initialInst inChan m = P.evalState (Nothing, initialInst, initialSendResp) innerLoop'+      where+        innerLoop' :: P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) ret+        innerLoop' = do+          (s, ViewInstance {extract}, _) <- P.get+          case s of+            Just x -> pure x+            Nothing -> do+              int <- P.embed $ STM.atomically (STM.readTQueue inChan)+              case extract int of+                ExtractOk SomeExtracted x -> interpretView $ interpretInteraction int (m x)+                _ -> pure ()++              -- if Just True == ((`S.member` customIDS) <$> extractCustomID int)+              --   then case extract int of+              --     ExtractOk SomeExtracted x -> interpretView $ interpretInteraction int (m x)+              --     _ -> pure ()+              --   else pure ()+              innerLoop'++    sender :: STM.TQueue Interaction -> Interaction -> IO ()+    sender eventIn int = STM.atomically $ STM.writeTQueue eventIn int

@@ -1,32 +1,33 @@-module Calamity.Internal.AesonThings-    ( WithSpecialCases(..)-    , IfNoneThen-    , ExtractFieldFrom-    , ExtractFieldInto-    , ExtractFields-    , ExtractArrayField-    , DefaultToEmptyArray-    , DefaultToZero-    , DefaultToFalse-    , DefaultToTrue-    , CalamityJSON(..)-    , CalamityJSONKeepNothing(..)-    , jsonOptions-    , jsonOptionsKeepNothing ) where+module Calamity.Internal.AesonThings (+  WithSpecialCases (..),+  IfNoneThen,+  ExtractFieldFrom,+  ExtractFieldInto,+  ExtractFields,+  ExtractArrayField,+  DefaultToEmptyArray,+  DefaultToZero,+  DefaultToFalse,+  DefaultToTrue,+  CalamityJSON (..),+  CalamityJSONKeepNothing (..),+  jsonOptions,+  jsonOptionsKeepNothing,+) where -import           Control.Lens+import Control.Lens -import           Data.Aeson-import           Data.Aeson.Lens-import           Data.Aeson.Types      ( Parser )-import           Data.Kind-import           Data.Reflection       ( Reifies(..) )-import           Data.Typeable-import           Data.String           ( IsString(fromString) )+import Data.Aeson+import Data.Aeson.Lens+import Data.Aeson.Types (Parser)+import Data.Kind+import Data.Reflection (Reifies (..))+import Data.String (IsString (fromString))+import Data.Typeable -import           GHC.Generics-import           GHC.TypeLits          ( KnownSymbol, symbolVal )-import           Control.Monad ((>=>))+import Control.Monad ((>=>))+import GHC.Generics+import GHC.TypeLits (KnownSymbol, symbolVal)  textSymbolVal :: forall n s. (KnownSymbol n, IsString s) => s textSymbolVal = fromString $ symbolVal @n Proxy@@ -49,15 +50,18 @@ instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where   runAction _ o =     let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field)-    in pure $ o & at (textSymbolVal @target) .~ v+     in pure $ o & at (textSymbolVal @target) .~ v  instance PerformAction (ExtractFields label '[]) where   runAction _ = pure -instance (KnownSymbol field,-          PerformAction (ExtractFieldInto label field field),-          PerformAction (ExtractFields label fields)) =>-         PerformAction (ExtractFields label (field : fields)) where+instance+  ( KnownSymbol field+  , PerformAction (ExtractFieldInto label field field)+  , PerformAction (ExtractFields label fields)+  ) =>+  PerformAction (ExtractFields label (field : fields))+  where   runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields))  instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where@@ -85,13 +89,14 @@     o' <- runSpecialCases (Proxy @xs) o     runAction (Proxy @action) o' -instance (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a))-  => FromJSON (WithSpecialCases rules a) where+instance+  (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a)) =>+  FromJSON (WithSpecialCases rules a)+  where   parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do     o' <- runSpecialCases (Proxy @rules) o     WithSpecialCases <$> genericParseJSON jsonOptions (Object o') - data DefaultToEmptyArray  instance Reifies DefaultToEmptyArray Value where@@ -138,12 +143,17 @@   parseJSON = fmap CalamityJSONKeepNothing . genericParseJSON jsonOptionsKeepNothing  jsonOptions :: Options-jsonOptions = defaultOptions { sumEncoding        = UntaggedValue-                             , fieldLabelModifier = camelTo2 '_' . filter (/= '_')-                             , omitNothingFields  = True }+jsonOptions =+  defaultOptions+    { sumEncoding = UntaggedValue+    , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+    , omitNothingFields = True+    }  jsonOptionsKeepNothing :: Options-jsonOptionsKeepNothing = defaultOptions { sumEncoding        = UntaggedValue-                                        , fieldLabelModifier = camelTo2 '_' . filter (/= '_')-                                        , omitNothingFields  = False }-+jsonOptionsKeepNothing =+  defaultOptions+    { sumEncoding = UntaggedValue+    , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+    , omitNothingFields = False+    }

@@ -72,7 +72,6 @@       & updateNullableDest @"application" n       & updateNullableDest @"messageReference" n       & mergeF @"flags" n-      & updateNullableDest @"stickers" n       & updateNullableDest @"referencedMessage" n       & updateNullableDest @"interaction" n       & mergeF @"components" n

@@ -22,9 +22,10 @@   MaybeNull (..), ) where -import Calamity.Internal.RunIntoIO+-- import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative+import Control.Monad (when) import Data.Aeson import Data.Aeson.Encoding (null_) import Data.Default.Class@@ -33,9 +34,9 @@ import Data.Text import qualified Data.Vector.Unboxing as VU import qualified DiPolysemy as Di+import GHC.Generics import qualified Polysemy as P import TextShow-import GHC.Generics import qualified TextShow.Generic as TSG  {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks@@ -43,18 +44,16 @@  This means Polysemy.Error won't work to break the loop, etc.  Instead, Error/Alternative will just result in the loop quitting. -}-whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r ()+whileMFinalIO :: P.Sem r Bool -> P.Sem r () whileMFinalIO action = do-  action' <- runSemToIO action-  P.embedFinal $ go action'- where-  go action' = do-    r <- action'-    case r of-      Just True ->-        go action'-      _ ->-        pure ()+  go action+  where+    go action = do+      r <- action+      when r $ go_b action+    {-# INLINE go #-}+    go_b = go+    {-# NOINLINE go_b #-}  {- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks @@ -63,16 +62,18 @@ -} untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a untilJustFinalIO action = do-  action' <- runSemToIO action-  P.embedFinal $ go action'- where-  go action' = do-    r <- action'-    case r of-      Just (Just a) ->-        pure a-      _ ->-        go action'+  go action+  where+    go action = do+      r <- action+      case r of+        Just a ->+          pure a+        _ ->+          go_b action+    {-# INLINE go #-}+    go_b = go+    {-# NOINLINE go_b #-}  whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ())@@ -148,10 +149,11 @@  newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a}   deriving (FromJSON, ToJSON) via a-  deriving TextShow via FromStringShow a+  deriving (TextShow) via FromStringShow a --- | An alternative 'Maybe' type that allows us to distinguish between parsed--- json fields that were null, and fields that didn't exist.+{- | An alternative 'Maybe' type that allows us to distinguish between parsed+ json fields that were null, and fields that didn't exist.+-} data MaybeNull a   = WasNull   | NotNull a

@@ -11,11 +11,13 @@   module Calamity.Types.Model.Channel.Embed,   module Calamity.Types.Model.Channel.ChannelType,   module Calamity.Types.Model.Channel.Message,+  module Calamity.Types.Model.Channel.Component, ) where  import Calamity.Internal.AesonThings import Calamity.Types.Model.Channel.Attachment import Calamity.Types.Model.Channel.ChannelType+import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Channel.DM import Calamity.Types.Model.Channel.Embed import Calamity.Types.Model.Channel.Group@@ -23,9 +25,8 @@ import Calamity.Types.Model.Channel.Message import Calamity.Types.Model.Channel.Reaction import Calamity.Types.Model.Channel.Webhook-import Calamity.Types.Partial+import Calamity.Types.Model.Guild.Permissions (Permissions) import Calamity.Types.Snowflake- import Data.Aeson import Data.Text (Text) import GHC.Generics@@ -59,6 +60,7 @@   { id :: Snowflake Channel   , name :: Text   , type_ :: !ChannelType+  , permissions :: Maybe Permissions   , parentID :: Maybe (Snowflake Category)   }   deriving (Show, Eq, Generic)

@@ -1,7 +1,8 @@ -- | Message attachments-module Calamity.Types.Model.Channel.Attachment (Attachment (..)) where+module Calamity.Types.Model.Channel.Attachment (+  Attachment (..),+) where -import Calamity.Internal.AesonThings () import Calamity.Types.Snowflake import Data.Aeson import Data.Text (Text)@@ -29,7 +30,7 @@   deriving (HasID Attachment) via HasIDField "id" Attachment  instance ToJSON Attachment where-  toJSON Attachment{id, filename, size, url, proxyUrl, dimensions = Just (width, height)} =+  toJSON Attachment {id, filename, size, url, proxyUrl, dimensions = Just (width, height)} =     object       [ "id" .= id       , "filename" .= filename@@ -39,7 +40,7 @@       , "width" .= width       , "height" .= height       ]-  toJSON Attachment{id, filename, size, url, proxyUrl} =+  toJSON Attachment {id, filename, size, url, proxyUrl} =     object ["id" .= id, "filename" .= filename, "size" .= size, "url" .= url, "proxy_url" .= proxyUrl]  instance FromJSON Attachment where@@ -50,3 +51,4 @@     Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url"       <*> pure         (fuseTup2 (width, height))+

@@ -1,120 +1,291 @@ -- | Message components module Calamity.Types.Model.Channel.Component (-    Component (..),-    Button (..),-    button,-    button',-    ButtonStyle (..),-    ComponentType (..),-    componentType,+  CustomID (..),+  Component (..),+  Button (..),+  LinkButton (..),+  button,+  button',+  lbutton,+  lbutton',+  ButtonStyle (..),+  Select (..),+  select,+  SelectOption (..),+  sopt,+  TextInput (..),+  TextInputStyle (..),+  textInput,+  ComponentType (..),+  componentType, ) where  import Calamity.Internal.AesonThings import Calamity.Types.Model.Guild.Emoji+import Control.Monad (replicateM) import Data.Aeson import Data.Scientific (toBoundedInteger) import qualified Data.Text as T import GHC.Generics+import System.Random (Uniform)+import System.Random.Stateful (Uniform (uniformM), UniformRange (uniformRM)) import TextShow import qualified TextShow.Generic as TSG +newtype CustomID = CustomID T.Text+  deriving stock (Eq, Ord, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric CustomID+  deriving (ToJSON, FromJSON) via T.Text++instance Uniform CustomID where+  uniformM = ((CustomID . T.pack) <$>) . replicateM 16 . uniformRM ('a', 'z')+ data Button = Button-    { style :: ButtonStyle-    , label :: Maybe T.Text-    , emoji :: Maybe RawEmoji-    , customID :: Maybe T.Text-    , url :: Maybe T.Text-    , disabled :: Bool-    }-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric Button-    deriving (ToJSON) via CalamityJSONKeepNothing Button-    deriving-        (FromJSON)-        via WithSpecialCases-                '["disabled" `IfNoneThen` DefaultToFalse]-                Button+  { style :: ButtonStyle+  , label :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , disabled :: Bool+  , customID :: CustomID+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric Button+  deriving (ToJSON) via CalamityJSONKeepNothing Button+  deriving+    (FromJSON)+    via WithSpecialCases+          '["disabled" `IfNoneThen` DefaultToFalse]+          Button +data LinkButton = LinkButton+  { stype :: ButtonStyle+  , label :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , url :: T.Text+  , disabled :: Bool+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric LinkButton+  deriving (ToJSON) via CalamityJSONKeepNothing LinkButton+  deriving+    (FromJSON)+    via WithSpecialCases+          '["disabled" `IfNoneThen` DefaultToFalse]+          LinkButton+ data ButtonStyle-    = ButtonPrimary-    | ButtonSecondary-    | ButtonSuccess-    | ButtonDanger-    | ButtonLink-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric ButtonStyle+  = ButtonPrimary+  | ButtonSecondary+  | ButtonSuccess+  | ButtonDanger+  | ButtonLink+  deriving (Eq, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric ButtonStyle -{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle', all other- fields are set to 'Nothing'--}-button :: ButtonStyle -> Button-button s = Button s Nothing Nothing Nothing Nothing False+instance ToJSON ButtonStyle where+  toJSON t = toJSON @Int $ case t of+    ButtonPrimary -> 1+    ButtonSecondary -> 2+    ButtonSuccess -> 3+    ButtonDanger -> 4+    ButtonLink -> 5 -{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and label,+instance FromJSON ButtonStyle where+  parseJSON = withScientific "ButtonStyle" $ \n -> case toBoundedInteger @Int n of+    Just v -> case v of+      1 -> pure ButtonPrimary+      2 -> pure ButtonSecondary+      3 -> pure ButtonSuccess+      4 -> pure ButtonDanger+      5 -> pure ButtonLink+      _ -> fail $ "Invalid ButtonStyle: " <> show n+    Nothing -> fail $ "Invalid ButtonStyle: " <> show n++{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and 'CustomID',  all other fields are set to 'Nothing' -}-button' :: ButtonStyle -> T.Text -> Button-button' s l = Button s (Just l) Nothing Nothing Nothing False+button :: ButtonStyle -> CustomID -> Button+button s = Button s Nothing Nothing False -instance ToJSON ButtonStyle where-    toJSON t = toJSON @Int $ case t of-        ButtonPrimary -> 1-        ButtonSecondary -> 2-        ButtonSuccess -> 3-        ButtonDanger -> 4-        ButtonLink -> 5+{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle', 'CustomID',+ and label, all other fields are set to 'Nothing'+-}+button' :: ButtonStyle -> T.Text -> CustomID -> Button+button' s l = Button s (Just l) Nothing False -instance FromJSON ButtonStyle where-    parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of-        Just v -> case v of-            1 -> pure ButtonPrimary-            2 -> pure ButtonSecondary-            3 -> pure ButtonSuccess-            4 -> pure ButtonDanger-            5 -> pure ButtonLink-            _ -> fail $ "Invalid ButtonStyle: " <> show n-        Nothing -> fail $ "Invalid ButtonStyle: " <> show n+{- | Constuct a non-disabled 'LinkButton' with the given 'ButtonStyle', link, all+   other fields are set to 'Nothing'+-}+lbutton ::+  ButtonStyle ->+  -- | The link to use+  T.Text ->+  LinkButton+lbutton s lnk = LinkButton s Nothing Nothing lnk False +{- | Constuct a non-disabled 'LinkButton' with the given 'ButtonStyle', link,+ and label, all other fields are set to 'Nothing'+-}+lbutton' ::+  ButtonStyle ->+  -- | The link to use+  T.Text ->+  -- | The label to use+  T.Text ->+  LinkButton+lbutton' s lnk lbl = LinkButton s (Just lbl) Nothing lnk False++data Select = Select+  { options :: [SelectOption]+  , placeholder :: Maybe T.Text+  , minValues :: Maybe Int+  , maxValues :: Maybe Int+  , disabled :: Bool+  , customID :: CustomID+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric Select+  deriving (ToJSON) via CalamityJSONKeepNothing Select+  deriving+    (FromJSON)+    via WithSpecialCases+          '["disabled" `IfNoneThen` DefaultToFalse]+          Select++data SelectOption = SelectOption+  { label :: T.Text+  , value :: T.Text+  , description :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , default_ :: Bool+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric SelectOption+  deriving (ToJSON) via CalamityJSONKeepNothing SelectOption+  deriving+    (FromJSON)+    via WithSpecialCases+          '["default" `IfNoneThen` DefaultToFalse]+          SelectOption++select :: [SelectOption] -> CustomID -> Select+select o = Select o Nothing Nothing Nothing False++sopt ::+  -- | Label+  T.Text ->+  -- | Value+  T.Text ->+  SelectOption+sopt l v = SelectOption l v Nothing Nothing False++data TextInput = TextInput+  { style :: TextInputStyle+  , label :: T.Text+  , minLength :: Maybe Int+  , maxLength :: Maybe Int+  , required :: Bool+  , value :: Maybe T.Text+  , placeholder :: Maybe T.Text+  , customID :: CustomID+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric TextInput+  deriving (ToJSON) via CalamityJSONKeepNothing TextInput+  deriving+    (FromJSON)+    via WithSpecialCases+          '["required" `IfNoneThen` DefaultToFalse]+          TextInput++data TextInputStyle+  = TextInputShort+  | TextInputParagraph+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric TextInputStyle++instance ToJSON TextInputStyle where+  toJSON t = toJSON @Int $ case t of+    TextInputShort -> 1+    TextInputParagraph -> 2++instance FromJSON TextInputStyle where+  parseJSON = withScientific "TextInputStyle" $ \n -> case toBoundedInteger @Int n of+    Just v -> case v of+      1 -> pure TextInputShort+      2 -> pure TextInputParagraph+      _ -> fail $ "Invalid TextInputStyle: " <> show n+    Nothing -> fail $ "Invalid TextInputStyle: " <> show n++textInput ::+  TextInputStyle ->+  -- | Label+  T.Text ->+  CustomID ->+  TextInput+textInput s l = TextInput s l Nothing Nothing True Nothing Nothing+ data Component-    = Button' Button-    | ActionRow' [Component]-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric Component+  = ActionRow' [Component]+  | Button' Button+  | LinkButton' LinkButton+  | Select' Select+  | TextInput' TextInput+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric Component  instance ToJSON Component where-    toJSON t =-        let (Object inner, type_) = case t of-                ActionRow' xs -> (Object ("components" .= xs), 1 :: Int)-                Button' b -> (toJSON b, 2 :: Int)-         in Object (inner <> ("type" .= type_))+  toJSON t =+    let (Object inner, type_) = case t of+          ActionRow' xs -> (Object ("components" .= xs), 1 :: Int)+          Button' b -> (toJSON b, 2 :: Int)+          LinkButton' lb -> (toJSON lb, 2 :: Int)+          Select' s -> (toJSON s, 3 :: Int)+          TextInput' ti -> (toJSON ti, 4 :: Int)+     in Object (inner <> ("type" .= type_))  instance FromJSON Component where-    parseJSON = withObject "Component" $ \v -> do-        type_ :: Int <- v .: "type"+  parseJSON = withObject "Component" $ \v -> do+    type_ :: Int <- v .: "type" -        case type_ of-            1 -> do-                ActionRow' <$> v .: "components"-            2 -> Button' <$> parseJSON (Object v)-            _ -> fail $ "Invalid ComponentType: " <> show type_+    case type_ of+      1 -> ActionRow' <$> v .: "components"+      2 -> do+        cid :: Maybe CustomID <- v .:? "custom_id"+        url :: Maybe T.Text <- v .:? "url"+        case (cid, url) of+          (Just _, _) -> Button' <$> parseJSON (Object v)+          (_, Just _) -> LinkButton' <$> parseJSON (Object v)+          _ -> fail $ "Impossible button: " <> show v+      3 -> Select' <$> parseJSON (Object v)+      4 -> TextInput' <$> parseJSON (Object v)+      _ -> fail $ "Invalid ComponentType: " <> show type_  componentType :: Component -> ComponentType componentType (ActionRow' _) = ActionRowType componentType (Button' _) = ButtonType+componentType (LinkButton' _) = ButtonType+componentType (Select' _) = SelectType+componentType (TextInput' _) = TextInputType  data ComponentType-    = ActionRowType-    | ButtonType-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric ComponentType+  = ActionRowType+  | ButtonType+  | SelectType+  | TextInputType+  deriving (Eq, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric ComponentType  instance ToJSON ComponentType where-    toJSON x = toJSON @Int $ case x of-        ActionRowType -> 1-        ButtonType -> 2+  toJSON x = toJSON @Int $ case x of+    ActionRowType -> 1+    ButtonType -> 2+    SelectType -> 3+    TextInputType -> 4  instance FromJSON ComponentType where-    parseJSON = withScientific "ComponentType" $ \n -> case toBoundedInteger @Int n of-        Just 1 -> pure ActionRowType-        Just 2 -> pure ButtonType-        _ -> fail $ "Invalid ComponentType: " <> show n+  parseJSON = withScientific "ComponentType" $ \n -> case toBoundedInteger @Int n of+    Just 1 -> pure ActionRowType+    Just 2 -> pure ButtonType+    Just 3 -> pure SelectType+    Just 4 -> pure TextInputType+    _ -> fail $ "Invalid ComponentType: " <> show n

@@ -1,8 +0,0 @@-module Calamity.Types.Model.Channel.Guild.Category-    ( Category ) where---data Category--instance Show Category-instance Eq Category

@@ -6,8 +6,8 @@ import Calamity.Internal.SnowflakeMap (SnowflakeMap) import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel-import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category-import {-# SOURCE #-} Calamity.Types.Model.Channel.Message+import Calamity.Types.Model.Channel.Guild.Category+import Calamity.Types.Model.Channel.Message import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake

@@ -5,7 +5,7 @@ import Calamity.Internal.SnowflakeMap (SnowflakeMap) import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel-import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category+import Calamity.Types.Model.Channel.Guild.Category import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake

@@ -3,6 +3,7 @@   Message (..),   MessageType (..),   MessageReference (..),+  Partial (PartialMessage), ) where  import Calamity.Internal.AesonThings@@ -52,7 +53,6 @@   , application :: Maybe (CalamityFromStringShow Object)   , messageReference :: Maybe MessageReference   , flags :: Word64-  , stickers :: Maybe [CalamityFromStringShow Object]   , referencedMessage :: Maybe Message   , interaction :: Maybe (CalamityFromStringShow Object)   , components :: [Component]@@ -94,7 +94,6 @@   , application :: Maybe Object   , messageReference :: Maybe MessageReference   , flags :: Word64-  , stickers :: Maybe [Object]   , referencedMessage :: Maybe Message   , interaction :: Maybe Object   , components :: [Component]@@ -104,6 +103,15 @@   deriving (HasID Message) via HasIDField "id" Message   deriving (HasID Channel) via HasIDField "channelID" Message   deriving (HasID User) via HasIDField "author" Message++data instance Partial Message = PartialMessage+  { channelID :: Snowflake Channel+  , guildID :: Maybe (Snowflake Guild)+  }+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric (Partial Message)+  deriving (FromJSON) via CalamityJSON (Partial Message)+  deriving (HasID Channel) via HasIDField "channelID" (Partial Message)  data MessageReference = MessageReference   { messageID :: Maybe (Snowflake Message)

@@ -7,7 +7,6 @@ import Calamity.Internal.OverriddenVia import Calamity.Internal.Utils import Calamity.Types.Model.Channel-import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake@@ -40,7 +39,6 @@     , application :: Maybe (MaybeNull (CalamityFromStringShow Object))     , messageReference :: Maybe (MaybeNull MessageReference)     , flags :: Maybe Word64-    , stickers :: Maybe (MaybeNull [CalamityFromStringShow Object])     , referencedMessage :: Maybe (MaybeNull Message)     , interaction :: Maybe (MaybeNull (CalamityFromStringShow Object))     , components :: Maybe [Component]@@ -76,7 +74,6 @@     , application :: Maybe (MaybeNull Object)     , messageReference :: Maybe (MaybeNull MessageReference)     , flags :: Maybe Word64-    , stickers :: Maybe (MaybeNull [Object])     , referencedMessage :: Maybe (MaybeNull Message)     , interaction :: Maybe (MaybeNull Object)     , components :: Maybe [Component]

@@ -112,14 +112,14 @@   parseJSON = withObject "Guild" $ \v -> do     id <- v .: "id" -    -- sadly we have now way of logging members/channels/presences' that failed to parser here     members' <- do       members' <- v .: "members"-      pure . SM.fromList . mapMaybe (parseMaybe @Object @Member (\m -> parseJSON $ Object (m <> "guild_id" .= id))) $ members'+      pure . SM.fromList . mapMaybe (parseMaybe @Object @Member (parseJSON . Object)) $ members' +    -- sadly we have now way of logging channels/presences' that failed to parse here     channels' <- do       channels' <- v .: "channels"-      pure . SM.fromList . mapMaybe (parseMaybe @Object @GuildChannel (\m -> parseJSON $ Object (m <> "guild_id" .= id))) $ channels'+      pure . SM.fromList . mapMaybe (parseMaybe @Object @GuildChannel (\c -> parseJSON $ Object (c <> "guild_id" .= id))) $ channels'      presences' <- do       presences' <- v .: "presences"@@ -158,7 +158,7 @@       <*> v .:? "system_channel_id"       <*> v .:? "joined_at"       <*> v .: "large"-      <*> v .: "unavailable"+      <*> v .:? "unavailable" .!= False       <*> v .: "member_count"       <*> v .: "voice_states"       <*> pure members'

@@ -4,7 +4,6 @@ import Calamity.Internal.AesonThings import Calamity.Internal.OverriddenVia import Calamity.Internal.Utils-import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake@@ -29,7 +28,6 @@   , email :: Maybe Text   , flags :: Maybe Word64   , premiumType :: Maybe Word64-  , guildID :: Snowflake Guild   , nick :: Maybe Text   , roles :: AesonVector (Snowflake Role)   , joinedAt :: CalamityFromStringShow UTCTime@@ -67,7 +65,6 @@   , email :: Maybe Text   , flags :: Maybe Word64   , premiumType :: Maybe Word64-  , guildID :: Snowflake Guild   , nick :: Maybe Text   , roles :: Vector (Snowflake Role)   , joinedAt :: UTCTime@@ -76,6 +73,5 @@   }   deriving (Eq, Show, Generic, NFData)   deriving (TextShow, FromJSON) via OverriddenVia Member Member'-  deriving (HasID Guild) via HasIDField "guildID" Member   deriving (HasID Member) via HasIDFieldCoerce "id" Member User   deriving (HasID User) via HasIDField "id" Member

@@ -1,23 +1,27 @@ -- | Guilds that are unavailable-module Calamity.Types.Model.Guild.UnavailableGuild-    ( UnavailableGuild(..) ) where+module Calamity.Types.Model.Guild.UnavailableGuild (UnavailableGuild (..)) where -import           Calamity.Internal.AesonThings-import           Calamity.Types.Model.Guild.Guild-import           Calamity.Types.Snowflake+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Guild.Guild+import Calamity.Types.Snowflake -import           Data.Aeson+import Data.Aeson -import           GHC.Generics+import GHC.Generics -import           TextShow-import qualified TextShow.Generic                 as TSG+import TextShow+import qualified TextShow.Generic as TSG  data UnavailableGuild = UnavailableGuild-  { id          :: Snowflake Guild+  { id :: Snowflake Guild   , unavailable :: Bool   }-  deriving ( Eq, Show, Generic )-  deriving ( TextShow ) via TSG.FromGeneric UnavailableGuild-  deriving ( ToJSON, FromJSON ) via CalamityJSON UnavailableGuild-  deriving ( HasID Guild ) via HasIDField "id" UnavailableGuild+  deriving (Eq, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric UnavailableGuild+  deriving (ToJSON) via CalamityJSON UnavailableGuild+  deriving+    (FromJSON)+    via WithSpecialCases+          '["disabled" `IfNoneThen` DefaultToFalse]+          UnavailableGuild+  deriving (HasID Guild) via HasIDField "id" UnavailableGuild

@@ -1,15 +1,18 @@ -- | Discord Interactions module Calamity.Types.Model.Interaction (-    Interaction (..),-    ApplicationCommandInteractionData (..),-    ApplicationCommandInteractionDataResolved (..),-    InteractionType (..),+  Interaction (..),+  InteractionToken (..),+  InteractionData (..),+  ResolvedInteractionData (..),+  InteractionType (..),+  Application,+  ApplicationCommand, ) where  import Calamity.Internal.AesonThings import Calamity.Internal.OverriddenVia import Calamity.Internal.Utils-import Calamity.Types.Model.Channel (Channel)+import Calamity.Types.Model.Channel (Attachment, Channel, Partial) import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Channel.Message (Message) import Calamity.Types.Model.Guild (Guild, Role)@@ -21,81 +24,91 @@ import Data.Scientific (toBoundedInteger) import qualified Data.Text as T import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG -data Interaction = Interaction-    { id :: Snowflake Interaction-    , applicationID :: Snowflake ()-    , type_ :: InteractionType-    , data_ :: Maybe ApplicationCommandInteractionData-    , guildID :: Maybe (Snowflake Guild)-    , channelID :: Maybe (Snowflake Channel)-    , member :: Maybe Member-    , user :: Maybe User-    , token :: T.Text-    , version :: Int-    , message :: Maybe Message-    }-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric Interaction-    deriving (FromJSON) via CalamityJSON Interaction+-- | Empty type to flag application IDs+data Application -data ApplicationCommandInteractionData = ApplicationCommandInteractionData-    { id :: Snowflake () -- no Command type yet-    , name :: T.Text-    , resolved :: Maybe ApplicationCommandInteractionDataResolved-    , -- , options :: [ApplicationCommandInteractionDataOptions]-      -- No commands yet-      customID :: T.Text-    , componentType :: ComponentType-    }-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric ApplicationCommandInteractionData-    deriving (FromJSON) via CalamityJSON ApplicationCommandInteractionData+-- | Empty type to flag application command IDs+data ApplicationCommand -data ApplicationCommandInteractionDataResolved' = ApplicationCommandInteractionDataResolved'-    { users :: CalamityFromStringShow (H.HashMap (Snowflake User) User)-    , members :: CalamityFromStringShow (H.HashMap (Snowflake Member) Member)-    , roles :: CalamityFromStringShow (H.HashMap (Snowflake Role) Role)-    , channels :: CalamityFromStringShow (H.HashMap (Snowflake Channel) Channel)-    }-    deriving (Generic)-    deriving (TextShow) via TSG.FromGeneric ApplicationCommandInteractionDataResolved'-    deriving (FromJSON) via CalamityJSON ApplicationCommandInteractionDataResolved'+newtype InteractionToken = InteractionToken+  { fromInteractionToken :: T.Text+  }+  deriving stock (Show, Generic)+  deriving (FromJSON, ToJSON) via T.Text -data ApplicationCommandInteractionDataResolved = ApplicationCommandInteractionDataResolved-    { users :: H.HashMap (Snowflake User) User-    , members :: H.HashMap (Snowflake Member) Member-    , roles :: H.HashMap (Snowflake Role) Role-    , channels :: H.HashMap (Snowflake Channel) Channel-    }-    deriving (Show, Generic)-    deriving-        (TextShow, FromJSON)-        via OverriddenVia ApplicationCommandInteractionDataResolved ApplicationCommandInteractionDataResolved'+data Interaction = Interaction+  { id :: Snowflake Interaction+  , applicationID :: Snowflake Application+  , type_ :: InteractionType+  , data_ :: Maybe InteractionData+  , guildID :: Maybe (Snowflake Guild)+  , channelID :: Maybe (Snowflake Channel)+  , member :: Maybe Member+  , user :: Maybe User+  , token :: InteractionToken+  , version :: Int+  , message :: Maybe Message+  , locale :: Maybe T.Text+  , guildLocale :: Maybe T.Text+  }+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON Interaction+  deriving (HasID Interaction) via HasIDField "id" Interaction+  deriving (HasID Application) via HasIDField "applicationID" Interaction -data InteractionType-    = PingType-    | ApplicationCommandType-    | MessageComponentType-    deriving (Show, Generic)-    deriving (TextShow) via TSG.FromGeneric InteractionType+data InteractionData = InteractionData+  { id :: Maybe (Snowflake ApplicationCommand)+  , name :: Maybe T.Text+  , resolved :: Maybe ResolvedInteractionData+  , -- , options :: [ApplicationCommandInteractionDataOptions]+    -- No commands yet+    customID :: Maybe CustomID+  , componentType :: Maybe ComponentType+  , values :: Maybe [T.Text]+  , targetID :: Maybe (Snowflake ())+  , components :: Maybe [Value]+  }+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON InteractionData --- instance ToJSON InteractionType where---     toJSON x = toJSON @Int $ case x of---         PingType -> 1---         ApplicationCommandType -> 2---         MessageComponentType -> 3+data ResolvedInteractionData' = ResolvedInteractionData'+  { users :: CalamityFromStringShow (H.HashMap (Snowflake User) User)+  , members :: CalamityFromStringShow (H.HashMap (Snowflake Member) Member)+  , roles :: CalamityFromStringShow (H.HashMap (Snowflake Role) Role)+  , channels :: CalamityFromStringShow (H.HashMap (Snowflake Channel) (Partial Channel))+  , messages :: CalamityFromStringShow (H.HashMap (Snowflake Message) (Partial Message))+  , attachments :: CalamityFromStringShow (H.HashMap (Snowflake Attachment) Attachment)+  }+  deriving (Generic)+  deriving (FromJSON) via CalamityJSON ResolvedInteractionData' ---     toEncoding x = toEncoding @Int $ case x of---         PingType -> 1---         ApplicationCommandType -> 2---         MessageComponentType -> 3+data ResolvedInteractionData = ResolvedInteractionData+  { users :: H.HashMap (Snowflake User) User+  , members :: H.HashMap (Snowflake Member) Member+  , roles :: H.HashMap (Snowflake Role) Role+  , channels :: H.HashMap (Snowflake Channel) (Partial Channel)+  , messages :: H.HashMap (Snowflake Message) (Partial Message)+  , attachments :: H.HashMap (Snowflake Attachment) Attachment+  }+  deriving (Show, Generic)+  deriving+    (FromJSON)+    via OverriddenVia ResolvedInteractionData ResolvedInteractionData' +data InteractionType+  = PingType+  | ApplicationCommandType+  | MessageComponentType+  | ApplicationCommandAutoCompleteType+  | ModalSubmitType+  deriving (Eq, Show, Generic)+ instance FromJSON InteractionType where-    parseJSON = withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of-        Just 1 -> pure PingType-        Just 2 -> pure ApplicationCommandType-        Just 3 -> pure MessageComponentType-        _ -> fail $ "Invalid InteractionType: " <> show n+  parseJSON = withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of+    Just 1 -> pure PingType+    Just 2 -> pure ApplicationCommandType+    Just 3 -> pure MessageComponentType+    Just 4 -> pure ApplicationCommandAutoCompleteType+    Just 5 -> pure ModalSubmitType+    _ -> fail $ "Invalid InteractionType: " <> show n

@@ -1,45 +1,40 @@ -- | Things that are messageable module Calamity.Types.Tellable (-    ToMessage (..),-    Tellable (..),-    TFile (..),-    TMention (..),-    tell,-    reply,+  ToMessage (..),+  Tellable (..),+  TMention (..),+  tell,+  reply,+  runToMessage, ) where  import Calamity.Client.Types-import Calamity.HTTP+import Calamity.HTTP.Channel (+  AllowedMentions,+  ChannelRequest (CreateMessage),+  CreateMessageAttachment,+  CreateMessageOptions,+ )+import Calamity.HTTP.Internal.Request (invoke)+import Calamity.HTTP.Internal.Types (RestError)+import Calamity.HTTP.User (UserRequest (CreateDM)) import Calamity.Types.Model.Channel-import Calamity.Types.Model.Guild+import Calamity.Types.Model.Guild.Member (Member)+import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake- import Control.Lens--import Data.ByteString.Lazy (ByteString) import Data.Default.Class import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Lazy as L- import GHC.Generics- import qualified Polysemy as P import qualified Polysemy.Error as P --- | A wrapper type for sending files-data TFile-    = TFile-        T.Text-        -- ^ The filename-        ByteString-        -- ^ The content-    deriving (Show, Generic)- -- | A wrapper type for allowing mentions newtype TMention a = TMention (Snowflake a)-    deriving (Show, Generic)+  deriving stock (Show, Generic)  {- | Things that can be used to send a message @@ -50,60 +45,102 @@  @ -} class ToMessage a where-    -- | Turn @a@ into a 'CreateMessageOptions' builder-    intoMsg :: a -> Endo CreateMessageOptions+  -- | Turn @a@ into a 'CreateMessageOptions' builder+  intoMsg :: a -> Endo CreateMessageOptions  -- | Message content, '(<>)' concatenates the content instance ToMessage L.Text where-    intoMsg t = Endo (#content %~ (<> Just (L.toStrict t)))+  intoMsg t = Endo (#content %~ (<> Just (L.toStrict t)))  -- | Message content, '(<>)' concatenates the content instance ToMessage T.Text where-    intoMsg t = Endo (#content %~ (<> Just t))+  intoMsg t = Endo (#content %~ (<> Just t))  -- | Message content, '(<>)' concatenates the content instance ToMessage String where-    intoMsg t = Endo (#content %~ (<> Just (T.pack t)))+  intoMsg t = Endo (#content %~ (<> Just (T.pack t))) --- | Message embed, '(<>)' merges embeds using '(<>)'+-- | Message embed, '(<>)' appends a new embed instance ToMessage Embed where-    intoMsg e = Endo (#embed %~ (<> Just e))+  intoMsg e = Endo (#embeds %~ (<> Just [e])) --- | Message file, '(<>)' keeps the last added file-instance ToMessage TFile where-    intoMsg (TFile n f) = Endo (#file %~ getLast . (<> Last (Just (n, f))) . Last)+-- | Message attachments, '(<>)' appends a new file+instance ToMessage CreateMessageAttachment where+  intoMsg a = Endo (#attachments %~ (<> Just [a]))  -- | Allowed mentions, '(<>)' combines allowed mentions instance ToMessage AllowedMentions where-    intoMsg m = Endo (#allowedMentions %~ (<> Just m))+  intoMsg m = Endo (#allowedMentions %~ (<> Just m))  -- | Add a 'User' id to the list of allowed user mentions instance ToMessage (TMention User) where-    intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [s])+  intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [s])  -- | Add a 'Member' id to the list of allowed user mentions instance ToMessage (TMention Member) where-    intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [coerceSnowflake s])+  intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [coerceSnowflake s])  -- | Add a 'Role' id to the list of allowed role mentions instance ToMessage (TMention Role) where-    intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles <>~ [s])+  intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles <>~ [s]) +fixupActionRow :: Component -> Component+fixupActionRow r@(ActionRow' _) = r+fixupActionRow x = ActionRow' [x]++{- | Add many components to a message.++ Each component will be wrapped in a singleton ActionRow if not already+-}+instance ToMessage [Component] where+  intoMsg c = Endo (#components %~ (<> Just (map fixupActionRow c)))++-- | Add an row of 'Button's to the message+instance ToMessage [Button] where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map Button' $ c]))++-- | Add an row of 'LinkButton's to the message+instance ToMessage [LinkButton] where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map LinkButton' $ c]))++-- | Add an row of 'Select's to the message+instance ToMessage [Select] where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map Select' $ c]))++{- | Add a singleton row containing a 'Component' to the message++ If the component is not already an actionrow, it is wrapped in a singleton row+-}+instance ToMessage Component where+  intoMsg c = Endo (#components %~ (<> Just [fixupActionRow c]))++-- | Add a singleton row containing a 'Button' to the message,+instance ToMessage Button where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' [Button' c]]))++-- | Add a singleton row containing a 'LinkButton' to the message,+instance ToMessage LinkButton where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' [LinkButton' c]]))++-- | Add a singleton row containing a 'Select' to the message,+instance ToMessage Select where+  intoMsg c = Endo (#components %~ (<> Just [ActionRow' [Select' c]]))+ -- | Set a 'MessageReference' as the message to reply to instance ToMessage MessageReference where-    intoMsg ref = Endo (#messageReference ?~ ref)+  intoMsg ref = Endo (#messageReference ?~ ref)  instance ToMessage (Endo CreateMessageOptions) where-    intoMsg = Prelude.id+  intoMsg = Prelude.id  instance ToMessage (CreateMessageOptions -> CreateMessageOptions) where-    intoMsg = Endo+  intoMsg = Endo  instance ToMessage CreateMessageOptions where-    intoMsg = Endo . const+  intoMsg = Endo . const  class Tellable a where-    getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel)+  getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel)  runToMessage :: ToMessage a => a -> CreateMessageOptions runToMessage = flip appEndo def . intoMsg@@ -123,9 +160,9 @@ -} tell :: forall msg r t. (BotC r, ToMessage msg, Tellable t) => t -> msg -> P.Sem r (Either RestError Message) tell target (runToMessage -> msg) = P.runError $ do-    cid <- getChannel target-    r <- invoke $ CreateMessage cid msg-    P.fromEither r+  cid <- getChannel target+  r <- invoke $ CreateMessage cid msg+  P.fromEither r  {- | Create a reply to an existing message in the same channel @@ -142,44 +179,44 @@ -} reply :: forall msg r t. (BotC r, ToMessage msg, HasID Channel t, HasID Message t) => t -> msg -> P.Sem r (Either RestError Message) reply target msg = P.runError $ do-    let msg' = runToMessage (intoMsg msg <> intoMsg (MessageReference (Just $ getID @Message target) (Just $ getID @Channel target) Nothing False))-    r <- invoke $ CreateMessage (getID @Channel target) msg'-    P.fromEither r+  let msg' = runToMessage (intoMsg msg <> intoMsg (MessageReference (Just $ getID @Message target) (Just $ getID @Channel target) Nothing False))+  r <- invoke $ CreateMessage (getID @Channel target) msg'+  P.fromEither r  instance Tellable DMChannel where-    getChannel = pure . getID+  getChannel = pure . getID  instance Tellable (Snowflake Channel) where-    getChannel = pure+  getChannel = pure  instance Tellable Channel where-    getChannel = pure . getID+  getChannel = pure . getID  instance Tellable (Snowflake DMChannel) where-    getChannel = pure . coerceSnowflake+  getChannel = pure . coerceSnowflake  instance Tellable TextChannel where-    getChannel = pure . getID+  getChannel = pure . getID  instance Tellable (Snowflake TextChannel) where-    getChannel = pure . coerceSnowflake+  getChannel = pure . coerceSnowflake  instance Tellable Message where-    getChannel = pure . getID+  getChannel = pure . getID  messageUser :: (BotC r, P.Member (P.Error RestError) r, HasID User a) => a -> P.Sem r (Snowflake Channel) messageUser (getID @User -> uid) = do-    c <- invoke $ CreateDM uid-    getID <$> P.fromEither c+  c <- invoke $ CreateDM uid+  getID <$> P.fromEither c  instance Tellable (Snowflake Member) where-    getChannel = messageUser . coerceSnowflake @_ @User+  getChannel = messageUser . coerceSnowflake @_ @User  instance Tellable Member where-    getChannel = messageUser+  getChannel = messageUser  instance Tellable User where-    getChannel = messageUser+  getChannel = messageUser  instance Tellable (Snowflake User) where-    getChannel = messageUser+  getChannel = messageUser

@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}++module Calamity.Types.TokenEff (+  TokenEff (..),+  getBotToken,+) where++import Calamity.Types.Token+import Polysemy++data TokenEff m a where+  GetBotToken :: TokenEff m Token++makeSem ''TokenEff

@@ -1,5 +1,33 @@ # Changelog for Calamity +## 0.3.0.0+++ The discord api version has been moved from v9 to v10.++ Added support for interactions and views with `Calamity.Interactions`.++ Some more effects have been put in, `RatelimitEff` and `TokenEff`, causing+  changes to `BotC`, `SetupEff`.++ The HTTP client can now be used without a `Client` instance.++ The `GuildMemberAdd` event now includes the guild id of the member.++ The `InteractionCreate` event has been added.++ Adding attachments to messages has now been reworked, and `TFile` has been+  replaced with `CreateMessageAttachment`.++ The `file` attribute of `CreateMessageOptions` has been removed and replaced+  with `attachments :: Maybe [CreateMessageAttachment]`.++ The `embed` attribute of `CreateMessageOptions` has been replaced with `embeds+  :: Maybe [Embed]`.++ The `components :: Maybe [Component]` field has been added to+  `CreateMessageOptions`.++ `editMessageEmbed` has been replaced with `editMessageEmbeds`.++ Added `Calamity.HTTP.Channel.editMessageComponents`.++ Added `Calamity.HTTP.Guild.SearchGuildMembers`.++ `Calamity.HTTP.Guild.GetGuildBans` now has a `GetGuildBansOptions` parameter.++ Added the module `Calamity.HTTP.Interaction`.++ Added the modules `Calamity.Interactions`,+  `Calamity.Interactions.{Eff,Utils,View}`.++ Fully fleshed out `Calamity.Types.Model.Channel.Component`.++ Removed `stickers` from `Message`.++ Removed the `guildID` field from `Member`.+ ## 0.2.0.2  + Dependency bump

@@ -2,7 +2,7 @@  <p align="center">   <a href="https://hackage.haskell.org/package/calamity"><img src="https://img.shields.io/hackage/v/calamity" alt="Hackage"></a>-  <a href="https://gitlab.com/simmsb/calamity/pipelines"><img src="https://img.shields.io/gitlab/pipeline/simmsb/calamity" alt="Gitlab pipeline status"></a>+  <a href="https://github.com/simmsb/calamity/actions/workflows/build.yml"><img src="https://github.com/simmsb/calamity/actions/workflows/build.yml/badge.svg" alt="Build Status"></a>   <a href="https://github.com/simmsb/calamity/blob/master/LICENSE"><img src="https://img.shields.io/github/license/simmsb/calamity" alt="License"></a>   <a href="https://hackage.haskell.org/package/calamity"><img src="https://img.shields.io/hackage-deps/v/calamity" alt="Hackage-Deps"></a>   <a href="https://discord.gg/NGCThCY"><img src="https://discord.com/api/guilds/754446998077178088/widget.png?style=shield" alt="Discord Invite"></a>@@ -57,17 +57,17 @@ {- cabal:   build-depends:      base >= 4.13 && < 5-     , calamity >= 0.1.30.1-     , text >= 1.2 && < 2-     , lens >= 4.18 && < 5+     , calamity >= 0.3.0.0+     , text >= 1.2 && < 2.1+     , lens >= 5.1 && < 6      , di-polysemy ^>= 0.2      , di >= 1.3 && < 2      , df1 >= 0.3 && < 0.5      , di-core ^>= 1.0.4-     , polysemy ^>= 1.5-     , polysemy-plugin ^>= 0.3-     , stm ^>= 2.5-     , text-show ^>= 3.9+     , polysemy >= 1.5 && <2+     , polysemy-plugin >= 0.3 && <0.5+     , stm >= 2.5 && <3+     , text-show >= 3.8 && <4 -}  {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}@@ -75,131 +75,151 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-}  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ApplicativeDo #-} -module Main where+module Main (main) where -import           Calamity-import           Calamity.Cache.InMemory+import Calamity+import Calamity.Cache.InMemory import Calamity.Commands-import Calamity.Commands.Context (FullContext, useFullContext)-import           Calamity.Metrics.Noop+import Calamity.Commands.Context (useFullContext)+import qualified Calamity.Interactions as I+import Calamity.Metrics.Noop+import Control.Concurrent+import Control.Lens+import Control.Monad+import qualified Data.Text as T+import qualified Di+import qualified DiPolysemy as DiP+import GHC.Generics+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.State as P+import System.Environment (getEnv)+import TextShow -import           Control.Concurrent-import           Control.Concurrent.STM.TVar-import           Control.Lens-import           Control.Monad+data MyViewState = MyViewState+  { numOptions :: Int+  , selected :: Maybe T.Text+  }+  deriving (Generic) -import qualified Data.Text as T+main :: IO ()+main = do+  token <- T.pack <$> getEnv "BOT_TOKEN"+  Di.new $ \di ->+    void . P.runFinal . P.embedToFinal . DiP.runDiToIO di+      . runCacheInMemory+      . runMetricsNoop+      . useConstantPrefix "!"+      . useFullContext+      $ runBotIO (BotToken token) defaultIntents $ do+        addCommands $ do+          -- just some examples -import qualified Di-import qualified DiPolysemy                  as DiP+          command @'[User] "utest" \ctx u -> do+            void . tell @T.Text ctx $ "got user: " <> showt u+          command @'[Named "u" User, Named "u1" User] "utest2" \ctx u u1 -> do+            void . tell @T.Text ctx $ "got user: " <> showt u <> "\nand: " <> showt u1+          command @'[T.Text, Snowflake User] "test" \_ctx something aUser -> do+            DiP.info $ "something = " <> showt something <> ", aUser = " <> showt aUser+          group "testgroup" $ do+            void $ command @'[[T.Text]] "test" \ctx l -> do+              void . tell @T.Text ctx $ "you sent: " <> showt l+            group "say" do+              command @'[KleenePlusConcat T.Text] "this" \ctx msg -> do+                void $ tell @T.Text ctx msg+          command @'[] "explode" \_ctx -> do+            Just _ <- pure Nothing+            DiP.debug @T.Text "unreachable!"+          command @'[] "bye" \ctx -> do+            void $ tell @T.Text ctx "bye!"+            stopBot -import qualified Polysemy                    as P-import qualified Polysemy.Async              as P-import qualified Polysemy.AtomicState        as P-import qualified Polysemy.Embed              as P-import qualified Polysemy.Fail               as P+          -- views! -import           Prelude                     hiding ( error )+          command @'[] "components" \ctx -> do+            let view options = do+                  ~(add, done) <- I.row do+                    add <- I.button ButtonPrimary "add"+                    done <- I.button ButtonPrimary "done"+                    pure (add, done)+                  s <- I.select options+                  pure (add, done, s)+            let initialState = MyViewState 1 Nothing+            s <- P.evalState initialState $+              I.runView (view ["0"]) (tell ctx) \(add, done, s) -> do+                when add do+                  n <- P.gets (^. #numOptions)+                  let n' = n + 1+                  P.modify' (#numOptions .~ n')+                  let options = map (T.pack . show) [0 .. n]+                  I.replaceView (view options) (void . I.edit) -import           System.Environment          (getEnv)+                when done do+                  finalSelected <- P.gets (^. #selected)+                  I.endView finalSelected+                  I.deleteInitialMsg+                  void . I.respond $ case finalSelected of+                    Just x -> "Thanks: " <> x+                    Nothing -> "Oopsie" -import           TextShow+                case s of+                  Just s' -> do+                    P.modify' (#selected ?~ s')+                    void I.deferComponent+                  Nothing -> pure ()+            P.embed $ print s -data Counter m a where-  GetCounter :: Counter m Int+          -- more views! -P.makeSem ''Counter+          command @'[] "cresponses" \ctx -> do+            let view = I.row do+                  a <- I.button ButtonPrimary "defer"+                  b <- I.button ButtonPrimary "deferEph"+                  c <- I.button ButtonPrimary "deferComp"+                  d <- I.button ButtonPrimary "modal"+                  pure (a, b, c, d) -runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) a -> P.Sem r a-runCounterAtomic m = do-  var <- P.embed $ newTVarIO (0 :: Int)-  P.runAtomicStateTVar var $ P.reinterpret (\case-                                              GetCounter -> P.atomicState (\v -> (v + 1, v))) m+                modalView = do+                  a <- I.textInput TextInputShort "a"+                  b <- I.textInput TextInputParagraph "b"+                  pure (a, b) -handleFailByLogging m = do-  r <- P.runFail m-  case r of-    Left e -> DiP.error $ T.pack e-    _      -> pure ()+            I.runView view (tell ctx) $ \(a, b, c, d) -> do+              when a do+                void I.defer+                P.embed $ threadDelay 1000000+                void $ I.followUp @T.Text "lol" -info, debug :: BotC r => T.Text -> P.Sem r ()-info = DiP.info-debug = DiP.info+              when b do+                void I.deferEphemeral+                P.embed $ threadDelay 1000000+                void $ I.followUpEphemeral @T.Text "lol" -tellt :: (BotC r, Tellable t) => t -> T.Text -> P.Sem r (Either RestError Message)-tellt t m = tell t $ T.toStrict m+              when c do+                void I.deferComponent+                P.embed $ threadDelay 1000000+                void $ I.followUp @T.Text "lol" -data MyCustomEvt = MyCustomEvt T.Text Message+              when d do+                void . P.async $ do+                  I.runView modalView (void . I.pushModal "lol") $ \(a, b) -> do+                    P.embed $ print (a, b)+                    void $ I.respond ("Thanks: " <> a <> " " <> b)+                    I.endView () -main :: IO ()-main = do-  token <- T.pack <$> getEnv "BOT_TOKEN"-  Di.new $ \di ->-    void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic -         . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" . useFullContext-      $ runBotIO (BotToken token) defaultIntents $ do-      addCommands $ do-        helpCommand-        command @'[User] "utest" $ \ctx u -> do-          void $ tellt ctx $ "got user: " <> showt u-        command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do-          void $ tellt ctx $ "got user: " <> showt u <> "\nand: " <> showt u1-        command @'[T.Text, Snowflake User] "test" $ \ctx something aUser -> do-          info $ "something = " <> showt something <> ", aUser = " <> showt aUser-        command @'[] "hello" $ \ctx -> do-          void $ tellt ctx "heya"-        group "testgroup" $ do-          command @'[[T.Text]] "test" $ \ctx l -> do-            void $ tellt ctx ("you sent: " <> showt l)-          command @'[] "count" $ \ctx -> do-            val <- getCounter-            void $ tellt ctx ("The value is: " <> showt val)-          group "say" $ do-            command @'[KleenePlusConcat T.Text] "this" $ \ctx msg -> do-              void $ tellt ctx msg-        command @'[Snowflake Emoji] "etest" $ \ctx e -> do-          void $ tellt ctx $ "got emoji: " <> showt e-        command @'[] "explode" $ \ctx -> do-          Just x <- pure Nothing-          debug "unreachable!"-        command @'[] "bye" $ \ctx -> do-          void $ tellt ctx "bye!"-          stopBot-        command @'[] "fire-evt" $ \ctx -> do-          fire . customEvt $ MyCustomEvt "aha" (ctx ^. #message)-        command @'[T.Text] "wait-for" $ \ctx s -> do-          void $ tellt ctx ("waiting for !" <> s)-          waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s))-          void $ tellt ctx ("got !" <> s)-      react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of-        "!say hi" -> replicateM_ 3 . P.async $ do-          info "saying heya"-          Right msg' <- tellt msg "heya"-          info "sleeping"-          P.embed $ threadDelay (5 * 1000 * 1000)-          info "slept"-          void . invoke $ EditMessage (msg ^. #channelID) msg' (editMessageContent $ Just "lol")-          info "edited"-        _ -> pure ()-      react @('CustomEvt (CtxCommandError FullContext)) \(CtxCommandError ctx e) -> do-        info $ "Command failed with reason: " <> showt e-        case e of-          ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> T.fromStrict n <> "`, with reason: ```\n" <> r <> "```"-      react @('CustomEvt MyCustomEvt) $ \(MyCustomEvt s m) ->-        void $ tellt m ("Somebody told me to tell you about: " <> s)+              pure () ```  ## Disabling library logging@@ -225,3 +245,23 @@   -- ... ``` ++## Nix++If you trust me, I have a [cachix](https://www.cachix.org/) cache setup at+`simmsb-calamity`.++With cachix installed, you should be able to run `cachix use simmsb-calamity` to+add my cache to your list of caches.++You can also just manually add the substituter and public key:++```+substituters = https://simmsb-calamity.cachix.org+trusted-public-keys = simmsb-calamity.cachix.org-1:CQsXXpwKsjSVu0BJFT/JSvy1j6R7rMSW2r3cRQdcuQM= +```++After this nix builds should just use the cache (I hope?)++For an example of a bot built using nix, take a look at:+[simmsb/calamity-bot](https://github.com/simmsb/calamity-bot)

@@ -1,11 +1,11 @@-cabal-version: 1.18+cabal-version: 2.0  -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           calamity-version:        0.2.0.2+version:        0.3.0.0 synopsis:       A library for writing discord bots in haskell description:    Please see the README on GitHub at <https://github.com/simmsb/calamity#readme> category:       Network, Web@@ -55,6 +55,7 @@       Calamity.HTTP.Channel       Calamity.HTTP.Emoji       Calamity.HTTP.Guild+      Calamity.HTTP.Interaction       Calamity.HTTP.Internal.Ratelimit       Calamity.HTTP.Internal.Request       Calamity.HTTP.Internal.Route@@ -64,6 +65,10 @@       Calamity.HTTP.Reason       Calamity.HTTP.User       Calamity.HTTP.Webhook+      Calamity.Interactions+      Calamity.Interactions.Eff+      Calamity.Interactions.Utils+      Calamity.Interactions.View       Calamity.Internal.AesonThings       Calamity.Internal.BoundedStore       Calamity.Internal.ConstructorName@@ -120,13 +125,12 @@       Calamity.Types.Snowflake       Calamity.Types.Tellable       Calamity.Types.Token+      Calamity.Types.TokenEff       Calamity.Types.Upgradeable       Calamity.Utils       Calamity.Utils.Colour       Calamity.Utils.Message       Calamity.Utils.Permissions-  other-modules:-      Paths_calamity   hs-source-dirs:       ./   default-extensions:@@ -222,6 +226,8 @@     , stm-chans >=3.0 && <4     , stm-containers >=1.1 && <2     , text >=1.2 && <2.1+    -- text 2.0 usage is blocked on generics lens,+    -- it can be jailbroken by end users however     , text-show >=3.8 && <4     , time >=1.8 && <1.13     , tls >=1.4 && <2@@ -230,6 +236,7 @@     , unboxing-vector ==0.2.*     , unordered-containers ==0.2.*     , vector ==0.12.*-    , websockets ==0.12.*+    , websockets >=0.12 && <0.13     , x509-system >=1.6.6 && <1.7+    , random >=1.2 && <1.3   default-language: Haskell2010