path: root/bot.pl

#!/usr/bin/perl

use strict;
use DBI;

# IRC Server stuff
use POE;
use POE::Component::IRC;

my $current_nick = 'francoise';
#my $current_nick = 'franzi';
my $channel      = '#kiffer.de';
#my $channel = "#test";

POE::Component::IRC->new("francoise");
POE::Session->new ( _start     => \&irc_start,
                    irc_join   => \&irc_join,
                    irc_part   => \&irc_part,
                    irc_nick   => \&irc_nick,
                    irc_quit   => \&irc_quit,
                    irc_376    => \&irc_connect,  #end of motd
                    irc_372    => \&irc_motd,
                    irc_353    => \&irc_names,
                    irc_311    => \&irc_whois,
                    irc_public => \&irc_pub_msg,
                    irc_msg    => \&irc_priv_msg,
                    irc_ctcp_action => \&irc_action,
#                   _default   => \&irc_default,
);


my %commands = ( 'help'     => \&francoise_help,
                 'stat'     => \&francoise_stat,
                 'topten'   => \&francoise_topten,
                 'topten0r' => \&francoise_topten0r,
                 'forget'   => \&francoise_forget,
                 'alias'    => \&francoise_alias,
                 'count'    => \&francoise_count,
               );

# this helps identify jamaica autorejoiner and doublejoiner
# %jamaica         holds encodedIP => nick
# %jamaicat        holds encodedIP => lastjoin
# $jamaicatimeout  says, after which timeout an IP is 'clear'
# for now 2 hours 
my %jamaica; my %jamaicat; my $jamaicatimeout = 7200;

my $hv = join( '|',
         ( 'bin', 'bist', 'ist', 'is', 'sind', 'seid',
           'werde', 'wirst', 'wird', 'werden', 'werdet',
           'war', 'warst', 'waren', 'wart',
           'habe', 'hast', 'hat', 'haben', 'habt',
           'hatte', 'hattest', 'hatten', 'hattet',
           'muss', 'muß', 'musst', 'mußt', 'muessen', 'müssen', 'muesst', 'mueßt', 'müsst', 'müßt' ) );

my %pasthv = ( 'bin' => 'war', 'bist' => 'warst', 'ist' => 'war', 'is' => 'war', 'sind' => 'waren', 'seid' => 'wart',
               'werde' => 'bin', 'wirst' => 'bist', 'wird' => 'ist', 'werden' => 'sind', 'werdet' => 'seid',
               'war' => 'war', 'warst' => 'warst', 'waren' => 'waren', 'wart' => 'wart',
               'habe' => 'hatte', 'hast' => 'hattest', 'hat' => 'hatte', 'haben' => 'hatten', 'habt' => 'hattet',
               'hatte' => 'hatte', 'hattest' => 'hattest', 'hatten' => 'hatten', 'hattet' => 'hattet',
               'muss' => 'musste', 'muß' => 'musste', 'musst' => 'musstest', 'mußt' => 'musstest', 'muessen' => 'mussten',
               'müssen' => 'mussten', 'muesst' => 'musstet', 'mueßt' => 'musstet', 'müsst' => 'musstet', 'müßt' => 'musstet' );

my %conjhv = ( 'bin' => 'wäre', 'bist' => 'wärst', 'ist' => 'wäre', 'sind' => 'wären', 'seid' => 'wärt',
               'werde' => 'würde', 'wirst' => 'würdest', 'wird' => 'würde', 'werden' => 'würden', 'werdet' => 'würdet',
               'war' => 'wäre', 'warst' => 'wärst', 'waren' => 'wären', 'wart' => 'wärt',
               'habe' => 'hätte', 'hast' => 'hättest', 'hat' => 'hätte', 'haben' => 'hätten', 'habt' => 'hättet',
               'hatte' => 'hätte', 'hattest' => 'hättest', 'hatten' => 'hätten', 'hattet' => 'hättet',
               'muss' => 'müsste', 'muß' => 'müsste', 'musst' => 'müsstest', 'mußt' => 'müsstest', 'muessen' => 'müssten',
               'müssen' => 'müssten', 'muesst' => 'müsstet', 'mueßt' => 'müsstet', 'müsst' => 'müsstet', 'müßt' => 'müsstet' );

my %futuhv = ( 'bin' => 'werde', 'bist' => 'wirst', 'ist' => 'wird', 'sind' => 'werden', 'seid' => 'werdet',
               'werde' => 'werde', 'wirst' => 'wirst', 'wird' => 'wird', 'werden' => 'werden', 'werdet' => 'werdet',
               'war' => 'bin', 'warst' => 'bist', 'waren' => 'sind', 'wart' => 'seid',
               'habe' => 'habe', 'hast' => 'hast', 'hat' => 'hat', 'haben' => 'haben', 'habt' => 'habt',
               'hatte' => 'habe', 'hattest' => 'hast', 'hatte' => 'hat', 'hatten' => 'haben', 'hattet' => 'habt',
               'muss' => 'muss', 'muß' => 'muss', 'musst' => 'musst', 'mußt' => 'mußt', 'muessen' => 'muessen',
               'müssen' => 'müssen', 'muesst' => 'müsst', 'mueßt' => 'müsst', 'müsst' => 'müsst', 'müßt' => 'müsst' );
               


my $starttime = time();

# Database connection stuff
my $dbh = DBI->connect("DBI:Pg:dbname='francoise'", 'francoise', 'kiffer')
    or die "ohoh, datenbank b0rken: $!";

sub irc_start {
  my ( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION ];

  $kernel->refcount_increment( $session->ID(), "my bot");
  $kernel->post(francoise=> register=> "all");

  $kernel->post(francoise=>connect=> {  Nick     => $current_nick,
                                        Username => 'francoise',
                                        Ircname  => 'francoise',
                                        Server   => 'irc.kiffer.de',
                                        Port     => '6667',
                                     }
                );
}

# minifunctions, console output only
sub irc_connect { $_[KERNEL]->post(francoise=>join=>$channel); }
sub irc_motd    { my $msg = $_[ARG1]; print "MOTD: $msg\n"; }
sub irc_part    { my $channel = $_[ARG1]; my $nick = (split /!/, $_[ARG0])[0]; print "#-> $nick has parted $channel\n"; }
sub irc_quit    { my $nick = $_[ARG0]; my $reason = $_[ARG1]; print "#-> $nick has quit ($reason)\n"; }
sub irc_default { print "IRC $1 received\n" if ( $_[ARG0] =~ /^irc_(.*)$/ ); }

#names list on join, check all users
sub irc_names {
  my $kernel = $_[KERNEL];
  my ( $channel, $names ) = (split /:/, $_[ARG1]);

  for my $user ( split ' ', $names ) {
    $user =~ s/^[@%+]//;
    $kernel->post( 'francoise', 'whois', $user);
  }

  $channel =~ s/[@|=] (.*?) /$1/;
  print "#-> Users on $channel [ $names ]\n";
}

#nick change
sub irc_nick {
  my ( $kernel, $newnick_ ) = @_[ KERNEL, ARG1 ];
  my $oldnick_ = (split /!/, $_[ARG0])[0];

  my $oldnick = francoise_getbasenick( $oldnick_ );
  my $newnick = francoise_getbasenick( $newnick_ );

  francoise_verifyuser( $newnick_, '', 0, $kernel )
    if $newnick_ ne $current_nick && $newnick ne $oldnick;

  print "#-> $oldnick_ is now known as $newnick_\n";
}

#user joined
sub irc_join {
  my ( $kernel, $channel ) = @_[KERNEL, ARG1];

  $_[ARG0] =~ /(.+)!~(.+)@(.+)/ or return;
  my ( $nick, $user, $host ) = ($1,$2,$3);

  $kernel->post( 'francoise', 'privmsg', $channel, 'Hier bin ich!'), return
    if $nick eq $current_nick;

  francoise_verifyuser( $nick, $host, 1 );
  return unless $host eq 'jamaica.kiffer.de';

  $kernel->post( 'francoise', 'privmsg', $channel, "Ich glaub ja, $jamaica{$user} und $nick kennen sich.")
    if $jamaica{$user} && $nick ne $jamaica{$user} && time() - $jamaicat{$user} < $jamaicatimeout;
  $jamaica{$user} = $nick; $jamaicat{$user} = time();

  print "#-> $nick has joined $channel\n";
}


sub irc_pub_msg{
  my ( $kernel, $msg ) = @_[KERNEL, ARG2];
  my $channel  = $_[ARG1]->[0];
  my $nick_    = (split /!/, $_[ARG0])[0];
  my @words    = (split / /, $msg);
  my $w0rds    = 0;

  return if $nick_ eq $current_nick;

  #tidy nick and tidy msg from dest nick
  my $nick = francoise_verifyuser( $nick_, "", 0, $kernel );
  $msg =~ s/^\S+: +//;

  #execute commands
  &{$commands{ $1 } || \&francoise_donothing } ( $kernel, $channel, $2 )
    if $msg =~ /^!(\S+) *(.*)$/;

  #update dictionary
  my $sth_lookup = $dbh->prepare( "SELECT COUNT(*) FROM words WHERE word = ?");
  my $sth_insert = $dbh->prepare( "INSERT INTO words ( word, is_0r, is_action ) VALUES ( ?, ?, ? )");

  for my $word ( @words ) {
    my $is0r = 'false'; my $isact = 'false';
    $sth_lookup->execute( $word );
    $is0r  = 'true', $w0rds++ if $word =~ /0r/;
    $isact = 'true'           if $word =~ /^\*.*\*$/;
    $sth_insert->execute( $word, $is0r, $isact )
      unless ($sth_lookup->fetchrow_array)[0];
  }

  #reply to whereis requests
  if ( $msg =~ /^wo ist? (\S+?)\??$/i ) {
    my $wois_ = $1;
    my $wois  = francoise_getbasenick( $1 );
    my ($awaymsg) = $dbh->selectrow_array( "SELECT awaymsg FROM users WHERE nick = ? AND isaway = 'true'", undef, $wois);

    $kernel->post( 'francoise', 'privmsg', $channel, $awaymsg ? "$wois_ ist $awaymsg" : "Ich weiss nicht, wo $wois_ ist." );

  } elsif( $msg =~ /^(.+?)\s+($hv)\s+(.*)$/i ) {
    #learn some new knowledge
    my ( $trigger, $hilfsverb, $reply ) = ($1,$2,$3);

    $dbh->do( "INSERT INTO knowledge ( trigger, hilfsverb, reply ) VALUES ( ?, ?, ?) ", undef, $trigger, $hilfsverb, $reply )
      unless ($dbh->selectrow_array(
       "SELECT COUNT(*) FROM knowledge WHERE trigger = ? AND hilfsverb = ? AND reply = ?", undef, $trigger, $hilfsverb, $reply
      ))[0];

  } else {
    #search in our knowledge
    my $thr = join ' ', $dbh->selectrow_array(
        "SELECT trigger, hilfsverb, reply FROM knowledge WHERE trigger = ? ORDER BY RANDOM() LIMIT 1", undef, $msg );
    $thr =~ s/^.*?(?:<reply> *?)(.*)$/$1/;
    $thr =~ s/!who/$nick/g;
    $thr =~ s'!date'francoise_date()'eg;
    $thr =~ s'!time'francoise_time()'eg;
    $kernel->post( 'francoise', 'privmsg', $channel, $thr ) if $thr;
  }

  #credit word and line count to user
  $dbh->do( "UPDATE users SET lines = lines + 1, words = words + ?, w0rds = w0rds + ?, isaway = false WHERE nick = ?", undef, $#words + 1, $w0rds, $nick );;

  print "$channel: <$nick> $msg\n";
}

sub irc_action{
  my ( $who, $msg ) = @_[ ARG0, ARG2 ];
  my $nick = francoise_getbasenick( ( split /!/, $who )[0] );
  #note whereis information
  $dbh->do( "UPDATE users SET isaway = true, awaymsg = ? WHERE nick = ?", undef, $1, $nick )
    if( $msg =~ /^ist? (.+)$/ );
}

sub irc_priv_msg{
  my ( $kernel, $msg ) = @_[KERNEL, ARG2];
  my $nick = (split /!/, $_[ARG0])[0];   
 
  &{$commands{ $1 } || \&francoise_donothing } ( $kernel, $nick, $2 )
    if( $msg =~ /^!(\S+) *(.*)$/ );

  #todo: hide that better, the lady is no puppet on a string
  $kernel->post( 'francoise', 'privmsg', $channel, $1)
    if( $msg =~ /^!say (.*)$/ );

  $kernel->post( 'francoise', $1, $2, $3, $4 )
    if $msg =~ /^!magic +(\S+) +(\S+) +(\S+) (.*)/;

  print "PRIV: [$nick] $msg\n";
}

sub irc_whois{
  my ( $nick, $host ) = (split / /, $_[ARG1])[0,2];

  francoise_verifyuser( $nick, $host, 0 )
    if( $nick ne $current_nick );
}

sub francoise_getbasenick{
  my $nick = $_[0]; $nick =~ s/^(.+?)[_|^-].*/$1/;
  return ($dbh->selectrow_array( "SELECT nick FROM aliases WHERE alias = ?", undef, $nick ))[0] || $nick;
}

sub francoise_verifyuser {
  my ( $nick_, $host, $updtime, $kernel ) = @_;
  my $nick = francoise_getbasenick( $nick_ );

  $kernel->post( 'francoise', 'whois', $nick_), return $nick
    unless $host;

  my ($cnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM users WHERE nick=?", undef, $nick );

  $dbh->do( "INSERT INTO users(id, nick, words, lines, lastlogin, lasthost) VALUES ( '', ?, 0, 0, now(), ? )", undef, $nick, $host)
    unless $cnt;
  $dbh->do( "UPDATE users SET lasthost = ?" . ( $updtime ? ", lastlogin = now()" : "" ) . " WHERE nick = ?", undef, $host, $nick )
    if $cnt;

  return $nick;
}

sub francoise_help {
  my ( $kernel, $dest ) = @_;

  $kernel->post( 'francoise', 'privmsg', $dest, 'Hallo, ich bin Francoise, der freundliche Kifferchat-Bot.');
  $kernel->post( 'francoise', 'privmsg', $dest, 'Ich kann folgende Kommandos ausfuehren:');
  $kernel->post( 'francoise', 'privmsg', $dest, '!help      Diese Hilfe anzeigen');
  $kernel->post( 'francoise', 'privmsg', $dest, '!stat      Informationen ueber mich ausgeben');
  $kernel->post( 'francoise', 'privmsg', $dest, '!topten    Die aktivsten Chatter anzeigen');
  $kernel->post( 'francoise', 'privmsg', $dest, '!topten0r  Die 13370rsten Chatter anzeigen');
  $kernel->post( 'francoise', 'privmsg', $dest, '!forget    Einen Trigger vergessen');
}

sub francoise_stat {
  my ( $kernel, $dest, $msg ) = @_;

  francoise_userstat( $kernel, $dest, $msg ), return
    if $msg;

  my $age   = time() - $starttime;
  my $secs  =    int($age % 60);
  my $mins  =    int(( $age / 60   ) % 3600);
  my $hours =    int(( $age / 3600 ) % 86400);
  my $days  =    int($age / 86400);

  my $agestring;

  if( $age < 60 ) {
      $agestring = "$secs Sekunde" . ($secs == 1 ? "" : "n");
  } elsif( $age < 3600 ) {
      $agestring = "$mins Minute" . ($mins == 1 ? "" : "n") . " $secs Sekunde"
          . ($secs == 1 ? "" : "n");
  } elsif( $age < 86400) {
      $agestring = "$hours Stunde" . ($hours == 1 ? "" : "n") . " $mins Minute"
          . ($mins == 1 ? "" : "n");
  } else {
      $agestring = "$days Tag" . ($days == 1 ? "" : "e") . " $hours Stunde" .
          ($hours == 1 ? "" : "n");
  }

  my ($usercnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM users" );
  my ($knowcnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM knowledge" );
  $kernel->post( 'francoise', 'privmsg', $dest, "Ich bin schon $agestring alt, kenne $usercnt Chatter und weiss ueber $knowcnt Dinge bescheid." );
}

sub francoise_userstat{
  my ( $kernel, $dest, $msg ) = @_;
  
  my $nick = francoise_getbasenick( $msg );
  my @userstat = $dbh->selectrow_array( "SELECT words, lines, w0rds, isaway, awaymsg FROM users WHERE nick = ?", undef, $nick );
  my $awaymsg = $userstat[3] ? " $nick ist momentan $userstat[4]." : "";

  $kernel->post( 'francoise', 'privmsg', $dest, "$nick hat schon $userstat[0] Worte in $userstat[1] Zeilen von sich gegeben und $userstat[2] mal in den Kanal ge0red.$awaymsg");
}

sub francoise_topten{
  my ($kernel, $dest ) = @_;

  my $sth = $dbh->prepare( "SELECT words, nick FROM users WHERE words > 0 ORDER BY words DESC LIMIT 10" );
  $sth->execute();
  while ( my ($words, $nick) = $sth->fetchrow_array ) {
    $kernel->post( 'francoise', 'privmsg', $dest, "$words  $nick" );
  }
}

sub francoise_topten0r {
  my ($kernel, $dest ) = @_;

  my $sth = $dbh->prepare( "SELECT w0rds, nick FROM users WHERE w0rds > 0 ORDER BY w0rds DESC LIMIT 10" );
  $sth->execute();

  while ( my ($w0rds, $nick ) = $sth->fetchrow_array ) {
    $kernel->post( 'francoise', 'privmsg', $dest, "$w0rds  $nick" );
  }
}

sub francoise_alias{
  my ($kernel, $dest, $msg ) = @_;
  my ($nick, $alias) = (split / /, $msg );

  my ($tmp) = $dbh->selectrow_array( "SELECT nick FROM aliases WHERE alias = ?", undef, $nick );
  $alias = $nick, $nick = $tmp if $tmp;

  ($tmp) = $dbh->selectrow_array( "SELECT COUNT(*) FROM aliases WHERE nick = ? AND alias = ?", undef, $nick, $alias );
  return if $tmp;

  my ( $usw, $usl, $us0 ) = $dbh->selectrow_array( "SELECT words, lines, w0rds FROM users WHERE nick = ?", undef, $nick );
  my ( $alw, $all, $al0 ) = $dbh->selectrow_array( "SELECT words, lines, w0rds FROM users WHERE nick = ?", undef, $alias);

  if( $alw || $all ) {
    $dbh->do( "UPDATE users SET isaway = false, words = ?, lines = ?, w0rds = ? WHERE nick = ?",
      undef, $usw+$alw, $usl+$all, $us0 + $al0, $nick );
    $dbh->do( "INSERT INTO aliases ( nick, alias ) VALUES ( ?, ? )", undef, $nick, $alias );
    $dbh->do( "DELETE FROM users WHERE nick = ?", undef, $alias );
  }
}

sub francoise_forget {
    my ($kernel, $channel, $what) = @_;

    my ($tmp) = $dbh->selectrow_array("SELECT COUNT(*) FROM knowledge WHERE trigger = ?", undef, $what);

    if ($tmp)
    {
        ($tmp) = $dbh->selectrow_array("SELECT COUNT(*) FROM users WHERE nick = ?", undef, $what);

        if ($tmp)
        {
            $kernel->post('francoise', 'privmsg', $channel, "$what wird nicht geloescht, das ist ein User!");
        } else
        {
            $dbh->do("DELETE FROM knowledge WHERE trigger = ?", undef, $what);
            $kernel->post('francoise', 'privmsg', $channel, "Mist, seit der letzten Tuete weiss ich nix mehr von $what :(");
        }
    } else
    {
        $kernel->post('francoise', 'privmsg', $channel, "$what? Nie von gehoert! *schwoer*");
    }
}

sub francoise_count {
    my ($kernel, $channel, $what) = @_;

    my ($tmp) = $dbh->selectrow_array("SELECT COUNT(*) FROM knowledge where trigger = ?", undef, $what);

    if ($tmp)
    {
        $kernel->post('francoise', 'privmsg', $channel, "Zu $what hab ich $tmp schlaue Sachen zu sagen.");
    } else
    {
        $kernel->post('francoise', 'privmsg', $channel, "Zu $what weiss ich noch gar nix.");
    }
}

sub francoise_donothing {
}

sub francoise_time {
  my ( $sec,$min,$hour) = localtime(time);
  return sprintf "%02d:%02d:%02d", $hour, $min, $sec;
}

my @mons = ('Januar','Februar','März','April','Mai','Juni','Juli','August','September','Oktober','November','Dezember');
sub francoise_date {
  my ($sec,$min,$hour,$mday,$mon) = localtime(time);
  return sprintf "%02d. %s", $mday, $mons[$mon];
}

#start everything
$poe_kernel->run();