source: perl/modules/jabber.pl @ 8fa9562

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 8fa9562 was 8fa9562, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 17 years ago
Added background color support to owl. If we run out of color pairs during a painting of the screen, further background colors will be silently dropped. I'm hoping this doesn't happen often. The used pair list is reset with each draw, so only what's actually on screen matters.
  • Property mode set to 100644
File size: 36.1 KB
Line 
1# -*- mode: cperl; cperl-indent-level: 4; indent-tabs-mode: nil -*-
2package BarnOwl::Jabber;
3use warnings;
4use strict;
5
6use Authen::SASL qw(Perl);
7use Net::Jabber;
8use Net::Jabber::MUC;
9use Net::DNS;
10use Getopt::Long;
11
12no warnings 'redefine';
13
14################################################################################
15# owl perl jabber support
16#
17# XXX Todo:
18# Rosters for MUCs
19# More user feedback
20#  * joining MUC
21#  * parting MUC
22#  * presence (Roster and MUC)
23# Implementing formatting and logging callbacks for C
24# Appropriate callbacks for presence subscription messages.
25#
26################################################################################
27
28
29################################################################################
30################################################################################
31package BarnOwl::Jabber::Connection;
32
33use base qw(Net::Jabber::Client);
34
35sub new {
36    my $class = shift;
37
38    my %args = ();
39    if(BarnOwl::getvar('debug') eq 'on') {
40        $args{debuglevel} = 1;
41        $args{debugfile} = 'jabber.log';
42    }
43    my $self = $class->SUPER::new(%args);
44    $self->{_BARNOWL_MUCS} = [];
45    return $self;
46}
47
48=head2 MUCJoin
49
50Extends MUCJoin to keep track of the MUCs we're joined to as
51Net::Jabber::MUC objects. Takes the same arguments as
52L<Net::Jabber::MUC/new> and L<Net::Jabber::MUC/Connect>
53
54=cut
55
56sub MUCJoin {
57    my $self = shift;
58    my $muc = Net::Jabber::MUC->new(connection => $self, @_);
59    $muc->Join(@_);
60    push @{$self->MUCs}, $muc;
61}
62
63=head2 MUCLeave ARGS
64
65Leave a MUC. The MUC is specified in the same form as L</FindMUC>
66
67=cut
68
69sub MUCLeave {
70    my $self = shift;
71    my $muc = $self->FindMUC(@_);
72    return unless $muc;
73
74    $muc->Leave();
75    $self->{_BARNOWL_MUCS} = [grep {$_->BaseJID ne $muc->BaseJID} $self->MUCs];
76}
77
78=head2 FindMUC ARGS
79
80Return the Net::Jabber::MUC object representing a specific MUC we're
81joined to, undef if it doesn't exists. ARGS can be either JID => $JID,
82or Room => $room, Server => $server.
83
84=cut
85
86sub FindMUC {
87    my $self = shift;
88
89    my %args;
90    while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); }
91
92    my $jid;
93    if($args{jid}) {
94        $jid = $args{jid};
95    } elsif($args{room} && $args{server}) {
96        $jid = Net::Jabber::JID->new(userid => $args{room},
97                                     server => $args{server});
98    }
99    $jid = $jid->GetJID('base') if UNIVERSAL::isa($jid, 'Net::Jabber::JID');
100
101    foreach my $muc ($self->MUCs) {
102        return $muc if $muc->BaseJID eq $jid;
103    }
104    return undef;
105}
106
107=head2 MUCs
108
109Returns a list (or arrayref in scalar context) of Net::Jabber::MUC
110objects we believe ourself to be connected to.
111
112=cut
113
114sub MUCs {
115    my $self = shift;
116    my $mucs = $self->{_BARNOWL_MUCS};
117    return wantarray ? @$mucs : $mucs;
118}
119
120################################################################################
121################################################################################
122package BarnOwl::Jabber::ConnectionManager;
123sub new {
124    my $class = shift;
125    return bless { }, $class;
126}
127
128sub addConnection {
129    my $self = shift;
130    my $jidStr = shift;
131
132    my $client = BarnOwl::Jabber::Connection->new;
133
134    $self->{Client}->{$jidStr} = $client;
135    $self->{Roster}->{$jidStr} = $client->Roster();
136    return $client;
137}
138
139sub removeConnection {
140    my $self = shift;
141    my $jidStr = shift;
142    return 0 unless exists $self->{Client}->{$jidStr};
143
144    $self->{Client}->{$jidStr}->Disconnect();
145    delete $self->{Roster}->{$jidStr};
146    delete $self->{Client}->{$jidStr};
147
148    return 1;
149}
150
151sub connected {
152    my $self = shift;
153    return scalar keys %{ $self->{Client} };
154}
155
156sub getJids {
157    my $self = shift;
158    return keys %{ $self->{Client} };
159}
160
161sub jidExists {
162    my $self = shift;
163    my $jidStr = shift;
164    return exists $self->{Client}->{$jidStr};
165}
166
167sub sidExists {
168    my $self = shift;
169    my $sid = shift || "";
170    foreach my $j ( keys %{ $self->{Client} } ) {
171        return 1 if ($self->{Client}->{$j}->{SESSION}->{id} eq $sid);
172    }
173    return 0;
174}
175
176sub getConnectionFromSid {
177    my $self = shift;
178    my $sid = shift;
179    foreach my $c (values %{ $self->{Client} }) {
180        return $c if $c->{SESSION}->{id} eq $sid;
181    }
182    return undef;
183}
184
185sub getConnectionFromJidStr {
186    my $self = shift;
187    my $jidStr = shift;
188    return $self->{Client}->{$jidStr};
189}
190
191sub getRosterFromSid {
192    my $self = shift;
193    my $sid = shift;
194    foreach my $j ( $self->getJids ) {
195        return $self->{Roster}->{$j}
196          if $self->{Client}->{$j}->{SESSION}->{id} eq $sid;
197    }
198    return undef;
199}
200
201sub getRosterFromJidStr {
202    my $self = shift;
203    my $jidStr = shift;
204    return $self->{Roster}->{$jidStr};
205    return undef;
206}
207################################################################################
208
209package BarnOwl::Jabber;
210
211our $conn = new BarnOwl::Jabber::ConnectionManager unless $conn;;
212our %vars;
213
214sub onStart {
215    if ( *BarnOwl::queue_message{CODE} ) {
216        register_owl_commands();
217        push @::onMainLoop,     sub { BarnOwl::Jabber::onMainLoop(@_) };
218        push @::onGetBuddyList, sub { BarnOwl::Jabber::onGetBuddyList(@_) };
219    } else {
220        # Our owl doesn't support queue_message. Unfortunately, this
221        # means it probably *also* doesn't support BarnOwl::error. So just
222        # give up silently.
223    }
224}
225
226push @::onStartSubs, sub { BarnOwl::Jabber::onStart(@_) };
227
228sub onMainLoop {
229    return if ( !$conn->connected() );
230
231    foreach my $jid ( $conn->getJids() ) {
232        my $client = $conn->getConnectionFromJidStr($jid);
233
234        my $status = $client->Process(0);
235        if ( !defined($status) ) {
236            BarnOwl::error("Jabber account $jid disconnected!");
237            do_logout($jid);
238        }
239        if ($::shutdown) {
240            do_logout($jid);
241            return;
242        }
243    }
244}
245
246sub blist_listBuddy {
247    my $roster = shift;
248    my $buddy  = shift;
249    my $blistStr .= "    ";
250    my %jq  = $roster->query($buddy);
251    my $res = $roster->resource($buddy);
252
253    $blistStr .= $jq{name} ? $jq{name} . "\t(" .$buddy->GetJID() . ')' : $buddy->GetJID();
254
255    if ($res) {
256        my %rq = $roster->resourceQuery( $buddy, $res );
257        $blistStr .= " [" . ( $rq{show} ? $rq{show} : 'online' ) . "]";
258        $blistStr .= " " . $rq{status} if $rq{status};
259        $blistStr = boldify($blistStr);
260    }
261    else {
262        if ($jq{ask}) {
263            $blistStr .= " [pending]";
264        }
265        elsif ($jq{subscription} eq 'none' || $jq{subscription} eq 'from') {
266            $blistStr .= " [not subscribed]";
267        }
268        else {
269            $blistStr .= " [offline]";
270        }
271    }
272    return $blistStr . "\n";
273}
274
275sub getSingleBuddyList {
276    my $jid = shift;
277    $jid = resolveJID($jid);
278    return "" unless $jid;
279    my $blist = "";
280    my $roster = $conn->getRosterFromJidStr($jid);
281    if ($roster) {
282        $blist .= "\n" . boldify("Jabber Roster for $jid\n");
283
284        foreach my $group ( $roster->groups() ) {
285            $blist .= "  Group: $group\n";
286            foreach my $buddy ( $roster->jids( 'group', $group ) ) {
287                $blist .= blist_listBuddy( $roster, $buddy );
288            }
289        }
290
291        my @unsorted = $roster->jids('nogroup');
292        if (@unsorted) {
293            $blist .= "  [unsorted]\n";
294            foreach my $buddy (@unsorted) {
295                $blist .= blist_listBuddy( $roster, $buddy );
296            }
297        }
298    }
299    return $blist;
300}
301
302sub onGetBuddyList {
303    my $blist = "";
304    foreach my $jid ($conn->getJids()) {
305        $blist .= getSingleBuddyList($jid);
306    }
307    return $blist;
308}
309
310################################################################################
311### Owl Commands
312sub register_owl_commands() {
313    BarnOwl::new_command(
314        jabberlogin => \&cmd_login,
315        { summary => "Log into jabber", },
316        { usage   => "jabberlogin JID" }
317    );
318    BarnOwl::new_command(
319        jabberlogout => \&cmd_logout,
320        { summary => "Log out of jabber" }
321    );
322    BarnOwl::new_command(
323        jwrite => \&cmd_jwrite,
324        {
325            summary => "Send a Jabber Message",
326            usage   => "jwrite JID [-g] [-t thread] [-s subject]"
327        }
328    );
329    BarnOwl::new_command(
330        jlist => \&cmd_jlist,
331        {
332            summary => "Show your Jabber roster.",
333            usage   => "jlist"
334        }
335    );
336    BarnOwl::new_command(
337        jmuc => \&cmd_jmuc,
338        {
339            summary     => "Jabber MUC related commands.",
340            description => "jmuc sends jabber commands related to muc.\n\n"
341              . "The following commands are available\n\n"
342              . "join MUC    Join a muc.\n\n"
343              . "part MUC    Part a muc.\n"
344              . "            The muc is taken from the current message if not supplied.\n\n"
345              . "invite JID MUC\n"
346              . "            Invite JID to MUC.\n"
347              . "            The muc is taken from the current message if not supplied.\n\n"
348              . "configure MUC\n"
349              . "            Configure [muc].\n"
350              . "            Necessary to initalize a new MUC\n"
351              . "            At present, only the default configuration is supported.",
352            usage => "jmuc COMMAND ARGS"
353        }
354    );
355    BarnOwl::new_command(
356        jroster => \&cmd_jroster,
357        {
358            summary     => "Jabber Roster related commands.",
359            description => "jroster sends jabber commands related to rosters.\n\n",
360            usage       => "jroster COMMAND ARGS"
361        }
362    );
363}
364
365sub cmd_login {
366    my $cmd = shift;
367    my $jid = new Net::XMPP::JID;
368    $jid->SetJID(shift);
369
370    my $uid           = $jid->GetUserID();
371    my $componentname = $jid->GetServer();
372    my $resource      = $jid->GetResource() || 'owl';
373    $jid->SetResource($resource);
374    my $jidStr = $jid->GetJID('full');
375
376    if ( !$uid || !$componentname ) {
377        BarnOwl::error("usage: $cmd JID");
378        return;
379    }
380
381    if ( $conn->jidExists($jidStr) ) {
382        BarnOwl::error("Already logged in as $jidStr.");
383        return;
384    }
385
386    my ( $server, $port ) = getServerFromJID($jid);
387
388    $vars{jlogin_jid} = $jidStr;
389    $vars{jlogin_havepass} = 0;
390    $vars{jlogin_connhash} = {
391        hostname      => $server,
392        tls           => 1,
393        port          => $port,
394        componentname => $componentname
395    };
396    $vars{jlogin_authhash} =
397      { username => $uid,
398        resource => $resource,
399    };
400
401    return do_login('');
402}
403
404sub do_login {
405    $vars{jlogin_password} = shift;
406    $vars{jlogin_authhash}->{password} = sub { return $vars{jlogin_password} || '' };
407    my $jidStr = $vars{jlogin_jid};
408    if ( !$jidStr && $vars{jlogin_havepass}) {
409        BarnOwl::error("Got password but have no jid!");
410    }
411    else
412    {
413        my $client = $conn->addConnection($jidStr);
414
415        #XXX Todo: Add more callbacks.
416        # * MUC presence handlers
417        # We use the anonymous subrefs in order to have the correct behavior
418        # when we reload
419        $client->SetMessageCallBacks(
420            chat      => sub { BarnOwl::Jabber::process_incoming_chat_message(@_) },
421            error     => sub { BarnOwl::Jabber::process_incoming_error_message(@_) },
422            groupchat => sub { BarnOwl::Jabber::process_incoming_groupchat_message(@_) },
423            headline  => sub { BarnOwl::Jabber::process_incoming_headline_message(@_) },
424            normal    => sub { BarnOwl::Jabber::process_incoming_normal_message(@_) }
425        );
426        $client->SetPresenceCallBacks(
427            available    => sub { BarnOwl::Jabber::process_presence_available(@_) },
428            unavailable  => sub { BarnOwl::Jabber::process_presence_available(@_) },
429            subscribe    => sub { BarnOwl::Jabber::process_presence_subscribe(@_) },
430            subscribed   => sub { BarnOwl::Jabber::process_presence_subscribed(@_) },
431            unsubscribe  => sub { BarnOwl::Jabber::process_presence_unsubscribe(@_) },
432            unsubscribed => sub { BarnOwl::Jabber::process_presence_unsubscribed(@_) },
433            error        => sub { BarnOwl::Jabber::process_presence_error(@_) });
434
435        my $status = $client->Connect( %{ $vars{jlogin_connhash} } );
436        if ( !$status ) {
437            $conn->removeConnection($jidStr);
438            BarnOwl::error("We failed to connect");
439        } else {
440            my @result = $client->AuthSend( %{ $vars{jlogin_authhash} } );
441
442            if ( !@result || $result[0] ne 'ok' ) {
443                if ( !$vars{jlogin_havepass} && ( !@result || $result[0] eq '401' ) ) {
444                    $vars{jlogin_havepass} = 1;
445                    $conn->removeConnection($jidStr);
446                    BarnOwl::start_password( "Password for $jidStr: ", \&do_login );
447                    return "";
448                }
449                $conn->removeConnection($jidStr);
450                BarnOwl::error( "Error in connect: " . join( " ", @result ) );
451            } else {
452                $conn->getRosterFromJidStr($jidStr)->fetch();
453                $client->PresenceSend( priority => 1 );
454                queue_admin_msg("Connected to jabber as $jidStr");
455            }
456        }
457
458    }
459    delete $vars{jlogin_jid};
460    $vars{jlogin_password} =~ tr/\0-\377/x/;
461    delete $vars{jlogin_password};
462    delete $vars{jlogin_havepass};
463    delete $vars{jlogin_connhash};
464    delete $vars{jlogin_authhash};
465    return "";
466}
467
468sub do_logout {
469    my $jid = shift;
470    my $disconnected = $conn->removeConnection($jid);
471    queue_admin_msg("Jabber disconnected ($jid).") if $disconnected;
472}
473
474sub cmd_logout {
475    # Logged into multiple accounts
476    if ( $conn->connected() > 1 ) {
477        # Logged into multiple accounts, no accout specified.
478        if ( !$_[1] ) {
479            my $errStr =
480              "You are logged into multiple accounts. Please specify an account to log out of.\n";
481            foreach my $jid ( $conn->getJids() ) {
482                $errStr .= "\t$jid\n";
483            }
484            queue_admin_msg($errStr);
485        }
486        # Logged into multiple accounts, account specified.
487        else {
488            if ( $_[1] eq '-a' )    #All accounts.
489            {
490                foreach my $jid ( $conn->getJids() ) {
491                    do_logout($jid);
492                }
493            }
494            else                    #One account.
495            {
496                my $jid = resolveJID( $_[1] );
497                do_logout($jid) if ( $jid ne '' );
498            }
499        }
500    }
501    else                            # Only one account logged in.
502    {
503        do_logout( ( $conn->getJids() )[0] );
504    }
505    return "";
506}
507
508sub cmd_jlist {
509    if ( !( scalar $conn->getJids() ) ) {
510        BarnOwl::error("You are not logged in to Jabber.");
511        return;
512    }
513    BarnOwl::popless_ztext( onGetBuddyList() );
514}
515
516sub cmd_jwrite {
517    if ( !$conn->connected() ) {
518        BarnOwl::error("You are not logged in to Jabber.");
519        return;
520    }
521
522    my $jwrite_to      = "";
523    my $jwrite_from    = "";
524    my $jwrite_sid     = "";
525    my $jwrite_thread  = "";
526    my $jwrite_subject = "";
527    my $jwrite_type    = "chat";
528
529    my @args = @_;
530    shift;
531    local @ARGV = @_;
532    my $gc;
533    GetOptions(
534        'thread=s'  => \$jwrite_thread,
535        'subject=s' => \$jwrite_subject,
536        'account=s' => \$jwrite_from,
537        'id=s'     =>  \$jwrite_sid,
538        'groupchat' => \$gc
539    );
540    $jwrite_type = 'groupchat' if $gc;
541
542    if ( scalar @ARGV != 1 ) {
543        BarnOwl::error(
544            "Usage: jwrite JID [-g] [-t thread] [-s 'subject'] [-a account]");
545        return;
546    }
547    else {
548        $jwrite_to = shift @ARGV;
549    }
550
551    if ( !$jwrite_from ) {
552        if ( $conn->connected() == 1 ) {
553            $jwrite_from = ( $conn->getJids() )[0];
554        }
555        else {
556            BarnOwl::error("Please specify an account with -a JID");
557            return;
558        }
559    }
560    else {
561        $jwrite_from = resolveJID($jwrite_from);
562        return unless $jwrite_from;
563    }
564
565    $vars{jwrite} = {
566        to      => $jwrite_to,
567        from    => $jwrite_from,
568        sid     => $jwrite_sid,
569        subject => $jwrite_subject,
570        thread  => $jwrite_thread,
571        type    => $jwrite_type
572    };
573
574    BarnOwl::message(
575"Type your message below.  End with a dot on a line by itself.  ^C will quit."
576    );
577    BarnOwl::start_edit_win( join( ' ', @args ), \&process_owl_jwrite );
578}
579
580sub cmd_jmuc {
581    die "You are not logged in to Jabber" unless $conn->connected();
582    my $ocmd = shift;
583    my $cmd  = shift;
584    if ( !$cmd ) {
585
586        #XXX TODO: Write general usage for jmuc command.
587        return;
588    }
589
590    my %jmuc_commands = (
591        join      => \&jmuc_join,
592        part      => \&jmuc_part,
593        invite    => \&jmuc_invite,
594        configure => \&jmuc_configure,
595        presence  => \&jmuc_presence
596    );
597    my $func = $jmuc_commands{$cmd};
598    if ( !$func ) {
599        BarnOwl::error("jmuc: Unknown command: $cmd");
600        return;
601    }
602
603    {
604        local @ARGV = @_;
605        my $jid;
606        my $muc;
607        my $m = BarnOwl::getcurmsg();
608        if ( $m->is_jabber && $m->{jtype} eq 'groupchat' ) {
609            $muc = $m->{room};
610            $jid = $m->{to};
611        }
612
613        my $getopt = Getopt::Long::Parser->new;
614        $getopt->configure('pass_through');
615        $getopt->getoptions( 'account=s' => \$jid );
616        $jid ||= defaultJID();
617        if ($jid) {
618            $jid = resolveJID($jid);
619            return unless $jid;
620        }
621        else {
622            BarnOwl::error('You must specify an account with -a {jid}');
623        }
624        return $func->( $jid, $muc, @ARGV );
625    }
626}
627
628sub jmuc_join {
629    my ( $jid, $muc, @args ) = @_;
630    local @ARGV = @args;
631    my $password;
632    GetOptions( 'password=s' => \$password );
633
634    $muc = shift @ARGV
635      or die("Usage: jmuc join MUC [-p password] [-a account]");
636
637    $conn->getConnectionFromJidStr($jid)->MUCJoin(Jid      => $muc,
638                                                  Password => $password,
639                                                  History  => {
640                                                      MaxChars => 0
641                                                     });
642    return;
643}
644
645sub jmuc_part {
646    my ( $jid, $muc, @args ) = @_;
647
648    $muc = shift @args if scalar @args;
649    die("Usage: jmuc part MUC [-a account]") unless $muc;
650
651    $conn->getConnectionFromJidStr($jid)->MUCLeave(JID => $muc);
652    queue_admin_msg("$jid has left $muc.");
653}
654
655sub jmuc_invite {
656    my ( $jid, $muc, @args ) = @_;
657
658    my $invite_jid = shift @args;
659    $muc = shift @args if scalar @args;
660
661    die('Usage: jmuc invite JID [muc] [-a account]')
662      unless $muc && $invite_jid;
663
664    my $message = Net::Jabber::Message->new();
665    $message->SetTo($muc);
666    my $x = $message->NewChild('http://jabber.org/protocol/muc#user');
667    $x->AddInvite();
668    $x->GetInvite()->SetTo($invite_jid);
669    $conn->getConnectionFromJidStr($jid)->Send($message);
670    queue_admin_msg("$jid has invited $invite_jid to $muc.");
671}
672
673sub jmuc_configure {
674    my ( $jid, $muc, @args ) = @_;
675    $muc = shift @args if scalar @args;
676    die("Usage: jmuc configure [muc]") unless $muc;
677    my $iq = Net::Jabber::IQ->new();
678    $iq->SetTo($muc);
679    $iq->SetType('set');
680    my $query = $iq->NewQuery("http://jabber.org/protocol/muc#owner");
681    my $x     = $query->NewChild("jabber:x:data");
682    $x->SetType('submit');
683
684    $conn->getConnectionFromJidStr($jid)->Send($iq);
685    queue_admin_msg("Accepted default instant configuration for $muc");
686}
687
688sub jmuc_presence {
689    my ( $jid, $muc, @args ) = @_;
690
691    $muc = shift @args if scalar @args;
692    die("Usage: jmuc presence MUC") unless $muc;
693
694    my $m = $conn->getConnectionFromJidStr($jid)->FindMUC(jid => $muc);
695    die("No such muc: $muc") unless $m;
696
697    my @jids = $m->Presence();
698    BarnOwl::popless_ztext("JIDs present in " . $m->BaseJID . "\n\t" .
699                           join("\n\t", map {$_->GetResource}@jids) . "\n");
700}
701
702
703#XXX TODO: Consider merging this with jmuc and selecting off the first two args.
704sub cmd_jroster {
705    die "You are not logged in to Jabber" unless $conn->connected();
706    my $ocmd = shift;
707    my $cmd  = shift;
708    if ( !$cmd ) {
709
710        #XXX TODO: Write general usage for jroster command.
711        return;
712    }
713
714    my %jroster_commands = (
715        sub      => \&jroster_sub,
716        unsub    => \&jroster_unsub,
717        add      => \&jroster_add,
718        remove   => \&jroster_remove,
719        auth     => \&jroster_auth,
720        deauth   => \&jroster_deauth
721    );
722
723    my $func = $jroster_commands{$cmd};
724    if ( !$func ) {
725        BarnOwl::error("jroster: Unknown command: $cmd");
726        return;
727    }
728
729    {
730        local @ARGV = @_;
731        my $jid;
732        my $name;
733        my @groups;
734        my $purgeGroups;
735        my $getopt = Getopt::Long::Parser->new;
736        $getopt->configure('pass_through');
737        $getopt->getoptions(
738            'account=s' => \$jid,
739            'group=s' => \@groups,
740            'purgegroups' => \$purgeGroups,
741            'name=s' => \$name
742        );
743        $jid ||= defaultJID();
744        if ($jid) {
745            $jid = resolveJID($jid);
746            return unless $jid;
747        }
748        else {
749            BarnOwl::error('You must specify an account with -a {jid}');
750        }
751        return $func->( $jid, $name, \@groups, $purgeGroups,  @ARGV );
752    }
753}
754
755sub jroster_sub {
756    my $jid = shift;
757    my $name = shift;
758    my @groups = @{ shift() };
759    my $purgeGroups = shift;
760    my $baseJid = baseJID($jid);
761
762    my $roster = $conn->getRosterFromJidStr($jid);
763
764    # Adding lots of users with the same name is a bad idea.
765    $name = "" unless (1 == scalar(@ARGV));
766
767    my $p = new Net::XMPP::Presence;
768    $p->SetType('subscribe');
769
770    foreach my $to (@ARGV) {
771        jroster_add($jid, $name, \@groups, $purgeGroups, ($to)) unless ($roster->exists($to));
772
773        $p->SetTo($to);
774        $conn->getConnectionFromJidStr($jid)->Send($p);
775        queue_admin_msg("You ($baseJid) have requested a subscription to ($to)'s presence.");
776    }
777}
778
779sub jroster_unsub {
780    my $jid = shift;
781    my $name = shift;
782    my @groups = @{ shift() };
783    my $purgeGroups = shift;
784    my $baseJid = baseJID($jid);
785
786    my $p = new Net::XMPP::Presence;
787    $p->SetType('unsubscribe');
788    foreach my $to (@ARGV) {
789        $p->SetTo($to);
790        $conn->getConnectionFromJidStr($jid)->Send($p);
791        queue_admin_msg("You ($baseJid) have unsubscribed from ($to)'s presence.");
792    }
793}
794
795sub jroster_add {
796    my $jid = shift;
797    my $name = shift;
798    my @groups = @{ shift() };
799    my $purgeGroups = shift;
800    my $baseJid = baseJID($jid);
801
802    my $roster = $conn->getRosterFromJidStr($jid);
803
804    # Adding lots of users with the same name is a bad idea.
805    $name = "" unless (1 == scalar(@ARGV));
806
807    foreach my $to (@ARGV) {
808        my %jq  = $roster->query($to);
809        my $iq = new Net::XMPP::IQ;
810        $iq->SetType('set');
811        my $item = new XML::Stream::Node('item');
812        $iq->NewChild('jabber:iq:roster')->AddChild($item);
813
814        my %allGroups = ();
815
816        foreach my $g (@groups) {
817            $allGroups{$g} = $g;
818        }
819
820        unless ($purgeGroups) {
821            foreach my $g (@{$jq{groups}}) {
822                $allGroups{$g} = $g;
823            }
824        }
825
826        foreach my $g (keys %allGroups) {
827            $item->add_child('group')->add_cdata($g);
828        }
829
830        $item->put_attrib(jid => $to);
831        $item->put_attrib(name => $name) if $name;
832        $conn->getConnectionFromJidStr($jid)->Send($iq);
833        my $msg = "$baseJid: "
834          . ($name ? "$name ($to)" : "($to)")
835          . " is on your roster in the following groups: { "
836          . join(" , ", keys %allGroups)
837          . " }";
838        queue_admin_msg($msg);
839    }
840}
841
842sub jroster_remove {
843    my $jid = shift;
844    my $name = shift;
845    my @groups = @{ shift() };
846    my $purgeGroups = shift;
847    my $baseJid = baseJID($jid);
848
849    my $iq = new Net::XMPP::IQ;
850    $iq->SetType('set');
851    my $item = new XML::Stream::Node('item');
852    $iq->NewChild('jabber:iq:roster')->AddChild($item);
853    $item->put_attrib(subscription=> 'remove');
854    foreach my $to (@ARGV) {
855        $item->put_attrib(jid => $to);
856        $conn->getConnectionFromJidStr($jid)->Send($iq);
857        queue_admin_msg("You ($baseJid) have removed ($to) from your roster.");
858    }
859}
860
861sub jroster_auth {
862    my $jid = shift;
863    my $name = shift;
864    my @groups = @{ shift() };
865    my $purgeGroups = shift;
866    my $baseJid = baseJID($jid);
867
868    my $p = new Net::XMPP::Presence;
869    $p->SetType('subscribed');
870    foreach my $to (@ARGV) {
871        $p->SetTo($to);
872        $conn->getConnectionFromJidStr($jid)->Send($p);
873        queue_admin_msg("($to) has been subscribed to your ($baseJid) presence.");
874    }
875}
876
877sub jroster_deauth {
878    my $jid = shift;
879    my $name = shift;
880    my @groups = @{ shift() };
881    my $purgeGroups = shift;
882    my $baseJid = baseJID($jid);
883
884    my $p = new Net::XMPP::Presence;
885    $p->SetType('unsubscribed');
886    foreach my $to (@ARGV) {
887        $p->SetTo($to);
888        $conn->getConnectionFromJidStr($jid)->Send($p);
889        queue_admin_msg("($to) has been unsubscribed from your ($baseJid) presence.");
890    }
891}
892
893################################################################################
894### Owl Callbacks
895sub process_owl_jwrite {
896    my $body = shift;
897
898    my $j = new Net::XMPP::Message;
899    $body =~ s/\n\z//;
900    $j->SetMessage(
901        to   => $vars{jwrite}{to},
902        from => $vars{jwrite}{from},
903        type => $vars{jwrite}{type},
904        body => $body
905    );
906
907    $j->SetThread( $vars{jwrite}{thread} )   if ( $vars{jwrite}{thread} );
908    $j->SetSubject( $vars{jwrite}{subject} ) if ( $vars{jwrite}{subject} );
909
910    my $m = j2o( $j, { direction => 'out' } );
911    if ( $vars{jwrite}{type} ne 'groupchat' && BarnOwl::getvar('displayoutgoing') eq 'on') {
912        BarnOwl::queue_message($m);
913    }
914
915    if ($vars{jwrite}{sid} && $conn->sidExists( $vars{jwrite}{sid} )) {
916        $conn->getConnectionFromSid($vars{jwrite}{sid})->Send($j);
917    }
918    else {
919        $conn->getConnectionFromJidStr($vars{jwrite}{from})->Send($j);
920    }
921
922    delete $vars{jwrite};
923    BarnOwl::message("");   # Kludge to make the ``type your message...'' message go away
924}
925
926### XMPP Callbacks
927
928sub process_incoming_chat_message {
929    my ( $sid, $j ) = @_;
930    BarnOwl::queue_message( j2o( $j, { direction => 'in',
931                                   sid => $sid } ) );
932}
933
934sub process_incoming_error_message {
935    my ( $sid, $j ) = @_;
936    my %jhash = j2hash( $j, { direction => 'in',
937                              sid => $sid } );
938    $jhash{type} = 'admin';
939    BarnOwl::queue_message( BarnOwl::Message->new(%jhash) );
940}
941
942sub process_incoming_groupchat_message {
943    my ( $sid, $j ) = @_;
944
945    # HACK IN PROGRESS (ignoring delayed messages)
946    return if ( $j->DefinedX('jabber:x:delay') && $j->GetX('jabber:x:delay') );
947    BarnOwl::queue_message( j2o( $j, { direction => 'in',
948                                   sid => $sid } ) );
949}
950
951sub process_incoming_headline_message {
952    my ( $sid, $j ) = @_;
953    BarnOwl::queue_message( j2o( $j, { direction => 'in',
954                                   sid => $sid } ) );
955}
956
957sub process_incoming_normal_message {
958    my ( $sid, $j ) = @_;
959    my %jhash = j2hash( $j, { direction => 'in',
960                              sid => $sid } );
961
962    # XXX TODO: handle things such as MUC invites here.
963
964    #    if ($j->HasX('http://jabber.org/protocol/muc#user'))
965    #    {
966    #   my $x = $j->GetX('http://jabber.org/protocol/muc#user');
967    #   if ($x->HasChild('invite'))
968    #   {
969    #       $props
970    #   }
971    #    }
972    #
973    BarnOwl::queue_message( BarnOwl::Message->new(%jhash) );
974}
975
976sub process_muc_presence {
977    my ( $sid, $p ) = @_;
978    return unless ( $p->HasX('http://jabber.org/protocol/muc#user') );
979}
980
981
982sub process_presence_available {
983    my ( $sid, $p ) = @_;
984    my $from = $p->GetFrom();
985    my $to = $p->GetTo();
986    my $type = $p->GetType();
987    my %props = (
988        to => $to,
989        from => $from,
990        recipient => $to,
991        sender => $from,
992        type => 'jabber',
993        jtype => $p->GetType(),
994        status => $p->GetStatus(),
995        show => $p->GetShow(),
996        xml => $p->GetXML(),
997        direction => 'in');
998
999    if ($type eq '' || $type eq 'available') {
1000        $props{body} = "$from is now online. ";
1001        $props{loginout} = 'login';
1002    }
1003    else {
1004        $props{body} = "$from is now offline. ";
1005        $props{loginout} = 'logout';
1006    }
1007    $props{replysendercmd} = $props{replycmd} = "jwrite $from -i $sid";
1008#    if(BarnOwl::getvar('debug') eq 'on') {
1009        BarnOwl::queue_message(BarnOwl::Message->new(%props));
1010#    }
1011}
1012
1013sub process_presence_subscribe {
1014    my ( $sid, $p ) = @_;
1015    my $from = $p->GetFrom();
1016    my $to = $p->GetTo();
1017    my %props = (
1018        to => $to,
1019        from => $from,
1020        xml => $p->GetXML(),
1021        type => 'admin',
1022        adminheader => 'Jabber presence: subscribe',
1023        direction => 'in');
1024
1025    $props{body} = "Allow user ($from) to subscribe to your ($to) presence?\n" .
1026                   "(Answer with the `yes' or `no' commands)";
1027    $props{yescommand} = "jroster auth $from -a $to";
1028    $props{nocommand} = "jroster deauth $from -a $to";
1029    $props{question} = "true";
1030    BarnOwl::queue_message(BarnOwl::Message->new(%props));
1031}
1032
1033sub process_presence_unsubscribe {
1034    my ( $sid, $p ) = @_;
1035    my $from = $p->GetFrom();
1036    my $to = $p->GetTo();
1037    my %props = (
1038        to => $to,
1039        from => $from,
1040        xml => $p->GetXML(),
1041        type => 'admin',
1042        adminheader => 'Jabber presence: unsubscribe',
1043        direction => 'in');
1044
1045    $props{body} = "The user ($from) has been unsubscribed from your ($to) presence.\n";
1046    BarnOwl::queue_message(BarnOwl::Message->new(%props));
1047
1048    # Find a connection to reply with.
1049    foreach my $jid ($conn->getJids()) {
1050        my $cJid = new Net::XMPP::JID;
1051        $cJid->SetJID($jid);
1052        if ($to eq $cJid->GetJID('base') ||
1053            $to eq $cJid->GetJID('full')) {
1054            my $reply = $p->Reply(type=>"unsubscribed");
1055            $conn->getConnectionFromJidStr($jid)->Send($reply);
1056            return;
1057        }
1058    }
1059}
1060
1061sub process_presence_subscribed {
1062    my ( $sid, $p ) = @_;
1063    queue_admin_msg("ignoring:".$p->GetXML());
1064    # RFC 3921 says we should respond to this with a "subscribe"
1065    # but this causes a flood of sub/sub'd presence packets with
1066    # some servers, so we won't. We may want to detect this condition
1067    # later, and have per-server settings.
1068    return;
1069}
1070
1071sub process_presence_unsubscribed {
1072    my ( $sid, $p ) = @_;
1073    queue_admin_msg("ignoring:".$p->GetXML());
1074    # RFC 3921 says we should respond to this with a "subscribe"
1075    # but this causes a flood of unsub/unsub'd presence packets with
1076    # some servers, so we won't. We may want to detect this condition
1077    # later, and have per-server settings.
1078    return;
1079}
1080
1081sub process_presence_error {
1082    my ( $sid, $p ) = @_;
1083    my $code = $p->GetErrorCode();
1084    my $error = $p->GetError();
1085    BarnOwl::error("Jabber: $code $error");
1086}
1087
1088
1089### Helper functions
1090
1091sub j2hash {
1092    my $j   = shift;
1093    my %initProps = %{ shift() };
1094
1095    my $dir = 'none';
1096    my %props = ( type => 'jabber' );
1097
1098    foreach my $k (keys %initProps) {
1099        $dir = $initProps{$k} if ($k eq 'direction');
1100        $props{$k} = $initProps{$k};
1101    }
1102
1103    my $jtype = $props{jtype} = $j->GetType();
1104    my $from = $j->GetFrom('jid');
1105    my $to   = $j->GetTo('jid');
1106
1107    $props{from} = $from->GetJID('full');
1108    $props{to}   = $to->GetJID('full');
1109
1110    $props{recipient}  = $to->GetJID('base');
1111    $props{sender}     = $from->GetJID('base');
1112    $props{subject}    = $j->GetSubject() if ( $j->DefinedSubject() );
1113    $props{thread}     = $j->GetThread() if ( $j->DefinedThread() );
1114    $props{body}       = $j->GetBody() if ( $j->DefinedBody() );
1115    $props{error}      = $j->GetError() if ( $j->DefinedError() );
1116    $props{error_code} = $j->GetErrorCode() if ( $j->DefinedErrorCode() );
1117    $props{xml}        = $j->GetXML();
1118
1119    if ( $jtype eq 'chat' ) {
1120        $props{replycmd} =
1121          "jwrite " . ( ( $dir eq 'in' ) ? $props{from} : $props{to} );
1122        $props{replycmd} .=
1123          " -a " . ( ( $dir eq 'out' ) ? $props{from} : $props{to} );
1124        $props{private} = 1;
1125    }
1126    elsif ( $jtype eq 'groupchat' ) {
1127        my $nick = $props{nick} = $from->GetResource();
1128        my $room = $props{room} = $from->GetJID('base');
1129        $props{replycmd} = "jwrite -g $room";
1130        $props{replycmd} .=
1131          " -a " . ( ( $dir eq 'out' ) ? $props{from} : $props{to} );
1132
1133        $props{sender} = $nick || $room;
1134        $props{recipient} = $room;
1135
1136        if ( $props{subject} && !$props{body} ) {
1137            $props{body} =
1138              '[' . $nick . " has set the topic to: " . $props{subject} . "]";
1139        }
1140    }
1141    elsif ( $jtype eq 'normal' ) {
1142        $props{replycmd}  = undef;
1143        $props{private} = 1;
1144    }
1145    elsif ( $jtype eq 'headline' ) {
1146        $props{replycmd} = undef;
1147    }
1148    elsif ( $jtype eq 'error' ) {
1149        $props{replycmd} = undef;
1150        $props{body}     = "Error "
1151          . $props{error_code}
1152          . " sending to "
1153          . $props{from} . "\n"
1154          . $props{error};
1155    }
1156
1157    $props{replysendercmd} = $props{replycmd};
1158    return %props;
1159}
1160
1161sub j2o {
1162    return BarnOwl::Message->new( j2hash(@_) );
1163}
1164
1165sub queue_admin_msg {
1166    my $err = shift;
1167    my $m   = BarnOwl::Message->new(
1168        type      => 'admin',
1169        direction => 'none',
1170        body      => $err
1171    );
1172    BarnOwl::queue_message($m);
1173}
1174
1175sub boldify($) {
1176    my $str = shift;
1177
1178    return '@b(' . $str . ')' if ( $str !~ /\)/ );
1179    return '@b<' . $str . '>' if ( $str !~ /\>/ );
1180    return '@b{' . $str . '}' if ( $str !~ /\}/ );
1181    return '@b[' . $str . ']' if ( $str !~ /\]/ );
1182
1183    my $txt = "$str";
1184    $txt =~ s{[)]}{)\@b[)]\@b(}g;
1185    return '@b(' . $txt . ')';
1186}
1187
1188sub getServerFromJID {
1189    my $jid = shift;
1190    my $res = new Net::DNS::Resolver;
1191    my $packet =
1192      $res->search( '_xmpp-client._tcp.' . $jid->GetServer(), 'srv' );
1193
1194    if ($packet)    # Got srv record.
1195    {
1196        my @answer = $packet->answer;
1197        return $answer[0]{target}, $answer[0]{port};
1198    }
1199
1200    return $jid->GetServer(), 5222;
1201}
1202
1203sub defaultJID {
1204    return ( $conn->getJids() )[0] if ( $conn->connected() == 1 );
1205    return;
1206}
1207
1208sub baseJID {
1209    my $givenJidStr = shift;
1210    my $givenJid    = new Net::XMPP::JID;
1211    $givenJid->SetJID($givenJidStr);
1212    return $givenJid->GetJID('base');
1213}
1214
1215sub resolveJID {
1216    my $givenJidStr = shift;
1217    my $givenJid    = new Net::XMPP::JID;
1218    $givenJid->SetJID($givenJidStr);
1219
1220    # Account fully specified.
1221    if ( $givenJid->GetResource() ) {
1222        # Specified account exists
1223        return $givenJidStr if ($conn->jidExists($givenJidStr) );
1224        BarnOwl::error("Invalid account: $givenJidStr");
1225    }
1226
1227    # Disambiguate.
1228    else {
1229        my $matchingJid = "";
1230        my $errStr =
1231          "Ambiguous account reference. Please specify a resource.\n";
1232        my $ambiguous = 0;
1233
1234        foreach my $jid ( $conn->getJids() ) {
1235            my $cJid = new Net::XMPP::JID;
1236            $cJid->SetJID($jid);
1237            if ( $givenJidStr eq $cJid->GetJID('base') ) {
1238                $ambiguous = 1 if ( $matchingJid ne "" );
1239                $matchingJid = $jid;
1240                $errStr .= "\t$jid\n";
1241            }
1242        }
1243
1244        # Need further disambiguation.
1245        if ($ambiguous) {
1246            queue_admin_msg($errStr);
1247        }
1248
1249        # Not one of ours.
1250        elsif ( $matchingJid eq "" ) {
1251            BarnOwl::error("Invalid account: $givenJidStr");
1252        }
1253
1254        # It's this one.
1255        else {
1256            return $matchingJid;
1257        }
1258    }
1259    return "";
1260}
1261
1262#####################################################################
1263#####################################################################
1264
1265package BarnOwl::Message::Jabber;
1266
1267our @ISA = qw( BarnOwl::Message );
1268
1269sub jtype { shift->{jtype} };
1270sub from { shift->{from} };
1271sub to { shift->{to} };
1272sub room { shift->{room} };
1273
1274sub smartfilter {
1275    my $self = shift;
1276    my $inst = shift;
1277
1278    my ($filter, $ftext);
1279
1280    if($self->jtype eq 'chat') {
1281        my $user;
1282        if($self->direction eq 'in') {
1283            $user = $self->from;
1284        } else {
1285            $user = $self->to;
1286        }
1287        $user = Net::Jabber::JID->new($user)->GetJID($inst ? 'full' : 'base');
1288        $filter = "jabber-user-$user";
1289        $ftext = qq{type ^jabber\$ and ( ( direction ^in\$ and from ^$user ) } .
1290                 qq{or ( direction ^out\$ and to ^$user ) ) };
1291        BarnOwl::filter("$filter $ftext");
1292        return $filter;
1293    } elsif ($self->jtype eq 'groupchat') {
1294        my $room = $self->room;
1295        $filter = "jabber-room-$room";
1296        $ftext = qq{type ^jabber\$ and room ^$room\$};
1297        BarnOwl::filter("$filter $ftext");
1298        return $filter;
1299    }
1300}
1301
13021;
Note: See TracBrowser for help on using the repository browser.