AnyEvent-MSN
3 results

 view release on metacpan or  search on metacpan

lib/AnyEvent/MSN.pm  view on Meta::CPAN 

);

# Simple callbacks
has 'on_' . $_ => (
    traits  => ['Code'],
    is      => 'ro',
    isa     => 'CodeRef',
    default => sub {
        sub {1}
    },
    handles => {'_trigger_' . $_ => 'execute_method'},
    )
    for qw[
    im nudge
    error fatal_error connect
    addressbook_update
    buddylist_update
    user_notification
    create_circle
];
has connected => (
             is      => 'ro',
             isa     => 'Bool',
             traits  => ['Bool'],
             default => 0,
             handles => {_set_connected => 'set', _unset_connected => 'unset'}
);
has redirect => (
         is        => 'ro',
         isa       => 'Str',
         predicate => '_has_redirect',
         writer    => '_set_redirect',
         clearer   => '_reset_redirect'    # XXX - Currently unused internally
);

# Auto connect
sub BUILD {
    my ($s, $p) = @_;
    return if $p->{no_autoconnect};
    $s->connect;
}

sub connect {
    my $s = shift;
    $s->_unset_connected;
    $s->_set_handle(
        AnyEvent::Handle->new(
            connect    => [$s->host, $s->port],
            on_connect => sub {

                # Get ready to read data from server
                $s->handle->push_read(
                    'AnyEvent::MSN::Protocol' => sub {
                        my ($cmd, $tid, @data) = @_;
                        my $method = $s->can('_handle_packet_' . lc($cmd));
                        $method ||= sub {
                            $s->_trigger_error(
                                            'Unhandled command type: ' . $cmd,
                                            0);
                        };
                        if ($cmd =~ m[^(?:GCF|MSG|NFY|NOT|SDG|UBX|PUT)$])
                        {    # payload types
                            $s->handle->unshift_read(
                                chunk => $data[-1] // $tid,    # GFC:0, MSG:2
                                sub {
                                    my ($_h, $_c) = @_;
                                    $s->$method(
                                        $tid, @data,
                                        $cmd =~ m[GCF] ? $s->_parse_xml($_c)
                                        : $cmd =~ m[(?:MSG|NFY|SDG)] ?
                                            AnyEvent::MSN::Protocol::__parse_msn_headers(
                                                                          $_c)
                                        : $_c
                                    );
                                }
                            );
                        }
                        elsif ($cmd =~ m[^\d+$]) {    # Error!
                            $s->_trigger_error(
                                 AnyEvent::MSN::Protocol::err2str($cmd, @data)
                            );
                        }
                        else {
                            $s->$method($tid, @data);
                        }
                    }
                );

                # Send version negotiation
                $s->send('VER %d %s CVR0', $s->tid, $s->protocol_version);

                # Schedule first PNG in two mins
                $s->_set_ping_timer(AE::timer 120,
                                    180, sub { $s->send('PNG') });
            },
            on_connect_error =>
                sub { shift; $s->_trigger_fatal_error(shift) },
            on_error => sub {
                my $h = shift;
                $s->_trigger_fatal_error(reverse @_);
                $h->destroy;
            },
            on_eof => sub {
                $_[0]->destroy;
                $s->cleanup('connection closed');
            }
        )
    );
}

# Commands from notification server
sub _handle_packet_adl {
    my $s = shift;

    # ACK for outgoing ADL
    # $s->send('BLP %d AL', $s->tid);
}

sub _handle_packet_chl {    # Official client challenge
    my ($s, $tid, @data) = @_;
    my $data =

lib/AnyEvent/MSN.pm  view on Meta::CPAN 

    # The fifth parameter is a URL the user can go to to
    #   get more information about the client.
    $s->send('USR %d SSO I %s', $s->tid, $s->passport);
}

sub _handle_packet_gcf {    # Get config
    my ($s, $tid, $len, $r) = @_;
    if ($tid == 0) {        # probably Policy list
        $s->_set_policies($r->{Policy});

        #for (@{$s->policy('SHIELDS')->{config}{block}{regexp}{imtext}}) {
        #    my $regex = MIME::Base64::decode_base64($_);
        #    warn 'Blocking ' . qr[$regex];
        #}
    }
    else {
        ...;
    }
}

sub _handle_packet_msg {
    my ($s, $from, $about, $len, $head, $body) = @_;
    given ($head->{'Content-Type'}) {
        when (m[text/x-msmsgsprofile]) {

     #
     # http://msnpiki.msnfanatic.com/index.php/MSNP8:Messages#Profile_Messages
     # My profile message. Expect no body.
        }
        when (m[text/x-msmsgsinitialmdatanotification]) {    # Expect no body
        }
        when (m[text/x-msmsgsoimnotification]) {

            # Offline Message Waiting.
            # Expect no body
            # XXX - How do I request it?
        }
        when (m[text/x-msmsgsactivemailnotification]) {

            #warn 'You\'ve got mail!/aol'
        }
        when (m[text/x-msmsgsinitialmdatanotification]) {

            #warn 'You\'ve got mail!/aol'
        }
        default { $s->_trigger_error('Unknown message type: ' . $_) }
    }
}

sub _handle_packet_nfy {
    my ($s, $type, $len, $headers, $data) = @_;

=begin comment
        use Data::Printer;
        dd $type, $len, $headers, $data;
        dd $s->_parse_xml($data);
=cut
    given ($headers->{Uri}) {
        when ('/user') {
            given ($type) {
                when ('PUT') {
                    my $xml = $s->_parse_xml($data);
                    if ((!defined $headers->{By})
                        && $headers->{From} eq '1:' . $s->passport)
                    {    # Without guid
                        $s->set_status($s->status)
                            ;    # Not fully logged in until sent
                        $s->_set_connected();
                        $s->_trigger_connect;
                    }
                    else {
                        $s->_trigger_user_notification($headers, $xml);
                    }
                }
                when ('DEL') {

                    # Remove from list
                }
                default {...}
            }
        }
        when ('/circle') {
            my $xml = $s->_parse_xml($data);
            $s->_trigger_create_circle($headers, $xml);
        }
        default {...}
    }
}
sub _handle_packet_not { my $s = shift; }
sub _handle_packet_out { my $s = shift; }

sub _handle_packet_put {
    my $s = shift;

    # ACK for our PUT packets
}

sub _handle_packet_qng {
    my ($s, $next) = @_;

    # PONG in reply to our PNG
    $s->_set_ping_timer(AE::timer $next, $next, sub { $s->send('PNG') });
}

sub _handle_packet_qry {
    my ($s, $tid) = @_;

    #
    my $token = $s->auth_token('contacts.msn.com')
        ->{'wst:RequestedSecurityToken'}{'wsse:BinarySecurityToken'}{content};
    $token =~ s/&/&/sg;
    $token =~ s/</&lt;/sg;
    $token =~ s/>/&gt;/sg;
    $token =~ s/"/&quot;/sg;

    # Reply to good challenge. Expect no body.
    $s->_soap_request(
        'https://local-bay.contacts.msn.com/abservice/SharingService.asmx',
        {   'content-type' => 'text/xml; charset=utf-8',
            SOAPAction =>
                '"http://www.msn.com/webservices/AddressBook/FindMembership"'
        },
        sprintf(<<'XML', $token),
<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
    <soap:Header>
        <ABApplicationHeader xmlns="http://www.msn.com/webservices/AddressBook">
            <ApplicationId>CFE80F9D-180F-4399-82AB-413F33A1FA11</ApplicationId>
            <IsMigration>false</IsMigration>
            <PartnerScenario>Initial</PartnerScenario>
        </ABApplicationHeader>
        <ABAuthHeader xmlns="http://www.msn.com/webservices/AddressBook">
            <TicketToken>%s</TicketToken>
            <ManagedGroupRequest>false</ManagedGroupRequest>
        </ABAuthHeader>
    </soap:Header>
    <soap:Body>
        <FindMembership xmlns="http://www.msn.com/webservices/AddressBook">
            <ServiceFilter>
                <Types>
                    <Space></Space>
                    <SocialNetwork></SocialNetwork>
                    <Profile></Profile>
                    <Invitation></Invitation>
                    <Messenger></Messenger>
                </Types>
            </ServiceFilter>
        </FindMembership>
    </soap:Body>
</soap:Envelope>
XML
        sub {
            my $contacts = shift;

            # XXX - Do something with these contacts
            #...

lib/AnyEvent/MSN.pm  view on Meta::CPAN 

    );
}

# Remove a contact:
# RML 12 112\r\n
# <ml><d n="penilecolada.com"><c n="junk" t="1"><s l="3" n="IM" /><s l="3" n="PE" /><s l="3" n="PF"/></c></d></ml>
sub add_temporary_contact {
    my $s = shift;
    my %contacts;
    for my $contact (@_) {
        my ($user, $domain) = split /\@/, $contact, 2;
        push @{$contacts{$domain}}, $user;
    }
    my $data = sprintf '<ml%s>%s</ml>', ($s->connected ? '' : ' l="1"'),
        join '', map {
        sprintf '<d n="%s">%s</d>', $_, join '', map {
            sprintf '<c n="%s" t="1">%s</c>', $_, join '',
                map {"<s l='3' n='$_' />"}
                qw[IM PE PF]
            } sort @{$contacts{$_}}
        } sort keys %contacts;
    my $tid = $s->tid;
    $s->send("ADL %d %d\r\n%s", $tid, length($data), $data);
    $tid;
}

sub remove_buddy {
    my $s = shift;
    my $data = sprintf <<'', reverse split '@', shift, 2;
<ml>
    <d n="%s">
        <c n="%s" t="1">
            <s l="3" n="IM" />
            <s l="3" n="PE" />
            <s l="3" n="PF" />
        </c>
    </d>
</ml>

    my $tid = $s->tid;
    $s->send("RML %d %d\r\n%s", $tid, length($data), $data);
    $tid;
}
after set_status => sub {
    my ($s, $status) = @_;
    my $body = sprintf '<user>' . '<s n="PE">
            <UserTileLocation>0</UserTileLocation><FriendlyName>%s</FriendlyName><PSM>%s</PSM><RUM></RUM><RLT>0</RLT></s>'
        . '<s n="IM"><Status>%s</Status><CurrentMedia></CurrentMedia></s>'
        . '<sep n="PD"><ClientType>1</ClientType><EpName>%s</EpName><Idle>false</Idle><State>%s</State></sep>'
        . '<sep n="PE" epid="%s"><VER>MSNMSGR:15.4.3508.1109</VER><TYP>1</TYP><Capabilities>2952790016:557056</Capabilities></sep>'
        . '<sep n="IM"><Capabilities>2953838624:132096</Capabilities></sep>'
        . '</user>', __html_escape($s->friendly_name),
        __html_escape($s->personal_message),
        $status,
        __html_escape($s->location), $status, $s->guid;
    my $out
        = sprintf
        qq[To: 1:%s\r\nRouting: 1.0\r\nFrom: 1:%s;epid=%s\r\n\r\nStream: 1\r\nFlags: ACK\r\nReliability: 1.0\r\n\r\nContent-Length: %d\r\nContent-Type: application/user+xml\r\nPublication: 1.0\r\nUri: /user\r\n\r\n%s],
        $s->passport,
        $s->passport, $s->guid, length($body), $body;
    $s->send("PUT %d %d\r\n%s", $s->tid, length($out), $out);
};

# Testing/Incomplete stuff
sub create_group_chat {
    my $s    = shift;
    my $body = '';      # For now.
    my $out
        = sprintf
        qq[To: 10:00000000-0000-0000-0000-000000000000\@live.com\r\nRouting: 1.0\r\nFrom: 1:%s;epid=%s\r\n\r\nStream: 1\r\nFlags: ACK\r\nReliability: 1.0\r\n\r\nContent-Length: %d\r\nContent-Type: application/multiparty+xml\r\nPublication: 1.0\r\nUri...
        $s->passport, $s->guid, length($body), $body;
    $s->send("PUT %d %d\r\n%s", $s->tid, length($out), $out);
}

# Random private methods
sub _parse_xml {
    my ($s, $data) = @_;
    state $xml_twig //= XML::Twig->new();
    my $xml = {};
    use Carp;

=begin comment Carp::confess('...') if ! length $data ;
=cut
    try {
        $xml_twig->parse($data);
        $xml = $xml_twig->simplify(keyattr => [qw[type id value]]);
    }
    catch { $s->_trigger_fatal_error(qq[parsing XML: $_]) };
    $xml;
}

# Non-OOP utility functions
sub __html_escape {
    my $x = shift;
    $x =~ s[&][&amp;]sg;
    $x =~ s[<][&lt;]sg;
    $x =~ s[>][&gt;]sg;
    $x =~ s["][&quot;]sg;
    $x;
}

sub __html_unescape {
    my $x = shift;
    $x =~ s[&lt;][<]sg;
    $x =~ s[&gt;][>]sg;
    $x =~ s[&quot;]["]sg;
    $x =~ s[&amp;][&]sg;
    $x;
}

#
__PACKAGE__->meta->make_immutable();
no Moose;
1;

=pod

=head1 NAME

AnyEvent::MSN - Simple, Less Annoying Client for Microsoft's Windows Live Messenger Network

=head1 Synopsis

    use AnyEvent::MSN;
    my $msn = AnyEvent::MSN->new(
        passport => 'you@hotmail.com',
        password => 'sekrit',
        on_im => sub { # Simiple echo bot
            my ($msn, $head, $body) = @_;
            $msn->im($head->{From}, $body)
        }
    );



( run in 1.543 second using v1.01-cache-2.11-cpan-437f7b0c052 )