slirc.pl

   1 #!/usr/bin/perl -w
   2 # slirc.pl: local Slack IRC gateway
   3 # Copyright (C) 2017-2019 Daniel Beer <dlbeer@gmail.com>
   4 # Amendments 2021 by Ralph Ronnquist <ralph.ronnquist@gmail.com>
   5 #
   6 # Permission to use, copy, modify, and/or distribute this software for any
   7 # purpose with or without fee is hereby granted, provided that the above
   8 # copyright notice and this permission notice appear in all copies.
   9 #
  10 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  11 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  12 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  13 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  14 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  15 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  16 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  17 #
  18 # To run, create a configuration file with the following content:
  19 #
  20 #     slack_token=<legacy API token>
  21 #     password=<password of your choice>
  22 #     port=<port>
  23 #
  24 # Then run ./slirc.pl <config-file>. Connect to the chosen port on
  25 # 127.0.0.1 with your chosen password.
  26 #
  27 # Updated 2018-05-15 to add support for listening on Unix domain sockets
  28 # by Colin Watson <cjwatson@chiark.greenend.org.uk>. To use this feature
  29 # with an IRC client supporting Unix domain connections, add the line
  30 # "unix_socket=<path>" to the config file.
  31 #
  32 # Updated 2019-02-18:
  33 # - HTML entities are now escaped/unescaped properly
  34 # - Channel IDs are translated with the correct sigil
  35 # - You can now close accumulated group chats. This is mapped to
  36 #   JOIN/PART (the behaviour of JOIN/PART for public channels is
  37 #   unaffected)
  38 # - IRC-side PING checks are now more lenient, to work around bugs in
  39 #   some IRC clients
  40 # - Added X commands for debug dumps and dynamically switching protocol
  41 #   debug on/off
  42 #
  43 # Updated 2019-05-08 based on changes from Neia Finch to improve
  44 # support for bots.
  45 #
  46 # Updated 2021-08-30 for Slack API changes.
  47
  48 use strict;
  49 use warnings;
  50 use utf8;
  51
  52 use AnyEvent;
  53 use AnyEvent::HTTP;
  54 use AnyEvent::Socket;
  55 use AnyEvent::WebSocket::Client;
  56 use URI::Encode qw(uri_encode);
  57 use Data::Dumper;
  58 use Time::localtime;
  59 use Digest::SHA qw(sha256);
  60 use JSON;
  61
  62 my $VERSION = "20210830";
  63 my $start_time = time();
  64 my %config;
  65
  66 $| = 1;
  67
  68 ########################################################################
  69 # Global chat state
  70 ########################################################################
  71
  72 my $connected;                  # Is the RTM connection ready?
  73 my $self_id;                    # Slack ID of our own user, or undef
  74
  75 my %channels;                   # Slack ID -> channel hash ref
  76 my %channels_by_name;           # irc_lcase -> channel hash ref
  77 # Properties:
  78 # - Id: Slack ID
  79 # - Members: Slack ID set
  80 # - Name: text (IRC name)
  81 # - Topic: text
  82
  83 my %users;                      # Slack ID -> user hash ref
  84 my %users_by_name;              # irc_lcase -> user hash ref
  85 my %users_by_dmid;              # Slack DMID -> user hash ref
  86 # Properties:
  87 # - Id: Slack ID
  88 # - Name: text (IRC name)
  89 # - Channels: Slack ID set
  90 # - Realname: text
  91 # - DMId: DM session ID (may be undefined, or blank if open in progress)
  92 # - TxQueue: messages awaiting transmission if no DM open
  93
  94 ########################################################################
  95 # IRC names
  96 ########################################################################
  97
  98 # Canonicalize an IRC name
  99 sub irc_lcase {
 100     my $name = lc(shift);
 101
 102     $name =~ s/\[/{/g;
 103     $name =~ s/]/}/g;
 104     $name =~ s/\|/\\/g;
 105     $name =~ s/\^/~/g;
 106
 107     return $name;
 108 }
 109
 110 # Compare two names
 111 sub irc_eq {
 112     my ($a, $b) = @_;
 113
 114     return irc_lcase($a) eq irc_lcase($b);
 115 }
 116
 117 # Choose an unused valid name with reference to the hash
 118 sub irc_pick_name {
 119     my ($name, $hash) = @_;
 120
 121     $name =~ s/[#,<>!\0\r\n: ]/_/g;
 122
 123     return $name if length($name) && irc_lcase($name) ne "x" &&
 124         !defined($hash->{irc_lcase($name)});
 125
 126     my $i = 1;
 127
 128     for (;;) {
 129         my $prop = "$name$i";
 130
 131         return $prop unless defined($hash->{irc_lcase($prop)});
 132         $i++;
 133     }
 134 }
 135
 136 ########################################################################
 137 # IRC server
 138 ########################################################################
 139
 140 # Forward decls to RTM subsystem
 141 sub rtm_send;
 142 sub rtm_send_to_user;
 143 sub rtm_apicall;
 144 sub rtm_download;
 145 sub rtm_destroy;
 146 sub rtm_update_join;
 147 sub rtm_update_part;
 148
 149 my %irc_clients;
 150
 151 sub irc_send_args {
 152     my ($c, $source, $short, $long) = @_;
 153
 154     $source =~ s/[\t\r\n\0 ]//g;
 155     $source =~ s/^://g;
 156     my @arg = (":$source");
 157
 158     for my $a (@$short) {
 159         $a =~ s/[\t\r\n\0 ]//g;
 160         $a =~ s/^://g;
 161         utf8::encode($a);
 162         $a = "*" unless length($a);
 163         push @arg, $a;
 164     }
 165
 166     if (defined($long)) {
 167         $long =~ s/[\r\n\0]/ /g;
 168         utf8::encode($long);
 169         push @arg, ":$long";
 170     }
 171
 172     my $line = join(' ', @arg);
 173     print "IRC $c->{Handle} SEND: $line\n" if $config{debug_dump};
 174     $c->{Handle}->push_write("$line\r\n");
 175 }
 176
 177 sub irc_send_num {
 178     my ($c, $num, $short, $long) = @_;
 179     my $dst = $c->{Nick};
 180
 181     $dst = "*" unless defined($c->{Nick});
 182     irc_send_args $c, "localhost",
 183         [sprintf("%03d", $num), $dst, @$short], $long;
 184 }
 185
 186 sub irc_send_from {
 187     my ($c, $uid, $short, $long) = @_;
 188     my $user = $users{$uid};
 189     my $nick = $uid eq $self_id ? $c->{Nick} : $user->{Name};
 190
 191     irc_send_args $c, "$nick!$user->{Id}\@localhost", $short, $long;
 192 }
 193
 194 sub irc_disconnect {
 195     my ($c, $msg) = @_;
 196
 197     print "IRC $c->{Handle} DISCONNECT: $msg\n";
 198     delete $irc_clients{$c->{Handle}};
 199     $c->{Handle}->destroy;
 200 }
 201
 202 sub irc_disconnect_all {
 203     print "IRC: disconnect all\n";
 204     foreach my $k (keys %irc_clients) {
 205         $irc_clients{$k}->{Handle}->destroy;
 206     }
 207     %irc_clients = ();
 208 }
 209
 210 sub irc_send_names {
 211     my ($c, $chan) = @_;
 212     my $i = 0;
 213     my @ulist = keys %{$chan->{Members}};
 214
 215     while ($i < @ulist) {
 216         my $n = @ulist - $i;
 217         $n = 8 if $n > 8;
 218         my $chunk = join(' ', map {
 219             $_ eq $self_id ? $c->{Nick} : $users{$_}->{Name}
 220         } @ulist[$i .. ($i + $n - 1)]);
 221         irc_send_num $c, 353, ['@', "#$chan->{Name}"], $chunk;
 222         $i += $n;
 223     }
 224
 225     irc_send_num $c, 366, ["#$chan->{Name}"], "End of /NAMES list";
 226 }
 227
 228 sub irc_server_notice {
 229     my ($c, $msg) = @_;
 230     my $nick = $c->{Nick};
 231
 232     $nick = "*" unless defined($nick);
 233     irc_send_args $c, "localhost", ["NOTICE", $nick], $msg;
 234 }
 235
 236 sub irc_gateway_notice {
 237     my ($c, $msg) = @_;
 238     my $nick = $c->{Nick};
 239
 240     $nick = "*" unless defined($nick);
 241     irc_send_args $c, "X!X\@localhost", ["NOTICE", $nick], $msg;
 242 }
 243
 244 sub irc_notify_away {
 245     my $c = shift;
 246     my $user = $users{$self_id};
 247     my ($num, $msg);
 248
 249     if ($user->{Presence} eq 'away') {
 250         $num = 306;
 251         $msg = "You have been marked as being away";
 252     } else {
 253         $num = 305;
 254         $msg = "You are no longer marked as being away";
 255     }
 256
 257     irc_send_num $c, $num, [], $msg if $c->{Ready};
 258 }
 259
 260 sub irc_broadcast_away {
 261     for my $k (keys %irc_clients) {
 262         my $c = $irc_clients{$k};
 263         irc_notify_away $c if $c->{Ready};
 264     }
 265 }
 266
 267 sub irc_send_motd {
 268     my $c = shift;
 269     my @banner =
 270       (
 271        '     _ _                  _',
 272        ' ___| (_)_ __ ___   _ __ | |',
 273        '/ __| | | \'__/ __| | \'_ \| |',
 274        '\__ \ | | | | (__ _| |_) | |',
 275        '|___/_|_|_|  \___(_) .__/|_|',
 276        '                   |_|',
 277        'slirc.pl, Copyright (C) 2017-2019 Daniel Beer <dlbeer@gmail.com>'
 278       );
 279
 280     for my $x (@banner) {
 281         irc_send_num $c, 372, [], $x;
 282     }
 283     irc_send_num $c, 376, [], "End of /MOTD command";
 284 }
 285
 286 sub irc_check_welcome {
 287     my $c = shift;
 288
 289     if (defined $c->{Nick} && defined $c->{User} &&
 290         (!$config{password} || defined $c->{Password}) &&
 291         !$c->{Authed}) {
 292         if (!$config{password} ||
 293             sha256($c->{Password}) eq sha256($config{password})) {
 294             $c->{Authed} = 1;
 295         } else {
 296             irc_server_notice $c, "Incorrect password";
 297             irc_disconnect $c, "Incorrect password";
 298             return;
 299         }
 300     }
 301
 302     return unless $c->{Authed} && !$c->{Ready} && $connected;
 303
 304     my $u = $users_by_name{irc_lcase($c->{Nick})};
 305     if (defined($u) && ($u->{Id} ne $self_id)) {
 306         irc_server_notice $c, "Nick already in use";
 307         irc_disconnect $c, "Nick already in use";
 308         return;
 309     }
 310
 311     my $lt = localtime($start_time);
 312
 313     irc_send_num $c, 001, [], "slirc.pl IRC-to-Slack gateway";
 314     irc_send_num $c, 002, [], "This is slirc.pl version $VERSION";
 315     irc_send_num $c, 003, [], "Server started " . ctime($start_time);
 316     irc_send_motd $c;
 317     $c->{Ready} = 1;
 318
 319     my $user = $users{$self_id};
 320
 321     for my $k (keys %{$user->{Channels}}) {
 322         my $chan = $channels{$k};
 323         irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
 324         irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{"Topic"};
 325         irc_send_names $c, $chan;
 326     }
 327
 328     irc_notify_away $c;
 329 }
 330
 331 sub irc_check_welcome_all {
 332     foreach my $k (keys %irc_clients) {
 333         irc_check_welcome $irc_clients{$k};
 334     }
 335 }
 336
 337 sub irc_broadcast_nick {
 338     my ($id, $newname) = @_;
 339     return if $id eq $self_id;
 340
 341     for my $k (keys %irc_clients) {
 342         my $c = $irc_clients{$k};
 343         irc_send_from $c, $id, ["NICK", $newname] if $c->{Ready};
 344     }
 345 }
 346
 347 sub irc_broadcast_join {
 348     my ($uid, $chid) = @_;
 349     my $chan = $channels{$chid};
 350
 351     for my $k (keys %irc_clients) {
 352         my $c = $irc_clients{$k};
 353         next unless $c->{Ready};
 354
 355         if ($uid eq $self_id) {
 356             irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
 357             irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{Topic};
 358             irc_send_names $c, $chan;
 359         } else {
 360             irc_send_from $c, $uid, ["JOIN", "#$chan->{Name}"];
 361         }
 362     }
 363 }
 364
 365 sub irc_broadcast_part {
 366     my ($uid, $chid) = @_;
 367     my $chan = $channels{$chid};
 368
 369     for my $k (keys %irc_clients) {
 370         my $c = $irc_clients{$k};
 371         next unless $c->{Ready};
 372         irc_send_from $c, $uid, ["PART", "#$chan->{Name}"];
 373     }
 374 }
 375
 376 sub irc_send_who {
 377     my ($c, $chname, $u) = @_;
 378
 379     my $user = $users{$u};
 380     my $nick = $u eq $self_id ? $c->{Nick} : $user->{Name};
 381     my $here = $user->{Presence} eq 'away' ? 'G' : 'H';
 382
 383     irc_send_num $c, 352, [$chname, $user->{Id}, "localhost", "localhost",
 384                            $nick, $here], "0 $user->{Realname}";
 385 }
 386
 387 sub irc_send_whois {
 388     my ($c, $uid) = @_;
 389     my $u = $users{$uid};
 390     my $nick = $uid eq $self_id ? $c->{Nick} : $u->{Name};
 391
 392     irc_send_num $c, 311,
 393         [$nick, $u->{Id}, "localhost", "*"], $u->{Realname};
 394     irc_send_num $c, 312, [$nick, "localhost"], "slirc.pl";
 395     my $clist = join(' ', map { "#" . $channels{$_}->{Name} }
 396                           keys %{$u->{Channels}});
 397     irc_send_num $c, 319, [$nick], $clist;
 398     irc_send_num $c, 301, [$nick], "away" if $u->{Presence} eq 'away';
 399 }
 400
 401 sub irc_invite_or_kick {
 402     my ($c, $action, $name, $chname) = @_;
 403
 404     $chname =~ s/^#//;
 405     my $chan = $channels_by_name{irc_lcase($chname)};
 406
 407     unless (defined $chan) {
 408         irc_send_num $c, 401, ["#$chname"], "No such nick/channel";
 409         return;
 410     }
 411
 412     my $what = $chan->{Type} eq "C" ? "channels" : "groups";
 413
 414     foreach (split(/,/, $name)) {
 415         my $user = $users_by_name{irc_lcase($_)};
 416
 417         if (defined $user) {
 418             rtm_apicall "$what.$action", { user => $user->{Id},
 419                                            channel => $chan->{Id} };
 420         } else {
 421             irc_send_num $c, 401, [$user], "No such nick/channel";
 422         }
 423     }
 424 }
 425
 426 my %gateway_command = (
 427     "debug_dump_state" => sub {
 428         my $c = shift;
 429         irc_gateway_notice $c, "Dumping debug state on stdout";
 430         print Dumper({ "connected" => $connected,
 431                        "self_id", => $self_id,
 432                        "%channels" => \%channels,
 433                        "%channels_by_name" => \%channels_by_name,
 434                        "users" => \%users,
 435                        "users_by_name" => \%users_by_name,
 436                        "users_by_dmid" => \%users_by_dmid
 437                      });
 438     },
 439     "debug_dump" => sub {
 440         my ($c, $arg) = @_;
 441         $config{debug_dump} = $arg ? 1 : 0 if defined $arg;
 442         irc_gateway_notice $c, "Protocol debug is " .
 443           ($config{debug_dump} ? "on" : "off");
 444     },
 445     "newgroup" => sub {
 446         my ($c, $name) = @_;
 447         unless (defined($name)) {
 448             irc_gateway_notice $c, "Syntax: newgroup <name>";
 449             return;
 450         }
 451         $name =~ s/^#//;
 452         irc_gateway_notice $c, "Creating group $name";
 453         rtm_apicall "groups.create", { name => $name };
 454     },
 455     "newchan" => sub {
 456         my ($c, $name) = @_;
 457         unless (defined($name)) {
 458             irc_gateway_notice $c, "Syntax: newchan <name>";
 459             return;
 460         }
 461         $name =~ s/^#//;
 462         irc_gateway_notice $c, "Creating channel $name";
 463         rtm_apicall "channels.create", { name => $name };
 464     },
 465     "archive" => sub{
 466         my ($c, $name) = @_;
 467         unless (defined($name)) {
 468             irc_gateway_notice $c, "Syntax: archive <name>";
 469             return;
 470         }
 471         $name =~ s/^#//;
 472         my $g = $channels_by_name{irc_lcase($name)};
 473         my $what = $g->{Type} eq "C" ? "channels" : "groups";
 474         if (defined $g) {
 475             irc_gateway_notice $c, "Archiving $name";
 476             rtm_apicall "$what.archive", { channel => $g->{Id} };
 477         } else {
 478             irc_gateway_notice $c, "No such channel: $name";
 479         }
 480     },
 481     "close" => sub{
 482         my ($c, $name) = @_;
 483         unless (defined($name)) {
 484             irc_gateway_notice $c, "Syntax: close <name>";
 485             return;
 486         }
 487
 488         $name =~ s/^#//;
 489         my $g = $channels_by_name{irc_lcase($name)};
 490         my $what = $g->{Type} eq "C" ? "channels" : "groups";
 491         if (defined $g) {
 492             irc_gateway_notice $c, "Closing $name";
 493             rtm_apicall "$what.close", { channel => $g->{Id} };
 494         } else {
 495             irc_gateway_notice $c, "No such channel: $name";
 496         }
 497     },
 498     "cat" => sub {
 499         my ($c, $fileid) = @_;
 500         unless (defined($fileid)) {
 501             irc_gateway_notice $c, "Syntax: cat <fileid> <filename>";
 502             return;
 503         }
 504
 505         rtm_apicall "files.info", { file => $fileid }, sub {
 506             my $data = shift;
 507             return unless defined $data;
 508
 509             my $body = $data->{content};
 510
 511             if (length($body) > 65536) {
 512                 irc_gateway_notice $c, "File too big";
 513             } else {
 514                 irc_gateway_notice $c, "---- BEGIN $fileid ----";
 515                 foreach (split(/\n/, $body)) {
 516                     irc_gateway_notice $c, "$_";
 517                 }
 518                 irc_gateway_notice $c, "---- END $fileid ----";
 519             }
 520         };
 521     },
 522     "disconnect" => sub {
 523         my ($c) = @_;
 524         irc_gateway_notice $c, "Disconnecting";
 525         rtm_destroy "User disconnection request";
 526     },
 527     "delim" => sub {
 528         my ($c, $nick) = @_;
 529         unless (defined($nick)) {
 530             irc_gateway_notice $c, "Syntax: delim <name>";
 531             return;
 532         }
 533         my $user;
 534
 535         if ($nick eq $c->{Nick}) {
 536             $user = $users{$self_id};
 537         } else {
 538             $user = $users_by_name{irc_lcase($nick)};
 539             $user = undef if $user->{Id} eq $self_id;
 540         }
 541
 542         unless (defined($user)) {
 543             irc_gateway_notice $c, "No such nick: $nick";
 544             return;
 545         }
 546
 547         unless (defined $user->{DMId}) {
 548             irc_gateway_notice $c, "DM already closed for $nick";
 549             return;
 550         }
 551
 552         irc_gateway_notice $c, "Closing DM for $nick";
 553         rtm_apicall "im.close", { channel => $user->{DMId} };
 554     },
 555 );
 556
 557 my %irc_command = (
 558     "NICK" => sub {
 559         my ($c, $newnick) = @_;
 560         return unless defined($newnick);
 561
 562         if (defined $c->{Nick}) {
 563             my $u = $users_by_name{irc_lcase($newnick)};
 564             if (defined($u) && ($u->{Id} ne $self_id)) {
 565                 irc_send_num $c, 433, [$newnick], "Nickname is already in use";
 566             } else {
 567                 irc_send_from $c, $self_id, ["NICK"], $newnick;
 568                 $c->{Nick} = $newnick;
 569             }
 570         } else {
 571             $c->{Nick} = $newnick;
 572             irc_check_welcome $c;
 573         }
 574     },
 575     "PASS" => sub {
 576         my ($c, $pass) = @_;
 577
 578         $c->{Password} = $pass;
 579         irc_check_welcome $c;
 580     },
 581     "USER" => sub {
 582         my ($c, @arg) = @_;
 583         return unless scalar(@arg) >= 4;
 584
 585         $c->{User} = $arg[0];
 586         $c->{Realname} = $arg[3];
 587         irc_check_welcome $c;
 588     },
 589     "AWAY" => sub {
 590         my ($c, $msg) = @_;
 591         return unless $c->{Ready};
 592         my $presence = defined $msg ? "away" : "auto";
 593         rtm_apicall "users.setPresence", { presence => $presence };
 594     },
 595     "PING" => sub {
 596         my ($c, $reply) = @_;
 597         $reply = "" unless defined($reply);
 598         irc_send_args $c, "localhost", ["PONG"], $reply;
 599     },
 600     "INVITE" => sub {
 601         my ($c, $name, $chname) = @_;
 602         return unless $c->{Ready};
 603         irc_invite_or_kick $c, "invite", $name, $chname;
 604     },
 605     "KICK" => sub {
 606         my ($c, $name, $chname) = @_;
 607         return unless $c->{Ready};
 608         irc_invite_or_kick $c, "kick", $name, $chname;
 609     },
 610     "JOIN" => sub {
 611         my ($c, $name) = @_;
 612         print "JOIN $name\n";
 613         return unless $c->{Ready};
 614         return unless defined($name);
 615
 616         foreach my $n (split(/,/, $name)) {
 617             $n =~ s/^#//;
 618             my $chan = $channels_by_name{irc_lcase($n)};
 619             if (not defined $chan) {
 620                 irc_send_num $c, 401, ["#$n"], "No such nick/channel";
 621             } elsif ($chan->{Members}->{$self_id}) {
 622                 # Already joined
 623             } elsif ($chan->{Type} eq "G") {
 624                 rtm_apicall "groups.open", { channel => $chan->{Id} };
 625                 irc_broadcast_join $self_id, $chan->{Id}
 626                   if rtm_update_join $self_id, $chan->{Id};
 627             } else {
 628                 #rtm_apicall "channels.join", { channel => $chan->{Id} };
 629                 rtm_apicall "conversations.join", { channel => $chan->{Id} };
 630             }
 631         }
 632     },
 633     "MODE" => sub {
 634         my ($c, $arg, $what) = @_;
 635         return unless $c->{Ready};
 636         return unless defined($arg);
 637
 638         $what = $what || "";
 639
 640         if ($arg eq $c->{Nick}) {
 641             irc_send_num $c, 221, [], "+i";
 642         } elsif ($arg =~ /^#(.*)$/) {
 643             my $chan = $channels_by_name{$1};
 644
 645             if (defined $chan) {
 646                 if ($what eq "b") {
 647                     irc_send_num $c, 368, ["#$chan->{Name}"],
 648                         "End of channel ban list";
 649                 } else {
 650                     irc_send_num $c, 324,
 651                         ["#$chan->{Name}",
 652                          ($chan->{Type} eq "G" ? "+ip" : "+p")];
 653                     irc_send_num $c, 329,
 654                         ["#$chan->{Name}", $start_time];
 655                 }
 656             } else {
 657                 irc_send_num $c, 403, [$arg], "No such channel";
 658             }
 659         } else {
 660             irc_send_num $c, 403, [$arg], "No such channel";
 661         }
 662     },
 663     "TOPIC" => sub {
 664         my ($c, $name, $topic) = @_;
 665         return unless defined($name) && defined($topic);
 666         return unless $c->{Ready};
 667
 668         $name =~ s/^#//;
 669         my $chan = $channels_by_name{irc_lcase($name)};
 670         unless (defined($chan)) {
 671             irc_send_num $c, 401, ["#$name"], "No such nick/channel";
 672             return;
 673         }
 674
 675         my $what = $chan->{Type} eq "C" ? "channels" : "groups";
 676
 677         rtm_apicall "$what.setTopic", { channel => $chan->{Id},
 678                                         topic => $topic };
 679     },
 680     "PART" => sub {
 681         my ($c, $name) = @_;
 682         return unless $c->{Ready};
 683         return unless defined($name);
 684
 685         foreach my $n (split(/,/, $name)) {
 686             $n =~ s/^#//;
 687             my $chan = $channels_by_name{irc_lcase($n)};
 688             if (not defined($chan)) {
 689                 irc_send_num $c, 401, ["#$n"], "No such nick/channel";
 690             } elsif ($chan->{Members}->{$self_id}) {
 691                 if ($chan->{Type} eq "G") {
 692                     rtm_apicall "groups.close", { channel => $chan->{Id} };
 693                     irc_broadcast_part $self_id, $chan->{Id}
 694                       if rtm_update_part $self_id, $chan->{Id};
 695                 } else {
 696                     #rtm_apicall "channels.leave", { channel => $chan->{Id} };
 697                     rtm_apicall "conersations.leave", { channel => $chan->{Id} };
 698                 }
 699             }
 700         }
 701     },
 702     "LIST" => sub {
 703         my ($c, @arg) = @_;
 704         return unless $c->{Ready};
 705
 706         irc_send_num $c, 321, ["Channel"], "Users Name";
 707         foreach my $chid (keys %channels) {
 708             my $chan = $channels{$chid};
 709             my $n = keys %{$chan->{Members}};
 710
 711             irc_send_num $c, 322, ["#$chan->{Name}", $n], $chan->{Topic};
 712         }
 713         irc_send_num $c, 323, [], "End of /LIST";
 714     },
 715     "WHOIS" => sub {
 716         my ($c, $nicklist) = @_;
 717         return unless $c->{Ready};
 718         return unless defined($nicklist);
 719         my $some = 0;
 720
 721         for my $nick (split(/,/, $nicklist)) {
 722             if (irc_eq($nick, "x")) {
 723                 irc_send_num $c, 311,
 724                     ["X", "X", "localhost", "*"], "Gateway service";
 725                 irc_send_num $c, 312, ["X", "localhost"], "slirc.pl";
 726             } elsif (irc_eq($nick, $c->{Nick})) {
 727                 irc_send_whois $c, $self_id;
 728             } else {
 729                 my $user;
 730
 731                 if ($nick =~ /^.*!([^@]*)/) {
 732                     $user = $users{$1};
 733                 } else {
 734                     $user = $users_by_name{irc_lcase($nick)};
 735                     $user = undef if defined($user) && $user->{Id} eq $self_id;
 736                 }
 737
 738                 if (defined($user)) {
 739                     irc_send_whois $c, $user->{Id};
 740                 } else {
 741                     irc_send_num $c, 401, [$nick], "No such nick/channel";
 742                 }
 743             }
 744         }
 745
 746         irc_send_num $c, 318, [$nicklist], "End of /WHOIS list";
 747     },
 748     "NAMES" => sub {
 749         my ($c, $name) = @_;
 750         return unless $c->{Ready};
 751         return unless defined($name);
 752
 753         my $n = $name;
 754         $n =~ s/^#//;
 755         my $chan = $channels_by_name{irc_lcase($n)};
 756         unless (defined($chan)) {
 757             irc_send_num $c, 401, [$name], "No such nick/channel";
 758             return;
 759         }
 760
 761         irc_send_names $c, $chan;
 762     },
 763     "WHO" => sub {
 764         my ($c, $name) = @_;
 765         return unless $c->{Ready};
 766
 767         if (!defined($name)) {
 768             foreach my $u (keys %users) {
 769                 irc_send_who $c, "*", $u;
 770             }
 771             irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
 772                                    "X", "H"], "0 Gateway service";
 773         } elsif (irc_eq($name, "X")) {
 774             irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
 775                                    "X", "H"], "0 Gateway service";
 776         } elsif ($name =~ /^.*!([^@]*)/) {
 777             unless (exists $users{$1}) {
 778                 irc_send_num $c, 401, [$name], "No such nick/channel";
 779                 return;
 780             }
 781
 782             irc_send_who $c, $name, $1;
 783         } elsif ($name =~ /^#(.*)$/) {
 784             my $chan = $channels_by_name{irc_lcase($1)};
 785
 786             unless (defined($chan)) {
 787                 irc_send_num $c, 401, [$name], "No such nick/channel";
 788                 return;
 789             }
 790
 791             foreach my $u (keys %{$chan->{Members}}) {
 792                 irc_send_who $c, "#$chan->{Name}", $u;
 793             }
 794         } else {
 795             my $user = $users_by_name{irc_lcase($name)};
 796
 797             unless (defined($user)) {
 798                 irc_send_num $c, 401, [$name], "No such nick/channel";
 799                 return;
 800             }
 801
 802             irc_send_who $c, $name, $self_id;
 803         }
 804
 805         $name = "*" unless defined($name);
 806         irc_send_num $c, 315, [$name], "End of /WHO list";
 807     },
 808     "MOTD" => sub {
 809         my $c = shift;
 810         irc_send_motd $c;
 811     },
 812     "PRIVMSG" => sub {
 813         my ($c, $namelist, $msg) = @_;
 814         return unless $c->{Ready};
 815         return unless defined($namelist) && defined($msg);
 816
 817         $msg =~ s/&/&amp;/g;
 818         $msg =~ s/</&lt;/g;
 819         $msg =~ s/>/&gt;/g;
 820         $msg =~ s/"/&quot;/g;
 821         $msg =~ s/&lt;@([^>]+)&gt;/'<@' . irc_name_to_id($c, $1) . '>'/eg;
 822         $msg =~ s/&lt;#([^>]+)&gt;/'<#' . irc_chan_to_id($c, $1) . '>'/eg;
 823
 824         foreach my $name (split(/,/, $namelist)) {
 825             if (irc_eq($name, "X")) {
 826                 my @args = split(/  */, $msg);
 827                 my $cmd = shift @args;
 828                 my $handler = $gateway_command{lc($cmd)};
 829
 830                 if (defined $handler) {
 831                     $handler->($c, @args);
 832                 } else {
 833                     irc_gateway_notice $c, "Unknown command: $cmd";
 834                 }
 835             } elsif ($name =~ /^#(.*)$/) {
 836                 my $chan = $channels_by_name{irc_lcase($1)};
 837
 838                 if (defined $chan) {
 839                     rtm_send {
 840                         type => "message", channel => $chan->{Id},
 841                         text => $msg };
 842                 } else {
 843                     irc_send_num $c, 401, [$name], "No such nick/channel";
 844                 }
 845             } elsif (irc_eq($name, $c->{Nick})) {
 846                 rtm_send_to_user $self_id, $msg;
 847             } else {
 848                 my $user = $users_by_name{irc_lcase($name)};
 849
 850                 if (defined $user) {
 851                     rtm_send_to_user $user->{Id}, $msg;
 852                 } else {
 853                     irc_send_num $c, 401, [$name], "No such nick/channel";
 854                 }
 855             }
 856         }
 857     },
 858     "PONG" => sub {
 859         shift->{PingCount} = 0;
 860     },
 861     "QUIT" => sub {
 862         my $c = shift;
 863         irc_disconnect $c, "QUIT";
 864     },
 865 );
 866
 867 sub irc_broadcast_notice {
 868     my ($msg) = @_;
 869
 870     print "NOTICE: $msg\n";
 871     foreach my $k (keys %irc_clients) {
 872         my $c = $irc_clients{$k};
 873         irc_server_notice $c, $msg if $c->{Authed};
 874     }
 875 }
 876
 877 sub irc_id_to_name {
 878     my ($c, $id) = @_;
 879     return $c->{Nick} if $id eq $self_id;
 880     my $u = $users{$id};
 881     return $u->{Name} if defined($u);
 882     return $id;
 883 }
 884
 885 sub irc_name_to_id {
 886     my ($c, $name) = @_;
 887     return $self_id if $name eq $c->{Nick};
 888     my $u = $users_by_name{$name};
 889     return $u->{Id} if defined($u);
 890     return $name;
 891 }
 892
 893 sub irc_id_to_chan {
 894     my ($c, $id) = @_;
 895     my $ch = $channels{$id};
 896     return $ch->{Name} if defined ($ch);
 897     return $id;
 898 }
 899
 900 sub irc_chan_to_id {
 901     my ($c, $chan) = @_;
 902     my $ch = $channels_by_name{$chan};
 903     return $ch->{Id} if defined($ch);
 904     return $chan;
 905 }
 906
 907 sub irc_do_message {
 908     my ($srcid, $dstname, $subtype, $text) = @_;
 909
 910     $text =~ s/\002//g;
 911     my $prefix = "";
 912     $prefix = "\002[$subtype]\002 " if defined($subtype);
 913
 914     for my $k (keys %irc_clients) {
 915         my $c = $irc_clients{$k};
 916         next unless $c->{Ready};
 917
 918         my $translate = $text;
 919         $translate =~ s/<@([^>]+)>/'<@' . irc_id_to_name($c, $1) . '>'/eg;
 920         $translate =~ s/<#([^>]+)>/'<#' . irc_id_to_chan($c, $1) . '>'/eg;
 921         $translate =~ s/&lt;/</g;
 922         $translate =~ s/&gt;/>/g;
 923         $translate =~ s/&quot;/"/g;
 924         $translate =~ s/&amp;/&/g;
 925
 926         for my $line (split(/\n/, $translate)) {
 927             irc_send_from $c, $srcid, ["PRIVMSG", $dstname], "$prefix$line";
 928         }
 929     }
 930 }
 931
 932 sub irc_privmsg {
 933     my ($id, $subtype, $msg) = @_;
 934     irc_do_message $id, $users{$id}->{Name}, $subtype, $msg;
 935 }
 936
 937 sub irc_chanmsg {
 938     my ($id, $subtype, $chid, $msg) = @_;
 939     irc_do_message $id, "#$channels{$chid}->{Name}", $subtype, $msg;
 940 }
 941
 942 sub irc_topic_change {
 943     my ($id, $chid) = @_;
 944     my $chan = $channels{$chid};
 945
 946     foreach my $k (keys %irc_clients) {
 947         my $c = $irc_clients{$k};
 948
 949         irc_send_from $c, $id, ["TOPIC", "#$chan->{Name}"], $chan->{Topic}
 950             if $c->{Ready};
 951     }
 952 }
 953
 954 sub irc_ping {
 955     my $c = shift;
 956
 957     if (++$c->{PingCount} >= 3) {
 958         irc_disconnect $c, "Ping timeout";
 959         return;
 960     }
 961
 962     irc_send_args $c, "localhost", ["PING"], time();
 963     $c->{PingTimer} = AnyEvent->timer(after => 60, cb => sub { irc_ping($c); });
 964 }
 965
 966 sub irc_line {
 967     my ($c, $fh, $line, $eol) = @_;
 968
 969     print "IRC $fh RECV: $line\n" if $config{debug_dump};
 970
 971     utf8::decode($line);
 972
 973     my $smallargs = $line;
 974     my $bigarg = undef;
 975
 976     if ($line =~ /^(.*?) :(.*)$/) {
 977         $smallargs = $1;
 978         $bigarg = $2;
 979     }
 980
 981     my @words = split /  */, $smallargs;
 982     push @words, $bigarg if defined($bigarg);
 983
 984     if (scalar(@words)) {
 985         my $cmd = shift @words;
 986         my $handler = $irc_command{uc($cmd)};
 987
 988         $handler->($c, @words) if (defined($handler));
 989     }
 990
 991     $fh->push_read(line => sub { irc_line($c, @_) });
 992 }
 993
 994 sub irc_listen {
 995     print "Start IRC listener\n";
 996     my $listen_host = $config{unix_socket} ? "unix/" : "127.0.0.1";
 997     tcp_server $listen_host,
 998                ($config{unix_socket} || $config{port} || 6667), sub {
 999         my ($fd, $host, $port) = @_;
1000
1001         my $fh;
1002         $fh = new AnyEvent::Handle
1003           fh => $fd,
1004           on_error => sub {
1005               my ($fh, $fatal, $msg) = @_;
1006               irc_disconnect $irc_clients{$fh}, "error: $msg";
1007           },
1008           on_eof => sub {
1009               my $fh = shift;
1010               irc_disconnect $irc_clients{$fh}, "EOF";
1011           };
1012
1013         print "IRC $fh Got connection from $host:$port\n";
1014
1015         my $c = { Handle => $fh };
1016         $c->{PingTimer} = AnyEvent->timer(after => 30,
1017                 cb => sub { irc_ping $c; });
1018         $c->{PingCount} = 0;
1019         $irc_clients{$fh} = $c;
1020         $fh->push_read(line => sub { irc_line($c, @_) });
1021
1022         irc_server_notice $c, "Waiting for RTM connection" if not $connected;
1023     }, sub {
1024         chmod 0600, $config{unix_socket} if $config{unix_socket};
1025     }
1026 }
1027
1028 ########################################################################
1029 # RTM client
1030 ########################################################################
1031
1032 my $rtm_client;
1033 my $rtm_con;
1034 my $rtm_msg_id = 1;
1035 my %rtm_apicall_handles;
1036 my $rtm_cooldown_timer;
1037
1038 my %rtm_mark_queue;
1039 my $rtm_mark_timer;
1040
1041 my $rtm_ping_timer;
1042 my $rtm_ping_count;
1043
1044 sub rtm_apicall {
1045     my ($method, $args, $cb) = @_;
1046     my @encode;
1047
1048     print "RTM APICALL $method ", Dumper($args) if $config{debug_dump};
1049
1050     $args->{token} = $config{slack_token};
1051
1052     foreach my $k (keys %$args) {
1053         my $ek = uri_encode($k);
1054         my $ev = uri_encode($args->{$k});
1055
1056         push @encode, "$ek=$ev";
1057     }
1058
1059     my $x;
1060     $x = http_post "https://slack.com/api/$method", join('&', @encode),
1061         headers => {
1062             "Content-Type", "application/x-www-form-urlencoded"
1063         }, sub {
1064             my ($body, $hdr) = @_;
1065             delete $rtm_apicall_handles{$x};
1066
1067             unless ($hdr->{Status} =~ /^2/) {
1068                 irc_broadcast_notice
1069                   "API HTTP error: $method: $hdr->{Status} $hdr->{Reason}";
1070                 $cb->(undef) if defined($cb);
1071                 return;
1072             }
1073
1074             my $data = decode_json $body;
1075
1076             print "RTM REPLY $method ", Dumper($data) if $config{debug_dump};
1077
1078             unless ($data->{ok}) {
1079                 irc_broadcast_notice "API error: $data->{error}";
1080                 $cb->(undef) if defined($cb);
1081                 return;
1082             }
1083
1084             $cb->($data) if defined($cb);
1085         };
1086
1087     $rtm_apicall_handles{$x} = 1;
1088 }
1089
1090 sub rtm_send {
1091     my $frame = shift;
1092
1093     $frame->{id} = $rtm_msg_id++;
1094     print "RTM SEND: ", Dumper($frame) if $config{debug_dump};
1095     $rtm_con->send(encode_json $frame);
1096 }
1097
1098 sub rtm_update_join {
1099     my ($uid, $chid) = @_;
1100     my $chan = $channels{$chid};
1101     my $user = $users{$uid};
1102
1103     if (!$chan->{Members}->{$uid}) {
1104         $chan->{Members}->{$uid} = 1;
1105         $user->{Channels}->{$chid} = 1;
1106         return 1;
1107     }
1108
1109     return undef;
1110 }
1111
1112 sub rtm_update_part {
1113     my ($uid, $chid) = @_;
1114     my $chan = $channels{$chid};
1115     my $user = $users{$uid};
1116
1117     if ($chan->{Members}->{$uid}) {
1118         delete $channels{$chid}->{Members}->{$uid};
1119         delete $users{$uid}->{Channels}->{$chid};
1120         return 1;
1121     }
1122
1123     return undef;
1124 }
1125
1126 sub rtm_update_user {
1127     my $c = shift;
1128     my $user;
1129
1130     if (exists $users{$c->{id}}) {
1131         $user = $users{$c->{id}};
1132         my $oldname = $user->{Name};
1133         delete $users_by_name{irc_lcase($oldname)};
1134         my $newname = irc_pick_name($c->{name}, \%users_by_name);
1135
1136         $user->{Realname} = $c->{real_name} // $c->{name};
1137
1138         irc_broadcast_nick $c->{id}, $newname
1139             if $oldname ne $newname;
1140
1141         $user->{Name} = $newname;
1142         $user->{Presence} = $c->{presence} // 'active';
1143         $users_by_name{$newname} = $user;
1144     } else {
1145         my $name = irc_pick_name($c->{name}, \%users_by_name);
1146         $user = {
1147             Id => $c->{id},
1148             Name => $name,
1149             Channels => {},
1150             Realname => $c->{real_name} // $c->{name},
1151             TxQueue => [],
1152             Presence => $c->{presence} // 'active'
1153         };
1154
1155         $users{$c->{id}} = $user;
1156         $users_by_name{$name} = $user;
1157     }
1158
1159     $user->{Realname} = "" unless defined($user->{Realname});
1160 }
1161
1162 sub rtm_record_unknown_uid {
1163     my $uid = shift;
1164
1165     unless (exists $users{$uid}) {
1166         # Temporary name
1167         my $name = irc_pick_name($uid, \%users_by_name);
1168
1169         my $u = {
1170             Id => $uid,
1171             Name => $name,
1172             Channels => {},
1173             Realname => "",
1174             TxQueue => []
1175         };
1176
1177         $users{$uid} = $u;
1178         $users_by_name{irc_lcase($name)} = $u;
1179
1180         rtm_apicall "users.info", { user => $uid }, sub {
1181             my $data = shift;
1182
1183             rtm_update_user $data->{user} if defined $data;
1184         };
1185     }
1186 }
1187
1188 sub rtm_update_channel {
1189     my ($type, $c) = @_;
1190     my $id = $c->{id};
1191
1192     rtm_apicall "conversations.members", { channel => $id }, sub {
1193
1194         my $id = $c->{id};
1195         my $data = shift;
1196         my $mhash = {};
1197         my $name = $c->{name};
1198
1199         $c->{members} = $data->{'members'};
1200
1201         $name = "+$name" if $type eq "G";
1202
1203         # Cross-reference users/channels
1204         foreach my $u (@{$c->{members}}) {
1205             rtm_record_unknown_uid $u;
1206             # Filter ourselves out of the membership list if this is a
1207             # closed group chat.
1208             next if $type eq 'G' && $u eq $self_id && !$c->{is_open};
1209             $mhash->{$u} = 1;
1210             $users{$u}->{Channels}->{$id} = 1;
1211         }
1212
1213         if (exists $channels{$id}) {
1214             my $chan = $channels{$id};
1215             $chan->{Members} = $mhash;
1216             $chan->{Topic} = $c->{topic}->{value};
1217             $chan->{Type} = $type;
1218         } else {
1219             my $name = irc_pick_name($name, \%channels_by_name);
1220             my $chan = {
1221                 Id => $c->{id},
1222                 Members => $mhash,
1223                 Name => $name,
1224                 Type => $type,
1225                 Topic => $c->{topic}->{value}
1226             };
1227
1228             $channels{$c->{id}} = $chan;
1229             $channels_by_name{irc_lcase($name)} = $chan;
1230         }
1231     };
1232 }
1233
1234 sub rtm_delete_channel {
1235     my $chid = shift;
1236     my $chan = $channels{$chid};
1237     return unless defined $chan;
1238
1239     foreach ($chan->{Members}) {
1240         my $user = $users{$_};
1241
1242         delete $user->{Channels}->{$chid};
1243     }
1244
1245     delete $channels_by_name{irc_lcase($chan->{Name})};
1246     delete $channels{$chid};
1247 }
1248
1249 sub rtm_mark_channel {
1250     my ($chid, $ts) = @_;
1251
1252     $rtm_mark_queue{$chid} = $ts;
1253
1254     unless (defined $rtm_mark_timer) {
1255         $rtm_mark_timer = AnyEvent->timer(after => 5, cb => sub {
1256             for my $chid (keys %rtm_mark_queue ) {
1257                 rtm_apicall "conversations.mark", {
1258                     channel => $chid,
1259                     ts => $rtm_mark_queue{$chid}
1260                 };
1261             }
1262             %rtm_mark_queue = ();
1263             undef $rtm_mark_timer;
1264         });
1265     }
1266 }
1267
1268 my %rtm_command = (
1269     "presence_change" => sub {
1270         my $msg = shift;
1271         my $user = $users{$msg->{user}};
1272
1273         if (defined $user) {
1274             my $old = $user->{Presence};
1275             $user->{Presence} = $msg->{presence} if defined $user;
1276             irc_broadcast_away if
1277               $msg->{user} eq $self_id and $old ne $msg->{presence};
1278         }
1279     },
1280     "manual_presence_change" => sub {
1281         my $msg = shift;
1282         my $user = $users{$self_id};
1283         my $old = $user->{Presence};
1284
1285         $user->{Presence} = $msg->{presence};
1286         irc_broadcast_away if $old ne $msg->{presence};
1287     },
1288     "im_open" => sub {
1289         my $msg = shift;
1290         rtm_record_unknown_uid $msg->{user};
1291
1292         my $u = $users{$msg->{user}};
1293         $u->{DMId} = $msg->{channel};
1294         $users_by_dmid{$msg->{channel}} = $u;
1295
1296         foreach my $msg (@{$u->{TxQueue}}) {
1297             rtm_send { type => "message",
1298                 channel => $u->{DMId}, text => $msg };
1299         }
1300
1301         $u->{TxQueue} = [];
1302     },
1303     "im_close" => sub {
1304         my $msg = shift;
1305         my $u = $users_by_dmid{$msg->{channel}};
1306         return unless defined($u);
1307
1308         delete $u->{DMId};
1309         delete $users_by_dmid{$msg->{channel}};
1310     },
1311     "group_joined" => sub {
1312         my $msg = shift;
1313
1314         rtm_update_channel "G", $msg->{channel};
1315         irc_broadcast_join $self_id, $msg->{channel}->{id};
1316     },
1317     "group_left" => sub {
1318         my $msg = shift;
1319
1320         irc_broadcast_part $self_id, $msg->{channel}
1321           if rtm_update_part $self_id, $msg->{channel};
1322     },
1323     "group_archive" => sub {
1324         my $msg = shift;
1325
1326         irc_broadcast_part $self_id, $msg->{channel}
1327           if rtm_update_part $self_id, $msg->{channel};
1328         rtm_delete_channel $msg->{channel};
1329     },
1330     "channel_joined" => sub {
1331         my $msg = shift;
1332
1333         rtm_update_channel "C", $msg->{channel};
1334         irc_broadcast_join $self_id, $msg->{channel}->{id};
1335     },
1336     "channel_left" => sub {
1337         my $msg = shift;
1338
1339         irc_broadcast_part $self_id, $msg->{channel}
1340           if rtm_update_part $self_id, $msg->{channel};
1341     },
1342     "channel_archive" => sub {
1343         my $msg = shift;
1344
1345         irc_broadcast_part $self_id, $msg->{channel}
1346           if rtm_update_part $self_id, $msg->{channel};
1347         rtm_delete_channel $msg->{channel};
1348     },
1349     "member_joined_channel" => sub {
1350         my $msg = shift;
1351
1352         rtm_record_unknown_uid $msg->{user};
1353         irc_broadcast_join $msg->{user}, $msg->{channel}
1354           if rtm_update_join($msg->{user}, $msg->{channel});
1355     },
1356     "member_left_channel" => sub {
1357         my $msg = shift;
1358
1359         irc_broadcast_part $msg->{user}, $msg->{channel}
1360           if rtm_update_part($msg->{user}, $msg->{channel});
1361     },
1362     "pong" => sub {
1363         $rtm_ping_count = 0;
1364     },
1365     "message" => sub {
1366         my $msg = shift;
1367         my $chan = $channels{$msg->{channel}};
1368         my $subtype = $msg->{subtype} || "";
1369         my $uid = $msg->{user} || $msg->{comment}->{user} || $msg->{bot_id};
1370         my $text = $msg->{text} // '';
1371
1372         if (defined($msg->{attachments})) {
1373             my $attext = join '\n', map {
1374                 ($_->{title} or "")
1375                   . " " . ($_->{text} or "")
1376                   . " " . ($_->{title_link} or "") } @{$msg->{attachments}};
1377             $text .= "\n" unless length($text);
1378             $text .= $attext;
1379         }
1380
1381         if (defined($chan)) {
1382             if ($subtype eq "channel_topic" or $subtype eq "group_topic") {
1383                 $chan->{Topic} = $msg->{topic};
1384                 irc_topic_change $uid, $chan->{Id};
1385             } else {
1386                 irc_chanmsg $uid, $msg->{subtype}, $chan->{Id}, $text;
1387             }
1388             rtm_mark_channel $chan->{Id}, $msg->{ts};
1389         } else {
1390             irc_privmsg $uid, $msg->{subtype}, $text;
1391         }
1392
1393         if ($subtype eq "file_share") {
1394             my $fid = $msg->{file}->{id};
1395             rtm_apicall "files.info", { file => $fid }, sub {
1396                 my $data = shift;
1397                 return unless defined $data;
1398
1399                 my $body = $data->{content};
1400                 return unless length($body) <= 65536;
1401
1402                 if (defined $chan) {
1403                     irc_chanmsg $uid, ">$fid", $chan->{Id}, $body;
1404                 } else {
1405                     irc_privmsg $uid, ">$fid", $body;
1406                 }
1407             };
1408         }
1409     },
1410 );
1411
1412 sub rtm_send_to_user {
1413     my ($id, $msg) = @_;
1414     my $u = $users{$id};
1415
1416     if (defined($u->{DMId}) && length($u->{DMId})) {
1417         rtm_send { type => "message",
1418                 channel => $u->{DMId}, text => $msg };
1419         return;
1420     }
1421
1422     push @{$u->{TxQueue}}, $msg;
1423
1424     if (!defined($u->{DMId})) {
1425         rtm_apicall "im.open", { user => $u->{Id} }, sub {
1426             my $result = shift;
1427             unless (defined $result) {
1428                 delete $u->{DMId};
1429                 foreach my $m (@{$u->{TxQueue}}) {
1430                     irc_broadcast_notice "Failed to send to $u->{Name}: $m";
1431                 }
1432                 $u->{TxQueue} = [];
1433             }
1434         };
1435
1436         $u->{DMId} = "";
1437     }
1438 }
1439
1440 sub rtm_start;
1441
1442 sub rtm_cooldown {
1443     return if defined($rtm_cooldown_timer);
1444     print "Waiting before reinitiating RTM\n";
1445     $rtm_cooldown_timer = AnyEvent->timer(after => 5, cb => sub {
1446         undef $rtm_cooldown_timer;
1447         rtm_start;
1448     });
1449 };
1450
1451 sub rtm_destroy {
1452     my $msg = shift;
1453     return unless defined($rtm_con);
1454
1455     irc_broadcast_notice $msg;
1456
1457     $connected = 0;
1458     undef $self_id;
1459     %channels = ();
1460     %channels_by_name = ();
1461     %users = ();
1462     %users_by_name = ();
1463     %users_by_dmid = ();
1464
1465     %rtm_apicall_handles = (); # cancel outstanding requests
1466     %rtm_mark_queue = ();
1467     undef $rtm_mark_timer;
1468     undef $rtm_ping_timer;
1469     $rtm_con->close;
1470     undef $rtm_con;
1471     undef $rtm_client;
1472
1473     irc_disconnect_all;
1474     rtm_cooldown;
1475 }
1476
1477 sub rtm_ping {
1478     if (++$rtm_ping_count >= 2) {
1479         rtm_destroy "RTM ping timeout";
1480         return;
1481     }
1482
1483     rtm_send { type => "ping" };
1484     $rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);
1485 }
1486
1487 sub rtm_start_ws {
1488     my $url = shift;
1489
1490     return if defined($rtm_client);
1491     $rtm_client = AnyEvent::WebSocket::Client->new;
1492
1493     print "WSS URL: $url\n" if $config{debug_dump};
1494     $rtm_client->connect($url)->cb(sub {
1495         $rtm_con = eval { shift->recv; };
1496         if ($@) {
1497             irc_broadcast_notice "WSS connection failed: $@\n";
1498             undef $rtm_client;
1499             rtm_cooldown;
1500         }
1501
1502         print "WSS connected\n";
1503         $rtm_msg_id = 1;
1504         $rtm_ping_count = 0;
1505         $connected = 1;
1506         irc_check_welcome_all;
1507
1508         $rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);
1509
1510         $rtm_con->on(each_message => sub {
1511             eval {
1512                 shift;
1513                 my $msg = decode_json shift->{body};
1514
1515                 print "RTM RECV: ", Dumper($msg) if $config{debug_dump};
1516                 irc_broadcast_notice "RTM error: $msg->{error}->{msg}"
1517                     if $msg->{error};
1518
1519                 if (defined $msg->{type}) {
1520                     my $handler = $rtm_command{$msg->{type}};
1521                     $handler->($msg) if defined($handler);
1522                 }
1523             };
1524             print "Error in message handler: $@" if $@;
1525         });
1526
1527         $rtm_con->on(finish => sub {
1528             eval {
1529                 my ($con) = @_;
1530
1531                 if (defined $con->close_error) {
1532                     rtm_destroy "RTM connection error: $con->close_error";
1533                 } elsif (defined $con->close_reason) {
1534                     rtm_destroy "RTM connection closed: $con->close_reason";
1535                 } else {
1536                     rtm_destroy "RTM connection finished";
1537                 }
1538             };
1539             print "Error in finish handler: $@" if $@;
1540         });
1541     });
1542 };
1543
1544 sub rtm_start {
1545     print "Requesting RTM connection\n";
1546     rtm_apicall "rtm.start", {}, sub {
1547         my $data = shift;
1548
1549         unless (defined($data)) {
1550             rtm_cooldown;
1551             return;
1552         }
1553
1554         $self_id = $data->{self}->{id};
1555
1556         foreach my $c (@{$data->{users}}) {
1557             rtm_update_user $c;
1558         }
1559
1560         foreach my $c (@{$data->{ims}}) {
1561             my $u = $users{$c->{user}};
1562
1563             $u->{DMId} = $c->{id};
1564             $users_by_dmid{$c->{id}} = $u;
1565         }
1566
1567         foreach my $c (@{$data->{channels}}) {
1568             rtm_update_channel "C", $c unless $c->{is_archived};
1569         }
1570
1571         foreach my $c (@{$data->{bots}}) {
1572             rtm_update_user $c;
1573             my $n = $c->{id};
1574         }
1575
1576         foreach my $c (@{$data->{groups}}) {
1577             rtm_update_channel "G", $c unless $c->{is_archived};
1578         }
1579
1580         rtm_start_ws $data->{url};
1581     };
1582 };
1583
1584 ########################################################################
1585 # RTM kick-off
1586 ########################################################################
1587
1588 my $cfgfile = shift || die "You must specify a config file";
1589 open(my $cfg, $cfgfile) || die "Can't open $cfgfile";
1590 foreach (<$cfg>) {
1591     chomp;
1592     $config{$1} = $2 if /^([-_0-9a-zA-Z]+)=(.*)$/;
1593 }
1594 close($cfg);
1595
1596 rtm_start;
1597 irc_listen;
1598 AnyEvent->condvar->recv;