#!/usr/bin/perl -w
# slirc.pl: local Slack IRC gateway
# Copyright (C) 2017-2019 Daniel Beer <dlbeer@gmail.com>
#
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
# To run, create a configuration file with the following content:
#
#     slack_token=<legacy API token>
#     password=<password of your choice>
#     port=<port>
#
# Then run ./slirc.pl <config-file>. Connect to the chosen port on
# 127.0.0.1 with your chosen password.
#
# Updated 2018-05-15 to add support for listening on Unix domain sockets
# by Colin Watson <cjwatson@chiark.greenend.org.uk>. To use this feature
# with an IRC client supporting Unix domain connections, add the line
# "unix_socket=<path>" to the config file.
#
# Updated 2019-02-18:
# - HTML entities are now escaped/unescaped properly
# - Channel IDs are translated with the correct sigil
# - You can now close accumulated group chats. This is mapped to
#   JOIN/PART (the behaviour of JOIN/PART for public channels is
#   unaffected)
# - IRC-side PING checks are now more lenient, to work around bugs in
#   some IRC clients
# - Added X commands for debug dumps and dynamically switching protocol
#   debug on/off
#
# Updated 2019-05-08 based on changes from Neia Finch to improve
# support for bots.

use strict;
use warnings;
use utf8;

use AnyEvent;
use AnyEvent::HTTP;
use AnyEvent::Socket;
use AnyEvent::WebSocket::Client;
use URI::Encode qw(uri_encode);
use Data::Dumper;
use Time::localtime;
use Digest::SHA qw(sha256);
use JSON;

my $VERSION = "20190225";
my $start_time = time();
my %config;

$| = 1;

########################################################################
# Global chat state
########################################################################

my $connected;			# Is the RTM connection ready?
my $self_id;			# Slack ID of our own user, or undef

my %channels;			# Slack ID -> channel hash ref
my %channels_by_name;		# irc_lcase -> channel hash ref
# Properties:
# - Id: Slack ID
# - Members: Slack ID set
# - Name: text (IRC name)
# - Topic: text

my %users;			# Slack ID -> user hash ref
my %users_by_name;		# irc_lcase -> user hash ref
my %users_by_dmid;              # Slack DMID -> user hash ref
# Properties:
# - Id: Slack ID
# - Name: text (IRC name)
# - Channels: Slack ID set
# - Realname: text
# - DMId: DM session ID (may be undefined, or blank if open in progress)
# - TxQueue: messages awaiting transmission if no DM open

########################################################################
# IRC names
########################################################################

# Canonicalize an IRC name
sub irc_lcase {
    my $name = lc(shift);

    $name =~ s/\[/{/g;
    $name =~ s/]/}/g;
    $name =~ s/\|/\\/g;
    $name =~ s/\^/~/g;

    return $name;
}

# Compare two names
sub irc_eq {
    my ($a, $b) = @_;

    return irc_lcase($a) eq irc_lcase($b);
}

# Choose an unused valid name with reference to the hash
sub irc_pick_name {
    my ($name, $hash) = @_;

    $name =~ s/[#,<>!\0\r\n: ]/_/g;

    return $name if length($name) && irc_lcase($name) ne "x" &&
	!defined($hash->{irc_lcase($name)});

    my $i = 1;

    for (;;) {
	my $prop = "$name$i";

	return $prop unless defined($hash->{irc_lcase($prop)});
	$i++;
    }
}

########################################################################
# IRC server
########################################################################

# Forward decls to RTM subsystem
sub rtm_send;
sub rtm_send_to_user;
sub rtm_apicall;
sub rtm_download;
sub rtm_destroy;
sub rtm_update_join;
sub rtm_update_part;

my %irc_clients;

sub irc_send_args {
    my ($c, $source, $short, $long) = @_;

    $source =~ s/[\t\r\n\0 ]//g;
    $source =~ s/^://g;
    my @arg = (":$source");

    for my $a (@$short) {
	$a =~ s/[\t\r\n\0 ]//g;
	$a =~ s/^://g;
	utf8::encode($a);
	$a = "*" unless length($a);
	push @arg, $a;
    }

    if (defined($long)) {
	$long =~ s/[\r\n\0]/ /g;
	utf8::encode($long);
	push @arg, ":$long";
    }

    my $line = join(' ', @arg);
    print "IRC $c->{Handle} SEND: $line\n" if $config{debug_dump};
    $c->{Handle}->push_write("$line\r\n");
}

sub irc_send_num {
    my ($c, $num, $short, $long) = @_;
    my $dst = $c->{Nick};

    $dst = "*" unless defined($c->{Nick});
    irc_send_args $c, "localhost",
	[sprintf("%03d", $num), $dst, @$short], $long;
}

sub irc_send_from {
    my ($c, $uid, $short, $long) = @_;
    my $user = $users{$uid};
    my $nick = $uid eq $self_id ? $c->{Nick} : $user->{Name};

    irc_send_args $c, "$nick!$user->{Id}\@localhost", $short, $long;
}

sub irc_disconnect {
    my ($c, $msg) = @_;

    print "IRC $c->{Handle} DISCONNECT: $msg\n";
    delete $irc_clients{$c->{Handle}};
    $c->{Handle}->destroy;
}

sub irc_disconnect_all {
    print "IRC: disconnect all\n";
    foreach my $k (keys %irc_clients) {
	$irc_clients{$k}->{Handle}->destroy;
    }
    %irc_clients = ();
}

sub irc_send_names {
    my ($c, $chan) = @_;
    my $i = 0;
    my @ulist = keys %{$chan->{Members}};

    while ($i < @ulist) {
	my $n = @ulist - $i;
	$n = 8 if $n > 8;
	my $chunk = join(' ', map {
	    $_ eq $self_id ? $c->{Nick} : $users{$_}->{Name}
	} @ulist[$i .. ($i + $n - 1)]);
	irc_send_num $c, 353, ['@', "#$chan->{Name}"], $chunk;
	$i += $n;
    }

    irc_send_num $c, 366, ["#$chan->{Name}"], "End of /NAMES list";
}

sub irc_server_notice {
    my ($c, $msg) = @_;
    my $nick = $c->{Nick};

    $nick = "*" unless defined($nick);
    irc_send_args $c, "localhost", ["NOTICE", $nick], $msg;
}

sub irc_gateway_notice {
    my ($c, $msg) = @_;
    my $nick = $c->{Nick};

    $nick = "*" unless defined($nick);
    irc_send_args $c, "X!X\@localhost", ["NOTICE", $nick], $msg;
}

sub irc_notify_away {
    my $c = shift;
    my $user = $users{$self_id};
    my ($num, $msg);

    if ($user->{Presence} eq 'away') {
	$num = 306;
	$msg = "You have been marked as being away";
    } else {
	$num = 305;
	$msg = "You are no longer marked as being away";
    }

    irc_send_num $c, $num, [], $msg if $c->{Ready};
}

sub irc_broadcast_away {
    for my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	irc_notify_away $c if $c->{Ready};
    }
}

sub irc_send_motd {
    my $c = shift;
    my @banner =
      (
       '     _ _                  _',
       ' ___| (_)_ __ ___   _ __ | |',
       '/ __| | | \'__/ __| | \'_ \| |',
       '\__ \ | | | | (__ _| |_) | |',
       '|___/_|_|_|  \___(_) .__/|_|',
       '                   |_|',
       'slirc.pl, Copyright (C) 2017-2019 Daniel Beer <dlbeer@gmail.com>'
      );

    for my $x (@banner) {
	irc_send_num $c, 372, [], $x;
    }
    irc_send_num $c, 376, [], "End of /MOTD command";
}

sub irc_check_welcome {
    my $c = shift;

    if (defined $c->{Nick} && defined $c->{User} &&
	(!$config{password} || defined $c->{Password}) &&
	!$c->{Authed}) {
	if (!$config{password} ||
	    sha256($c->{Password}) eq sha256($config{password})) {
	    $c->{Authed} = 1;
	} else {
	    irc_server_notice $c, "Incorrect password";
	    irc_disconnect $c, "Incorrect password";
	    return;
	}
    }

    return unless $c->{Authed} && !$c->{Ready} && $connected;

    my $u = $users_by_name{irc_lcase($c->{Nick})};
    if (defined($u) && ($u->{Id} ne $self_id)) {
	irc_server_notice $c, "Nick already in use";
	irc_disconnect $c, "Nick already in use";
	return;
    }

    my $lt = localtime($start_time);

    irc_send_num $c, 001, [], "slirc.pl IRC-to-Slack gateway";
    irc_send_num $c, 002, [], "This is slirc.pl version $VERSION";
    irc_send_num $c, 003, [], "Server started " . ctime($start_time);
    irc_send_motd $c;
    $c->{Ready} = 1;

    my $user = $users{$self_id};

    for my $k (keys %{$user->{Channels}}) {
	my $chan = $channels{$k};
	irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
	irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{"Topic"};
	irc_send_names $c, $chan;
    }

    irc_notify_away $c;
}

sub irc_check_welcome_all {
    foreach my $k (keys %irc_clients) {
	irc_check_welcome $irc_clients{$k};
    }
}

sub irc_broadcast_nick {
    my ($id, $newname) = @_;
    return if $id eq $self_id;

    for my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	irc_send_from $c, $id, ["NICK", $newname] if $c->{Ready};
    }
}

sub irc_broadcast_join {
    my ($uid, $chid) = @_;
    my $chan = $channels{$chid};

    for my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	next unless $c->{Ready};

	if ($uid eq $self_id) {
	    irc_send_from $c, $self_id, ["JOIN", "#$chan->{Name}"];
	    irc_send_num $c, 332, ["#$chan->{Name}"], $chan->{Topic};
	    irc_send_names $c, $chan;
	} else {
	    irc_send_from $c, $uid, ["JOIN", "#$chan->{Name}"];
	}
    }
}

sub irc_broadcast_part {
    my ($uid, $chid) = @_;
    my $chan = $channels{$chid};

    for my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	next unless $c->{Ready};
	irc_send_from $c, $uid, ["PART", "#$chan->{Name}"];
    }
}

sub irc_send_who {
    my ($c, $chname, $u) = @_;

    my $user = $users{$u};
    my $nick = $u eq $self_id ? $c->{Nick} : $user->{Name};
    my $here = $user->{Presence} eq 'away' ? 'G' : 'H';

    irc_send_num $c, 352, [$chname, $user->{Id}, "localhost", "localhost",
			   $nick, $here], "0 $user->{Realname}";
}

sub irc_send_whois {
    my ($c, $uid) = @_;
    my $u = $users{$uid};
    my $nick = $uid eq $self_id ? $c->{Nick} : $u->{Name};

    irc_send_num $c, 311,
	[$nick, $u->{Id}, "localhost", "*"], $u->{Realname};
    irc_send_num $c, 312, [$nick, "localhost"], "slirc.pl";
    my $clist = join(' ', map { "#" . $channels{$_}->{Name} }
			  keys %{$u->{Channels}});
    irc_send_num $c, 319, [$nick], $clist;
    irc_send_num $c, 301, [$nick], "away" if $u->{Presence} eq 'away';
}

sub irc_invite_or_kick {
    my ($c, $action, $name, $chname) = @_;

    $chname =~ s/^#//;
    my $chan = $channels_by_name{irc_lcase($chname)};

    unless (defined $chan) {
	irc_send_num $c, 401, ["#$chname"], "No such nick/channel";
	return;
    }

    my $what = $chan->{Type} eq "C" ? "channels" : "groups";

    foreach (split(/,/, $name)) {
	my $user = $users_by_name{irc_lcase($_)};

	if (defined $user) {
	    rtm_apicall "$what.$action", { user => $user->{Id},
					   channel => $chan->{Id} };
	} else {
	    irc_send_num $c, 401, [$user], "No such nick/channel";
	}
    }
}

my %gateway_command = (
    "debug_dump_state" => sub {
	my $c = shift;
	irc_gateway_notice $c, "Dumping debug state on stdout";
	print Dumper({ "connected" => $connected,
		       "self_id", => $self_id,
		       "%channels" => \%channels,
		       "%channels_by_name" => \%channels_by_name,
		       "users" => \%users,
		       "users_by_name" => \%users_by_name,
		       "users_by_dmid" => \%users_by_dmid
		     });
    },
    "debug_dump" => sub {
	my ($c, $arg) = @_;
	$config{debug_dump} = $arg ? 1 : 0 if defined $arg;
	irc_gateway_notice $c, "Protocol debug is " .
	  ($config{debug_dump} ? "on" : "off");
    },
    "newgroup" => sub {
	my ($c, $name) = @_;
	unless (defined($name)) {
	    irc_gateway_notice $c, "Syntax: newgroup <name>";
	    return;
	}
	$name =~ s/^#//;
	irc_gateway_notice $c, "Creating group $name";
	rtm_apicall "groups.create", { name => $name };
    },
    "newchan" => sub {
	my ($c, $name) = @_;
	unless (defined($name)) {
	    irc_gateway_notice $c, "Syntax: newchan <name>";
	    return;
	}
	$name =~ s/^#//;
	irc_gateway_notice $c, "Creating channel $name";
	rtm_apicall "channels.create", { name => $name };
    },
    "archive" => sub{
	my ($c, $name) = @_;
	unless (defined($name)) {
	    irc_gateway_notice $c, "Syntax: archive <name>";
	    return;
	}
	$name =~ s/^#//;
	my $g = $channels_by_name{irc_lcase($name)};
	my $what = $g->{Type} eq "C" ? "channels" : "groups";
	if (defined $g) {
	    irc_gateway_notice $c, "Archiving $name";
	    rtm_apicall "$what.archive", { channel => $g->{Id} };
	} else {
	    irc_gateway_notice $c, "No such channel: $name";
	}
    },
    "close" => sub{
	my ($c, $name) = @_;
	unless (defined($name)) {
	    irc_gateway_notice $c, "Syntax: close <name>";
	    return;
	}

	$name =~ s/^#//;
	my $g = $channels_by_name{irc_lcase($name)};
	my $what = $g->{Type} eq "C" ? "channels" : "groups";
	if (defined $g) {
	    irc_gateway_notice $c, "Closing $name";
	    rtm_apicall "$what.close", { channel => $g->{Id} };
	} else {
	    irc_gateway_notice $c, "No such channel: $name";
	}
    },
    "cat" => sub {
	my ($c, $fileid) = @_;
	unless (defined($fileid)) {
	    irc_gateway_notice $c, "Syntax: cat <fileid> <filename>";
	    return;
	}

	rtm_apicall "files.info", { file => $fileid }, sub {
	    my $data = shift;
	    return unless defined $data;

	    my $body = $data->{content};

	    if (length($body) > 65536) {
		irc_gateway_notice $c, "File too big";
	    } else {
		irc_gateway_notice $c, "---- BEGIN $fileid ----";
		foreach (split(/\n/, $body)) {
		    irc_gateway_notice $c, "$_";
		}
		irc_gateway_notice $c, "---- END $fileid ----";
	    }
	};
    },
    "disconnect" => sub {
	my ($c) = @_;
	irc_gateway_notice $c, "Disconnecting";
	rtm_destroy "User disconnection request";
    },
    "delim" => sub {
	my ($c, $nick) = @_;
	unless (defined($nick)) {
	    irc_gateway_notice $c, "Syntax: delim <name>";
	    return;
	}
	my $user;

	if ($nick eq $c->{Nick}) {
	    $user = $users{$self_id};
	} else {
	    $user = $users_by_name{irc_lcase($nick)};
	    $user = undef if $user->{Id} eq $self_id;
	}

	unless (defined($user)) {
	    irc_gateway_notice $c, "No such nick: $nick";
	    return;
	}

	unless (defined $user->{DMId}) {
	    irc_gateway_notice $c, "DM already closed for $nick";
	    return;
	}

	irc_gateway_notice $c, "Closing DM for $nick";
	rtm_apicall "im.close", { channel => $user->{DMId} };
    },
);

my %irc_command = (
    "NICK" => sub {
	my ($c, $newnick) = @_;
	return unless defined($newnick);

	if (defined $c->{Nick}) {
	    my $u = $users_by_name{irc_lcase($newnick)};
	    if (defined($u) && ($u->{Id} ne $self_id)) {
		irc_send_num $c, 433, [$newnick], "Nickname is already in use";
	    } else {
		irc_send_from $c, $self_id, ["NICK"], $newnick;
		$c->{Nick} = $newnick;
	    }
	} else {
	    $c->{Nick} = $newnick;
	    irc_check_welcome $c;
	}
    },
    "PASS" => sub {
	my ($c, $pass) = @_;

	$c->{Password} = $pass;
	irc_check_welcome $c;
    },
    "USER" => sub {
	my ($c, @arg) = @_;
	return unless scalar(@arg) >= 4;

	$c->{User} = $arg[0];
	$c->{Realname} = $arg[3];
	irc_check_welcome $c;
    },
    "AWAY" => sub {
	my ($c, $msg) = @_;
	return unless $c->{Ready};
	my $presence = defined $msg ? "away" : "auto";
	rtm_apicall "users.setPresence", { presence => $presence };
    },
    "PING" => sub {
	my ($c, $reply) = @_;
	$reply = "" unless defined($reply);
	irc_send_args $c, "localhost", ["PONG"], $reply;
    },
    "INVITE" => sub {
	my ($c, $name, $chname) = @_;
	return unless $c->{Ready};
	irc_invite_or_kick $c, "invite", $name, $chname;
    },
    "KICK" => sub {
	my ($c, $name, $chname) = @_;
	return unless $c->{Ready};
	irc_invite_or_kick $c, "kick", $name, $chname;
    },
    "JOIN" => sub {
	my ($c, $name) = @_;
	return unless $c->{Ready};
	return unless defined($name);

	foreach my $n (split(/,/, $name)) {
	    $n =~ s/^#//;
	    my $chan = $channels_by_name{irc_lcase($n)};
	    if (not defined $chan) {
		irc_send_num $c, 401, ["#$n"], "No such nick/channel";
	    } elsif ($chan->{Members}->{$self_id}) {
		# Already joined
	    } elsif ($chan->{Type} eq "G") {
		rtm_apicall "groups.open", { channel => $chan->{Id} };
		irc_broadcast_join $self_id, $chan->{Id}
		  if rtm_update_join $self_id, $chan->{Id};
	    } else {
		rtm_apicall "channels.join", { channel => $chan->{Id} };
	    }
	}
    },
    "MODE" => sub {
	my ($c, $arg, $what) = @_;
	return unless $c->{Ready};
	return unless defined($arg);

	$what = $what || "";

	if ($arg eq $c->{Nick}) {
	    irc_send_num $c, 221, [], "+i";
	} elsif ($arg =~ /^#(.*)$/) {
	    my $chan = $channels_by_name{$1};

	    if (defined $chan) {
		if ($what eq "b") {
		    irc_send_num $c, 368, ["#$chan->{Name}"],
			"End of channel ban list";
		} else {
		    irc_send_num $c, 324,
			["#$chan->{Name}",
			 ($chan->{Type} eq "G" ? "+ip" : "+p")];
		    irc_send_num $c, 329,
			["#$chan->{Name}", $start_time];
		}
	    } else {
		irc_send_num $c, 403, [$arg], "No such channel";
	    }
	} else {
	    irc_send_num $c, 403, [$arg], "No such channel";
	}
    },
    "TOPIC" => sub {
	my ($c, $name, $topic) = @_;
	return unless defined($name) && defined($topic);
	return unless $c->{Ready};

	$name =~ s/^#//;
	my $chan = $channels_by_name{irc_lcase($name)};
	unless (defined($chan)) {
	    irc_send_num $c, 401, ["#$name"], "No such nick/channel";
	    return;
	}

	my $what = $chan->{Type} eq "C" ? "channels" : "groups";

	rtm_apicall "$what.setTopic", { channel => $chan->{Id},
					topic => $topic };
    },
    "PART" => sub {
	my ($c, $name) = @_;
	return unless $c->{Ready};
	return unless defined($name);

	foreach my $n (split(/,/, $name)) {
	    $n =~ s/^#//;
	    my $chan = $channels_by_name{irc_lcase($n)};
	    if (not defined($chan)) {
		irc_send_num $c, 401, ["#$n"], "No such nick/channel";
	    } elsif ($chan->{Members}->{$self_id}) {
		if ($chan->{Type} eq "G") {
		    rtm_apicall "groups.close", { channel => $chan->{Id} };
		    irc_broadcast_part $self_id, $chan->{Id}
		      if rtm_update_part $self_id, $chan->{Id};
		} else {
		    rtm_apicall "channels.leave", { channel => $chan->{Id} };
		}
	    }
	}
    },
    "LIST" => sub {
	my ($c, @arg) = @_;
	return unless $c->{Ready};

	irc_send_num $c, 321, ["Channel"], "Users Name";
	foreach my $chid (keys %channels) {
	    my $chan = $channels{$chid};
	    my $n = keys %{$chan->{Members}};

	    irc_send_num $c, 322, ["#$chan->{Name}", $n], $chan->{Topic};
	}
	irc_send_num $c, 323, [], "End of /LIST";
    },
    "WHOIS" => sub {
	my ($c, $nicklist) = @_;
	return unless $c->{Ready};
	return unless defined($nicklist);
	my $some = 0;

	for my $nick (split(/,/, $nicklist)) {
	    if (irc_eq($nick, "x")) {
		irc_send_num $c, 311,
		    ["X", "X", "localhost", "*"], "Gateway service";
		irc_send_num $c, 312, ["X", "localhost"], "slirc.pl";
	    } elsif (irc_eq($nick, $c->{Nick})) {
		irc_send_whois $c, $self_id;
	    } else {
		my $user;

		if ($nick =~ /^.*!([^@]*)/) {
		    $user = $users{$1};
		} else {
		    $user = $users_by_name{irc_lcase($nick)};
		    $user = undef if defined($user) && $user->{Id} eq $self_id;
		}

		if (defined($user)) {
		    irc_send_whois $c, $user->{Id};
		} else {
		    irc_send_num $c, 401, [$nick], "No such nick/channel";
		}
	    }
	}

	irc_send_num $c, 318, [$nicklist], "End of /WHOIS list";
    },
    "NAMES" => sub {
	my ($c, $name) = @_;
	return unless $c->{Ready};
	return unless defined($name);

	my $n = $name;
	$n =~ s/^#//;
	my $chan = $channels_by_name{irc_lcase($n)};
	unless (defined($chan)) {
	    irc_send_num $c, 401, [$name], "No such nick/channel";
	    return;
	}

	irc_send_names $c, $chan;
    },
    "WHO" => sub {
	my ($c, $name) = @_;
	return unless $c->{Ready};

	if (!defined($name)) {
	    foreach my $u (keys %users) {
		irc_send_who $c, "*", $u;
	    }
	    irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
				   "X", "H"], "0 Gateway service";
	} elsif (irc_eq($name, "X")) {
	    irc_send_num $c, 352, ["*", "X", "localhost", "localhost",
				   "X", "H"], "0 Gateway service";
	} elsif ($name =~ /^.*!([^@]*)/) {
	    unless (exists $users{$1}) {
		irc_send_num $c, 401, [$name], "No such nick/channel";
		return;
	    }

	    irc_send_who $c, $name, $1;
	} elsif ($name =~ /^#(.*)$/) {
	    my $chan = $channels_by_name{irc_lcase($1)};

	    unless (defined($chan)) {
		irc_send_num $c, 401, [$name], "No such nick/channel";
		return;
	    }

	    foreach my $u (keys %{$chan->{Members}}) {
		irc_send_who $c, "#$chan->{Name}", $u;
	    }
	} else {
	    my $user = $users_by_name{irc_lcase($name)};

	    unless (defined($user)) {
		irc_send_num $c, 401, [$name], "No such nick/channel";
		return;
	    }

	    irc_send_who $c, $name, $self_id;
	}

	$name = "*" unless defined($name);
	irc_send_num $c, 315, [$name], "End of /WHO list";
    },
    "MOTD" => sub {
	my $c = shift;
	irc_send_motd $c;
    },
    "PRIVMSG" => sub {
	my ($c, $namelist, $msg) = @_;
	return unless $c->{Ready};
	return unless defined($namelist) && defined($msg);

	$msg =~ s/&/&amp;/g;
	$msg =~ s/</&lt;/g;
	$msg =~ s/>/&gt;/g;
	$msg =~ s/"/&quot;/g;
	$msg =~ s/&lt;@([^>]+)&gt;/'<@' . irc_name_to_id($c, $1) . '>'/eg;
	$msg =~ s/&lt;#([^>]+)&gt;/'<#' . irc_chan_to_id($c, $1) . '>'/eg;

	foreach my $name (split(/,/, $namelist)) {
	    if (irc_eq($name, "X")) {
		my @args = split(/  */, $msg);
		my $cmd = shift @args;
		my $handler = $gateway_command{lc($cmd)};

		if (defined $handler) {
		    $handler->($c, @args);
		} else {
		    irc_gateway_notice $c, "Unknown command: $cmd";
		}
	    } elsif ($name =~ /^#(.*)$/) {
		my $chan = $channels_by_name{irc_lcase($1)};

		if (defined $chan) {
		    rtm_send {
			type => "message", channel => $chan->{Id},
			text => $msg };
		} else {
		    irc_send_num $c, 401, [$name], "No such nick/channel";
		}
	    } elsif (irc_eq($name, $c->{Nick})) {
		rtm_send_to_user $self_id, $msg;
	    } else {
		my $user = $users_by_name{irc_lcase($name)};

		if (defined $user) {
		    rtm_send_to_user $user->{Id}, $msg;
		} else {
		    irc_send_num $c, 401, [$name], "No such nick/channel";
		}
	    }
	}
    },
    "PONG" => sub {
	shift->{PingCount} = 0;
    },
    "QUIT" => sub {
	my $c = shift;
	irc_disconnect $c, "QUIT";
    },
);

sub irc_broadcast_notice {
    my ($msg) = @_;

    print "NOTICE: $msg\n";
    foreach my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	irc_server_notice $c, $msg if $c->{Authed};
    }
}

sub irc_id_to_name {
    my ($c, $id) = @_;
    return $c->{Nick} if $id eq $self_id;
    my $u = $users{$id};
    return $u->{Name} if defined($u);
    return $id;
}

sub irc_name_to_id {
    my ($c, $name) = @_;
    return $self_id if $name eq $c->{Nick};
    my $u = $users_by_name{$name};
    return $u->{Id} if defined($u);
    return $name;
}

sub irc_id_to_chan {
    my ($c, $id) = @_;
    my $ch = $channels{$id};
    return $ch->{Name} if defined ($ch);
    return $id;
}

sub irc_chan_to_id {
    my ($c, $chan) = @_;
    my $ch = $channels_by_name{$chan};
    return $ch->{Id} if defined($ch);
    return $chan;
}

sub irc_do_message {
    my ($srcid, $dstname, $subtype, $text) = @_;

    $text =~ s/\002//g;
    my $prefix = "";
    $prefix = "\002[$subtype]\002 " if defined($subtype);

    for my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};
	next unless $c->{Ready};

	my $translate = $text;
	$translate =~ s/<@([^>]+)>/'<@' . irc_id_to_name($c, $1) . '>'/eg;
	$translate =~ s/<#([^>]+)>/'<#' . irc_id_to_chan($c, $1) . '>'/eg;
	$translate =~ s/&lt;/</g;
	$translate =~ s/&gt;/>/g;
	$translate =~ s/&quot;/"/g;
	$translate =~ s/&amp;/&/g;

	for my $line (split(/\n/, $translate)) {
	    irc_send_from $c, $srcid, ["PRIVMSG", $dstname], "$prefix$line";
	}
    }
}

sub irc_privmsg {
    my ($id, $subtype, $msg) = @_;
    irc_do_message $id, $users{$id}->{Name}, $subtype, $msg;
}

sub irc_chanmsg {
    my ($id, $subtype, $chid, $msg) = @_;
    irc_do_message $id, "#$channels{$chid}->{Name}", $subtype, $msg;
}

sub irc_topic_change {
    my ($id, $chid) = @_;
    my $chan = $channels{$chid};

    foreach my $k (keys %irc_clients) {
	my $c = $irc_clients{$k};

	irc_send_from $c, $id, ["TOPIC", "#$chan->{Name}"], $chan->{Topic}
	    if $c->{Ready};
    }
}

sub irc_ping {
    my $c = shift;

    if (++$c->{PingCount} >= 3) {
	irc_disconnect $c, "Ping timeout";
	return;
    }

    irc_send_args $c, "localhost", ["PING"], time();
    $c->{PingTimer} = AnyEvent->timer(after => 60, cb => sub { irc_ping($c); });
}

sub irc_line {
    my ($c, $fh, $line, $eol) = @_;

    print "IRC $fh RECV: $line\n" if $config{debug_dump};

    utf8::decode($line);

    my $smallargs = $line;
    my $bigarg = undef;

    if ($line =~ /^(.*?) :(.*)$/) {
	$smallargs = $1;
	$bigarg = $2;
    }

    my @words = split /  */, $smallargs;
    push @words, $bigarg if defined($bigarg);

    if (scalar(@words)) {
	my $cmd = shift @words;
	my $handler = $irc_command{uc($cmd)};

	$handler->($c, @words) if (defined($handler));
    }

    $fh->push_read(line => sub { irc_line($c, @_) });
}

sub irc_listen {
    print "Start IRC listener\n";
    my $listen_host = $config{unix_socket} ? "unix/" : "127.0.0.1";
    tcp_server $listen_host,
	       ($config{unix_socket} || $config{port} || 6667), sub {
	my ($fd, $host, $port) = @_;

	my $fh;
	$fh = new AnyEvent::Handle
	  fh => $fd,
	  on_error => sub {
	      my ($fh, $fatal, $msg) = @_;
	      irc_disconnect $irc_clients{$fh}, "error: $msg";
	  },
	  on_eof => sub {
	      my $fh = shift;
	      irc_disconnect $irc_clients{$fh}, "EOF";
	  };

	print "IRC $fh Got connection from $host:$port\n";

	my $c = { Handle => $fh };
	$c->{PingTimer} = AnyEvent->timer(after => 30,
		cb => sub { irc_ping $c; });
	$c->{PingCount} = 0;
	$irc_clients{$fh} = $c;
	$fh->push_read(line => sub { irc_line($c, @_) });

	irc_server_notice $c, "Waiting for RTM connection" if not $connected;
    }, sub {
	chmod 0600, $config{unix_socket} if $config{unix_socket};
    }
}

########################################################################
# RTM client
########################################################################

my $rtm_client;
my $rtm_con;
my $rtm_msg_id = 1;
my %rtm_apicall_handles;
my $rtm_cooldown_timer;

my %rtm_mark_queue;
my $rtm_mark_timer;

my $rtm_ping_timer;
my $rtm_ping_count;

sub rtm_apicall {
    my ($method, $args, $cb) = @_;
    my @encode;

    print "RTM APICALL $method ", Dumper($args) if $config{debug_dump};

    $args->{token} = $config{slack_token};

    foreach my $k (keys %$args) {
	my $ek = uri_encode($k);
	my $ev = uri_encode($args->{$k});

	push @encode, "$ek=$ev";
    }

    my $x;
    $x = http_post "https://slack.com/api/$method", join('&', @encode),
	headers => {
	    "Content-Type", "application/x-www-form-urlencoded"
	}, sub {
	    my ($body, $hdr) = @_;
	    delete $rtm_apicall_handles{$x};

	    unless ($hdr->{Status} =~ /^2/) {
		irc_broadcast_notice
		  "API HTTP error: $method: $hdr->{Status} $hdr->{Reason}";
		$cb->(undef) if defined($cb);
		return;
	    }

	    my $data = decode_json $body;

	    print "RTM REPLY $method ", Dumper($data) if $config{debug_dump};

	    unless ($data->{ok}) {
		irc_broadcast_notice "API error: $data->{error}";
		$cb->(undef) if defined($cb);
		return;
	    }

	    $cb->($data) if defined($cb);
	};

    $rtm_apicall_handles{$x} = 1;
}

sub rtm_send {
    my $frame = shift;

    $frame->{id} = $rtm_msg_id++;
    print "RTM SEND: ", Dumper($frame) if $config{debug_dump};
    $rtm_con->send(encode_json $frame);
}

sub rtm_update_join {
    my ($uid, $chid) = @_;
    my $chan = $channels{$chid};
    my $user = $users{$uid};

    if (!$chan->{Members}->{$uid}) {
	$chan->{Members}->{$uid} = 1;
	$user->{Channels}->{$chid} = 1;
	return 1;
    }

    return undef;
}

sub rtm_update_part {
    my ($uid, $chid) = @_;
    my $chan = $channels{$chid};
    my $user = $users{$uid};

    if ($chan->{Members}->{$uid}) {
	delete $channels{$chid}->{Members}->{$uid};
	delete $users{$uid}->{Channels}->{$chid};
	return 1;
    }

    return undef;
}

sub rtm_update_user {
    my $c = shift;
    my $user;

    if (exists $users{$c->{id}}) {
	$user = $users{$c->{id}};
	my $oldname = $user->{Name};
	delete $users_by_name{irc_lcase($oldname)};
	my $newname = irc_pick_name($c->{name}, \%users_by_name);

	$user->{Realname} = $c->{real_name} // $c->{name};

	irc_broadcast_nick $c->{id}, $newname
	    if $oldname ne $newname;

	$user->{Name} = $newname;
	$user->{Presence} = $c->{presence} // 'active';
	$users_by_name{$newname} = $user;
    } else {
	my $name = irc_pick_name($c->{name}, \%users_by_name);
	$user = {
	    Id => $c->{id},
	    Name => $name,
	    Channels => {},
	    Realname => $c->{real_name} // $c->{name},
	    TxQueue => [],
	    Presence => $c->{presence} // 'active'
	};

	$users{$c->{id}} = $user;
	$users_by_name{$name} = $user;
    }

    $user->{Realname} = "" unless defined($user->{Realname});
}

sub rtm_record_unknown_uid {
    my $uid = shift;

    unless (exists $users{$uid}) {
	# Temporary name
	my $name = irc_pick_name($uid, \%users_by_name);

	my $u = {
	    Id => $uid,
	    Name => $name,
	    Channels => {},
	    Realname => "",
	    TxQueue => []
	};

	$users{$uid} = $u;
	$users_by_name{irc_lcase($name)} = $u;

	rtm_apicall "users.info", { user => $uid }, sub {
	    my $data = shift;

	    rtm_update_user $data->{user} if defined $data;
	};
    }
}

sub rtm_update_channel {
    my ($type, $c) = @_;

    my $id = $c->{id};
    my $mhash = {};
    my $name = $c->{name};

    $name = "+$name" if $type eq "G";

    # Cross-reference users/channels
    foreach my $u (@{$c->{members}}) {
	rtm_record_unknown_uid $u;
	# Filter ourselves out of the membership list if this is a
	# closed group chat.
	next if $type eq 'G' && $u eq $self_id && !$c->{is_open};
	$mhash->{$u} = 1;
	$users{$u}->{Channels}->{$id} = 1;
    }

    if (exists $channels{$id}) {
	my $chan = $channels{$id};
	$chan->{Members} = $mhash;
	$chan->{Topic} = $c->{topic}->{value};
	$chan->{Type} = $type;
    } else {
	my $name = irc_pick_name($name, \%channels_by_name);
	my $chan = {
	    Id => $c->{id},
	    Members => $mhash,
	    Name => $name,
	    Type => $type,
	    Topic => $c->{topic}->{value}
	};

	$channels{$c->{id}} = $chan;
	$channels_by_name{irc_lcase($name)} = $chan;
    }
}

sub rtm_delete_channel {
    my $chid = shift;
    my $chan = $channels{$chid};
    return unless defined $chan;

    foreach ($chan->{Members}) {
	my $user = $users{$_};

	delete $user->{Channels}->{$chid};
    }

    delete $channels_by_name{irc_lcase($chan->{Name})};
    delete $channels{$chid};
}

sub rtm_mark_channel {
    my ($chid, $ts) = @_;

    $rtm_mark_queue{$chid} = $ts;

    unless (defined $rtm_mark_timer) {
	$rtm_mark_timer = AnyEvent->timer(after => 5, cb => sub {
	    for my $chid (keys %rtm_mark_queue ) {
		rtm_apicall "channels.mark", {
		    channel => $chid,
		    ts => $rtm_mark_queue{$chid}
		};
	    }
	    %rtm_mark_queue = ();
	    undef $rtm_mark_timer;
	});
    }
}

my %rtm_command = (
    "presence_change" => sub {
	my $msg = shift;
	my $user = $users{$msg->{user}};

	if (defined $user) {
	    my $old = $user->{Presence};
	    $user->{Presence} = $msg->{presence} if defined $user;
	    irc_broadcast_away if
	      $msg->{user} eq $self_id and $old ne $msg->{presence};
	}
    },
    "manual_presence_change" => sub {
	my $msg = shift;
	my $user = $users{$self_id};
	my $old = $user->{Presence};

	$user->{Presence} = $msg->{presence};
	irc_broadcast_away if $old ne $msg->{presence};
    },
    "im_open" => sub {
	my $msg = shift;
	rtm_record_unknown_uid $msg->{user};

	my $u = $users{$msg->{user}};
	$u->{DMId} = $msg->{channel};
	$users_by_dmid{$msg->{channel}} = $u;

	foreach my $msg (@{$u->{TxQueue}}) {
	    rtm_send { type => "message",
		channel => $u->{DMId}, text => $msg };
	}

	$u->{TxQueue} = [];
    },
    "im_close" => sub {
	my $msg = shift;
	my $u = $users_by_dmid{$msg->{channel}};
	return unless defined($u);

	delete $u->{DMId};
	delete $users_by_dmid{$msg->{channel}};
    },
    "group_joined" => sub {
	my $msg = shift;

	rtm_update_channel "G", $msg->{channel};
	irc_broadcast_join $self_id, $msg->{channel}->{id};
    },
    "group_left" => sub {
	my $msg = shift;

	irc_broadcast_part $self_id, $msg->{channel}
	  if rtm_update_part $self_id, $msg->{channel};
    },
    "group_archive" => sub {
	my $msg = shift;

	irc_broadcast_part $self_id, $msg->{channel}
	  if rtm_update_part $self_id, $msg->{channel};
	rtm_delete_channel $msg->{channel};
    },
    "channel_joined" => sub {
	my $msg = shift;

	rtm_update_channel "C", $msg->{channel};
	irc_broadcast_join $self_id, $msg->{channel}->{id};
    },
    "channel_left" => sub {
	my $msg = shift;

	irc_broadcast_part $self_id, $msg->{channel}
	  if rtm_update_part $self_id, $msg->{channel};
    },
    "channel_archive" => sub {
	my $msg = shift;

	irc_broadcast_part $self_id, $msg->{channel}
	  if rtm_update_part $self_id, $msg->{channel};
	rtm_delete_channel $msg->{channel};
    },
    "member_joined_channel" => sub {
	my $msg = shift;

	rtm_record_unknown_uid $msg->{user};
	irc_broadcast_join $msg->{user}, $msg->{channel}
	  if rtm_update_join($msg->{user}, $msg->{channel});
    },
    "member_left_channel" => sub {
	my $msg = shift;

	irc_broadcast_part $msg->{user}, $msg->{channel}
	  if rtm_update_part($msg->{user}, $msg->{channel});
    },
    "pong" => sub {
	$rtm_ping_count = 0;
    },
    "message" => sub {
	my $msg = shift;
	my $chan = $channels{$msg->{channel}};
	my $subtype = $msg->{subtype} || "";
	my $uid = $msg->{user} || $msg->{comment}->{user} || $msg->{bot_id};
	my $text = $msg->{text} // '';

	if (defined($msg->{attachments})) {
	    my $attext = join '\n', map {
		($_->{title} or "")
		  . " " . ($_->{text} or "")
		  . " " . ($_->{title_link} or "") } @{$msg->{attachments}};
	    $text .= "\n" unless length($text);
	    $text .= $attext;
	}

	if (defined($chan)) {
	    if ($subtype eq "channel_topic" or $subtype eq "group_topic") {
		$chan->{Topic} = $msg->{topic};
		irc_topic_change $uid, $chan->{Id};
	    } else {
		irc_chanmsg $uid, $msg->{subtype}, $chan->{Id}, $text;
	    }
	    rtm_mark_channel $chan->{Id}, $msg->{ts};
	} else {
	    irc_privmsg $uid, $msg->{subtype}, $text;
	}

	if ($subtype eq "file_share") {
	    my $fid = $msg->{file}->{id};
	    rtm_apicall "files.info", { file => $fid }, sub {
		my $data = shift;
		return unless defined $data;

		my $body = $data->{content};
		return unless length($body) <= 65536;

		if (defined $chan) {
		    irc_chanmsg $uid, ">$fid", $chan->{Id}, $body;
		} else {
		    irc_privmsg $uid, ">$fid", $body;
		}
	    };
	}
    },
);

sub rtm_send_to_user {
    my ($id, $msg) = @_;
    my $u = $users{$id};

    if (defined($u->{DMId}) && length($u->{DMId})) {
	rtm_send { type => "message",
		channel => $u->{DMId}, text => $msg };
	return;
    }

    push @{$u->{TxQueue}}, $msg;

    if (!defined($u->{DMId})) {
	rtm_apicall "im.open", { user => $u->{Id} }, sub {
	    my $result = shift;
	    unless (defined $result) {
		delete $u->{DMId};
		foreach my $m (@{$u->{TxQueue}}) {
		    irc_broadcast_notice "Failed to send to $u->{Name}: $m";
		}
		$u->{TxQueue} = [];
	    }
	};

	$u->{DMId} = "";
    }
}

sub rtm_start;

sub rtm_cooldown {
    return if defined($rtm_cooldown_timer);
    print "Waiting before reinitiating RTM\n";
    $rtm_cooldown_timer = AnyEvent->timer(after => 5, cb => sub {
	undef $rtm_cooldown_timer;
	rtm_start;
    });
};

sub rtm_destroy {
    my $msg = shift;
    return unless defined($rtm_con);

    irc_broadcast_notice $msg;

    $connected = 0;
    undef $self_id;
    %channels = ();
    %channels_by_name = ();
    %users = ();
    %users_by_name = ();
    %users_by_dmid = ();

    %rtm_apicall_handles = (); # cancel outstanding requests
    %rtm_mark_queue = ();
    undef $rtm_mark_timer;
    undef $rtm_ping_timer;
    $rtm_con->close;
    undef $rtm_con;
    undef $rtm_client;

    irc_disconnect_all;
    rtm_cooldown;
}

sub rtm_ping {
    if (++$rtm_ping_count >= 2) {
	rtm_destroy "RTM ping timeout";
	return;
    }

    rtm_send { type => "ping" };
    $rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);
}

sub rtm_start_ws {
    my $url = shift;

    return if defined($rtm_client);
    $rtm_client = AnyEvent::WebSocket::Client->new;

    print "WSS URL: $url\n" if $config{debug_dump};
    $rtm_client->connect($url)->cb(sub {
	$rtm_con = eval { shift->recv; };
	if ($@) {
	    irc_broadcast_notice "WSS connection failed: $@\n";
	    undef $rtm_client;
	    rtm_cooldown;
	}

	print "WSS connected\n";
	$rtm_msg_id = 1;
	$rtm_ping_count = 0;
	$connected = 1;
	irc_check_welcome_all;

	$rtm_ping_timer = AnyEvent->timer(after => 60, cb => \&rtm_ping);

	$rtm_con->on(each_message => sub {
	    eval {
		shift;
		my $msg = decode_json shift->{body};

		print "RTM RECV: ", Dumper($msg) if $config{debug_dump};
		irc_broadcast_notice "RTM error: $msg->{error}->{msg}"
		    if $msg->{error};

		if (defined $msg->{type}) {
		    my $handler = $rtm_command{$msg->{type}};
		    $handler->($msg) if defined($handler);
		}
	    };
	    print "Error in message handler: $@" if $@;
	});

	$rtm_con->on(finish => sub {
	    eval {
		my ($con) = @_;

		if (defined $con->close_error) {
		    rtm_destroy "RTM connection error: $con->close_error";
		} elsif (defined $con->close_reason) {
		    rtm_destroy "RTM connection closed: $con->close_reason";
		} else {
		    rtm_destroy "RTM connection finished";
		}
	    };
	    print "Error in finish handler: $@" if $@;
	});
    });
};

sub rtm_start {
    print "Requesting RTM connection\n";
    rtm_apicall "rtm.start", {}, sub {
	my $data = shift;

	unless (defined($data)) {
	    rtm_cooldown;
	    return;
	}

	$self_id = $data->{self}->{id};

	foreach my $c (@{$data->{users}}) {
	    rtm_update_user $c;
	}

	foreach my $c (@{$data->{ims}}) {
	    my $u = $users{$c->{user}};

	    $u->{DMId} = $c->{id};
	    $users_by_dmid{$c->{id}} = $u;
	}

	foreach my $c (@{$data->{channels}}) {
	    rtm_update_channel "C", $c unless $c->{is_archived};
	}

	foreach my $c (@{$data->{bots}}) {
	    rtm_update_user $c;
	    my $n = $c->{id};
	}

	foreach my $c (@{$data->{groups}}) {
	    rtm_update_channel "G", $c unless $c->{is_archived};
	}

	rtm_start_ws $data->{url};
    };
};

########################################################################
# RTM kick-off
########################################################################

my $cfgfile = shift || die "You must specify a config file";
open(my $cfg, $cfgfile) || die "Can't open $cfgfile";
foreach (<$cfg>) {
    chomp;
    $config{$1} = $2 if /^([-_0-9a-zA-Z]+)=(.*)$/;
}
close($cfg);

rtm_start;
irc_listen;
AnyEvent->condvar->recv;