serverevent.pm

MSN fast change name is new utility 4 you

package Net::OICQ::ServerEvent;

# $Id: ServerEvent.pm,v 1.8 2003/10/17 20:01:52 tans Exp $

# Copyright (c) 2003 Shufeng Tan.  All rights reserved.
# 
# This package is free software and is provided "as is" without express
# or implied warranty.  It may be used, redistributed and/or modified
# under the terms of the Perl Artistic License (see
# http://www.perl.com/perl/misc/Artistic.html)

use 5.006;
use strict;
use warnings;
eval "no encoding; use bytes;" if $] >= 5.008;

use Crypt::OICQ qw(encrypt decrypt);
use Net::OICQ::Event;
our @ISA = qw(Net::OICQ::Event);

my @MsgPrecursors = ("\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x01",
		     "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01",
		     "..\x00\x00\x00\x01\x01\x00.\x00\x01");
my @AutoMsgPrecursors = ("\x00\x00\x00\x01\x00\x00\x00\x00\x02");

# Separators
my $FS = $Net::OICQ::FS;   # Field separator
my $RS = $Net::OICQ::RS;   # Record separator

my $InfoHeader = \@Net::OICQ::InfoHeader;

sub new {
    my ($class, $packet, $oicq) = @_;
    my $self = {
        OICQ  => $oicq,
        Header => substr($packet, 0, 7),
    };
    bless $self, $class;
    my $cmdcode = $self->cmdcode;
    my $cmd     = $self->cmd;
    if ($cmd =~ /reg_new_id_/) {
        $oicq->log_t("Cmd $cmd ($cmdcode):\n", $oicq->hexdump($packet));
        return undef;
    }
    my $crypt = substr($packet, 7, -1);
    my $plain;
    if ($cmd eq 'login') {
        eval { $plain = decrypt(undef, $crypt, $oicq->{PWKey}) };
        $@ && $oicq->{Debug} && $oicq->log_t($@);
        unless (defined $plain) {
            eval { $plain = decrypt(undef, $crypt, $oicq->{RandKey}) };
        }
        $@ && $oicq->log_t($@);
    } else {
        eval { $plain = decrypt(undef, $crypt, $oicq->{Key}) };
    }

    return undef unless defined $plain;
    $self->{Data} = $plain;
    return $self;
}

# Default method for server data

sub default {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $ui = $oicq->{UI};
    if (defined $ui) {
        $ui->info("Server ack to ", $self->cmd, ": 0x",
                  unpack('H*', $self->{Data}), "\n");
    }
    return unless $oicq->{Debug};
    $oicq->log_t("Decryted data from server:\n", $oicq->hexdump($self->{Data}));
}

# Server replies with session key

sub login {
    my ($self) = @_;
    my $oicq  = $self->{OICQ};
    my $plain = $self->{Data};
    if (length($plain) < 0x11) {   # Server did not return a session key
        if (substr($plain, 0, 1) ne "\x01") {
            $oicq->log_t("wrong passwd for $oicq->{Id}, hexdump:\n",
                         $oicq->hexdump($plain));
            return undef;
        }
        if (substr($plain, 1, 4) ne $oicq->{_Id}) {
            $oicq->log_t("server reply to login request from ",
                         unpack('L', substr($plain, 1, 4)), ":\n",
                         $oicq->hexdump($plain));
            return undef;
        }
        # Find new server address
        $oicq->log_t("redirected to server $oicq->{SvrIP}:$oicq->{SvrPort}");
        $oicq->{SvrPort} = unpack('n', substr($plain, 9, 2));
        $oicq->{SvrIP} = join('.', map {ord} split('',  substr($plain, 5, 4)));
        $oicq->{Socket} = undef;
        $oicq->desect($plain,
            ['H*', 'Flag', 0, 1],
            ['N',  'uid',  1, 4],
            ['H*', 'IP',   5, 4],
            ['n',  'Port', 9, 2]);
        return 0;
    }
    my $key = substr($plain, 1, 0x10);
    $oicq->{Key} = $key;
    $oicq->desect($plain,
        ['H*', 'S_LOGIN', 0, 1],
        ['H*', 'session key', 0x01, 0x10],
        ['N',  'uid',     0x11, 0x04],
        ['H*', 'S_LOGIN', 0x15, 0x0f],
        ['H*', 'S_LOGIN', 0x24, 0x01],
        ['H*', 'S_LOGIN', 0x25, 0x02],
        ['H*', 'S_LOGIN', 0x27, 0x18],
        ['H*', 'S_LOGIN', 0x3f, 0x0e],
        ['H*', 'S_LOGIN', 0x4d, 0x20],
        ['H*', 'S_LOGIN', 0x6d, 0x12],
        ['H*', 'S_LOGIN', 0x7f]);
    return 1;
}

sub logout {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    $oicq->log("Impossible: logout packet from server?\n",
               $oicq->hexdump($self->{Data}));
    return;
}

# Server replies with user info
sub get_user_info {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $plain = $self->{Data};
    my @field = split(/$FS/, $plain);

    return unless defined $field[0];
    return if $field[0] =~ /^-/;

    $oicq->{MyInfo} = [@field] if $field[0] == $oicq->{Id};
    $oicq->{Info}->{$field[0]} = {} unless defined $oicq->{Info}->{$field[0]};
    my $hashref = $oicq->{Info}->{$field[0]};
    $hashref->{Nickname} = $field[1];
    $hashref->{Age}      = $field[7];
    $hashref->{Sex}      = $field[8];
    $hashref->{Face}     = $oicq->get_face($field[21]);

    my $datfile = "$oicq->{Dir}/$oicq->{Id}/$field[0].dat";
    my $dat = new FileHandle(">$datfile");
    if (defined $dat) {
        print $dat "\$_ = {\n";
        for(my $j = 0; $j<=$#field; $j++) {
            printf $dat "%-15s => '%s',\n", $InfoHeader->[$j], $field[$j];
        }
        print $dat "};\n";
        $dat->close;
        my $ui = $oicq->{UI};
        if (defined $ui && defined $ui->{show_user_info}) {
            $ui->show_user_info(\@field);
            delete $ui->{show_user_info};
        }
    } else {
        $oicq->log_t("Failed to open user info file >$datfile");
    }

    return 1;
}

# Server ack
sub send_msg {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $plain = $self->{Data};
    my $text = $plain eq "\0" ?
                   "Message transmitted by server" :
                   "Server ack to send_msg: 0x" . unpack('H*', $plain);
    my $ui = $oicq->{UI};
    if (defined $ui) {
        $ui->info("$text\n");
    }
    if ($oicq->{Debug} or not defined $oicq->{UI}) {
        $oicq->log_t($text);
    }
    return 1;
}

sub recv_msg {
    my ($self) = @_;
    my $oicq  = $self->{OICQ};
    my $plain = $self->{Data};
    my $srcid = unpack('N', substr($plain, 0, 4));
    my $dstid = unpack('N', substr($plain, 4, 4));
    defined $oicq->{Info}->{$srcid} or $oicq->{Info}->{$srcid} = {};
    $oicq->{Info}->{$srcid}->{Client} = substr($plain, 0x14, 2);
    if ($oicq->{Debug} > 1) {
        print 'recv_msg data(8,14)=0x', unpack('H*', substr($plain, 8, 14)),
              "\nMD5($dstid Key)=0x", unpack('H*', substr($plain, 30, 16)),
              "\ndecrypted data:\n", $oicq->hexdump($plain), "\n";
    }
    return if length($plain) < 0x32;
    my $time  = unpack('N', substr($plain, 0x32, 4));
    my $mesg = $self->get_msg(substr($plain, 0x36));
    my $ui = $oicq->{UI};
    if (defined $ui) {
        if (defined $mesg) {
            $ui->msg($srcid, $dstid, $time, $mesg);
        } else {
            $ui->error("get_msg error logged, probably due to new MsgPrecursor\n");
        }
    }
    if ($oicq->{Debug} or $oicq->{LogChat}) {
        $oicq->log_t("Received message from $srcid:\n$mesg");
    }
    if (defined $oicq->{Socket} and defined $mesg) {
        $oicq->ack_msg($plain);
        my $chatbot = $oicq->{Info}->{$srcid}->{ChatBot};
        (defined $chatbot && -f $chatbot) or $chatbot = $oicq->{ChatBot};
        if (defined $chatbot && -f $chatbot) {
            eval { require $chatbot; on_message($oicq, $srcid, $mesg) };
            if ($@) {
               $oicq->log_t("on_message error: $@");
               defined $ui && $ui->error($@);
            }
        } else {
            $self->check_autoreply($oicq, $srcid, $mesg);
        }
    }
    $oicq->desect($plain,
        ['N',  'srcid', 0x00, 4],
        ['N',  'dstid', 0x04, 4],
        ['H*', 'S_RMTS', 0x08, 0x0d],
        ['N',  'srcid again', 0x16, 4],
        ['N',  'dstid again', 0x1a, 4],
        ['H*', 'S_RMTS', 0x1e, 0x23]);
    return 1;
}

# Extract message from decrypted data using MsgPrecursor
sub get_msg {
    my ($self, $plain) = @_;
    my $oicq = $self->{OICQ};
    foreach my $precursor (@MsgPrecursors) {
	if ($plain =~ /^$precursor(.*)$/s) {
	    return $1;
	}
    }
    foreach my $precursor (@AutoMsgPrecursors) {
        if ($plain =~ /^$precursor(.*)$/s) {
            return "Auto-Reply:\n" . $1;
	}
    }
    $oicq->log("Unable to get message from data:\n", $oicq->hexdump($plain));
    $plain =~ s/^(.{11})/'#'.unpack("H*", $1).'#'/se;
    return $plain;
}