View ¡m../sdba/MSN.pm¡n
package MSN; use strict; use warnings; use Exporter (); use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); my $VERSION = "1.3.12 - Edited By : Talha Asad Final Version"; @ISA = qw (Exporter); @EXPORT = qw (); @EXPORT_OK = qw (); %EXPORT_TAGS = (); =head1 NAME MSN Protocol Connector Version 1.3.6 =head1 DESCRIPTION MSN protocol connection that creates a simple interface to the MSN protocol =head1 USAGE Here is a quick echo bot. use MSN; my $msn = MSN->new(Handle => `email@msn.com`, Password => `secret`); $msn->set_handler(Message => \&on_message); $msn->connect(); while(1) { $msn->do_one_loop } sub on_message { my ($self, $email, $name, $msg) = @_; $msg =~ s/<(|\n)+?>//g; $self->sendmsg($msg); } =head1 BUGS No known bugs at this time. =head1 CHANGE LOG Version 1.3.5 to 1.3.6 (Jan 25, 2004) sgf - added code to allow excessively long messages with sendmsg sgf - added code to make sure name is under 129 characters with set_name sgf - tweaked remcontact/addcontact's multiprotocol support Version 1.3.4 to 1.3.5 (Jan 25, 2004) wtk - added methods addcontact and remcontact to add/rem items from the FL list (actual contacts list) wtk - added Status sub to example code (shows how to get online/offline contact notifications) ejh - added code to skip some MSGs with Content-Type application Version 1.3.3 to 1.3.4 (Jan 13, 2004) ejh - fixed response to BYE. now deletes the socket correctly Version 1.3.2 to 1.3.3 (Jan 5, 2004) wtk - fixed variable masking warning Version 1.3.1 to 1.3.2 (Jan 3, 2004) fixed assigning and deleting buddies with JOI and BYE fixed deleting empty sockets fixed password and handle error for new SB session Version 1.3 to 1.3.1 (Jan 1, 2004) fixed small bug in adding users Version 1.2.3 to 1.3 (Dec 31, 2003) added isVer and Ver to check which protocol version is in use fixed to run on both MSNP9 and MSNP10 with no code changes added getlist(AL|RL|BL|FL) to return the respective lists. added block and unblock fixed the need for haveing a blank string as first parameter to new. (still accepts it for backwards compatibility) Version 1.2.2 to 1.2.3 fixed minor error when people left a chat Version 1.2.1 to 1.2.2 Moved over to using carp and croak for user errors Added a checksum to help in the problem solving phases Moved the print for both checksum and version up to where they are always called =head1 REQUIRMENTS URI::Escape HTTP::Request LWP::UserAgent IO::Socket IO::Select Data::Dumper Digest::MD5 LWP::Simple =cut #used in authenticate use URI::Escape; use HTTP::Request; use LWP::UserAgent; #general use IO::Socket; use IO::Select; use Carp; use Digest::SHA1 qw(sha1 sha1_hex sha1_base64); use MIME::Base64; #debug use Data::Dumper; use Event::Handler; #used in the challenge phase use Digest::MD5 qw(md5 md5_hex md5_base64); use LWP::Simple; use constant CVER9 => '0x0409 winnt 5.0 i386 MSNMSGR 6.0.0268 MSMSGS '; use constant CVER10 => '0x0409 winnt 5.0 i386 MSNMSGR 6.1.0203 MSMSGS '; use constant VER => 'MSNP9 CVR0'; use constant VERSION => "Msn Module -- v 1.3.12 -- Edited By : Talha Asad Final Version"; sub checksum { my $o = tell(DATA); seek DATA,0,0; local $/; my $t = unpack("%32C*",
) % 65535;seek DATA,$o,0; return $t;}; local %SIG; # Insist on warning messages being on. $^W = 1; # Catch warnings and display additional information. local $SIG{__WARN__} = \&complain; sub complain { print "Warning: @_"; my $i = 1; my @callerstack; my ($pack, $file, $line, $subname) = caller(0); push(@callerstack, ($line, $file)); while(($pack, $file, $line, $subname) = caller($i++)) { push(@callerstack, ($subname, $line, $file)); } push(@callerstack, "main"); ($line, $file, $subname) = (shift(@callerstack), shift(@callerstack), shift(@callerstack)); print " in $subname line $line <$file>\n"; while(@callerstack) { ($line, $file, $subname) = (shift(@callerstack), shift(@callerstack), shift(@callerstack)); print " called from $subname line $line <$file>\n"; } } print VERSION . "\nChecksum:" . checksum() . "\n\n"; my $Select = IO::Select->new(); =head1 METHODS (Common) =head2 new To create a normal connection my $msn = MSN->new(Handle => $Email, Password => $Password); if you want to connect to a different host or port my $msn = MSN->new( Handle => $Email, Password => $Password, Host => 'messenger.hotmail.com', Port => 1863 ); Other options include Debug (0 by defualt) =cut sub new { my $proto = shift; my $type = shift || ""; # || 'NS'; if ($type ne "" && $type ne "SB") { unshift(@_, $type) }; my $class = ref($proto) || $proto; my $self = {Calls => {}, Host => 'messenger.hotmail.com', Port => 1863, Debug => 0, Type => 'NS', @_ }; if ($self->{Type} eq 'NS') { $self->{handler} = new Event::Handler; } unless (($self->{Type} eq "NS") && $self->{Handle} && $self->{Password} || $self->{Type} eq "SB") { carp "Cannont create object without both Handle and Password being set.\n"; } bless( $self, $class ); return $self; } =head2 connect Takes no arguments at all. Initiates the connect; $msn->connect(); =cut sub connect { # added as wrapper for connect by Eric H. Oct 23 my $self = shift; # Create the socket and add to the Select object. $self->{Socket} = IO::Socket::INET->new( PeerAddr => $self->{Host}, PeerPort => $self->{Port}, Proto => 'tcp' ) or die "Connection error: $!"; $Select->add( $self->{Socket} ); $self->GetMaster->{Socks}->{ $self->{Socket}->fileno } = $self; # Kick off the conversation!!! $self->send( 'VER', VER ); # Get version info } =head2 do_one_loop Runs a single round of listening to all sockets for communitcation. Should be called shortly after connect() in a loop. while(1) { $msn->do_one_loop } =head2 set_name Sets your display name. returns 1 on success, 0 on error $msn->set_name("Dude"); =cut sub set_name { my ($self,$newName) = @_; my $Master = $self->GetMaster(); unless (length $newName <= 129) { carp "Display name to long to set"; return 0; } $newName = uri_escape($newName); $Master->send('PRP', 'MFN ' . $newName) if $self->isVer('MSNP10'); $Master->send('REA', $Master->{Handle} . ' ' . $newName) if $self->isVer('MSNP9'); return 1; } =head2 Ver Returns the protocol version currently being used to communicate with the MSN servers print "Using " . $self->Ver() . "\n"; =cut sub Ver { my $self = shift; return $self->GetMaster->{protocol}; } =head2 isVer Checks the version microsoft is using so you can act accordingly. this way if you are using MSNP10 specific commands they don't break if it goes back to MSNP9 for a week. $self->set_name("They are on MSNP10") if $self->isVer('MSNP10'); although this may not provide a lot of functionality at the moment it may be key later on. =cut sub isVer { my ($self,$version) = @_; return ($self->Ver() eq $version); } =head2 set_status Sets your away status. $msn->set_status("NLN"); =cut sub set_status { my ($self, $status) = @_; if (!defined $status) { $status = "NLN"; } my $cid = "536870920"; $self->send("CHG", $status . " " . $cid . " " . $self->GetMaster->{MSNObject}); } =head2 Handling Events =head3 set_handler Sets a handler for an event. Takes the event name followed by a code ref $msn->set_handler(Connected => \&Connected); =cut sub set_handler { my ($self,$event,$handler) = @_; # handles internal representation of events. # can be overiden but its not likely to be neccessary return $self->{handler}->add_handler($event,$handler); } =head3 set_handlers Sets multiple handlers in a single call. Takes a hash of "Event" => &handler. $msn->set_handlers(Connected => \&Connected, Message => \&Message); =cut =head3 Events =item Log($msg) anytime the module wants to log something =item Disconnected() when all sockets are closed =item Connected() after 'OK NS' recieved =item Join($user,$friendly) when JOI is recieved =item Update_Chat_Buddies() when IRO is recieved =item Chat_Buddy_Left() when BYE is revieved =item Chat_Room_Closed() when last buddy leaves a conversation =item Status($username,$status) =item Ring($user,$friendly) when somebody rings you (RNG) =item Answer() when ANS is recieved =item Typing($user,$friendly) when Typeing message is sent to you =item Message($user,$friendly,$msg) when Message is sent to you =item SystemMessage($user,$friendly,$msg) when message is send to the NF isntead of SB =item Uknown_Command($cmd,@data) when an unhandled even comes in =cut sub set_handlers { my $self = shift; my $handlers = { @_ }; for my $event (keys %$handlers) { $self->set_handler($event,$handlers->{$event}); } } =head2 getlist Gets a list of names on a specific list (RL,BL,AL,FL) print @{$self->getlist("RL")}; # print out the RL list print scalar @{$self->getlist("FL")); # print out how many people have added this bot =cut sub getlist { my $self = shift; my $list = shift; if(!exists $self->GetMaster->{Lists}->{$list}) { carp "That list '$list' does not exists. Please try RL,BL,AL or FL"; return 0; } else { return keys %{$self->GetMaster->{Lists}->{$list}}; } } =head2 sendmsg Sends a message to the current conversation. Has a simple form $self->sendmsg("message here"); and a more complex form $self->sendmsg("message here",Font => "Arial", Color => '00ff00'); The complex form supports Font Color Effect CharacterSet PitchFamily =cut sub sendmsg { my $self = shift; my $response = shift || carp("You must pass the message you want to send"); my $settings = { Font => "Tahoma", Effect => "s", Color => "009900", CharacterSet => 0, PitchFamily => 0, @_ }; $settings->{Font} = uri_escape($settings->{Font}); while ($response =~ /(.{1,1400})/gs) { my $message = $1; if (length $message) { # Check for emoticons my $emomsg = ''; my $emoticons = 0; foreach my $sc (keys(%{$self->GetMaster->{CEs}})) { if((index($message, $sc) > -1) && (index($emomsg, "$sc\t") == -1)) { $emomsg .= "$sc\t".$self->GetMaster->{CEs}{$sc}{object}."\t"; if((++$emoticons) == 5) { last; } } } # Check if($emomsg) { my $emoheader = "MIME-Version: 1.0\r\nContent-Type: text/x-mms-emoticon\r\n\r\n$emomsg"; $self->sendraw("MSG", "N ".length($emoheader)."\r\n$emoheader"); } # Send my $header = qq{MIME-Version: 1.0\nContent-Type: text/plain; charset=UTF-8\n} . qq{X-MMS-IM-Format: FN=$settings->{Font}; EF=$settings->{Effect}; }. qq{CO=$settings->{Color}; CS=$settings->{CharacterSet}; } . qq{PF=$settings->{PitchFamily}\n}; if (exists $settings->{Name}) { $header .= "P4-Context: " . $settings->{Name} . "\n\n" . $message; } else { $header .= "\n" . $message; } $header =~ s/\n/\r\n/gs; $self->sendraw('MSG', 'U '.length($header)."\r\n" . $header); } } } =head2 call calls the user, waits for them to join and then sends them the attached message (if you send it) $msn->call("user@wherever.com"); or $msg->call("user@whereever.com","your a dork"); =cut sub call { my $self = shift; my $handle = shift; my $message = shift; unless($handle && $message) { carp "call called without both handle and message"; return; } $self->send( 'XFR', 'SB' ); # try to get a new SwitchBoard?? my $TrID = $self->GetMaster->{TrID} - 1; $self->GetMaster->{Calls}->{$TrID}->{Handle} = $handle; # add this call to the list of pending calls for when i get to a switch board? $self->GetMaster->{Calls}->{$TrID}->{Message} = $message; # add this call to the list of pending calls for when i get to a switch board? } =head2 invite Invites someone into a current conversation $self->invite("you@here.com"); That would invite user you@here.com into the conversation that $self refers to =cut sub invite { my $self = shift; my $handle = shift; unless($handle) { carp "invite called without handle"; return; } if ($self->{Type} ne 'NS') { $self->send('CAL', $handle); } else { carp "invite can only be called in a SB"; } } =head2 sendtyping Sends the message telling the current conversation that you are typing a message. $self->sendtyping =cut sub sendtyping { my $self = shift; my $header = qq{MIME-Version: 1.0\nContent-Type: text/x-msmsgscontrol\nTypingUser: } . $self->GetMaster->{Handle} . qq{\n\n\n}; $header =~ s/\n/\r\n/gs; $self->sendraw( 'MSG', 'N ' . length($header) . "\r\n" . $header); } # GetMaster goes up the tree to get the base object sub GetMaster { my $self = shift; return $self->{_Master}->GetMaster if (defined $self->{_Master}); return $self; } sub call_event { my $self = shift; $self->GetMaster->{handler}->call_event(@_); } sub _send { my $self = shift; my $msg = shift; unless ($msg) { carp "No message specified!\n"; return; } # Send the data to the socket. $self->{Socket}->print($msg); chomp($msg); my $fn = $self->{Socket}->fileno; $self->writelog("($fn $self->{Type}) TX: $msg"); return length($msg); } =head2 block Blocks the user by removing them from the AL list and adding them to the BL list. returns 1 on success, 0 on error $msn->block('eric256@rocketmail.com'); =cut sub block { my ($self,$email) = @_; my $client = $self->GetMaster(); unless ($email) { carp "email address required to block"; return 0; } delete $client->{Lists}->{AL}->{$email}; $client->{Lists}->{BL}->{$email} = 1; $client->send( "REM", "AL $email" ); $client->send( "ADC", "BL N=$email" ) if $self->isVer('MSNP10'); $client->send( "ADD", "BL $email $email") if $self->isVer('MSNP9'); return 1; } =head2 unblock unBlocks the user by removing them from the BL list and adding them to the AL list. returns 1 on success, 0 on error $msn->unblock('eric256@rocketmail.com'); =cut sub unblock { my ($self,$email) = @_; my $client = $self->GetMaster(); unless ($email) { carp "email address required to unblock"; return 0; } delete $client->{Lists}->{BL}->{$email}; $client->{Lists}->{AL}->{$email} = 1; $client->send( "REM", "BL $email" ); $client->send( "ADC", "AL N=$email" ) if $self->isVer('MSNP10'); $client->send( "ADD", "AL $email $email") if $self->isVer('MSNP9'); return 1; } =head2 addcontact adds the contact to the FL list, which is MSNs contact list. returns 1 on success, 0 on error $msn->addcontact('eric256@rocketmail.com'); =cut sub addcontact { my ($self,$email) = @_; my $client = $self->GetMaster(); unless ($email) { carp "email address required to add"; return 0; } $client->{Lists}->{FL}->{$email} = 1; $client->send( "ADC", "FL N=$email" ) if $self->isVer('MSNP10'); $client->send( "ADD", "FL $email $email" ) if $self->isVer('MSNP9'); return 1; } =head2 remcontact removes the contact to the FL list, which is MSNs contact list. returns 1 on success, 0 on error $msn->remcontact('eric256@rocketmail.com'); =cut sub remcontact { my ($self,$email) = @_; my $client = $self->GetMaster(); unless ($email) { carp "email address required to rem"; return 0; } delete $client->{Lists}->{FL}->{$email}; $client->send( "REM", "FL $email" ); return 1; } =head1 METHODS (Specialized) In general these methods should be left alone. If you do use these then you are on your own when the protocols changes. =head2 send Sends a message to MSN adding Transaction ID's and new lines. (it is recommended that you DO NOT use this method) $msn->send("CHG","NLN"); =cut sub send { my $self = shift; my ( $cmd, $data ) = @_; unless ($cmd) { carp "No command specified!\n"; return 0; } # Generate TrID using global TrID value... my $datagram = $cmd . ' ' . $self->GetMaster->{TrID}++ . ' ' . $data . "\r\n"; return $self->_send($datagram); } =head2 sendraw Sends the message/command adding Transaction IDs but no newline. (not recommended for use) $self->sendraw("CHG","NLN\r\n"); =cut sub sendraw { my $self = shift; my ( $cmd, $data ) = @_; # same as send without the "\r\n" unless ($cmd) { carp "No command specified!\n"; return 0; } my $datagram = $cmd . ' ' . $self->GetMaster->{TrID}++ . ' ' . $data; return $self->_send($datagram); } =head2 sendrawnoid Sends the message/command just as they are. You need to include any transaction ids and line ends. (not recommended for use) $self->sendrawnoid("CHG","1 NLN\r\n"); =cut sub sendrawnoid { my $self = shift; # send without ID my ( $cmd, $data ) = @_; unless ($cmd) { carp "No command specified!\n"; return 0; } my $datagram = $cmd . ' ' . $data; return $self->_send($datagram); } sub writelog { my $self = shift; my $msg = shift; unless ($msg) { carp "No message given"; return 0; } $self->call_event("Log",$self,$msg) if ($self->GetMaster->{Debug}); return 1; } sub buddyadd { my $self = shift; my ( $username, $fname ) = @_; $self->{Buddies}->{$username}->{FName} = $fname; unless ( defined( $self->{Buddies}->{$username}->{Status} ) ) { $self->{Buddies}->{$username}->{Status} = 'NONE'; $self->{Buddies}->{$username}->{LastChange} = time; } return 1; } sub buddyname { my $self = shift; my $username = shift; return $self->{Buddies}->{$username}->{FName}; } sub buddystatus { my $self = shift; my ( $username, $status ) = @_; if ($status) { $self->call_event("Status", $self, $username, $status ); $self->{Buddies}->{$username}->{Status} = $status; $self->{Buddies}->{$username}->{LastChange} = time; } return $self->{Buddies}->{$username}->{Status}; } sub do_one_loop { my $self = shift; my $fh; # foreach open socket go get the data! my @ready; @ready = $Select->can_read(.15); foreach $fh (@ready) { my $fn = $fh->fileno; unless ($_ = $fh->getline()) { $Select->remove($fh); delete($self->GetMaster->{Socks}->{$fn}); if (!keys %{$self->GetMaster->{Socks}}) { $self->call_event("Disconnected",$self); return !1;} next; } # kinda alias $self to the object that owns this file handle.... # any reason to use the fileno as the key? my $self = $self->GetMaster->{Socks}->{$fn}; $self->{fn} = $fn; #my $self = $fh->{_parent}; s/[\r\n]//g; my $incomingdata = $_; $self->writelog("($fn $self->{Type}) RX: $_"); my ($cmd, @data) = split(/ /, $_); if ($cmd eq 'VER') { $self->{protocol} = $data[1]; $self->send('CVR', CVER10 . $self->{Handle}) if $self->isVer('MSNP10'); $self->send('CVR', CVER9 . $self->{Handle}) if $self->isVer('MSNP9');; } elsif ($cmd eq 'CVR') { $self->send('USR', 'TWN I ' . $self->{Handle}); } elsif ($cmd eq 'USR') { if ($data[1] eq 'TWN' && $data[2] eq 'S') { my $token = $self->authenticate($data[3]); $self->send('USR', 'TWN S ' . $token); } elsif ($data[1] eq 'OK') { if ( $self->{Type} eq "NS") { $self->send('SYN', "0 0") if $self->isVer('MSNP10');; $self->send('SYN', "0") if $self->isVer('MSNP9');; sleep(1); $self->call_event("Connected",$self); } if (defined $self->GetMaster->{Calls}->{$self->{TrID}}) { $self->send('CAL', $self->GetMaster->{Calls}->{$self->{TrID}}->{Handle}); } } else { die 'Unsupported authentication method: "' . "@data" .'"\n'; } } elsif ( $cmd eq 'XFR' ) { if ( $data[1] eq 'NS' ) { my ($Host, $Port) = split (/:/, $data[2]); $self->{Socket}->close(); $Select->remove( $self->{Socket} ); if( defined $self->{Socket}->fileno ) { delete( $self->GetMaster->{Socks}->{ $self->{Socket}->fileno } ); } $self->{Socket} = IO::Socket::INET->new( PeerAddr => $Host, PeerPort => $Port || 1863, Proto => 'tcp' ) or die "$!"; $Select->add( $self->{Socket} ); $self->GetMaster->{Socks}->{ $self->{Socket}->fileno } = $self; $self->send( 'VER', VER ); } elsif ( $data[1] eq 'SB' ) { if (defined $self->GetMaster->{Calls}->{$data[0]}->{Handle}) { my ( $Host, $Port ) = split ( /:/, $data[2] ); my $session = MSN->new(Type => 'SB'); $session->{Socket} = IO::Socket::INET->new( PeerAddr => $Host, PeerPort => $Port || 1863, Proto => 'tcp' ) or die "$!"; # Add the new connection to the Select structure. $Select->add($session->{Socket} ); $self->GetMaster->{Socks}->{ $session->{Socket}->fileno } = $session; $session->{_Master} = $self; $session->{Key} = $data[4]; $session->{TrID} = $data[0]; $session->{_message} = $self->GetMaster->{Calls}->{$data[0]}->{Message}; $session->{Type} = 'SB'; $session->{Handle} = $self->GetMaster->{Calls}->{$data[0]}->{Handle}; $session->send( 'USR', $self->GetMaster->{Handle} . ' ' . $data[4] ); $self->{Sessions}->{$self->GetMaster->{Calls}->{$data[0]}->{Handle}} = $session; } else { die "Huh? Recieved XFR SB request, but there are no pending calls!\n"; } } } elsif ( $cmd eq 'JOI' ) { my ($user,$friendly) = @data; # call join event. if ($self->{_message}) { $self->sendmsg("$self->{_message}"); delete $self->{_message}; } $self->{Buddies}->{$user} = $friendly; my $check = 'PASSED'; my @list = $self->getlist("BL"); foreach my $item (@list) { my ($person) = split(/ /,$item); if ($user eq $person) { $self->call_event("Blocked_User_Found", $user); $check = "BLOCKED"; } } if ($check ne 'BLOCKED') { $self->call_event("Join", $self, $user, uri_unescape($friendly)); } } elsif ( $cmd eq 'IRO' ) { my (undef,$current,$total,$user,$friendly) = @data; $self->{Buddies}->{$user} = $friendly; my $check = 'PASSED'; my @list = $self->getlist("BL"); foreach my $item (@list) { my ($person) = split(/ /,$item); if ($user eq $person) { $self->call_event("Blocked_User_Found", $self, $user); $check = "BLOCKED"; } } if ($current == $total) { if ($check ne 'BLOCKED') { $self->call_event("Update_Chat_Buddies", $self, $user, uri_unescape($friendly)); } } } elsif ( $cmd eq 'BYE' ) { my ($user) = @data; delete $self->{Buddies}->{$user} if $self->{Buddies}->{$user}; $self->call_event("Chat_Buddy_Left",$self,$user); unless(keys %{$self->{Buddies}}) { print "Now Closing Socket # : " . $self->{Socket}->fileno() . "\n"; $self->call_event("Chat_Room_Closed",$self); $Select->remove( $self->{Socket}->fileno() ); delete($self->GetMaster->{Socks}->{$fn}); delete( $self->GetMaster->{Sessions}->{ $user } ); undef $self; } } elsif ( $cmd eq 'RNG' ) { my ( $sid, $addr, undef, $key, $chandle, $cname ) = @data; $self->call_event("Ring",$self,$chandle, $cname); my ( $Host, $Port ) = split ( /:/, $addr ); # 1. parse the call # 2. create a session to track it # 3. create a new msn object for that session .... why? # 4. connect the socket to the given address and respond. # 5. save relevante info in the Session and send the Reply. #temp kludge for readabilaty my $session = $self->{Sessions}->{$chandle}; $session = MSN->new(Type => 'SB'); # create new MSN module to handle it .... why? #open socket up to it. $session->{Socket} = IO::Socket::INET->new( PeerAddr => $Host, # local host PeerPort => $Port, # global port Proto => 'tcp' ) or die "$!"; # add that to the list of sockets to watch $Select->add( $session->{Socket} ); # store a ref to that socket so we can get it later.....why? $self->GetMaster->{Socks}->{ $session->{Socket}->fileno } = $session; $session->{_Master} = $self; $session->{Key} = $key; $session->{Handle} = $chandle; $session->send( 'ANS', $self->GetMaster->{Handle} . " $key $sid" ); } elsif ( $cmd eq 'ANS' ) { my ($response) = @data; $self->call_event("Answer",$self); } elsif ( $cmd eq 'MSG' ) { my ( $user, $friendly, $length ) = @data; my $response; my $msg; my $header; $fh->read( $msg, $length ); ($header, $msg) = _strip_header($msg); if ( $self->{Type} eq 'SB' ) { if ($header->{'Content-Type'} =~ /text\/x-msmsgscontrol/) { $self->call_event("Typing",$self,$user,$friendly); } elsif ($header->{'Content-Type'} =~ /text\/x-msmsgsinvite/) { my $settings = { map { split(/\: /,$_) } split (/\n/, $msg) }; if ( $settings->{'Invitation-Command'} eq "INVITE" && $settings->{'Application-Name'} eq "File Transfer") { $self->call_event("FileRecieveInvitation", $self,$user,$friendly, $settings->{'Invitation-Cookie'}, $settings->{'Application-File'}, $settings->{'Application-FileSize'}); } elsif ($settings->{'Invitation-Command'} eq "ACCEPT") { $self->call_event("FileRecieveAccept", $self, $user, $friendly, $settings->{'Invitation-Cookie'}) } # other.... } elsif ($header->{'Content-Type'} =~ /application\/x-msnmsgrp2p/) { $self->p2p_transfer($user, $msg); } elsif ($header->{'Content-Type'} =~ /application\/x-msnmsgr-sessionreqbody/) {} else { # regular hopefully my $every = $header->{'X-MMS-IM-Format'}; my @liness = split(/FN/,$every); my $ef = $liness[1]; $self->call_event("Message",$self,$user,$friendly,$msg); } }elsif ( $self->{Type} eq 'NS' ) { $self->GetMaster->{'ClientIP'} = $header->{'ClientIP'}; print "Your IP: " . $header->{'ClientIP'} . "\n"; } else { $self->call_event("SystemMessage",$self,$user,$friendly,$msg); } } elsif ( $cmd eq 'NLN' ) { $self->buddystatus( $data[1], $data[0] ); } elsif ( $cmd eq 'ILN' ) { $self->buddystatus( $data[2], $data[1] ); } elsif ( $cmd eq 'FLN' ) { $self->buddystatus( $data[0], 'FLN' ); } elsif ( $cmd =~ /[0-9]+/ ) { $self->writelog( "ERROR: " . converterror($cmd) ); } elsif ( $cmd eq 'ADC' ) { my ($TrID, $list, $handle, $name) = @data; if ( $list eq 'RL' || $list eq 'FL' ) { $self->send( 'ADC', "AL $handle"); } } elsif ( $cmd eq 'ADD' ) { my ($TrID, $list, $unknown, $handle, $name) = @data; if ( $list eq 'RL' || $list eq 'FL' ) { $self->send( 'ADD', "AL $handle $name"); } } elsif ($cmd eq 'CHL') { my $digest = md5_hex($data[1] . 'JXQ6J@TUOGYV@N0M'); $self->sendraw('QRY', 'PROD0061VRRZH@4F 32' . "\r\n" . $digest); } elsif ( $cmd eq 'GTC' ) { if ( $data[0] eq 'A' ) { $self->writelog( "ACK! Your account requires confirmation for " . "people to add you to their contact lists. " . "We'll fix that.\n\n" ); $self->send( 'GTC', 'N' ); } } elsif ( $cmd eq 'BLP' ) { if ( $data[0] eq 'BL' ) { $self->writelog( "ACK! Your account doesn't allow unknown people " . "to contact you. We'll fix that.\n\n" ); $self->send( 'BLP', 'AL' ); } } elsif ( $cmd eq 'CAL' ) { } elsif ( $cmd eq 'CHG' ) { } elsif ($cmd eq 'QRY') { } elsif ($cmd eq 'BPR') { } elsif ($cmd eq 'REA') { } elsif ($cmd eq 'LSG') { #$self->writelog( "Group Listing - $data[0]\n\n" ); } elsif ($cmd eq 'SYN') { $self->{Lists}->{SYN}->{Total} = $data[3] if $self->isVer('MSNP10'); $self->{Lists}->{SYN}->{Total} = $data[2] if $self->isVer('MSNP9'); $self->writelog( "SYN'd Successfully Total Contacts\: $self->{Lists}->{SYN}->{Total}\n\n" ); } elsif ($cmd eq 'LST') { my ($email,$friendly,$bitmask,$group); $email = $data[0]; $friendly = $data[1]; $bitmask = $data[2]; $group = $data[3]; if ($self->isVer('MSNP10')) { my @temp = @data; $bitmask = pop @temp; if ($bitmask =~ /[a-z]/) { $group = $bitmask; $bitmask = pop @temp; } my $values = {}; foreach my $t (@temp) { my ($key, $value) = split (/=/, $t); $values->{$key} = $value; } $friendly = $values->{F}; $email = $values->{N}; } $self->{Lists}->{SYN}->{Current}++; my $current = $self->{Lists}->{SYN}->{Current}; my $total = $self->{Lists}->{SYN}->{Total}; my $onAL = 0; my $onBL = 0; my $onRL = 0; my $onFL = 0; #$scurrent++; $onRL = 1 if ($bitmask & 8); $onBL = 1 if ($bitmask & 4); $onAL = 1 if ($bitmask & 2); $onFL = 1 if ($bitmask & 1); if ($onRL eq 1) { $self->{Lists}->{RL}->{$email} = 1; } if ($onBL eq 1) { $self->{Lists}->{BL}->{$email} = 1; } if ($onAL eq 1) { $self->{Lists}->{AL}->{$email} = 1; } if ($onFL eq 1) { $self->{Lists}->{FL}->{$email} = 1; } if ($onRL && !$onAL && !$onBL) { $self->send("ADD", "AL $email $email"); } if ($current == $total) { } } else { $self->call_event("Unknown_Command", $self, $cmd, @data ); $self->writelog( "RECIEVED UNKNOWN: $cmd @data\n\n" ); } } return 1; } sub converterror { my $err = shift; my %errlist; $errlist{200} = 'Invalid Syntax'; $errlist{201} = 'Invalid parameter'; $errlist{205} = 'Invalid user'; $errlist{206} = 'Domain name missing'; $errlist{207} = 'Already logged in'; $errlist{208} = 'Invalid User Name'; $errlist{209} = 'Invlaid Friendly Name'; $errlist{210} = 'List Full'; $errlist{215} = 'User already on list'; $errlist{216} = 'User not on list'; $errlist{217} = 'User not online'; #<-- $errlist{218} = 'Already in that mode'; $errlist{219} = 'User is in the opposite list'; $errlist{223} = 'Too Many Groups'; #<-- $errlist{224} = 'Invalid Groups '; #<-- $errlist{225} = 'User Not In Group'; #<-- $errlist{229} = 'Group Name too long'; #<-- $errlist{230} = 'Cannont Remove Group Zero'; #<-- $errlist{231} = 'Invalid Group'; #<-- $errlist{280} = 'Switchboard Failed'; #<-- $errlist{281} = 'Transfer to Switchboard failed'; #<-- $errlist{300} = 'Required Field Missing'; $errlist{301} = 'Too Many Hits to FND'; #<-- $errlist{302} = 'Not Logged In'; $errlist{500} = 'Internal Server Error'; $errlist{501} = 'Database Server Error'; $errlist{502} = 'Command Disabled'; $errlist{510} = 'File Operation Failed'; $errlist{520} = 'Memory Allocation Failed'; $errlist{540} = 'Challenge Responce Failed'; $errlist{600} = 'Server Is Busy'; $errlist{601} = 'Server Is Unavailable'; $errlist{602} = 'Peer Name Server is Down'; $errlist{603} = 'Database Connection Failed'; $errlist{604} = 'Server Going Down'; $errlist{605} = 'Server Unavailable'; $errlist{707} = 'Could Not Create Connection'; $errlist{710} = 'Bad CVR Parameter Sent'; $errlist{711} = 'Write is Blocking'; $errlist{712} = 'Session is Overloaded'; $errlist{713} = 'Too Many Active Users'; $errlist{714} = 'Too Many Sessions'; $errlist{715} = 'Command Not Expected'; $errlist{717} = 'Bad Friend File'; $errlist{731} = 'Badly Formated CVR'; $errlist{800} = 'Friendly Name Change too Rapidly'; $errlist{910} = 'Server Too Busy'; $errlist{911} = 'Authentication Failed'; $errlist{912} = 'Server Too Busy'; $errlist{913} = 'Not allowed While Offline'; $errlist{914} = 'Server Not Available'; $errlist{915} = 'Server Not Available'; $errlist{916} = 'Server Not Available'; $errlist{917} = 'Authentication Failed'; $errlist{918} = 'Server Too Busy'; $errlist{919} = 'Server Too Busy'; $errlist{920} = 'Not Accepting New Users'; $errlist{921} = 'Server Too Busy: User Digest'; $errlist{922} = 'Server Too Busy'; $errlist{923} = 'Kids Passport Without Parental Consent'; #<--K $errlist{924} = 'Passport Account Not Verified'; return ( $errlist{$err} ); } sub _strip_header { my ($msg) = shift; $msg =~ s/\r//gs; # fix newlines #warn "\n$msg"; if ($msg =~ /^(.*?)\n\n(.*?)$/s) { my ($head, $msg) = ($1,$2); my @temp = split (/\n/, $head); my $header = {}; foreach my $item (@temp) { my ($key,$value) = split(/:\s*/,$item); $header->{$key} = $value || ""; } # my $header = { map { split(/\:\s*/, $_ ) } @temp }; # print Dumper($header); return $header,$msg; } return $msg; } sub _do_connect_loop { my ($redir,$auth) = @_; if ($redir =~ /ru=([^\&]+)/) { $redir = $1; } my $ua = new LWP::UserAgent; my @requests = (); $ua->requests_redirectable( \@requests ); $ua->agent('MSMSGS'); my $request = new HTTP::Request ( GET => $redir ); $request->headers->header('Authorization' => $auth); my $response = $ua->request($request); $redir = $response->header('location') || undef; my $info = $response->header('authentication-info') || undef; if (defined $info) { my ($Version,$pairs) = $info =~ /^(.*?) (.*)$/; my $settings = {map { split('=',$_,2) } split(',' , $pairs)}; if ($settings->{'da-status'} =~ /^success|redir$/ ) { if ($settings->{'da-status'} eq 'success') { $settings->{'from-PP'} =~ s/'//g; return $settings->{'from-PP'}; } elsif ($settings->{'da-status'} eq 'redir') { return _do_connect_loop($redir,$auth); } else { warn "Authentication Error: Unexpected return: $info"; } } } elsif (defined $redir) { return _do_connect_loop($redir,$auth); } elsif (my $error_info = $response->header('www-authenticate')) { $error_info =~ s/^.+cbtxt=(.+)$/$1/; $error_info =~ tr/+/ /; $error_info =~ s/%(..)/pack("c",hex($1))/ge; warn "\nSERVER RETURNED ERROR: $error_info"; } else { warn 'Authentication Error: No expected reply recieved...'; } } sub authenticate { my ($self, $challenge) = @_; $challenge = {map { split '=' } split(',', $challenge)} ; my $ua = new LWP::UserAgent; my $response = $ua->get('https://nexus.passport.com/rdr/pprdr.asp'); my %passport_urls = map { split '=' } split(',',($response->headers->header('PassportURLs'))); my $DALogin = $passport_urls{'DALogin'}; my ($username,$password) = (uri_escape($self->{Handle}), uri_escape($self->{Password})); my $auth_string = "Passport1.4 OrgVerb=GET,OrgURL=$challenge->{ru}}," . "sign-in=$username,pwd=$password,lc=$challenge->{lc},". "id=$challenge->{id},tw=$challenge->{tw}," . "fs=$challenge->{fs},ct=$challenge->{ct}," . "kpp=$challenge->{kpp},kv=$challenge->{kv}," . "ver=$challenge->{ver},tpf=$challenge->{tpf}"; return _do_connect_loop('https://' . $DALogin,$auth_string); } sub add_emoticon { my $self = shift; my $shortcut = shift; my $file = shift; if((-e $file) && $file =~ /png$/) { # Read data $self->GetMaster->{CEs}{$shortcut}{data} = ''; open(EMO, $file); binmode(EMO); while(
) { $self->GetMaster->{CEs}{$shortcut}{data} .= $_; } close(EMO); # SHA1D and first part of object my $sha1d = sha1_base64($self->GetMaster->{CEs}{$shortcut}{data}).'='; my $object = '
GetMaster->{CEs}{$shortcut}{object} = $object.' SHA1C="'.$sha1c.'" />'; return 1; } else { carp "Could not find the file $file, or it is not a PNG file"; return 0; } } sub display_picture { my $self = shift; my $file = shift; if(!$file) { # Remove DP $self->GetMaster->{DPData} = ''; $self->GetMaster->{MSNObject} = ''; $self->set_status(); } else { if((-e $file) && $file =~ /png$/) { # Read the file, store it and make the MSNObject $self->GetMaster->{DPData} = ''; open(DP, $file); binmode(DP); while(
) { $self->GetMaster->{DPData} .= $_; } close(DP); # SHA1D and first part of object my $sha1d = sha1_base64($self->GetMaster->{DPData}).'='; my $object = '
GetMaster->{MSNObject} = uri_escape($object.' SHA1C="'.$sha1c.'" />'); # Set new status & return $self->set_status("NLN"); print "Done With Dp!\n"; return 1; } else { print "Could not find the file $file, or it is not a PNG file"; return 0; } } } sub p2p_transfer { my $self = shift; my $user = shift; my $data = shift; # Grab parameters if this is an invitation my ($euf, $sessid, $callid, $branch, $context); if(index($data, "INVITE MSNMSGR:") > 0) { my @lines = split("\n", $data); foreach my $param (@lines) { if($param) { my @value = split(' ', $param); my $cmd = $value[0]; if($cmd eq "EUF-GUID:") { $euf = $value[1]; } elsif($cmd eq "SessionID:") { $sessid = $value[1]; } elsif($cmd eq "Call-ID:") { $callid = $value[1]; } elsif($cmd eq "Via:") { $branch = substr($param, index($param, 'branch=')+7); } elsif($cmd eq "Context:") { $context = decode_base64($value[1]); } } } } # Grab binary fields my %fields; $fields{1} = substr($data, 0, 4); $fields{2} = substr($data, 4, 4); $fields{4} = substr($data, 16, 8); $fields{7} = substr($data, 32, 4); $fields{8} = substr($data, 36, 4); # Check if this a start of a new transfer if($euf) { # Make a unique BID my $bid; do { $bid = 1000 + int(rand(10000000)); } while(exists $self->{P2PTransfers}{$bid}{SessionID}); # Then send the BaseID message my $bin = (chr(0)x4).MakeDWord($bid).(chr(0)x8).$fields{4}.(chr(0)x4).MakeDWord(2).$fields{2}.$fields{7}.$fields{4}.(chr(0)x4); $bin = "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $user\r\n\r\n$bin"; $self->sendraw("MSG", "D ".length($bin)."\r\n$bin"); # Check if this is a Emote/DP/FTP if ($euf eq '{A4268EEC-FEC5-49E5-95C3-F126696BDBF6}') { # DP or Emote # Store information we need later on $self->{P2PTransfers}{$bid}{SessionID} = $sessid; # Check for emoticon if($context !~ /msnpm\.tmp/) { my $location = substr($context, index($context, 'Location="')+10); $location = substr($location, 0, index($location, '.tmp"')); print $location; $self->{P2PTransfers}{$bid}{Location} = $location; } # Then send the 200OK my $okdata = "\r\n\r\nSessionID: $sessid\r\n\0"; $okdata = "MSNSLP/1.0 200 OK\r\n" . "To:
GetMaster->{Handle}."\r\n" . "Via: MSNSLP/1.0/TLP ;branch=$branch\r\n" . "CSeq: 1 \r\n" . "Call-ID: $callid\r\n" . "Max-Forwards: 0\r\n" . "Content-Type: application/x-msnmsgr-sessionreqbody\r\n" . "Content-Length: ".length($okdata).$okdata; my $bin = (chr(0)x4).MakeDWord($bid-3).(chr(0)x8).MakeDWord(length($okdata)).(chr(0)x4).MakeDWord(length($okdata)).(chr(0)x4).MakeDWord(100).(chr(0)x4).(chr(0)x8); $bin = "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $user\r\n\r\n$bin$okdata".(chr(0)x4); $self->sendraw("MSG", "D ".length($bin)."\r\n$bin"); } elsif($euf eq '{5D3E02AB-6190-11D3-BBBB-00C04F795683}') { # ToDo: FTP } } else { my $bid = GetDWord($fields{7}); my $process = GetDWord($fields{8}); if($process == 100) { # Send the DataPrep message $bid+=3; my $bin = MakeDWord($self->{P2PTransfers}{$bid}{SessionID}).MakeDWord($bid-2).(chr(0)x8).MakeDWord(4).(chr(0)x4).MakeDWord(4).(chr(0)x4).MakeDWord(101).(chr(0)x8).(chr(0)x8).MakeDWord(4, 1); $bin = "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $user\r\n\r\n$bin"; $self->sendraw("MSG", "D ".length($bin)."\r\n$bin"); } elsif($process == 101) { # Send the actual DP data :) $bid+=2; # Predefined values (this saves time instead of having to create them in each loop) my $L = 1; my $FileD = ($self->{P2PTransfers}{$bid}{Location} ? $self->GetMaster->{CEs}{$self->{P2PTransfers}{$bid}{Location}}{data} : $self->GetMaster->{DPData}); my $FileL = MakeDWord(length($FileD)); my $BID = MakeDWord($bid-1); my $SID = MakeDWord($self->{P2PTransfers}{$bid}{SessionID}); do { my $TFileD = substr($FileD, $L-1, 1202); my $bin = $SID.$BID.MakeDWord($L-1).(chr(0)x4).$FileL.(chr(0)x4).MakeDWord(length($TFileD)).MakeDWord(32).MakeDWord(102).(chr(0)x4).(chr(0)x8).$TFileD.MakeDWord(4, 1); $bin = "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $user\r\n\r\n$bin"; $self->sendraw("MSG", "D ".length($bin)."\r\n$bin"); $L += length($TFileD); } while ($L < length($FileD)); # Remove object from p2ptransfers hash # We are done *big smile* delete $self->{P2PTransfers}{$bid}; } } } sub _sendout { my ($self,$msg) = @_; # Send the data to the socket. $self->{Socket}->print($msg); while ( my ($user) = each(%{$self->{Buddies}}) ) { $self->call_event("Chat_Buddy_Left", $self, $user); } $Select->remove( $self->{Socket}->fileno() ); delete($self->GetMaster->{Socks}->{$self->{fn}}); undef $self; } sub file_trans { my $self = shift; my $path = shift || warn "No Path Specified"; my $filename = shift; my $size = -s "$path/$filename"; my $header = qq{MIME-Version: 1.0\nContent-Type: text/x-msmsgsinvite; charset=UTF-8\n\n} . qq{Application-Name: File Transfer\nApplication-GUID: {5D3E02AB-6190-11d3-BBBB-00C04F795683}\nInvitation-Command: INVITE\n}. qq{Invitation-Cookie: 1578608\nApplication-File: $filename\nApplication-FileSize: $size \nConnectivity: N\n\n}; $self->{'FileName'} = "$filename"; $self->{'Path'} = "$path"; $header =~ s/\n/\r\n/gs; $self->sendraw( 'MSG', 'N ' . length($header) . "\r\n" . $header ); } sub MakeDWord { my $word = shift; my $little = shift; my $a = ($word / 16777220) % 256; my $b = ($word / 65536) % 256; my $c = ($word / 256) %256; my $d = $word % 256; return ($little ? chr($a).chr($b).chr($c).chr($d) : chr($d).chr($c).chr($b).chr($a)); } sub GetDWord { my $word = shift; my $little = shift; my $a = ord(substr($word, 0, 1)); my $b = ord(substr($word, 1, 1)); my $c = ord(substr($word, 2, 1)); my $d = ord(substr($word, 3, 1)); $a = $little ? $a * 16777220 : $a; $b = $little ? $b * 65536 : $b * 256; $c = $little ? $c * 256 : $c * 65536; $d = $little ? $d: $d * 16777220; return ($a+$b+$c+$d); } =head1 EXAMPLE use MSN; my $Email = 'email@msn.com'; my $Password = 'big secret password'; my $msn = MSN->new(Handle => $Email, Password => $Password); $msn->set_handler(Connected => \&Connected); $msn->set_handler(Message => \&Message); $msn->set_handler(Answer => \&Answer); $msn->set_handler(Join => \&Join); $msn->set_handler(Update_Chat_Buddies => \&UpdateBuddies); $msn->set_handler(Status => \&Status); $msn->connect(); while (1) { $msn->do_one_loop; } sub Message { my ($self, $victim, $name, $msg) = @_; $msg =~ s/<(|\n)+?>//g; $self->sendmsg($msg); } sub Connected { my $self = shift; warn "Calling Eric!"; $msn->call('eric256@rocketmail.com',"Dude"); } sub Answer { my ($self, $username) = @_; $self->sendmsg("I don't know anything!"); } sub Join { my ($self,$user,$friendly) = @_; $self->sendmsg("Welcome $user"); } sub UpdateBuddies { my $self = shift; $self->sendmsg("Hello " . join(",", map {$self->{Buddies}->{$_}} keys %{$self->{Buddies}})); } sub Status { my( $self, $username, $status ) = @_; if( $status eq 'NLN' ) { # $username is online, do something about it } elsif( $status eq 'FLN' ) { # $username is offline, do something about it } } 1; =cut =head1 CONTRIBUTIONS Eric Hodges (ejh) eric256@rocketmail.com Steve Fullbrook (sgf) keenie_bean@hotmail.com William Kelley (wtk) wtk@kjwconsulting.com If you know you should be on this list and are not then please contact one of the above contributors to have the situation fixed. =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =head1 SEE ALSO =cut return 1; __DATA__