extra/discord/discord.factor

   1 ! Copyright (C) 2023 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.syntax arrays assocs byte-arrays calendar
   4 combinators combinators.short-circuit concurrency.mailboxes
   5 continuations destructors formatting hashtables help http
   6 http.client http.websockets io io.encodings.string
   7 io.encodings.utf8 io.streams.string json kernel math multiline
   8 namespaces prettyprint prettyprint.sections random sequences
   9 sets splitting strings threads tools.hexdump unicode vocabs
  10 words ;
  11 IN: discord
  12
  13 CONSTANT: discord-api-url "https://discord.com/api/v10"
  14 CONSTANT: discord-bot-gateway  "wss://gateway.discord.gg/gateway/bot?v=10&encoding=json"
  15
  16 TUPLE: discord-webhook url id token ;
  17
  18 TUPLE: discord-bot-config
  19     client-id client-secret
  20     token application-id guild-id channel-id permissions
  21     user-callback obey-names
  22     metadata
  23     discord-bot mailbox connect-thread ;
  24
  25 TUPLE: discord-bot
  26     config in out bot-thread heartbeat-thread
  27     send-heartbeat? reconnect? stop?
  28     sequence-number
  29     messages last-message
  30     application user session_id resume_gateway_url
  31     guilds channels ;
  32
  33 : <discord-bot> ( in out config -- discord-bot )
  34     discord-bot new
  35         swap >>config
  36         swap >>out
  37         swap >>in
  38         t >>send-heartbeat?
  39         t >>reconnect?
  40         f >>stop?
  41         V{ } clone >>messages
  42         H{ } clone >>guilds
  43         H{ } clone >>channels ;
  44
  45 : add-discord-auth-header ( request -- request )
  46     discord-bot-config get token>> "Bot " prepend "Authorization" set-header ;
  47
  48 : add-json-header ( request -- request )
  49     "application/json" "Content-Type" set-header ;
  50
  51 : json-request ( request -- json ) http-request nip utf8 decode json> ;
  52 : gwrite ( string -- ) [ write ] with-global ;
  53 : gprint ( string -- ) [ print ] with-global ;
  54 : gprint-flush ( string -- ) [ print flush ] with-global ;
  55 : gflush ( -- ) [ flush ] with-global ;
  56 : gbl ( -- ) [ bl ] with-global ;
  57 : gnl ( -- ) [ nl ] with-global ;
  58 : g. ( object -- ) [ . ] with-global ;
  59 : g... ( object -- ) [ ... ] with-global ;
  60
  61 : >discord-url ( route -- url ) discord-api-url prepend ;
  62 : discord-get-request ( route -- request )
  63     >discord-url <get-request> add-discord-auth-header ;
  64 : discord-get ( route -- json )
  65     discord-get-request json-request ;
  66 : discord-post-request ( payload route -- request )
  67     >discord-url <post-request> add-discord-auth-header ;
  68 : discord-patch-request ( payload route -- request )
  69     >discord-url <patch-request> add-discord-auth-header ;
  70 : discord-delete-request ( route -- request )
  71     >discord-url <delete-request> add-discord-auth-header ;
  72 : discord-post ( payload route -- json )
  73     discord-post-request json-request ;
  74 : discord-post-json ( payload route -- json )
  75     [ >json ] dip discord-post-request add-json-header json-request ;
  76 : discord-patch-json ( payload route -- json )
  77     [ >json ] dip discord-patch-request add-json-header json-request ;
  78 : discord-delete-json ( route -- json )
  79     discord-delete-request add-json-header json-request ;
  80
  81 : bot-guild-join-uri ( discord-bot-config -- uri )
  82     [ permissions>> ] [ client-id>> ] [ guild-id>> ] tri
  83     "https://discord.com/oauth2/authorize?scope=bot&permissions=%d&client_id=%s&guild_id=%s" sprintf ;
  84
  85 : get-discord-user ( user -- json ) "/users/%s" sprintf discord-get ;
  86 : get-discord-users-me ( -- json ) "/users/@me" discord-get ;
  87 : get-discord-users-guilds ( -- json ) "/users/@me/guilds" discord-get ;
  88 : get-discord-users-guild-member ( guild-id -- json ) "/users/@me/guilds/%s/member" sprintf discord-get ;
  89 : get-discord-user-connections ( -- json ) "/users/@me/connections" discord-get ;
  90 : get-discord-user-application-role-connection ( application-id -- json )
  91     "/users/@me/applications/%s/role-connection" sprintf discord-get ;
  92 : get-discord-channel ( channel-id -- json ) "/channels/%s" sprintf discord-get ;
  93 : get-discord-channel-pins ( channel-id -- json ) "/channels/%s/pins" sprintf discord-get ;
  94 : get-discord-channel-messages ( channel-id -- json ) "/channels/%s/messages" sprintf discord-get ;
  95 : get-discord-channel-message ( channel-id message-id -- json ) "/channels/%s/messages/%s" sprintf discord-get ;
  96
  97 : set-discord-application-commands ( json application-id -- json )
  98     "/applications/%s/commands" sprintf discord-post-json ;
  99 : set-discord-application-guild-commands ( json application-id guild-id -- json )
 100     "/applications/%s/guilds/%s/commands" sprintf discord-post-json ;
 101
 102 : delete-discord-application-command ( application-id -- json )
 103     "/applications/%s/commands" sprintf discord-delete-json ;
 104 : delete-discord-application-guild-command ( application-id -- json )
 105     "/applications/%s/commands" sprintf discord-delete-json ;
 106
 107 : create-interaction-response ( interaction-id interaction-token -- json )
 108     [ H{ { "type" 4 } { "data" "pang" } } clone ] 2dip
 109     "/webhooks/%s/%s/messages/callback" sprintf discord-post ;
 110
 111 : get-original-interaction-response ( application-id interaction-token -- json )
 112     "/webhooks/%s/%s/messages/@original" sprintf discord-get ;
 113
 114
 115
 116 : send-message* ( string channel-id -- json )
 117     [ "content" associate ] dip "/channels/%s/messages" sprintf discord-post-json ;
 118 : send-message ( string channel-id -- ) send-message* drop ;
 119 : reply-message ( string -- ) discord-bot get last-message>> "channel_id" of send-message ;
 120 : ghosting-payload ( -- string )
 121     { 124 124 8203 }
 122     197 [ { 124 124 124 124 8203 } ] replicate concat
 123     1 [ 124 ] replicate "" 3append-as ;
 124
 125 : ghost-ping ( message who channel-id -- )
 126     [ ghosting-payload glue ] dip send-message ;
 127
 128 : get-channel-webhooks ( channel-id -- json ) "/channels/%s/webhooks" sprintf discord-get ;
 129 : get-guild-webhooks ( guild-id -- json ) "/guilds/%s/webhooks" sprintf discord-get ;
 130 : get-webhook ( webhook-id -- json ) "/webhooks/%s" sprintf discord-get ;
 131
 132 : get-guilds-me ( -- json ) "/users/@me/guilds" discord-get ;
 133 : get-guild-active-threads ( channel-id -- json ) "/guilds/%s/threads/active" sprintf discord-get ;
 134 : get-application-info ( -- json ) "/oauth2/applications/@me" discord-get ;
 135
 136 : get-discord-gateway ( -- json ) "/gateway" discord-get ;
 137 : get-discord-bot-gateway ( -- json ) "/gateway/bot" discord-get ;
 138
 139 : gateway-identify-json ( -- json )
 140     \ discord-bot get config>> token>> [[ {
 141         "op": 2,
 142         "d": {
 143             "token": "%s",
 144             "properties": {
 145                 "os": "darwin",
 146                 "browser": "discord.factor",
 147                 "device": "discord.factor"
 148             },
 149             "large_threshold": 250,
 150             "intents": 3276541
 151         }
 152     }]] sprintf json> >json ;
 153
 154 : jitter-millis ( heartbeat-millis -- millis ) 0 1 uniform-random-float * >integer ;
 155
 156 : send-heartbeat ( seq/f -- )
 157     json-null or "d" associate H{ { "op" 1 } } assoc-union!
 158     >json send-masked-message ;
 159
 160 : start-heartbeat-thread ( millis -- )
 161     '[
 162         _
 163         [ jitter-millis sleep f send-heartbeat ]
 164         [
 165             milliseconds
 166             '[
 167                 _ sleep discord-bot get
 168                 [ send-heartbeat?>> ] [ sequence-number>> ] bi
 169                 '[
 170                     _ [
 171                         output-stream get disposed>>
 172                         [ f ] [ send-heartbeat t ] if
 173                     ] [ 2drop f ] recover
 174                 ] [ f ] if
 175             ] loop
 176         ] bi
 177     ] "discord-bot-heartbeat" spawn discord-bot get heartbeat-thread<< ;
 178
 179 ENUM: discord-opcode
 180     { DISPATCH           0 }
 181     { HEARTBEAT          1 }
 182     { IDENTIFY           2 }
 183     { PRESENCE           3 }
 184     { VOICE_STATE        4 }
 185     { VOICE_PING         5 }
 186     { RESUME             6 }
 187     { RECONNECT          7 }
 188     { REQUEST_MEMBERS    8 }
 189     { INVALIDATE_SESSION 9 }
 190     { HELLO              10 }
 191     { HEARTBEAT_ACK      11 }
 192     { GUILD_SYNC         12 } ;
 193
 194 SINGLETONS:
 195     AUTOMOD_ACTION AUTOMOD_RULE_CREATE AUTOMOD_RULE_DELETE AUTOMOD_RULE_UPDATE
 196     CHANNEL_CREATE CHANNEL_DELETE CHANNEL_PINS_UPDATE CHANNEL_UPDATE
 197     GUILD_AVAILABLE GUILD_BAN_ADD GUILD_BAN_REMOVE
 198     GUILD_CHANNEL_CREATE GUILD_CHANNEL_DELETE GUILD_CHANNEL_PINS_UPDATE GUILD_CHANNEL_UPDATE
 199     GUILD_CREATE GUILD_EMOJIS_UPDATE GUILD_INTEGRATION_UPDATE GUILD_JOIN
 200     GUILD_MEMBER_ADD GUILD_MEMBER_REMOVE GUILD_MEMBER_UPDATE GUILD_REMOVE
 201     GUILD_ROLE_CREATE GUILD_ROLE_DELETE GUILD_ROLE_UPDATE
 202     GUILD_STICKERS_UPDATE GUILD_UNAVAILABLE GUILD_UPDATE
 203     INTERACTION_CREATE
 204     INVITE_CREATE INVITE_DELETE
 205     MEMBER_BAN MEMBER_JOIN MEMBER_REMOVE MEMBER_UNBAN MEMBER_UPDATE
 206     MESSAGE_CREATE MESSAGE_DELETE MESSAGE_EDIT
 207     MESSAGE_REACTION_ADD MESSAGE_REACTION_REMOVE MESSAGE_UPDATE
 208     PRESENCE_UPDATE
 209     RAW_MESSAGE_DELETE RAW_MESSAGE_EDIT
 210     REACTION_ADD REACTION_CLEAR REACTION_REMOVE
 211     SCHEDULED_EVENT_CREATE SCHEDULED_EVENT_REMOVE SCHEDULED_EVENT_UPDATE
 212     SCHEDULED_EVENT_USER_ADD SCHEDULED_EVENT_USER_REMOVE
 213     SHARD_CONNECT SHARD_DISCONNECT
 214     SHARD_READY SHARD_RESUMED THREAD_CREATE
 215     THREAD_DELETE THREAD_JOIN
 216     THREAD_MEMBER_JOIN THREAD_MEMBER_REMOVE THREAD_UPDATE
 217     VOICE_SERVER_UPDATE VOICE_STATE_UPDATE
 218     READY TYPING_START USER_UPDATE WEBHOOKS_UPDATE ;
 219
 220 : guild-name ( guild-id -- name ) discord-bot get guilds>> at "name" of ;
 221 : channel-name ( guild-id channel-id -- name ) 2array discord-bot get channels>> at "name" of ;
 222 : guild-channel-name ( guild-id channel-id -- name )
 223     [ ":" glue print ]
 224     [ drop guild-name "`" dup surround ]
 225     [ channel-name "`" dup surround ] 2tri ":" glue ;
 226
 227 : handle-channel-message ( json -- )
 228     {
 229         [ "guild_id" of "guild_id:" prepend write bl ]
 230         [ "id" of "channel_id:" prepend write bl ]
 231         [ [ "guild_id" of ] [ "id" of ] bi guild-channel-name write bl ]
 232         [ "name" of "name:`" "`" surround write bl ]
 233         [ "rate_limit_per_user" of "rate_limit_per_user:%d" sprintf write bl ]
 234         [ "default_auto_archive_duration" of -1 or "default_auto_archive_duration:%d minutes" sprintf write bl ]
 235         [ "nsfw" of unparse "nsfw:%s" sprintf write bl ]
 236         [ "position" of unparse "position:%s" sprintf write bl ]
 237         [ "topic" of json-null>f "topic:`" "`" surround print flush ]
 238     } cleave ;
 239
 240 : handle-guild-message ( json -- )
 241     {
 242         [ dup "id" of discord-bot get guilds>> set-at ]
 243         [
 244             [ "id" of ] [ "channels" of ] bi
 245             discord-bot get channels>> '[ tuck "id" of 2array _ set-at ] with each
 246         ]
 247     } cleave ;
 248
 249 : my-user-id ( -- id ) discord-bot get user>> "id" of ;
 250 : message-from-me? ( json -- ? ) "author" of "id" of my-user-id = ;
 251 : message-mentions ( json -- ids ) "mentions" of ;
 252 : message-mentions-ids ( json -- ids ) message-mentions [ "id" of ] map ;
 253 : message-mentions-me? ( json -- ? ) message-mentions my-user-id '[ "id" of _ = ] any? ;
 254 : message-mentions-me-and-not-from-me? ( json -- ? )
 255     { [ message-mentions-me? ] [ message-from-me? not ] } 1&& ;
 256 : message-channel-id ( json -- ids ) "channel_id" of ;
 257 : obey-message? ( json -- ? )
 258     "author" of "username" of
 259     discord-bot get config>> obey-names>> [ in? ] [ drop f ] if* ;
 260
 261 : handle-incoming-message ( guild_id channel_id message_id author content -- )
 262     5drop ;
 263
 264 GENERIC: dispatch-message ( json singleton -- )
 265 M: object dispatch-message "unhandled: " gwrite name>> gwrite g... ;
 266 M: string dispatch-message "unhandled string: " gwrite gwrite g... ;
 267
 268 M: READY dispatch-message drop
 269     [ discord-bot get ] dip
 270     {
 271         [ "user" of >>user ]
 272         [ "session_id" of >>session_id ]
 273         [ "application" of >>application ]
 274         [ "resume_gateway_url" of >>resume_gateway_url ]
 275     } cleave drop ;
 276
 277 M: AUTOMOD_ACTION dispatch-message 2drop ;
 278 M: AUTOMOD_RULE_CREATE dispatch-message 2drop ;
 279 M: AUTOMOD_RULE_UPDATE dispatch-message 2drop ;
 280 M: AUTOMOD_RULE_DELETE dispatch-message 2drop ;
 281 M: CHANNEL_CREATE dispatch-message drop handle-channel-message ;
 282 M: CHANNEL_UPDATE dispatch-message drop handle-channel-message ;
 283 M: CHANNEL_DELETE dispatch-message drop handle-channel-message ;
 284 M: CHANNEL_PINS_UPDATE dispatch-message 2drop ;
 285 M: GUILD_CREATE dispatch-message drop handle-guild-message ;
 286 M: GUILD_UPDATE dispatch-message drop handle-guild-message ;
 287 M: GUILD_EMOJIS_UPDATE dispatch-message 2drop ;
 288 M: GUILD_STICKERS_UPDATE dispatch-message 2drop ;
 289 M: GUILD_INTEGRATION_UPDATE dispatch-message 2drop ;
 290 M: GUILD_CHANNEL_CREATE dispatch-message 2drop ;
 291 M: GUILD_CHANNEL_UPDATE dispatch-message 2drop ;
 292 M: GUILD_CHANNEL_DELETE dispatch-message 2drop ;
 293 M: GUILD_CHANNEL_PINS_UPDATE dispatch-message 2drop ;
 294 M: GUILD_JOIN dispatch-message 2drop ;
 295 M: GUILD_REMOVE dispatch-message 2drop ;
 296 M: GUILD_AVAILABLE dispatch-message 2drop ;
 297 M: GUILD_UNAVAILABLE dispatch-message 2drop ;
 298 M: GUILD_MEMBER_ADD dispatch-message 2drop ;
 299 M: GUILD_MEMBER_REMOVE dispatch-message 2drop ;
 300 M: GUILD_MEMBER_UPDATE dispatch-message 2drop ;
 301 M: GUILD_BAN_ADD dispatch-message 2drop ;
 302 M: GUILD_BAN_REMOVE dispatch-message 2drop ;
 303 M: GUILD_ROLE_CREATE dispatch-message 2drop ;
 304 M: GUILD_ROLE_UPDATE dispatch-message 2drop ;
 305 M: GUILD_ROLE_DELETE dispatch-message 2drop ;
 306 M: INTERACTION_CREATE dispatch-message 2drop ;
 307 M: INVITE_CREATE dispatch-message 2drop ;
 308 M: INVITE_DELETE dispatch-message 2drop ;
 309 M: MEMBER_BAN dispatch-message 2drop ;
 310 M: MEMBER_UNBAN dispatch-message 2drop ;
 311 M: MEMBER_JOIN dispatch-message 2drop ;
 312 M: MEMBER_REMOVE dispatch-message 2drop ;
 313 M: MEMBER_UPDATE dispatch-message 2drop ;
 314 M: PRESENCE_UPDATE dispatch-message 2drop ;
 315 M: RAW_MESSAGE_EDIT dispatch-message 2drop ;
 316 M: RAW_MESSAGE_DELETE dispatch-message 2drop ;
 317 M: REACTION_ADD dispatch-message 2drop ;
 318 M: REACTION_REMOVE dispatch-message 2drop ;
 319 M: REACTION_CLEAR dispatch-message 2drop ;
 320 M: SCHEDULED_EVENT_CREATE dispatch-message 2drop ;
 321 M: SCHEDULED_EVENT_REMOVE dispatch-message 2drop ;
 322 M: SCHEDULED_EVENT_UPDATE dispatch-message 2drop ;
 323 M: SCHEDULED_EVENT_USER_ADD dispatch-message 2drop ;
 324 M: SCHEDULED_EVENT_USER_REMOVE dispatch-message 2drop ;
 325 M: SHARD_CONNECT dispatch-message 2drop ;
 326 M: SHARD_DISCONNECT dispatch-message 2drop ;
 327 M: SHARD_READY dispatch-message 2drop ;
 328 M: SHARD_RESUMED dispatch-message 2drop ;
 329 M: THREAD_CREATE dispatch-message 2drop ;
 330 M: THREAD_JOIN dispatch-message 2drop ;
 331 M: THREAD_UPDATE dispatch-message 2drop ;
 332 M: THREAD_DELETE dispatch-message 2drop ;
 333 M: THREAD_MEMBER_JOIN dispatch-message 2drop ;
 334 M: THREAD_MEMBER_REMOVE dispatch-message 2drop ;
 335 M: USER_UPDATE dispatch-message 2drop ;
 336 M: VOICE_STATE_UPDATE dispatch-message 2drop ;
 337 M: VOICE_SERVER_UPDATE dispatch-message 2drop ;
 338 M: WEBHOOKS_UPDATE dispatch-message 2drop ;
 339
 340 M: MESSAGE_CREATE dispatch-message drop
 341     [
 342         "MESSAGE_CREATE" write bl [
 343             {
 344                 [ [ "guild_id" of ] [ "channel_id" of ] bi guild-channel-name write bl ]
 345                 [ "id" of "id:" prepend write bl ]
 346                 [ "author" of "username" of ":" append write bl ]
 347                 [ "content" of "`" dup surround print flush ]
 348             } cleave
 349         ] [
 350             {
 351                 [ [ "guild_id" of ] [ "channel_id" of ] bi ]
 352                 [ "id" of ]
 353                 [ "author" of "username" of ]
 354                 [ "content" of ]
 355             } cleave handle-incoming-message
 356         ] bi
 357     ] with-global ;
 358 M: MESSAGE_UPDATE dispatch-message drop
 359     [
 360         "MESSAGE_UPDATE" write bl {
 361             [ [ "guild_id" of ] [ "channel_id" of ] bi guild-channel-name write bl ]
 362             [ "id" of "id:" prepend write bl ]
 363             [ "author" of "username" of ":" append write bl ]
 364             [ "content" of "`" dup surround print flush ]
 365         } cleave
 366     ] with-global ;
 367 M: MESSAGE_EDIT dispatch-message 2drop ;
 368 M: MESSAGE_DELETE dispatch-message drop
 369     [
 370         "MESSAGE_DELETE" write bl {
 371             [ [ "guild_id" of ] [ "channel_id" of ] bi guild-channel-name write bl ]
 372             [ "id" of "id:" prepend print flush ]
 373         } cleave
 374     ] with-global ;
 375 M: MESSAGE_REACTION_ADD dispatch-message 2drop ;
 376 M: MESSAGE_REACTION_REMOVE dispatch-message 2drop ;
 377 M: TYPING_START dispatch-message drop
 378     [
 379         "TYPING_START:" write bl
 380         [ [ "guild_id" of ] [ "channel_id" of ] bi guild-channel-name write bl ]
 381         [
 382             "member" of [ "nick" of json-null>f ] [ "user" of "username" of ] bi or
 383             " started typing" append print flush
 384         ] bi
 385     ] with-global ;
 386
 387 : handle-discord-RESUME ( json -- ) drop ;
 388
 389 : handle-discord-RECONNECT ( json -- ) drop ;
 390
 391 : handle-discord-HELLO ( json -- )
 392     "d" of "heartbeat_interval" of start-heartbeat-thread
 393     gateway-identify-json send-masked-message ;
 394
 395 : handle-discord-HEARTBEAT_ACK ( json -- ) drop ;
 396
 397 : parse-discord-op ( json -- )
 398     [
 399         clone now "timestamp" pick set-at discord-bot get
 400         [ messages>> push ] [ [ "d" of ] dip last-message<< ] 2bi
 401     ] keep
 402     [ ] [ "s" of discord-bot get sequence-number<< ] [ "op" of ] tri {
 403         { 0 [
 404             [ "d" of ] [ "t" of [ "discord" lookup-word ] transmute ] bi
 405             [ dispatch-message ]
 406             [
 407                 discord-bot get config>> user-callback>>
 408                 [ call( json message-type -- ) ] [ 2drop ] if*
 409             ] 2bi
 410         ] }
 411         { 6 [ handle-discord-RESUME ] }
 412         { 7 [ handle-discord-RECONNECT ] }
 413         { 10 [ handle-discord-HELLO ] }
 414         { 11 [ handle-discord-HEARTBEAT_ACK ] }
 415         [ "unknown opcode:" gwrite g. g... gflush ]
 416     } case ;
 417
 418 : stopping-discord-bot ( -- )
 419     discord-bot get t >>stop? drop ;
 420
 421 DEFER: discord-reconnect
 422 : handle-discord-websocket ( obj opcode -- )
 423     "opcode: " gwrite dup g. over dup byte-array? [ utf8 decode json> ] when g... gflush
 424     {
 425         { f [
 426             [
 427                 "closed with error, code %d" sprintf gprint-flush
 428                 stopping-discord-bot
 429             ] [ "closed with f" gprint-flush ] if*
 430         ] }
 431         { 1 [
 432             [ drop ]
 433             [ utf8 decode json> parse-discord-op ] bi
 434         ] }
 435         { 2 [
 436             [ [ hexdump. flush ] with-global ] when*
 437         ] }
 438         { 8 [
 439             drop "close received" gprint-flush
 440         ] }
 441         { 9 [
 442             [ "ping received" gprint-flush send-heartbeat ] when*
 443         ] }
 444         [ 2drop ]
 445     } case ;
 446
 447 : discord-reconnect ( -- )
 448     "reconnect" g.
 449     discord-bot-gateway <get-request>
 450     add-discord-auth-header
 451     [ drop ] do-http-request
 452     dup response? [
 453         throw
 454     ] [
 455         [ in>> stream>> ] [ out>> stream>> ] bi \ discord-bot-config get
 456         <discord-bot>
 457         [ discord-bot-config get discord-bot<< ] keep
 458         dup '[
 459             _ \ discord-bot [
 460                 discord-bot get [ in>> ] [ out>> ] bi
 461                 [
 462                     [ handle-discord-websocket discord-bot-config get discord-bot>> stop?>> not ] read-websocket-loop
 463                 ] with-streams
 464             ] with-variable
 465             discord-bot-config get mailbox>> "disconnected" swap mailbox-put
 466         ] "Discord Bot" spawn >>bot-thread discord-bot-config get discord-bot<<
 467     ] if ;
 468
 469 M: discord-bot dispose
 470     f >>reconnect?
 471     t >>stop?
 472     f >>send-heartbeat?
 473     [
 474         [ in>> &dispose drop ]
 475         [ out>> &dispose drop ]
 476         [ f >>in f >>out drop ] tri
 477     ] with-destructors ;
 478
 479 M: discord-bot-config dispose
 480     discord-bot>> dispose ;
 481
 482 : discord-connect ( config -- )
 483     <mailbox> >>mailbox
 484     \ discord-bot-config [
 485         [
 486             [
 487                 "connecting" g.
 488                 discord-reconnect
 489                 discord-bot-config get
 490                 ! wait here for signal to maybe reconnect
 491                 [ mailbox>> mailbox-get ] [ discord-bot>> ] bi
 492                 [ reconnect?>> ] [ stop?>> not ] bi and
 493             ] loop
 494         ] "Discord bot connect loop" spawn discord-bot-config get connect-thread<<
 495     ] with-variable ;
 496
 497 : reply-command ( json -- ? )
 498     "content" of [ blank? ] trim
 499     " " split1 [ [ blank? ] trim ] bi@
 500     swap {
 501         { "help" [
 502             ":" split1 swap lookup-word dup [
 503                 [ [ print-topic ] with-string-writer ]
 504                 [ 2drop f ] recover
 505             ] when "vocab:word not found (maybe it's not loaded)" or
 506             reply-message t
 507         ] }
 508         { "effects" [
 509             all-words swap '[ name>> _ = ] filter
 510             [
 511                 [ vocabulary-name ]
 512                 [ name>> ":" glue ]
 513                 [ props>> "declared-effect" of unparse " " glue ] tri
 514             ] map
 515             [ "no words found" reply-message f ]
 516             [ "\n" join reply-message t ] if-empty
 517         ] }
 518         [ 2drop f ]
 519     } case ;
 520
 521 : reply-echo ( json -- ? )
 522     dup message-mentions-me-and-not-from-me?
 523     [ "content" of "echobot sez: " prepend reply-message t ]
 524     [ drop f ] if ;
 525
 526 GENERIC: discord-help-bot ( json opcode -- )
 527
 528 M: object discord-help-bot 2drop ;
 529
 530 M: MESSAGE_CREATE discord-help-bot drop
 531     '[ _ { [ reply-command ] [ reply-echo ] } 1|| drop ]
 532     [ g... gflush ] recover ;