#!/usr/pkg/bin/perl
use utf8;

# vim: ts=4:sw=4:et:ai:sts=4
#
# KGB - an IRC bot helping collaboration
# Copyright © 2008 Martín Ferrari
# Copyright © 2008,2009,2010,2011,2012,2013 Damyan Ivanov
# Copyright © 2010 gregor herrmann
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 51
# Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

=head1 NAME

kgb-bot - an IRC bot helping collaborative work

=head1 SYNOPSIS

kgb-bot [--config I<file>] [--foreground] [--simulate I<file>]

=head1 OPTIONS

=over 4

=item --config I<file>

Specify configuration file to load. Default is F</usr/pkg/etc/kgb-bot/kgb.conf>.

=item --config-dir I<directory>

Specify directory with configuration files to load. All files like F<*.conf>
are loaded, in alphabetical order. Default is F</usr/pkg/etc/kgb-bot/kgb.conf.d>.

=item --foreground

Do not detach from console, print log messages to STDERR and do not become a
daemon, useful for debugging.

=item --simulate I<file>

Do not connect to IRC. Instead, output each notification line to the given
I<file>, like:

    #chan repo user branch revision module changed-paths
    #chan repo commit message line 1
    #chan repo commit message line 2

There are no colour codes in the output, unless B<--simulate-color> is also
given.

=item --simulate-color

Include color codes in the file used by B<--simulate>.

=item --debug

Log additional debugging information

=back

=cut

package KGB;

use strict;
use warnings;
use encoding 'utf8';
use open ':encoding(utf8)';
use App::KGB::Painter;
use Time::Piece qw(localtime);

our $VERSION = '1.31';

use Cwd;

our $config;
our ( $config_file, $config_dir, $foreground, $debug );
our %const = (
    SOAPsvc => "SOAPServer",
    BAsvc   => "BotAddressed",
    Connsvc => "Connecter",
    NSsvc   => "NickServID",
    NRsvc   => "NickReclaim",
    AJsvc   => "AutoJoin",
);
our %supported_protos = (
    "0" => 1,
    "1" => 1,
    "2" => 1,
    "3" => 1,
);
our $progname;
our $restart      = 0;
our $shuttingdown = 0;
our $painter;

sub save_progname () {
    $progname = Cwd::realpath($0);
}

sub polygen_available () {
    unless ( eval { require IPC::Run } ) {
        KGB->debug("error loading IPC::Run\n");
        KGB->debug($@);
        return undef;
    }

    unless ( eval { require File::Which } ) {
        KGB->debug("error loading File::Which\n");
        KGB->debug($@);
        return undef;
    }

    my $oldpath = $ENV{PATH};
    $ENV{PATH}='/usr/bin/:/usr/games';
    my $polygen;
    unless ( $polygen = File::Which::which('polygen') ) {
        KGB->debug("missing polygen binary\n");
    }
    $ENV{PATH} = $oldpath;

    return $polygen;
}

sub merge_conf_hash($$);

sub merge_conf_hash($$) {
    my ( $dst, $src ) = @_;

    while ( my ($k, $v) = each %$src ) {
        if ( ref($v) ) {
            if ( exists $dst->{$k} ) {
                die
                    "Error merging key '$k': source is a reference, but destination is scalar\n"
                    unless ref( $dst->{$k} );
                ref( $dst->{$k} ) eq ref($v)
                    or die
                    "Error merging key '$k': reference type mismatch\n";
                if ( ref($v) eq 'ARRAY' ) {
                    push @{ $dst->{$k} }, @$v;
                }
                elsif ( ref($v) eq 'HASH' ) {
                    merge_conf_hash( $dst->{$k}, $v );
                }
                else {
                    die "Error merging key '$k': unknown reference type\n";
                }
            }
            else {
                $dst->{$k} = $v;
            }
        }
        else {
            die
                "Error merging key '$k': source is scalar, but destination is not\n"
                if exists $dst->{$k} and ref( $dst->{$k} );
            $dst->{$k} = $v;
        }
    }
}

sub parse_conf_file($;$);
sub parse_conf_file($;$) {
    my $src = shift;
    my $met = shift // {};

    return {} if $met->{$src}++;

    my $conf = {};
    KGB->debug("Loading '$src.");
    if ( -d $src ) {
        -r _ or die "'$src' is not readable\n";
        -x _ or die "'$src' is not usable (missing execute permission)\n";
        for ( sort <$src/*.conf> ) {
            my $c = parse_conf_file($_);

            eval { merge_conf_hash( $conf, $c ); 1 } or die "Error loading $_: $@";
        }
    }
    elsif ( -e $src ) {
        die "$src is world-readable\n" if ( stat($src) )[2] & 04;

        $conf = YAML::LoadFile($src)
            or die "Error loading config from $src\n";
    }
    else {
        die "'$src' does not exist\n";
    }

    if ( exists $conf->{include} ) {
        my $inc = $conf->{include};
        my @inc;

        if (ref($inc)) {
            die "'include' should be scalar or list\n"
                unless ref($inc) eq 'ARRAY';

            push @inc, @$inc;
        }
        else {
            push @inc, $inc;
        }

        for my $f ( @inc ) {
            my $c = parse_conf_file( $f, $met );
            eval { merge_conf_hash( $conf, $c ); 1 } or die "Error loading $f: $@";
        }
    }

    return $conf;
}

sub read_conf ($) {
    my $file = shift;

    my $conf = {};
    $conf = parse_conf_file($file) if -e $file;

    die "Invalid or missing config key: soap"
        unless ( ref $conf->{soap}
        and ref $conf->{soap} eq "HASH" );
    die "Invalid or missing config key: repositories"
        unless ( ref $conf->{repositories}
        and ref $conf->{repositories} eq "HASH" );
    die "Invalid or missing config key: networks"
        unless ( ref $conf->{networks}
        and ref $conf->{networks} eq "HASH" );
    die "Invalid or missing config key: channels"
        unless ( ref $conf->{channels}
        and ref $conf->{channels} eq "ARRAY" );

    $conf->{soap}{service_name} ||= "KGB";
    $conf->{soap}{server_port}  ||= 5391;
    $conf->{soap}{server_addr}  ||= "127.0.0.1";

    if ( my $queue_limit = ( $conf->{queue_limit} //= 150 ) ) {
        $queue_limit =~ /^\d{1,10}$/
            or die
            "Invalid value for config key 'queue_limit' ($queue_limit)";
    }

    $conf->{min_protocol_ver} = 1
        unless ( defined $conf->{min_protocol_ver} );
    $conf->{smart_answers} ||= ["My master told me to not respond."];

    $conf->{admins} //= [];
    ref( $conf->{admins} ) and ref( $conf->{admins} ) eq 'ARRAY'
        or die "Invalid config key: 'admins'. Must be an array";

    unless ( $KGB::supported_protos{ $conf->{min_protocol_ver} } ) {
        die("Unrecognised min_protocol_ver (",
            $conf->{min_protocol_ver},
            "). I only know about protocols ",
            join( ", ", keys %KGB::supported_protos ),
            ".\n"
        );
    }
    foreach ( keys %{ $conf->{networks} } ) {
        $conf->{networks}{$_}{nick}     ||= "KGB";
        $conf->{networks}{$_}{ircname}  ||= "KGB bot";
        $conf->{networks}{$_}{username} ||= "kgb";
        $conf->{networks}{$_}{port}     ||= 6667;
        die "Missing server name in network $_\n"
            unless $conf->{networks}{$_}{server};
    }

    $conf->{broadcast_channels} = [];

    $_->{channels} //= [] for values %{ $conf->{repositories} };

    foreach ( @{ $conf->{channels} } ) {
        $_->{repositories} //= [];
        die "Missing channel name at channel\n" unless ( $_->{name} );
        die "Invalid network at channel " . $_->{name} . "\n"
            unless ( $_->{network} and $conf->{networks}{ $_->{network} } );
        push @{ $conf->{networks}{ $_->{network} }{channels} }, $_->{name};
        die "Invalid repos key at channel " . $_->{name} . "\n"
            unless $_->{broadcast}
            or ( ref $_->{repos} and ref $_->{repos} eq "ARRAY" );
        if ( $_->{broadcast} ) {
            push @{ $conf->{broadcast_channels} }, $_->{name};
            KGB->out("Repository list ignored for broadcast channel $_->{name}\n")
                if @{ $_->{repositories} };
        }
        else {
            KGB->out("Channel " . $_->{name} . " doesn't listen on any repository\n")
                unless @{ $_->{repos} };
            foreach my $repo ( @{ $_->{repos} } ) {
                die "Invalid repository $repo at channel " . $_->{name} . "\n"
                    unless ( $conf->{repositories}{$repo} );
                push @{ $conf->{repositories}{$repo}{channels} }, $_->{name};
            }
        }
    }
    my %chanidx
        = map ( { $conf->{channels}[$_]{name} => $conf->{channels}[$_] }
        0 .. $#{ $conf->{channels} } );
    $conf->{chanidx} = \%chanidx;

    $conf->{colors}             ||= {};
    $conf->{colors}{revision}   //= '';
    $conf->{colors}{path}       //= 'teal';
    $conf->{colors}{author}     //= 'green';
    $conf->{colors}{branch}     //= 'brown';
    $conf->{colors}{module}     //= 'purple';
    $conf->{colors}{web}        //= 'silver';
    $conf->{colors}{separator}  //= '';

    $conf->{colors}{addition}     //= 'green';
    $conf->{colors}{modification} //= 'teal';
    $conf->{colors}{deletion}     //= 'bold red';
    $conf->{colors}{replacement}  //= 'brown';

    $conf->{colors}{prop_change} //= 'underline';

    $KGB::debug = $conf->{debug} if exists $conf->{debug};
    $conf->{pid_dir} //= '/var/run/kgb-bot';

    KGB->debug( JSON::XS::encode_json($conf) );
    return $conf;
}

sub load_conf($) {
    my $file = shift;
    my $conf = read_conf($file);

    # Save globals
    $config_file = Cwd::realpath($file);
    $config      = $conf;
    return $conf;
}

sub reload_conf() {
    my $new_conf = eval { KGB::read_conf($config_file) };
    if ($@) {
        KGB->out("Error in configuration file: $@");
        return -1;
    }
    if (   $new_conf->{soap}{service_name} ne $config->{soap}{service_name}
        or $new_conf->{soap}{server_port} ne $config->{soap}{server_port}
        or $new_conf->{soap}{server_addr} ne $config->{soap}{server_addr} )
    {
        KGB->out("Cannot reload configuration file, restarting\n");
        return -2;    # need restart
    }

    $painter = App::KGB::Painter->new( { styles => $new_conf->{colors} } );

    KGB->out("Configuration file reloaded\n");
    $config = $new_conf;
    return 0;
}

sub out {
    shift;
    print $KGB::out localtime->strftime('%Y.%m.%d %H:%M:%S').': ', @_, ( $_[-1] =~ /\n$/s ) ? () : "\n";
}

sub debug {
    return unless $KGB::debug;

    shift->out( @_ );
}

sub open_log {
    if ( my $f = $KGB::config->{log_file} ) {
        open( STDOUT, ">>", $f )
            or die "Error opening log $f: $!\n";
        open( STDERR, ">>", $f )
            or die "Error opening log $f: $!\n";
    }
    else {
        open( STDOUT, ">", "/dev/null" )
            or die "Error closing stdout: $!\n";
        open( STDERR, ">", "/dev/null" )
            or die "Error closing stderr: $!\n";
    }
}

package KGB::POE;

use strict;
use warnings;

use POE;

sub _start {
    my $kernel  = $_[KERNEL];
    my $session = $_[SESSION];
    my $heap    = $_[HEAP];

    $kernel->sig( INT  => 'sighandler' );
    $kernel->sig( TERM => 'sighandler' );
    $kernel->sig( QUIT => 'restarthandler' );
    $kernel->sig( HUP  => 'reloadhandler' );

    $kernel->alias_set( $KGB::config->{soap}{service_name} );
    $kernel->post(
        SOAPServer => 'ADDMETHOD',
        $KGB::config->{soap}{service_name}, 'commit',
        $KGB::config->{soap}{service_name}, 'commit',
    );
    $kernel->yield("_irc_reconnect") unless $KGB::simulate;

    KGB->out(
        "Listening on http://", $KGB::config->{soap}{server_addr},
        ":",                    $KGB::config->{soap}{server_port},
        "?session=",            $KGB::config->{soap}{service_name},
        "\n"
    );
    undef;
}

sub _stop {
    my $kernel  = $_[KERNEL];
    my $session = $_[SESSION]->ID();
    KGB->out("_stop \@session $session\n");
    $kernel->post(
        SOAPServer => 'DELSERVICE',
        $KGB::config->{soap}{service_name}
    );
}

sub sighandler {
    my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] );
    if ($KGB::shuttingdown) {
        die "Dying forcefully...\n";
    }
    KGB->out("Deadly signal $sig received, exiting...\n");
    $kernel->sig_handled();
    $kernel->signal(
        $kernel => 'POCOIRC_SHUTDOWN',
        "KGB going to drink vodka"
    );
    $kernel->post( SOAPServer => 'STOPLISTEN' );
    %{ $_[HEAP] } = ();
    $KGB::shuttingdown = 1;
    undef;
}

sub restarthandler {
    my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] );
    if ($KGB::shuttingdown) {
        die "Dying forcefully...\n";
    }
    KGB->out("Signal $sig received, restarting...\n");
    $kernel->sig_handled();
    $KGB::restart      = 1;
    $KGB::shuttingdown = 1;
    $kernel->signal( $kernel => 'POCOIRC_SHUTDOWN', "KGB restartink" );
    $kernel->post( SOAPServer => 'STOPLISTEN' );
    %{ $_[HEAP] } = ();
    undef;
}

sub reloadhandler {
    my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] );
    KGB->out("Signal $sig received, reloading...\n");
    $kernel->sig_handled();
    my $ret = KGB::reload_conf();
    if ( $ret == -1 ) {    # error in config file
        return undef;
    }
    elsif ( $ret == -2 ) {    # needs reload
        KGB->out("Forcing restart\n");
        $KGB::restart      = 1;
        $KGB::shuttingdown = 1;
        $kernel->signal( $kernel => 'POCOIRC_SHUTDOWN', "KGB restartink" );
        $kernel->post( SOAPServer => 'STOPLISTEN' );
        %{ $_[HEAP] } = ();
        return undef;
    }

    # reopen log file
    # we catch any exceptions, because we don't want reloading to be able
    # to kill the server
    unless ($KGB::foreground) {
        KGB->out("Error re-openning logs: $@\n")
            unless eval { KGB::open_log(); 1 };
    }

    # Reload successful
    $kernel->yield("_irc_reconnect");
    undef;
}

package KGB::SOAP;

use strict;
use warnings;

use POE;
use List::Util qw(max);
use Digest::SHA qw(sha1_hex);
use File::Basename;
use App::KGB::Change;
use Error ':try';

sub colorize {
    my( $category, $text ) = @_;

    return $text if $KGB::simulate and not $KGB::simulate_color;

    return $KGB::painter->colorize( $category => $text );
}

sub colorize_change {
    my $c = shift;

    return $KGB::painter->colorize_change($c);
}

sub do_commit_msg {
    my ($kernel, $repo_id, $data) = @_;

    my $rev_prefix = $data->{rev_prefix} // '';
    my $commit_id = $data->{commit_id};
    my $changes = $data->{changes};
    my @log = split( /\n+/, $data->{commit_log} );
    my $author = $data->{author} // '';
    my $branch = $data->{branch} // '';
    my $module = $data->{module} // '';

    local $KGB::config->{colors} = {}
        if exists $data->{extra}
        and exists $data->{extra}{use_color}
        and not $data->{extra}{use_color};

    my $repo = $KGB::config->{repositories}{$repo_id};

    my @channels = @{ $repo->{channels} };
    push @channels, @{ $KGB::config->{broadcast_channels} }
        unless $repo->{private};

    throw Error::Simple("Repository $repo_id has no associated channels.\n")
        unless (@channels);

    my $path_string;
    my %dirs;
    my $changed_files   = scalar(@$changes);
    my $MAGIC_MAX_FILES = 4;

    $_ = App::KGB::Change->new($_)
        for grep { defined($_) and $_ ne '' } @$changes;  # convert to objects

    my $common_dir = App::KGB::Change->detect_common_dir($changes) // '';

    my @info;

    push @info, colorize( author => $author ) if $author ne '';
    push @info, colorize( branch => $branch ) if $branch ne '';
    push @info, "$rev_prefix" . colorize( revision => $commit_id )
        if defined $commit_id;
    push @info, colorize( module => $module ) if $module ne '';
    push @info, colorize( path => "$common_dir/" ) if $common_dir ne '';

    if ( $changed_files > $MAGIC_MAX_FILES ) {
        my %dirs;
        for my $c (@$changes) {
            my $dir = dirname( $c->path );
            $dirs{$dir}++;
        }

        my $dirs = scalar( keys %dirs );

        my $path_string = join( ' ',
            ( $dirs > 1 )
            ? sprintf( "(%d files in %d dirs)", $changed_files, $dirs )
            : sprintf( "(%d files)",            $changed_files ) );

        push @info, colorize( path => $path_string );
    }
    else {
        push @info, join( ' ', map { colorize_change($_) } @$changes )
            if @$changes;
    }

    my @string = join( ' ', @info );

    my $web_string
        = defined( $data->{extra}{web_link} )
        ? colorize( web => $data->{extra}{web_link} )
        : undef;

    my $use_notices = $data->{extra}{use_irc_notices};

    # one-line notifications result in:
    #  user branch commit module changes log link
    # multi-line notifications look like:
    #  user branch commit module changes link
    #  log line 1
    #  log line 2 ...
    if ( 1 == @log and length($log[0]) <= 80 ) {
        $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $log[0];
    }
    else {
        push @string, @log;
    }

    $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $web_string
        if defined($web_string);

    my @tmp;
    # Standard says 512 (minus \r\n), anyway that's further trimmed when
    # resending to clients because of prefix.
    # Let's trim on 400, to be safe
    my $MAGIC_MAX_LINE
        = ( 400 - length("PRIVMSG ") - max( map( length, @channels ) ) );

    while ( $_ = shift @string ) {
        if ( length($_) > $MAGIC_MAX_LINE ) {
            push @tmp, substr( $_, 0, $MAGIC_MAX_LINE );
            unshift @string,
                colorize( repository => $repo_id )
                . substr( $_, $MAGIC_MAX_LINE );
        }
        else {
            push @tmp, $_;
        }
    }
    @string = @tmp;

    foreach my $chan ( @channels ) {
        if ($KGB::simulate) {
            my $fh = IO::File->new(">> $KGB::simulate")
                or die "Error opening $KGB::simulate for writing: $!\n";
            $fh->autoflush(1);
            $fh->binmode(':utf8');
            for (@string) {
                $fh->print("$chan $_\n");
            }
            $fh->close;
        }
        else {
            $kernel->yield(
                irc_notify => $chan => \@string,
                $use_notices ? 'notice' : 'privmsg'
            );
        }
    }
}

sub do_commit_v0 {
    my ( $kernel, $repo_id, $passwd, $rev, $paths, $log, $author )
        = @_;

    throw Error::Simple("Unknown repository '$repo_id'\n")
        unless $KGB::config->{repositories}{$repo_id};

    throw Error::Simple("Invalid password for repository $repo_id\n")
        if $KGB::config->{repositories}{$repo_id}{password}
        and $KGB::config->{repositories}{$repo_id}{password} ne $passwd;

    do_commit_msg(
        $kernel,
        $repo_id,
        {   rev_prefix => 'r',
            commit_id  => $rev,
            changes    => $paths,
            commit_log => $log,
            author     => $author
        }
    );
}

sub do_commit_v1 {
    my ($kernel, $repo_id, $checksum, $rev,
        $paths,  $log,      $author,  $branch,   $module
    ) = @_;

    # v1 is the same as v2, but has no rev_prefix parameter
    return do_commit_v2(
        $kernel, $repo_id, $checksum, 'r', $rev,
        $paths,  $log,      $author,  $branch,   $module
    );
}

sub do_commit_v2 {
    my ($kernel,     $repo_id, $checksum,
        $rev_prefix, $rev,      $paths,   $log,
        $author,     $branch,   $module,
    ) = @_;

    throw Error::Simple("Repository $repo_id is unknown\n")
        unless $KGB::config->{repositories}{$repo_id};

    # Protocol v2 always uses UTF-8
    utf8::decode($_)
        for ( $repo_id, $rev, @$paths, $log, $author, $branch, $module );
    my $message = join( "",
        $repo_id,
        $rev // (),
        @$paths,
        $log,
        ( defined($author) ? $author : () ),
        ( defined($branch) ? $branch : () ),
        ( defined($module) ? $module : () ),
        $KGB::config->{repositories}{$repo_id}{password} );
    utf8::encode($message);    # Convert to byte-sequence

    throw Error::Simple("Authentication failed for repository $repo_id\n")
        if $KGB::config->{repositories}{$repo_id}{password}
        and sha1_hex($message) ne $checksum;

    do_commit_msg(
        $kernel,
        $repo_id,
        {   rev_prefix => $rev_prefix,
            commit_id  => $rev,
            changes    => $paths,
            commit_log => $log,
            author     => $author,
            branch     => $branch,
            module     => $module
        }
    );
}

sub do_commit_v3 {
    my ( $kernel, $repo_id, $serialized, $checksum ) = @_;

    throw Error::Simple("Repository $repo_id is unknown\n")
        unless exists $KGB::config->{repositories}{$repo_id};

    my $pwd = $KGB::config->{repositories}{$repo_id}{password};
    throw Error::Simple("Authentication failed for repository $repo_id\n")
        if not defined($pwd)
        or sha1_hex( $repo_id, $serialized, $pwd ) ne $checksum;

    my $data;
    my $ok = eval { $data = Storable::thaw($serialized); 1 };

    throw Error::Simple("Invalid serialized data\n")
        unless $ok;

    do_commit_msg( $kernel, $repo_id, $data );
}

sub commit {
    my $kernel   = $_[KERNEL];
    my $response = $_[ARG0];
    my $params   = $response->soapbody();

    my $result;
    try {
        $result = do_commit( $kernel, $params );

        $response->content("OK");
        $kernel->post( SOAPServer => 'DONE', $response );
    }
    catch Error::Simple with {
        my $E = shift;
        KGB->out("$E");
        $kernel->post(
            SOAPServer => 'FAULT',
            $response, 'Client.Arguments',
            "$E",
        );
    }
    otherwise {
        my $E = shift;
        KGB->out("commit crashed: $E");
        $kernel->post(
            SOAPServer => 'FAULT',
            $response, 'Server.Code',
            'Internal Server Error'
        );
    };
}

sub do_commit {
    my ( $kernel, $params ) = @_;

    KGB->out( "commit: " . YAML::Dump($params) ) if $KGB::debug;

    throw Error::Simple("commit(params ...)\n")
        unless ref $params
        and ref $params eq "HASH"
        and $params->{Array}
        and ref $params->{Array}
        and ref $params->{Array} eq "ARRAY";

    my $proto_ver;
    if ( @{ $params->{Array} } == 6 ) {
        $proto_ver = 0;
    }
    else {
        $proto_ver = shift @{ $params->{Array} };
    }

    throw Error::Simple(
        sprintf(
            "Protocol version %s not welcomed\n", $proto_ver // '<undef>'
        )
        )
        unless defined($proto_ver)
        and $KGB::supported_protos{$proto_ver}
        and $proto_ver >= $KGB::config->{min_protocol_ver};

    throw Error::Simple("Rate limit enforced\n")
        if $KGB::config->{queue_limit}
        and $KGB::IRC::irc_object
        and $KGB::config->{queue_limit} < $KGB::IRC::irc_object->send_queue;

    if ( $proto_ver == 0 ) {
        return do_commit_v0( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 1 ) {
        return do_commit_v1( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 2 ) {
        return do_commit_v2( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 3 ) {
        return do_commit_v3( $kernel, @{ $params->{Array} } );
    }
    throw Error::Simple("Invalid protocol version ($proto_ver)\n");
}

package KGB::IRC;

use strict;
use warnings;

use Digest::MD5 qw(md5_hex);
use POE;
use POE::Component::IRC::Common qw( parse_user matches_mask );
use Schedule::RateLimiter;

our %current = ();
our $irc_object;
our $autoresponse_limitter
    = Schedule::RateLimiter->new( iterations => 5, seconds => 30,
    block => 0 );

# Handles the connection, disconnection and real-time configuration changes WRT
# IRC servers and channels
sub _irc_reconnect {
    my ( $kernel, $session ) = @_[ KERNEL, SESSION ];
    my ( @to_start, @to_stop, @to_restart );

    foreach my $net ( keys %current ) {
        next unless ( defined( $current{$net} ) );
        my ( $new, $old )
            = ( $KGB::config->{networks}{$net}, $current{$net} );
        if ( !$new ) {
            push @to_stop, $net;
        }
        elsif ($new->{nick} ne $old->{nick}
            or $new->{ircname}  ne $old->{ircname}
            or $new->{username} ne $old->{username}
            or ( $new->{password} || "" ) ne ( $old->{password} || "" )
            or ( $new->{nickserv_password} || "" ) ne
            ( $old->{nickserv_password} || "" )
            or $new->{server} ne $old->{server}
            or $new->{port}   ne $old->{port} )
        {
            push @to_restart, $net;
        }
        else {
            my ( %newchan, %oldchan, %allchan );
            %newchan = map( { $_ => 1 } @{ $new->{channels} } );
            %oldchan = map( { $_ => 1 } @{ $old->{channels} } );
            %allchan = ( %newchan, %oldchan );
            foreach my $chan ( keys %allchan ) {
                if ( $newchan{$chan} and !$oldchan{$chan} ) {
                    KGB->out("Joining $chan...\n");
                    $kernel->post( "irc_$net" => join => $chan );
                }
                elsif ( !$newchan{$chan} and $oldchan{$chan} ) {
                    KGB->out("Parting $chan...\n");
                    $kernel->post( "irc_$net" => part => $chan );
                }
            }
            $current{$net} = $new;
        }
    }
    foreach ( keys %{ $KGB::config->{networks} } ) {
        if ( !$current{$_} ) {
            push @to_start, $_;
        }
    }
    foreach my $net (@to_start) {
        my $opts = $KGB::config->{networks}{$net};
        $current{$net} = $opts;

        my $irc = POE::Component::IRC::State->spawn( Alias => "irc_$net" );

        # No need to register, as it's done automatically now. If you register
        # twice, POE never exits
    }
    foreach ( @to_stop, @to_restart ) {
        KGB->out("Disconnecting from $_\n");
        $kernel->post( "irc_$_" => "shutdown" );
        delete $current{$_};
    }
    if (@to_restart) {
        $kernel->delay( "_irc_reconnect", 3 );
    }
}

sub irc_registered {
    my ( $kernel, $heap, $sender ) = @_[ KERNEL, HEAP, SENDER ];
    $irc_object = $_[ARG0];

    my $alias = $irc_object->session_alias();
    $alias =~ s/^irc_//;
    my $opts = $KGB::config->{networks}{$alias};

    $irc_object->plugin_add( $KGB::const{AJsvc},
        POE::Component::IRC::Plugin::AutoJoin->new(
            Channels => $opts->{channels},
        )
    ) if ( $opts->{channels} );

    $irc_object->plugin_add( $KGB::const{NSsvc},
        POE::Component::IRC::Plugin::NickServID->new(
            Password => $opts->{nickserv_password},
        )
    ) if ( $opts->{nickserv_password} );

    $irc_object->plugin_add( $KGB::const{NRsvc},
        POE::Component::IRC::Plugin::NickReclaim->new() );

    $irc_object->plugin_add( $KGB::const{Connsvc},
        POE::Component::IRC::Plugin::Connector->new() );

    $irc_object->plugin_add( $KGB::const{BAsvc},
        POE::Component::IRC::Plugin::BotAddressed->new() );

    $irc_object->plugin_add(
        'CTCP' => POE::Component::IRC::Plugin::CTCP->new(
            version    => "KGB v$KGB::VERSION",
            userinfo   => "KGB v$KGB::VERSION",
            clientinfo => "VERSION USERINFO CLIENTINFO SOURCE",
            source     => "http://alioth.debian.org/projects/kgb",
        )
    );

    $kernel->post(
        $sender => connect => {
            Server   => $opts->{server},
            Port     => $opts->{port},
            Nick     => $opts->{nick},
            Ircname  => $opts->{ircname},
            Username => $opts->{username},
            Password => $opts->{password},
            Flood    => $opts->{flood},
        }
    );
    undef;
}

sub _default {
    return 0 unless $KGB::debug;
    my ( $event, $args ) = @_[ ARG0 .. $#_ ];
    my $out = "$event ";
    foreach (@$args) {
        if ( ref($_) eq 'ARRAY' ) {
            $out .= "[" . join( ", ", @$_ ) . "] ";
        }
        elsif ( ref($_) eq 'HASH' ) {
            $out .= "{" . join( ", ", %$_ ) . "} ";
        }
        elsif ( defined $_ ) {
            $out .= "'$_' ";
        }
        else {
            $out .= "undef ";
        }
    }
    KGB->debug("$out\n");
    return 0;
}

sub irc_public {
    my ( $kernel, $heap, $who, $where, $what )
        = @_[ KERNEL, HEAP, ARG0, ARG1, ARG2 ];
    my $nick = parse_user($who);
    my $chan = $where->[0];

    $kernel->yield( irc_new_hash => $chan => $what );

    KGB->debug( $chan . ':<' . $nick . '> ' . $what . "\n" );
    undef;
}

sub get_net {
    my $obj = shift;

    ( my $net = $obj->get_heap()->session_alias() ) =~ s/^irc_//;

    return $net;
}

sub irc_001 {
    my ( $kernel, $sender ) = @_[ KERNEL, SENDER ];
    my $net = get_net($sender);
    my $channels = $KGB::config->{networks}{$net}{channels};

    # Get the component's object at any time by accessing the heap of
    # the SENDER
    KGB->out( "Connected to $net (", $sender->get_heap->server_name(), ")\n" );
    KGB->out( "Joining @$channels...\n" ) if ($channels);
    undef;
}

sub get_polygen_joke {
    my ( $out, $err );

    my $polygen = KGB::polygen_available();
    return undef unless $polygen;

    my $grammar = 'manager';
    my @polygen
        = ( $polygen, "/usr/share/polygen/eng/$grammar.grm" );

    my $result = eval { IPC::Run::run( \@polygen, \undef, \$out, \$err ) };
    if ($@) {
        KGB->debug( "Error while running " . join( ' ', @polygen ) . ": $@" );
        return undef;
    }
    elsif ($result) {
        return $out;
    }
    else {
        KGB->debug( "Error while running " . join( ' ', @polygen ) . ": $err" );
        return undef;
    }
}

sub get_smart_answer {
    my $chan = shift;

    # Channel config
    if ( $KGB::config->{chanidx}{$chan}{smart_answers_polygen} ) {
        my $polygen_joke = get_polygen_joke;

        return $polygen_joke if $polygen_joke;
    }

    my $smart_answers
        = $chan ? $KGB::config->{chanidx}{$chan}{smart_answers} : undef;
    return $smart_answers->[ ( int( rand( scalar(@$smart_answers) ) ) ) ]
        if $smart_answers;

    # Global config
    if ( $KGB::config->{smart_answers_polygen} ) {
        my $polygen_joke = get_polygen_joke;

        return $polygen_joke if $polygen_joke;
    }

    $smart_answers = $KGB::config->{smart_answers};
    return $smart_answers->[ ( int( rand( scalar(@$smart_answers) ) ) ) ]
        if $smart_answers;

    return undef;
}

sub got_a_message {
    my ( $kernel, $sender, $who, $where, $what ) = @_;
    my $chan = $where ? $where->[0] : undef;    # could be a private message
    my $net = get_net($sender);

    return undef if $who =~ /\.bot\./;  # try to ignore bots

    unless ( $autoresponse_limitter->event() ) {
        KGB->out("Auto response rate-limit reached.\n");
        return undef;
    }

    if ( $what =~ /^\!([a-z]+)$/ ) {
        $kernel->yield( irc_command => $1 => $who => $chan => $net );
    }
    else {
        my $msg = get_smart_answer($chan);
        return undef unless ($msg);
        my $nick = parse_user($who);
        reply( $kernel, $net, $chan, $nick, $msg );
    }
}

sub irc_bot_addressed {
    my ( $kernel, $sender, $who, $where, $what )
        = @_[ KERNEL, SENDER, ARG0, ARG1, ARG2 ];

    got_a_message( $kernel, $sender, $who, $where, $what );
}

sub irc_msg {
    my ( $kernel, $sender, $who, $what ) = @_[ KERNEL, SENDER, ARG0, ARG2 ];

    got_a_message( $kernel, $sender, $who, undef, $what );
}

sub irc_new_hash {
    my ( $kernel, $heap, $chan, $str ) = @_[ KERNEL, HEAP, ARG0, ARG1 ];

    my $hash = md5_hex( $chan, substr( $str, 0, 100 ) );

    my $seen_idx  = $heap->{seen_idx}  ||= {};
    my $seen_list = $heap->{seen_list} ||= [];
    my $idx = exists $seen_idx->{$hash} ? $seen_idx->{$hash} : undef;

    # if found, move to the top of the list
    if ( defined($idx) ) {
        my $hash = splice( @$seen_list, $idx, 1 );
        $seen_idx->{ $seen_list->[$_] }++ for 0 .. ( $idx - 1 );
        unshift @$seen_list, $hash;
        $seen_idx->{$hash} = 0;

        return undef;
    }

    # only keep last 100 hashes
    if ( scalar( @{ $heap->{seen_list} } ) == 100 ) {
        delete $seen_idx->{ pop @$seen_list };
    }

    push @$seen_list, $hash;
    $seen_idx->{$hash} = $#$seen_list;
}

sub irc_notify {
    my ( $kernel, $heap, $chan, $str, $method )
        = @_[ KERNEL, HEAP, ARG0, ARG1, ARG2 ];

    $method ||= 'privmsg';

    # put some hidden character to avoid addressing anyone
    my $safety = $KGB::painter->color_codes->{normal};
    $_ = "$safety$_" for @$str;

    my $part = substr( $str->[0], 0, 100 );
    utf8::encode($part);
    my $hash = md5_hex( $chan, $part );

    if ( exists $heap->{seen_idx}{$hash} ) {
        KGB->debug("'$part' seen recently\n");

        return undef;
    }

    my $alias = "irc_" . $KGB::config->{chanidx}{$chan}{network};
    $kernel->post( $alias => $method => $chan => $_ ) foreach (@$str);
    if ( $KGB::debug ) {
        KGB->out("$alias/$chan > $_\n") foreach (@$str);
    }
}

sub reply {
    my ( $kernel, $net, $chan, $nick, $msg ) = @_;
    # put some hidden character to avoid addressing anyone
    my $safety = $KGB::painter->color_codes->{normal};
    return $chan
        ? $kernel->post( "irc_$net" => privmsg => $chan => "$safety$nick: $msg" )
        : $kernel->post( "irc_$net" => privmsg => $nick => "$safety$msg" );
}

sub irc_command {
    my ( $kernel, $heap, $command, $who, $chan, $net )
        = @_[ KERNEL, HEAP, ARG0 .. ARG3 ];

    my $nick = parse_user($who);

    return reply( $kernel, $net, $chan, $nick, "You are not my master" )
        unless grep { matches_mask( $_, $who ) } @{ $KGB::config->{admins} };

    if ( $command eq 'version' ) {
        return reply( $kernel, $net, $chan, $nick,
                  "Tried /CTCP "
                . $KGB::config->{networks}{$net}{nick}
                . " VERSION?" );
    }
    else {
        return reply( $kernel, $net, $chan, $nick,
            "command '$command' is not known to me" );
    }
}

package KGB::JSON;

use JSON::XS;
use POE;
use Digest::SHA qw(sha1_hex);

sub json_error {
    my ( $json, $resp, $error ) = @_;
    KGB->out($error);
    $resp->code(200);
    $resp->message('OK');
    $resp->content(
        encode_json(
            { id => $json->{id} // 0, error => $error, result => undef }
        )
    );
}

sub http_error {
    my ( $resp, $error, $code ) = @_;
    KGB->out($error);
    $resp->code($code // 400);
    $resp->message($error);
    $resp->content('');
}

sub json_request {
    my ( $req, $resp, $path ) = @_[ ARG0, ARG1, ARG2 ];

    my ($repo_id, $auth);
    unless (defined( $repo_id = $req->header('X-KGB-Project') )
        and defined( $auth = $req->header('X-KGB-Auth') ) )
    {
        http_error( $resp,
            'Invalid or missing X-KGB-Project or X-KGB-Auth headers' );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    unless ( exists $KGB::config->{repositories}{$repo_id} ) {
        http_error( $resp, "Unknown project ($repo_id)" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    my $check = sha1_hex( $KGB::config->{repositories}{$repo_id}{password},
        $repo_id, $req->content );

    unless ( $check eq $auth ) {
        http_error( $resp, "[$repo_id] Authentication failed", 401 );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    my $json;
    my $ok = eval { $json = decode_json( $req->content ); 1; };

    unless ($ok) {
        http_error( $resp, "[$repo_id] Error decoding JSON request" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    unless (exists $json->{method}
        and defined $json->{method}
        and not ref( $json->{method} )
        and length $json->{method} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"method\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    unless (exists $json->{params}
        and defined $json->{params}
        and ref( $json->{params} )
        and ref( $json->{params} ) eq 'ARRAY'
        and length $json->{params} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"params\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    unless (exists $json->{id}
        and defined $json->{id}
        and not ref( $json->{id} )
        and length $json->{id} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"id\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    my $json_result;
    $ok = eval {
        $json_result = encode_json(
            {   id     => $json->{id} // 0,
                result => __PACKAGE__->handle_json_request( $_[KERNEL], $repo_id, $json ),
                error  => undef
            }
        );
        1;
    };

    unless ($ok) {
        KGB->out($@);
        json_error( $json, $resp, "[$repo_id] Internal server error" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    $resp->code(200);
    $resp->message('OK');
    $resp->content($json_result);
    $_[KERNEL]->post( $_[SENDER], DONE => $resp );
    return;
}

sub handle_json_request {
    my ( $self, $kernel, $repo_id, $req ) = @_;

    my $meth = "do_json_$req->{method}";

    die "Unknown method '$req->{method}'" unless $self->can($meth);

    return $self->$meth( $kernel, $repo_id, @{ $req->{params} } );
}

sub do_json_commit_v4 {
    my ( $self, $kernel, $repo_id, $data ) = @_;

    KGB::SOAP::do_commit_msg( $kernel, $repo_id, $data );
}

sub do_json_relay_message {
    my ( $self, $kernel, $repo_id, $message, $opts ) = @_;

    $opts ||= {};

    defined $repo_id or die "Missing repo_id argument\n";
    exists $KGB::config->{repositories}{$repo_id} or die "Invalid repository '$repo_id'\n";
    my $repo = $KGB::config->{repositories}{$repo_id};
    my @channels = @{ $repo->{channels} };
    die("Repository $repo_id has no associated channels.\n") unless @channels;

    my @messages;

    defined($message) or die "No message parameter";
    if (ref($message) ) {
        ref($message) eq 'ARRAY'
            or die "Unsupported ref ("
            . ref($message)
            . ") for the message parameter";

        for (@$message) {
            defined($_) and not ref($_) or die "Invalid message";
            length($_) or die "Empty message";
        }

        KGB->debug(
            sprintf( "Received a batch of %d messages\n", scalar(@$message) )
        );
        @messages = @$message;
    }
    else {
        length($message) or die "Empty message";

        push @messages, $message;
    }

    die "Too much messages (rate limit overflow)"
        if $KGB::config->{queue_limit}
        and $KGB::IRC::irc_object
        and $KGB::config->{queue_limit}
        < ( $KGB::IRC::irc_object->send_queue + scalar(@messages) );

    foreach my $msg (@messages) {
        foreach my $chan ( @channels ) {
            for my $line ( split( /\n/, $msg ) ) {
                if ($KGB::simulate) {
                    my $fh = IO::File->new(">> $KGB::simulate")
                        or die "Error opening $KGB::simulate for writing: $!\n";
                    $fh->autoflush(1);
                    $fh->binmode(':utf8');
                    $fh->print("$chan $line\n");
                    $fh->close;
                }
                else {
                    $kernel->yield(
                        irc_notify => $chan => [$line],
                        $opts->{use_irc_notices} ? 'notice' : 'privmsg'
                    );
                }
            }
        }
    }

    return 'OK';
}

package main;

use strict;
use warnings;

use POE;
use POE::Component::Server::SOAP;
use POE::Component::IRC::State;
use POE::Component::IRC::Plugin::AutoJoin;
use POE::Component::IRC::Plugin::BotAddressed;
use POE::Component::IRC::Plugin::Connector;
use POE::Component::IRC::Plugin::NickReclaim;
use POE::Component::IRC::Plugin::NickServID;
use POE::Component::IRC::Plugin::CTCP;
use Getopt::Long;
use YAML ();
use Proc::PID::File;

KGB::save_progname();
$KGB::out = \*STDERR;
binmode( $KGB::out, ':utf8' );

my $conf_file  = '/usr/pkg/etc/kgb-bot/kgb.conf';
my $conf_dir   = '/usr/pkg/etc/kgb-bot/kgb.conf.d';
$KGB::foreground = 0;
$KGB::simulate = 0;
$KGB::simulate_color = 0;
$KGB::debug = 0;

Getopt::Long::Configure("bundling");
GetOptions(
    'c|config=s'   => \$conf_file,
    'cd|config-dir=s' => \$conf_dir,
    'f|foreground' => \$KGB::foreground,
    'simulate=s'    => \$KGB::simulate,
    'simulate-color!' => \$KGB::simulate_color,
    'debug!'        => \$KGB::debug,
) or die 'Invalid parameters';

@ARGV and die "No command line arguments supported\n";

KGB::load_conf($conf_file);

use Cwd;
$KGB::simulate = Cwd::realpath($KGB::simulate) if $KGB::simulate;

$KGB::painter
    = App::KGB::Painter->new( { styles => $KGB::config->{colors} } );

unless ($KGB::foreground) {
    pipe IN, OUT or die "pipe: $!\n";
    my $pid = fork();
    die "Can't fork: $!" unless ( defined $pid );
    if ($pid) {
        close OUT;
        my $r = join( "", <IN> );
        close IN or die $!;
        if ( $r =~ /^OK$/ ) {
            exit 0;
        }
        else {
            die $r;
        }
    }
    else {
        $poe_kernel->has_forked;
    }
    close IN;
    eval {
        die "Already running\n"
            if (
            Proc::PID::File->running(
                verify => 1,
                dir    => $KGB::config->{pid_dir},
            )
            );
        POSIX::setsid() or die "setsid: $!\n";
        umask(0022);
        chdir("/") or die "chdir: $!\n";

        open( STDIN, "<", "/dev/null" ) or die "Error closing stdin: $!\n";

        KGB::open_log();
    };
    if ($@) {
        print OUT $@;
        exit 1;
    }
    else {
        print OUT "OK\n";
        close OUT;
    }
}

POE::Component::Server::SOAP->new(
    ALIAS   => $KGB::const{SOAPsvc},
    ADDRESS => $KGB::config->{soap}{server_addr},
    PORT    => $KGB::config->{soap}{server_port},
    # override PoCo::SOAP HANDLERS to plug json-rpc
    SIMPLEHTTP => {
                'HANDLERS'      =>      [
                        {
                                'DIR'           =>      '^/json-rpc',
                                'SESSION'       =>      $KGB::config->{soap}{service_name},
                                'EVENT'         =>      'json_request',
                        },
                        {
                                'DIR'           =>      '.*',
                                'SESSION'       =>      'SOAPServer',
                                'EVENT'         =>      'Got_Request',
                        },
                ],
    },
);

POE::Session->create(
    package_states => [
        "KGB::POE" => [
            qw(_start _stop sighandler restarthandler
                reloadhandler)
        ],
        "KGB::IRC" => [
            qw(_irc_reconnect irc_registered irc_001
                irc_public irc_bot_addressed irc_new_hash irc_notify _default
                irc_command irc_msg),
        ],
        "KGB::SOAP" => [qw(commit)],
        'KGB::JSON' => [qw(json_request)],
    ],

    #    options => {trace => 1, debug => 1}
);

$poe_kernel->run;
if ($KGB::restart) {
    exec( $KGB::progname, '--foreground',
        '--config'     => $KGB::config_file,
        $KGB::debug ? '--debug' : (),
    ) or die "couldn't re-exec: $!\ņ";
}
exit 0;
