-
Notifications
You must be signed in to change notification settings - Fork 11
/
Client.hs
802 lines (731 loc) · 29.1 KB
/
Client.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
-- | The client
module Calamity.Client.Client (
react,
runBotIO,
runBotIO',
runBotIO'',
stopBot,
sendPresence,
events,
fire,
waitUntil,
waitUntilM,
CalamityEvent (Dispatch, ShutDown),
customEvt,
) where
import Calamity.Cache.Eff
import Calamity.Client.ShardManager
import Calamity.Client.Types
import Calamity.Gateway.DispatchEvents
import Calamity.Gateway.Intents
import Calamity.Gateway.Types
import Calamity.HTTP.Internal.Ratelimit
import Calamity.Internal.ConstructorName
import Calamity.Internal.RunIntoIO
import Calamity.Internal.SnowflakeMap qualified as SM
import Calamity.Internal.UnixTimestamp
import Calamity.Internal.Updateable
import Calamity.Internal.Utils
import Calamity.Metrics.Eff
import Calamity.Types.LogEff
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild
import Calamity.Types.Model.Presence (Presence (..))
import Calamity.Types.Model.User
import Calamity.Types.Model.Voice qualified as V
import Calamity.Types.Snowflake
import Calamity.Types.Token
import Calamity.Types.TokenEff
import Control.Concurrent.Chan.Unagi
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception (SomeException)
import Control.Monad
import Data.Default.Class
import Data.Dynamic
import Data.Foldable
import Data.IORef
import Data.Maybe
import Data.Proxy
import Data.Text qualified as T
import Data.Time.Clock.POSIX
import Df1 qualified
import Di.Core qualified as DC
import DiPolysemy qualified as Di
import Optics
import Polysemy qualified as P
import Polysemy.Async qualified as P
import Polysemy.AtomicState qualified as P
import Polysemy.Error qualified as P
import Polysemy.Fail qualified as P
import Polysemy.Reader qualified as P
import Polysemy.Resource qualified as P
import TextShow (TextShow (showt))
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)
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
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)
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
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)
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 . 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.
This version only handles the @'P.Reader' 'Client'@ effect, allowing you to
handle the @'P.AtomicState' 'EventHandlers'@ yourself.
-}
runBotIO'' ::
forall r a.
( P.Members
'[ LogEff
, MetricEff
, CacheEff
, P.Reader Client
, P.AtomicState EventHandlers
, P.Embed IO
, 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 (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 . 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.
Refer to 'EventType' for what events you can register, and 'EHType' for the
parameters the event handlers they receive.
You'll probably want @TypeApplications@ and need @DataKinds@ enabled to
specify the type of @s@.
==== Examples
Reacting to every message:
@
'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg
@
Reacting to a custom event:
@
data MyCustomEvt = MyCustomEvt 'Data.Text.Text' 'Message'
'react' @(\''CustomEvt' MyCustomEvt) $ \\(MyCustomEvt s m) ->
'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s)
@
==== Notes
This function is pretty bad for giving nasty type errors,
since if something doesn't match then 'EHType' might not get substituted,
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 ())
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'
removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r ()
removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id')
{- | Fire an event that the bot will then handle.
==== Examples
Firing an event named \"my-event\":
@
'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)
@
-}
fire :: (BotC r) => CalamityEvent -> P.Sem r ()
fire e = do
inc <- P.asks (^. #eventsIn)
P.embed $ writeChan inc e
{- | Build a Custom CalamityEvent
The type of @a@ must match up with the event handler you want to receive it.
==== Examples
@
'customEvt' (MyCustomEvent "lol")
@
-}
customEvt :: forall a. (Typeable a) => a -> CalamityEvent
customEvt = Custom
-- | 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
{- | Wait until an event satisfying a condition happens, then returns its
parameters.
The check function for this command is pure unlike 'waitUntilM'
This is what it would look like with @s ~ \''MessageCreateEvt'@:
@
'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message'
@
And for @s ~ \''MessageUpdateEvt'@:
@
'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message')
@
==== Examples
Waiting for a message containing the text \"hi\":
@
f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.isInfixOf' "hi" $ m ^. #content)
print $ msg ^. #content
@
-}
waitUntil ::
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)
where
checker :: MVar (EHType s) -> EHType s -> P.Sem r ()
checker result args = do
when (f args) $ do
P.embed $ putMVar result args
{- | Wait until an event satisfying a condition happens, then returns its
parameters
This is what it would look like with @s ~ \''MessageCreateEvt'@:
@
'waitUntilM' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message'
@
And for @s ~ \''MessageUpdateEvt'@:
@
'waitUntilM' :: (('Message', 'Message') -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message')
@
==== Examples
Waiting for a message containing the text \"hi\":
@
f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.isInfixOf' "hi" $ m ^. #content))
print $ msg ^. #content
@
-}
waitUntilM ::
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)
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
-- | 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)
-- | 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
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"
{- | 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"
handleCustomEvent :: forall a r. (Typeable a, BotC r) => a -> P.Sem r ()
handleCustomEvent d = do
eventHandlers <- P.atomicGet
let handlers = getCustomEventHandlers @a eventHandlers
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 . T.pack $ "got exception: " <> show e
handleEvent :: (BotC r) => Int -> DispatchData -> P.Sem r ()
handleEvent shardID data' = do
debug . T.pack $ "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]
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 . T.pack $ "Failed handling actions for event: " <> show err
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)
handleEvent' _ Resumed = pure []
handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do
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)
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)
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)
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)
handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do
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)
-- <|> (DMChannel' <$> os ^? #dms % at (coerceSnowflake channelID) . _Just)
-- 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)
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)
-- 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)
-- 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 gid member) = do
updateCache evt
Just guild <- getGuild gid
Just member <- pure $ guild ^. #members % at (getID member)
pure $ map ($ (guild, 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 ($ (guild, 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 ($ (newGuild, 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)
handleEvent' eh (InviteDelete d) = do
pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh)
handleEvent' eh evt@(MessageCreate msg user member) = do
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
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
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 = let Member {..} = oldMember in User {..}
newUser :: User = let Member {..} = newMember in User {..}
userUpdates =
if oldUser /= newUser
then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)
else mempty
pure $ userUpdates <> map ($ (newGuild, 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)
handleEvent' eh evt@(InteractionCreate interaction) = do
updateCache evt
pure $ map ($ interaction) (getEventHandlers @'InteractionEvt eh)
handleEvent' _ (UNHANDLED e) = do
debug . T.pack $ "Not handling event: " <> show e
pure []
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 Resumed = pure ()
updateCache (ChannelCreate (DMChannel' chan)) =
setDM chan
updateCache (ChannelCreate (GuildChannel' chan)) =
updateGuild (getID chan) (#channels %~ SM.insert chan)
updateCache (ChannelUpdate (DMChannel' chan)) =
updateDM (getID chan) (update chan)
updateCache (ChannelUpdate (GuildChannel' chan)) =
updateGuild (getID chan) (#channels % ix (getID chan) %~ update chan)
updateCache (ChannelDelete (DMChannel' chan)) =
delDM (getID chan)
updateCache (ChannelDelete (GuildChannel' 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.elems (guild ^. #members)) (\Member {..} -> setUser User {..})
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 gid member) = do
setUser $ (\Member {..} -> User {..}) member
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 !user !_) = do
setMessage msg
whenJust user $ \u ->
setUser u
updateCache (MessageUpdate msg !_ !_) =
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 % traversed %~ updateReactionAdd isMe (reaction ^. #emoji)
)
updateCache (MessageReactionRemove reaction) = do
isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser
updateMessage
(getID reaction)
( \m ->
m
& #reactions
% traversed
%~ updateReactionRemove isMe (reaction ^. #emoji)
& #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 ()
updateCache (ChannelUpdate (GroupChannel' _)) = pure ()
updateCache (ChannelDelete (GroupChannel' _)) = pure ()
-- these don't modify state
updateCache (GuildBanAdd _) = pure ()
updateCache (GuildBanRemove _) = pure ()
updateCache (GuildIntegrationsUpdate _) = pure ()
updateCache (TypingStart _) = pure ()
updateCache (ChannelPinsUpdate _) = pure ()
updateCache (WebhooksUpdate _) = pure ()
updateCache (InviteCreate _) = pure ()
updateCache (InviteDelete _) = pure ()
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
-- we don't handle voice server update and direct voice connections currently
updateCache (VoiceStateUpdate V.VoiceState {guildID = Nothing}) = pure ()
updateCache (VoiceServerUpdate _) = pure ()
-- we don't update the cache from interactions
-- TODO: should we?
updateCache (InteractionCreate _) = pure ()
updateCache (UNHANDLED _) = pure ()
updateReactionAdd :: Bool -> RawEmoji -> Reaction -> Reaction
updateReactionAdd isMe emoji reaction =
if emoji == reaction ^. #emoji
then
reaction
& #count
%~ succ
& #me
%~ (|| isMe)
else reaction
updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction
updateReactionRemove isMe emoji reaction =
if emoji == reaction ^. #emoji
then
reaction
& #count
%~ pred
& #me
%~ (&& not isMe)
else reaction