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