2 # slirc.pl: local Slack IRC gateway
3 # Copyright (C) 2017 Daniel Beer <dlbeer@gmail.com>
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.
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.
17 # To run, create a configuration file with the following content:
19 # slack_token=<legacy API token>
20 # password=<password of your choice>
23 # Then run ./slirc.pl <config-file>. Connect to the chosen port on
24 # 127.0.0.1 with your chosen password.
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.
38 use AnyEvent::WebSocket::Client;
39 use URI::Encode qw(uri_encode);
41 use Digest::SHA qw(sha256);
44 my $VERSION = "20171127";
45 my $start_time = time();
48 ########################################################################
50 ########################################################################
52 my $connected; # Is the RTM connection ready?
53 my $self_id; # Slack ID of our own user, or undef if not connected
55 my %channels; # Slack ID -> channel hash ref
56 my %channels_by_name; # irc_lcase -> channel hash ref
59 # - Members: Slack ID set
60 # - Name: text (IRC name)
63 my %users; # Slack ID -> user hash ref
64 my %users_by_name; # irc_lcase -> user hash ref
65 my %users_by_dmid; # Slack DMID -> user hash ref
68 # - Name: text (IRC name)
69 # - Channels: Slack ID set
71 # - DMId: DM session ID (may be undefined, or blank if open in progress)
72 # - TxQueue: messages awaiting transmission if no DM open
74 ########################################################################
76 ########################################################################
78 # Canonicalize an IRC name
94 return irc_lcase($a) eq irc_lcase($b);
97 # Choose an unused valid name with reference to the hash
99 my ($name, $hash) = @_;
101 $name =~ s/[#,<>!\0\r\n: ]/_/g;
103 return $name if length($name) && irc_lcase($name) ne "x" &&
104 !defined($hash->{irc_lcase($name)});
109 my $prop = "$name$i";
111 return $prop unless !defined($hash->{irc_lcase($prop)});
116 ########################################################################
118 ########################################################################
120 # Forward decls to RTM subsystem
122 sub rtm_send_to_user;
130 my ($c, $source, $short, $long) = @_;
132 $source =~ s/[\t\r\n\0 ]//g;
134 my @arg = (":$source");
136 for my $a (@$short) {
137 $a =~ s/[\t\r\n\0 ]//g;
140 $a = "*" unless length($a);
144 if (defined($long)) {
145 $long =~ s/[\r\n\0]/ /g;
150 my $line = join(' ', @arg);
151 print "IRC $c->{Handle} SEND: $line\n";
152 $c->{Handle}->push_write("$line\r\n");
156 my ($c, $num, $short, $long) = @_;
157 my $dst = $c->{Nick};
159 $dst = "*" unless defined($c->{Nick});
160 irc_send_args $c, "localhost",
161 [sprintf("%03d", $num), $dst, @$short], $long;
165 my ($c, $uid, $short, $long) = @_;
166 my $user = $users{$uid};
167 my $nick = $uid eq $self_id ? $c->{Nick} : $user->{Name};
169 irc_send_args $c, "$nick!$user->{Id}\@localhost", $short, $long;
175 print "IRC $c->{Handle} DISCONNECT: $msg\n";
176 delete $irc_clients{$c->{Handle}};
177 $c->{Handle}->destroy;
180 sub irc_disconnect_all {
181 print "IRC: disconnect all\n";
182 foreach my $k (keys %irc_clients) {
183 $irc_clients{$k}->{Handle}->destroy;
191 my @ulist = keys %{$chan->{Members}};
193 while ($i < @ulist) {
196 my $chunk = join(' ', map {
197 $_ eq $self_id ? $c->{Nick} : $users{$_}->{Name}
198 } @ulist[$i .. ($i + $n - 1)]);
199 irc_send_num $c, 353, ['@', "#$chan->{Name}"], $chunk;
203 irc_send_num $c, 366, ["#$chan->{Name}"], "End of /NAMES list";
206 sub irc_server_notice {
208 my $nick = $c->{Nick};
210 $nick = "*" unless defined($nick);
211 irc_send_args $c, "localhost", ["NOTICE", $nick], $msg;
214 sub irc_gateway_notice {
216 my $nick = $c->{Nick};
218 $nick = "*" unless defined($nick);
219 irc_send_args $c, "X!X\@localhost", ["NOTICE", $nick], $msg;
222 sub irc_notify_away {
224 my $user = $users{$self_id};
227 if ($user->{Presence} eq 'away') {
229 $msg = "You have been marked as being away";
232 $msg = "You are no longer marked as being away";
235 irc_send_num $c, $num, [], $msg if $c->{Ready};
238 sub irc_broadcast_away {
239 for my $k (keys %irc_clients) {
240 my $c = $irc_clients{$k};
241 irc_notify_away $c if $c->{Ready};
245 sub irc_check_welcome {
248 if (defined $c->{Nick} && defined $c->{User} &&
249 (!$config{password} || defined $c->{Password}) &&
251 if (!$config{password} ||
252 sha256($c->{Password}) eq sha256($config{password})) {
255 irc_server_notice $c, "Incorrect password";
256 irc_disconnect $c, "Incorrect password";
261 return unless $c->{Authed} && !$c->{Ready} && $connected;
263 my $u = $users_by_name{irc_lcase($c->{Nick})};
264 if (defined($u) && ($u->{Id} ne $self_id)) {
265 irc_server_notice $c, "Nick already in use";
266 irc_disconnect $c, "Nick already in use";
270 irc_send_num $c, 001, [], "slirc.pl version $VERSION";
271 irc_send_num $c, 002, [],
272 "Copyright (C) 2017 Daniel Beer <dlbeer\@gmail.com>";
273 irc_send_num $c, 003, [], `uptime`;
276 my $user = $users{$self_id};
278 for my $k (keys %{$user->{Channels}}) {
279 my $chan = $channels{$k};
280 irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
281 irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{"Topic"};
282 irc_send_names $c, $chan;
288 sub irc_check_welcome_all {
289 foreach my $k (keys %irc_clients) {
290 irc_check_welcome $irc_clients{$k};
294 sub irc_broadcast_nick {
295 my ($id, $newname) = @_;
296 return if $id eq $self_id;
298 for my $k (keys %irc_clients) {
299 my $c = $irc_clients{$k};
300 irc_send_from $c, $id, ["NICK", $newname] if $c->{Ready};
304 sub irc_broadcast_join {
305 my ($uid, $chid) = @_;
306 my $chan = $channels{$chid};
308 for my $k (keys %irc_clients) {
309 my $c = $irc_clients{$k};
310 next unless $c->{Ready};
312 if ($uid eq $self_id) {
313 irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
314 irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{Topic};
315 irc_send_names $c, $chan;
317 irc_send_from $c, $uid, ["JOIN", "#$chan->{Name}"];
322 sub irc_broadcast_part {
323 my ($uid, $chid) = @_;
324 my $chan = $channels{$chid};
326 for my $k (keys %irc_clients) {
327 my $c = $irc_clients{$k};
328 next unless $c->{Ready};
329 irc_send_from $c, $uid, ["PART", "#$chan->{Name}"];
334 my ($c, $chname, $u) = @_;
336 my $user = $users{$u};
337 my $nick = $u eq $self_id ? $c->{Nick} : $user->{Name};
338 my $here = $user->{Presence} eq 'away' ? 'G' : 'H';
340 irc_send_num $c, 352, [$chname, $user->{Id}, "localhost", "localhost",
341 $nick, $here], "0 $user->{Realname}";
346 my $u = $users{$uid};
347 my $nick = $uid eq $self_id ? $c->{Nick} : $u->{Name};
349 irc_send_num $c, 311,
350 [$nick, $u->{Id}, "localhost", "*"], $u->{Realname};
351 irc_send_num $c, 312, [$nick, "localhost"], "slirc.pl";
352 my $clist = join(' ', map { "#" . $channels{$_}->{Name} }
353 keys %{$u->{Channels}});
354 irc_send_num $c, 319, [$nick], $clist;
355 irc_send_num $c, 301, [$nick], "away" if $u->{Presence} eq 'away';
358 sub irc_invite_or_kick {
359 my ($c, $action, $name, $chname) = @_;
362 my $chan = $channels_by_name{irc_lcase($chname)};
364 unless (defined $chan) {
365 irc_send_num $c, 401, ["#$chname"], "No such nick/channel";
369 my $what = $chan->{Type} eq "C" ? "channels" : "groups";
371 foreach (split(/,/, $name)) {
372 my $user = $users_by_name{irc_lcase($_)};
375 rtm_apicall "$what.$action", { user => $user->{Id},
376 channel => $chan->{Id} };
378 irc_send_num $c, 401, [$user], "No such nick/channel";
383 my %gateway_command = (
386 unless (defined($name)) {
387 irc_gateway_notice $c, "Syntax: newgroup <name>";
391 irc_gateway_notice $c, "Creating group $name";
392 rtm_apicall "groups.create", { name => $name };
396 unless (defined($name)) {
397 irc_gateway_notice $c, "Syntax: newchan <name>";
401 irc_gateway_notice $c, "Creating channel $name";
402 rtm_apicall "channels.create", { name => $name };
406 unless (defined($name)) {
407 irc_gateway_notice $c, "Syntax: archive <name>";
411 my $g = $channels_by_name{irc_lcase($name)};
412 my $what = $g->{Type} eq "C" ? "channels" : "groups";
414 irc_gateway_notice $c, "Archiving $name";
415 rtm_apicall "$what.archive", { channel => $g->{Id} };
417 irc_gateway_notice $c, "No such channel: $name";
422 unless (defined($name)) {
423 irc_gateway_notice $c, "Syntax: close <name>";
428 my $g = $channels_by_name{irc_lcase($name)};
429 my $what = $g->{Type} eq "C" ? "channels" : "groups";
431 irc_gateway_notice $c, "Closing $name";
432 rtm_apicall "$what.close", { channel => $g->{Id} };
434 irc_gateway_notice $c, "No such channel: $name";
438 my ($c, $fileid) = @_;
439 unless (defined($fileid)) {
440 irc_gateway_notice $c, "Syntax: catfile <fileid> <filename>";
444 rtm_apicall "files.info", { file => $fileid }, sub {
446 return unless defined $data;
448 my $body = $data->{content};
450 if (length($body) > 65536) {
451 irc_gateway_notice $c, "File too big";
453 irc_gateway_notice $c, "---- BEGIN $fileid ----";
454 foreach (split(/\n/, $body)) {
455 irc_gateway_notice $c, "$_";
457 irc_gateway_notice $c, "---- END $fileid ----";
461 "disconnect" => sub {
463 irc_gateway_notice $c, "Disconnecting";
464 rtm_destroy "User disconnection request";
468 unless (defined($nick)) {
469 irc_gateway_notice $c, "Syntax: delim <name>";
474 if ($nick eq $c->{Nick}) {
475 $user = $users{$self_id};
477 $user = $users_by_name{irc_lcase($nick)};
478 $user = undef if $user->{Id} eq $self_id;
481 unless (defined($user)) {
482 irc_gateway_notice $c, "No such nick: $nick";
486 unless (defined $user->{DMId}) {
487 irc_gateway_notice $c, "DM already closed for $nick";
491 irc_gateway_notice $c, "Closing DM for $nick";
492 rtm_apicall "im.close", { channel => $user->{DMId} };
498 my ($c, $newnick) = @_;
499 return unless defined($newnick);
501 if (defined $c->{Nick}) {
502 my $u = $users_by_name{irc_lcase($newnick)};
503 if (defined($u) && ($u->{Id} ne $self_id)) {
504 irc_send_num $c, 433, [$newnick], "Nickname is already in use";
506 irc_send_from $c, $self_id, ["NICK"], $newnick;
507 $c->{Nick} = $newnick;
510 $c->{Nick} = $newnick;
511 irc_check_welcome $c;
517 $c->{Password} = $pass;
518 irc_check_welcome $c;
522 return unless scalar(@arg) >= 4;
524 $c->{User} = $arg[0];
525 $c->{Realname} = $arg[3];
526 irc_check_welcome $c;
530 return unless $c->{Ready};
531 my $presence = defined $msg ? "away" : "auto";
532 rtm_apicall "users.setPresence", { presence => $presence };
535 my ($c, $reply) = @_;
536 $reply = "" unless defined($reply);
537 irc_send_args $c, "localhost", ["PONG"], $reply;
540 my ($c, $name, $chname) = @_;
541 return unless $c->{Ready};
542 irc_invite_or_kick $c, "invite", $name, $chname;
545 my ($c, $name, $chname) = @_;
546 return unless $c->{Ready};
547 irc_invite_or_kick $c, "kick", $name, $chname;
551 return unless $c->{Ready};
552 return unless defined($name);
554 foreach my $n (split(/,/, $name)) {
556 my $chan = $channels_by_name{irc_lcase($n)};
557 if (not defined $chan) {
558 irc_send_num $c, 401, ["#$n"], "No such nick/channel";
559 } elsif ($chan->{Members}->{$self_id}) {
561 } elsif ($chan->{Type} eq "G") {
562 irc_send_num $c, 473, ["#$n"],
563 "<channel> :Cannot join channel (+i)";
565 rtm_apicall "channels.join", { channel => $chan->{Id} };
570 my ($c, $arg, $what) = @_;
571 return unless $c->{Ready};
572 return unless defined($arg);
576 if ($arg eq $c->{Nick}) {
577 irc_send_num $c, 221, [], "+i";
578 } elsif ($arg =~ /^#(.*)$/) {
579 my $chan = $channels_by_name{$1};
583 irc_send_num $c, 368, ["#$chan->{Name}"],
584 "End of channel ban list";
586 irc_send_num $c, 324,
588 ($chan->{Type} eq "G" ? "+ip" : "+p")];
589 irc_send_num $c, 329,
590 ["#$chan->{Name}", $start_time];
593 irc_send_num $c, 403, [$arg], "No such channel";
596 irc_send_num $c, 403, [$arg], "No such channel";
600 my ($c, $name, $topic) = @_;
601 return unless defined($name) && defined($topic);
602 return unless $c->{Ready};
605 my $chan = $channels_by_name{irc_lcase($name)};
606 unless (defined($chan)) {
607 irc_send_num $c, 401, ["#$name"], "No such nick/channel";
611 my $what = $chan->{Type} eq "C" ? "channels" : "groups";
613 rtm_apicall "$what.setTopic", { channel => $chan->{Id},
618 return unless $c->{Ready};
619 return unless defined($name);
621 foreach my $n (split(/,/, $name)) {
623 my $chan = $channels_by_name{irc_lcase($n)};
624 if (not defined($chan)) {
625 irc_send_num $c, 401, ["#$n"], "No such nick/channel";
626 } elsif ($chan->{Members}->{$self_id}) {
627 my $what = $chan->{Type} eq "C" ? "channels" : "groups";
628 rtm_apicall "$what.leave", { channel => $chan->{Id} };
634 return unless $c->{Ready};
636 irc_send_num $c, 321, ["Channel"], "Users Name";
637 foreach my $chid (keys %channels) {
638 my $chan = $channels{$chid};
639 my $n = keys %{$chan->{Members}};
641 irc_send_num $c, 322, ["#$chan->{Name}", $n], $chan->{Topic};
643 irc_send_num $c, 323, [], "End of /LIST";
646 my ($c, $nicklist) = @_;
647 return unless $c->{Ready};
648 return unless defined($nicklist);
651 for my $nick (split(/,/, $nicklist)) {
652 if (irc_eq($nick, "x")) {
653 irc_send_num $c, 311,
654 ["X", "X", "localhost", "*"], "Gateway service";
655 irc_send_num $c, 312, ["X", "localhost"], "slirc.pl";
656 } elsif (irc_eq($nick, $c->{Nick})) {
657 irc_send_whois $c, $self_id;
661 if ($nick =~ /^.*!([^@]*)/) {
664 $user = $users_by_name{irc_lcase($nick)};
665 $user = undef if defined($user) && $user->{Id} eq $self_id;
668 if (defined($user)) {
669 irc_send_whois $c, $user->{Id};
671 irc_send_num $c, 401, [$nick], "No such nick/channel";
676 irc_send_num $c, 318, [$nicklist], "End of /WHOIS list";
680 return unless $c->{Ready};
681 return unless defined($name);
685 my $chan = $channels_by_name{irc_lcase($n)};
686 unless (defined($chan)) {
687 irc_send_num $c, 401, [$name], "No such nick/channel";
691 irc_send_names $c, $chan;
695 return unless $c->{Ready};
697 if (!defined($name)) {
698 foreach my $u (keys %users) {
699 irc_send_who $c, "*", $u;
701 irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
702 "X", "H"], "0 Gateway service";
703 } elsif (irc_eq($name, "X")) {
704 irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
705 "X", "H"], "0 Gateway service";
706 } elsif ($name =~ /^.*!([^@]*)/) {
707 unless (exists $users{$1}) {
708 irc_send_num $c, 401, [$name], "No such nick/channel";
712 irc_send_who $c, $name, $1;
713 } elsif ($name =~ /^#(.*)$/) {
714 my $chan = $channels_by_name{irc_lcase($1)};
716 unless (defined($chan)) {
717 irc_send_num $c, 401, [$name], "No such nick/channel";
721 foreach my $u (keys %{$chan->{Members}}) {
722 irc_send_who $c, "#$chan->{Name}", $u;
725 my $user = $users_by_name{irc_lcase($name)};
727 unless (defined($user)) {
728 irc_send_num $c, 401, [$name], "No such nick/channel";
732 irc_send_who $c, $name, $self_id;
735 $name = "*" unless defined($name);
736 irc_send_num $c, 315, [$name], "End of /WHO list";
739 my ($c, $namelist, $msg) = @_;
740 return unless $c->{Ready};
741 return unless defined($namelist) && defined($msg);
743 $msg =~ s/<@([^>]+)>/'<@' . irc_name_to_id($c, $1) . '>'/eg;
744 $msg =~ s/<#([^>]+)>/'<@' . irc_chan_to_id($c, $1) . '>'/eg;
746 foreach my $name (split(/,/, $namelist)) {
747 if (irc_eq($name, "X")) {
748 my @args = split(/ */, $msg);
749 my $cmd = shift @args;
750 my $handler = $gateway_command{lc($cmd)};
752 if (defined $handler) {
753 $handler->($c, @args);
755 irc_gateway_notice $c, "Unknown command: $cmd";
757 } elsif ($name =~ /^#(.*)$/) {
758 my $chan = $channels_by_name{irc_lcase($1)};
762 type => "message", channel => $chan->{Id},
765 irc_send_num $c, 401, [$name], "No such nick/channel";
767 } elsif (irc_eq($name, $c->{Nick})) {
768 rtm_send_to_user $self_id, $msg;
770 my $user = $users_by_name{irc_lcase($name)};
773 rtm_send_to_user $user->{Id}, $msg;
775 irc_send_num $c, 401, [$name], "No such nick/channel";
781 shift->{PingCount} = 0;
785 irc_disconnect $c, "QUIT";
789 sub irc_broadcast_notice {
792 print "NOTICE: $msg\n";
793 foreach my $k (keys %irc_clients) {
794 my $c = $irc_clients{$k};
795 irc_server_notice $c, $msg if $c->{Authed};
801 return $c->{Nick} if $id eq $self_id;
803 return $u->{Name} if defined($u);
809 return $self_id if $name eq $c->{Nick};
810 my $u = $users_by_name{$name};
811 return $u->{Id} if defined($u);
817 my $ch = $channels{$id};
818 return $ch->{Name} if defined ($ch);
824 my $ch = $channels_by_name{$chan};
825 return $ch->{Id} if defined($ch);
830 my ($srcid, $dstname, $subtype, $text) = @_;
834 $prefix = "\002[$subtype]\002 " if defined($subtype);
836 for my $k (keys %irc_clients) {
837 my $c = $irc_clients{$k};
838 next unless $c->{Ready};
840 my $translate = $text;
841 $translate =~ s/<@([^>]+)>/'<@' . irc_id_to_name($c, $1) . '>'/eg;
842 $translate =~ s/<#([^>]+)>/'<@' . irc_id_to_chan($c, $1) . '>'/eg;
844 for my $line (split(/\n/, $translate)) {
845 irc_send_from $c, $srcid, ["PRIVMSG", $dstname], "$prefix$line";
851 my ($id, $subtype, $msg) = @_;
852 irc_do_message $id, $users{$id}->{Name}, $subtype, $msg;
856 my ($id, $subtype, $chid, $msg) = @_;
857 irc_do_message $id, "#$channels{$chid}->{Name}", $subtype, $msg;
860 sub irc_topic_change {
861 my ($id, $chid) = @_;
862 my $chan = $channels{$chid};
864 foreach my $k (keys %irc_clients) {
865 my $c = $irc_clients{$k};
867 irc_send_from $c, $id, ["TOPIC", "#$chan->{Name}"], $chan->{Topic}
875 if (++$c->{PingCount} >= 2) {
876 irc_disconnect $c, "Ping timeout";
880 irc_send_args $c, "localhost", ["PING"], time();
881 $c->{PingTimer} = AnyEvent->timer(after => 60, cb => sub { irc_ping($c); });
885 my ($c, $fh, $line, $eol) = @_;
887 print "IRC $fh RECV: $line\n";
891 my $smallargs = $line;
894 if ($line =~ /^(.*?) :(.*)$/) {
899 my @words = split / */, $smallargs;
900 push @words, $bigarg if defined($bigarg);
902 if (scalar(@words)) {
903 my $cmd = shift @words;
904 my $handler = $irc_command{uc($cmd)};
906 $handler->($c, @words) if (defined($handler));
909 $fh->push_read(line => sub { irc_line($c, @_) });
913 print "Start IRC listener\n";
914 my $listen_host = $config{unix_socket} ? "unix/" : "127.0.0.1";
915 tcp_server $listen_host,
916 ($config{unix_socket} || $config{port} || 6667), sub {
917 my ($fd, $host, $port) = @_;
920 $fh = new AnyEvent::Handle
923 my ($fh, $fatal, $msg) = @_;
924 irc_disconnect $irc_clients{$fh}, "error: $msg";
928 irc_disconnect $irc_clients{$fh}, "EOF";
931 print "IRC $fh Got connection from $host:$port\n";
933 my $c = { Handle => $fh };
934 $c->{PingTimer} = AnyEvent->timer(after => 30,
935 cb => sub { irc_ping $c; });
937 $irc_clients{$fh} = $c;
938 $fh->push_read(line => sub { irc_line($c, @_) });
940 irc_server_notice $c, "Waiting for RTM connection" if not $connected;
942 chmod 0600, $config{unix_socket} if $config{unix_socket};
946 ########################################################################
948 ########################################################################
953 my %rtm_apicall_handles;
954 my $rtm_cooldown_timer;
963 my ($method, $args, $cb) = @_;
966 print "RTM APICALL $method ", Dumper($args);
968 $args->{token} = $config{slack_token};
970 foreach my $k (keys %$args) {
971 my $ek = uri_encode($k);
972 my $ev = uri_encode($args->{$k});
974 push @encode, "$ek=$ev";
978 $x = http_post "https://slack.com/api/$method", join('&', @encode),
980 "Content-Type", "application/x-www-form-urlencoded"
982 my ($body, $hdr) = @_;
983 delete $rtm_apicall_handles{$x};
985 unless ($hdr->{Status} =~ /^2/) {
987 "API HTTP error: $method: $hdr->{Status} $hdr->{Reason}";
988 $cb->(undef) if defined($cb);
992 my $data = decode_json $body;
994 print "RTM REPLY $method ", Dumper($data);
996 unless ($data->{ok}) {
997 irc_broadcast_notice "API error: $data->{error}";
998 $cb->(undef) if defined($cb);
1002 $cb->($data) if defined($cb);
1005 $rtm_apicall_handles{$x} = 1;
1011 $frame->{id} = $rtm_msg_id++;
1012 print "RTM SEND: ", Dumper($frame);
1013 $rtm_con->send(encode_json $frame);
1016 sub rtm_update_join {
1017 my ($uid, $chid) = @_;
1018 my $chan = $channels{$chid};
1019 my $user = $users{$uid};
1021 if (!$chan->{Members}->{$uid}) {
1022 $chan->{Members}->{$uid} = 1;
1023 $user->{Channels}->{$chid} = 1;
1030 sub rtm_update_part {
1031 my ($uid, $chid) = @_;
1032 my $chan = $channels{$chid};
1033 my $user = $users{$uid};
1035 if ($chan->{Members}->{$uid}) {
1036 delete $channels{$chid}->{Members}->{$uid};
1037 delete $users{$uid}->{Channels}->{$chid};
1044 sub rtm_update_user {
1048 if (exists $users{$c->{id}}) {
1049 $user = $users{$c->{id}};
1050 my $oldname = $user->{Name};
1051 delete $users_by_name{irc_lcase($oldname)};
1052 my $newname = irc_pick_name($c->{name}, \%users_by_name);
1054 $user->{Realname} = $c->{real_name};
1056 irc_broadcast_nick $c->{id}, $newname
1057 if $oldname ne $newname;
1059 $user->{Name} = $newname;
1060 $user->{Presence} = $c->{presence} || 'active';
1061 $users_by_name{$newname} = $user;
1063 my $name = irc_pick_name($c->{name}, \%users_by_name);
1068 Realname => $c->{real_name},
1070 Presence => $c->{presence} || 'active'
1073 $users{$c->{id}} = $user;
1074 $users_by_name{$name} = $user;
1077 $user->{Realname} = "" unless defined($user->{Realname});
1080 sub rtm_record_unknown_uid {
1083 unless (exists $users{$uid}) {
1085 my $name = irc_pick_name($uid, \%users_by_name);
1096 $users_by_name{irc_lcase($name)} = $u;
1098 rtm_apicall "users.info", { user => $uid }, sub {
1101 rtm_update_user $data->{user} if defined $data;
1106 sub rtm_update_channel {
1107 my ($type, $c) = @_;
1111 my $name = $c->{name};
1113 $name = "+$name" if $type eq "G";
1115 # Cross-reference users/channels
1116 foreach my $u (@{$c->{members}}) {
1117 rtm_record_unknown_uid $u;
1119 $users{$u}->{Channels}->{$id} = 1;
1122 if (exists $channels{$id}) {
1123 my $chan = $channels{$id};
1124 $chan->{Members} = $mhash;
1125 $chan->{Topic} = $c->{topic}->{value};
1126 $chan->{Type} = $type;
1128 my $name = irc_pick_name($name, \%channels_by_name);
1134 Topic => $c->{topic}->{value}
1137 $channels{$c->{id}} = $chan;
1138 $channels_by_name{irc_lcase($name)} = $chan;
1142 sub rtm_delete_channel {
1144 my $chan = $channels{$chid};
1145 return unless defined $chan;
1147 foreach ($chan->{Members}) {
1148 my $user = $users{$_};
1150 delete $user->{Channels}->{$chid};
1153 delete $channels_by_name{irc_lcase($chan->{Name})};
1154 delete $channels{$chid};
1157 sub rtm_mark_channel {
1158 my ($chid, $ts) = @_;
1160 $rtm_mark_queue{$chid} = $ts;
1162 unless (defined $rtm_mark_timer) {
1163 $rtm_mark_timer = AnyEvent->timer(after => 5, cb => sub {
1164 for my $chid (keys %rtm_mark_queue ) {
1165 rtm_apicall "channels.mark", {
1167 ts => $rtm_mark_queue{$chid}
1170 %rtm_mark_queue = ();
1171 undef $rtm_mark_timer;
1177 "presence_change" => sub {
1179 my $user = $users{$msg->{user}};
1181 if (defined $user) {
1182 my $old = $user->{Presence};
1183 $user->{Presence} = $msg->{presence} if defined $user;
1184 irc_broadcast_away if
1185 $msg->{user} eq $self_id and $old ne $msg->{presence};
1188 "manual_presence_change" => sub {
1190 my $user = $users{$self_id};
1191 my $old = $user->{Presence};
1193 $user->{Presence} = $msg->{presence};
1194 irc_broadcast_away if $old ne $msg->{presence};
1198 rtm_record_unknown_uid $msg->{user};
1200 my $u = $users{$msg->{user}};
1201 $u->{DMId} = $msg->{channel};
1202 $users_by_dmid{$msg->{channel}} = $u;
1204 foreach my $msg (@{$u->{TxQueue}}) {
1205 rtm_send { type => "message",
1206 channel => $u->{DMId}, text => $msg };
1213 my $u = $users_by_dmid{$msg->{channel}};
1214 return unless defined($u);
1217 delete $users_by_dmid{$msg->{channel}};
1219 "group_joined" => sub {
1222 rtm_update_channel "G", $msg->{channel};
1223 irc_broadcast_join $self_id, $msg->{channel}->{id};
1225 "group_left" => sub {
1228 irc_broadcast_part $self_id, $msg->{channel}
1229 if rtm_update_part $self_id, $msg->{channel};
1231 "group_archive" => sub {
1234 irc_broadcast_part $self_id, $msg->{channel}
1235 if rtm_update_part $self_id, $msg->{channel};
1236 rtm_delete_channel $msg->{channel};
1238 "channel_joined" => sub {
1241 rtm_update_channel "C", $msg->{channel};
1242 irc_broadcast_join $self_id, $msg->{channel}->{id};
1244 "channel_left" => sub {
1247 irc_broadcast_part $self_id, $msg->{channel}
1248 if rtm_update_part $self_id, $msg->{channel};
1250 "channel_archive" => sub {
1253 irc_broadcast_part $self_id, $msg->{channel}
1254 if rtm_update_part $self_id, $msg->{channel};
1255 rtm_delete_channel $msg->{channel};
1257 "member_joined_channel" => sub {
1260 rtm_record_unknown_uid $msg->{user};
1261 irc_broadcast_join $msg->{user}, $msg->{channel}
1262 if rtm_update_join($msg->{user}, $msg->{channel});
1264 "member_left_channel" => sub {
1267 irc_broadcast_part $msg->{user}, $msg->{channel}
1268 if rtm_update_part($msg->{user}, $msg->{channel});
1271 $rtm_ping_count = 0;
1275 my $chan = $channels{$msg->{channel}};
1276 my $subtype = $msg->{subtype} || "";
1277 my $uid = $msg->{user} || $msg->{comment}->{user};
1278 my $text = $msg->{text};
1280 $text = "" unless defined($text);
1282 if (defined($chan)) {
1283 if ($subtype eq "channel_topic" or $subtype eq "group_topic") {
1284 $chan->{Topic} = $msg->{topic};
1285 irc_topic_change $uid, $chan->{Id};
1287 irc_chanmsg $uid, $msg->{subtype}, $chan->{Id}, $text;
1289 rtm_mark_channel $chan->{Id}, $msg->{ts};
1291 irc_privmsg $uid, $msg->{subtype}, $text;
1294 if ($subtype eq "file_share") {
1295 my $fid = $msg->{file}->{id};
1296 rtm_apicall "files.info", { file => $fid }, sub {
1298 return unless defined $data;
1300 my $body = $data->{content};
1301 return unless length($body) <= 65536;
1303 if (defined $chan) {
1304 irc_chanmsg $uid, ">$fid", $chan->{Id}, $body;
1306 irc_privmsg $uid, ">$fid", $body;
1313 sub rtm_send_to_user {
1314 my ($id, $msg) = @_;
1315 my $u = $users{$id};
1317 if (defined($u->{DMId}) && length($u->{DMId})) {
1318 rtm_send { type => "message",
1319 channel => $u->{DMId}, text => $msg };
1323 push @{$u->{TxQueue}}, $msg;
1325 if (!defined($u->{DMId})) {
1326 rtm_apicall "im.open", { user => $u->{Id} }, sub {
1328 unless (defined $result) {
1330 foreach my $m (@{$u->{TxQueue}}) {
1331 irc_broadcast_notice "Failed to send to $u->{Name}: $m";
1344 return if defined($rtm_cooldown_timer);
1345 print "Waiting before reinitiating RTM\n";
1346 $rtm_cooldown_timer = AnyEvent->timer(after => 5, cb => sub {
1347 undef $rtm_cooldown_timer;
1354 return unless defined($rtm_con);
1356 irc_broadcast_notice $msg;
1361 %channels_by_name = ();
1363 %users_by_name = ();
1364 %users_by_dmid = ();
1366 %rtm_apicall_handles = (); # cancel outstanding requests
1367 %rtm_mark_queue = ();
1368 undef $rtm_mark_timer;
1369 undef $rtm_ping_timer;
1379 if (++$rtm_ping_count >= 2) {
1380 rtm_destroy "RTM ping timeout";
1384 rtm_send { type => "ping" };
1385 $rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);
1391 return if defined($rtm_client);
1392 $rtm_client = AnyEvent::WebSocket::Client->new;
1394 print "WSS URL: $url\n";
1395 $rtm_client->connect($url)->cb(sub {
1396 $rtm_con = eval { shift->recv; };
1398 irc_broadcast_notice "WSS connection failed: $@\n";
1403 print "WSS connected\n";
1405 $rtm_ping_count = 0;
1407 irc_check_welcome_all;
1409 $rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);
1411 $rtm_con->on(each_message => sub {
1414 my $msg = decode_json shift->{body};
1416 print "RTM RECV: ", Dumper($msg);
1417 irc_broadcast_notice "RTM error: $msg->{error}->{msg}"
1420 if (defined $msg->{type}) {
1421 my $handler = $rtm_command{$msg->{type}};
1422 $handler->($msg) if defined($handler);
1425 print "Error in message handler: $@" if $@;
1428 $rtm_con->on(finish => sub {
1432 if (defined $con->close_error) {
1433 rtm_destroy "RTM connection error: $con->close_error";
1434 } elsif (defined $con->close_reason) {
1435 rtm_destroy "RTM connection closed: $con->close_reason";
1437 rtm_destroy "RTM connection finished";
1440 print "Error in finish handler: $@" if $@;
1446 print "Requesting RTM connection\n";
1447 rtm_apicall "rtm.start", {}, sub {
1450 unless (defined($data)) {
1455 $self_id = $data->{self}->{id};
1457 foreach my $c (@{$data->{users}}) {
1461 foreach my $c (@{$data->{ims}}) {
1462 my $u = $users{$c->{user}};
1464 $u->{DMId} = $c->{id};
1465 $users_by_dmid{$c->{id}} = $u;
1468 foreach my $c (@{$data->{channels}}) {
1469 rtm_update_channel "C", $c unless $c->{is_archived};
1472 foreach my $c (@{$data->{groups}}) {
1473 rtm_update_channel "G", $c unless $c->{is_archived};
1476 rtm_start_ws $data->{url};
1480 ########################################################################
1482 ########################################################################
1484 my $cfgfile = shift || die "You must specify a config file";
1485 open(my $cfg, $cfgfile) || die "Can't open $cfgfile";
1488 $config{$1} = $2 if /^([-_0-9a-zA-Z]+)=(.*)$/;
1494 AnyEvent->condvar->recv;