perl/lib/Thrasher/Protocol/Test.pm

   1 package Thrasher::Protocol::Test;
   2 use strict;
   3 use warnings;
   4
   5 =head1 NAME
   6
   7 Thrasher::Protocol::Test - test protocol for Thrasher Bird
   8
   9 =head1 DESCRIPTION
  10
  11 This is a test protocol; it is specifically designed to be used in
  12 the unit tests. The primary difference is that it simply records
  13 interactions with the protocol, so the interactions can be tested,
  14 rather than actually performing any actions.
  15
  16 =cut
  17
  18 use base 'Thrasher::Protocol';
  19
  20 use Thrasher::Log qw(log debug);
  21 use Thrasher::Session;
  22 use Thrasher::XML qw(extract save save_sub);
  23
  24 use MIME::Base64 qw(decode_base64);
  25
  26 use Data::Dumper;
  27 use Carp qw(confess);
  28
  29 my $avatar1 = decode_base64(<<AVATAR1);
  30 iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA
  31 BGdBTUEAALGOfPtRkwAAACBjSFJNAAB6JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VG
  32 AAADBUlEQVR42mLctX/X/lt8dxkuvbvMoPRS/kJFTHkhAx4AUv+V77vDkWdHGWTeSDEABBDTfw4G
  33 h4NGxxxmuSxyuC/20ICBAGDkY2I4bnSGoddnGsMT4WcMAAHEBJNg/v2fgfHvfwZiwHsgZIKqBwgg
  34 FrCp/xgYWL7/Z2D6C1HwcnmGAJuogAGnjAgDIwvLA3aVggcoJkDVg/QBBBATA9BSpl//IQJ/oAp+
  35 /VwvoCiwn12Ibz8zJ8v9z4cq9j+ZFuMA0//79w+4AQABBHYBM8iAbwgv/P707QMDhxDQZG4G5r/f
  36 GHjE2RxYvrA73K9wOPDowxsB4d/8DKwgA4AuBggglp/v3kIMQPLC96fvJn579CaAS/ATA8OHFwwM
  37 f/8wcHCxMyhYSzuw7ZrAwPToKwOLOcgF/xkAAojlwqIlDBwT9jOYuPxl4BWEuEC1Y/eBu0yMC+Rd
  38 VBOYv31meHz25YNPD94uZPj3j4FVQSY/askRgS/rfzOwezMwAAQAQQC+/wG0vrP/xeOcACyQsQA7
  39 MSMABSossPPj8MHz0t3gGC8YrxwvFADr3PAA4MXkITbA5OCvva6/yxm6QMeqmwAs1zcAAoiJiZGJ
  40 4ZkpI0NDHTPDhue/GBjOHwlQ12Hr10uzWy9hpQGMs/cMonw/Gf5//FgPch0nByfDB+YvDPesGBj4
  41 PCwZAAKIiYWVBRwL/xj/MzwO9TywZtfbwKPzD3z4v387A8uJvQwML54xMLx9zcAm8C8AZAArCysD
  42 229meCwABBATUB8D9x92eKjmv2bYcPjmb8W52z5MuPj4H8NfRmZgqP5g4DVTFwCnGZAr/rLDDQAI
  43 IJZ/wJBkArqc6SciFVa+ZfjAwPC/sHTPy4la1mr5ovJqAd9e/twAjuJfvxmYgemXGageZBhAALGw
  44 MDMzfPz8ioERSyrufs/wgGHLLWDmugXPYMxMTAwfv7wC2w4CAAHExMrBwnD55UkGYgEbByvDmecH
  45 wez/QEsBAojl/t0HDD4/s8Ac4f+ShDPSk88XEj53wPkAAQYAlD41GOhA6JcAAAAASUVORK5CYII=
  46 AVATAR1
  47
  48 my $avatar2 = decode_base64(<<AVATAR2);
  49 iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsSAAALEgHS3X78AAAA
  50 BGdBTUEAALGOfPtRkwAAACBjSFJNAAB6JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VG
  51 AAABsUlEQVR42mL8//8/AyUAIIAYcUmsC2boB1IFUO6EoLUMhdjUAQQQLs0OQPz/w5WC/+9PGvwH
  52 sUFi2NQCBBATDkPmawYnMLy5MIHh7Y0LDGq2EDFsCgECiAmL7Q1cYgoK/BIPGC6tZ2C4tImBQVCa
  53 gYGTj0EBJIeuHiCAmNA0KwCpfL2oAAZWpgNwcTYOBgYdJzAzH6oGDgACCN0F/SLaDgKSahsYGP4h
  54 iQLZMpoMDEJSDAIgNcgaAAKICTnggFSAcQLQgj8PGBiQY/c/xBBjdzAvADlAAQKICT3guLiBtv9l
  55 wHABCPPwMzComwugBChAADEhB5yyA9Dmvx8gGrC4AIRVtD4wcAoIwAMUIIAYoYFy3jg9QUBOfwED
  56 wy8g7zcE3z3EAHaNsiFCDIQfXAZqOMYAtInBECCAQC6oBwWcnMkBuC0g/O0dA8OdE0B8Csh+z4Ai
  57 J68CDFARcIDWAwQQyIAETT8BSMChGfANaMe3jxAaWY4R6CVdfbDnEgACiAVE/v4uwPDnG6ozuYEB
  58 Jq8P8YKAKND876jynz9AggcggBihgVFPZmZsBAggRkqzM0CAAQCgU5LNtkF1hAAAAABJRU5ErkJg
  59 gg==
  60 AVATAR2
  61
  62 my $avatar3 = decode_base64(<<AVATAR3);
  63 iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0RVh0
  64 U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAHESURBVDjL1ZNPSJNxHMY/v9/7823Lbcxp
  65 y2bpAsEsWWBCW130YLeYEEYEYUUgWkSHEgm6BEGwQ9Qp6FzQ/6CIboHHEoPAWDcHzrFXF5iw6bu9
  66 77dD9OdYeIgeeC7P4Tk8f5SIsBloNol/b8D5jEV3GOIG2pug3f7FFg2pNoup4c7e989Pv6nkx51r
  67 EwfuNltW4qfBZFqTMNAMhH9jiO9ati92+PPMqcL68ojUS71SLyflUa5jNhIw+wDUhYwOlv2OIy6B
  68 ECI+CkDwBWnytLpyee90+oROsTgHXxch7kFgC5fOyrPbj90xc2ho4Obxq+cuKkuBVPGrRUxjiUZl
  69 CRoak1TwJQ++A0GP+/d04eN8vTh40GTuPKFHv5wtl+u1ItpaASljWjXLTgWz08b01IA8bCyA1MAC
  70 27RILNLvKhPVQEQBZnRox3VjWQNof+1Ydnc6d2tuZn9fOGTbja0nR9b7M0erUSqACwRDEI4yNel8
  71 yD1wz/zI0gY6ge02DAJ7gFZgW6rLjH16bValpERKiCwgD2+wEgnoaSCm/qTqZJvJjg6riV1xr+vd
  72 vFV8+tZ7VfP8F0BB/cVkokAC2AAcYA1A/f9n+gbO0Zmbd9Cq1QAAAABJRU5ErkJggg==
  73 AVATAR3
  74
  75 my @avatars = ($avatar1, $avatar2, $avatar3);
  76
  77 sub registration {
  78     my $self = shift;
  79     my $jid = shift;
  80     my $registration_info = shift;
  81
  82     # As a special case, if the registration info's username is
  83     # "fail", we return an error given by $registration_info->{password}.
  84     no warnings 'uninitialized';
  85     if ($registration_info->{username} eq 'fail') {
  86         return 0, $registration_info->{password};
  87     } else {
  88         return $self->SUPER::registration($jid, $registration_info);
  89     }
  90 }
  91
  92 sub name { 'Test' }
  93
  94 sub identifier { 'aim' }
  95
  96 sub create_login_session {
  97     my $self = shift;
  98     my $continuation = shift;
  99     my $registration_info = shift;
 100     my $full_jid = shift;
 101     my $component = shift;
 102
 103     # Magic: If the username is "fail", we'll give the
 104     # error indicated by "password".
 105     if ($registration_info->{username} eq 'fail') {
 106         $continuation->($registration_info->{password});
 107     } else {
 108         # FIXME: Check for existing logins.
 109         my $session = new Thrasher::Session($full_jid, $component,
 110                                             $self,
 111                                             $registration_info->{username});
 112
 113         $self->set_session_state($session, 'logging in');
 114
 115         $continuation->($session);
 116     }
 117 }
 118
 119 sub initial_login {
 120     my $self = shift;
 121     my $session = shift;
 122
 123     push @{$self->{logged_in}}, $session;
 124
 125     $self->SUPER::initial_login($session);
 126 }
 127
 128 sub subscribe {
 129     my $self = shift;
 130     my $session = shift;
 131     my $target_name = shift;
 132     my $continuation = shift;
 133
 134     # Per our usual magic, if the target name contains the string
 135     # "fail", we'll report failure. Otherwise, we report success.
 136     if ($target_name =~ /fail/) {
 137         $continuation->(0);
 138     } else {
 139         $session->{subscribed}->{$target_name} = 1;
 140         $continuation->(1);
 141     }
 142 }
 143
 144 sub unsubscribe {
 145     my $self = shift;
 146     my $session = shift;
 147     my $target_name = shift;
 148     my $continuation = shift;
 149
 150     if (!(delete $session->{subscribed}->{$target_name})) {
 151         print STDERR "Warning, removing nonexistant contact\n";
 152     }
 153     $continuation->();
 154 }
 155
 156 sub logout {
 157     my $self = shift;
 158     my ($session, $continuation) = @_;
 159
 160     $continuation->($session);
 161     return $self->SUPER::logout(@_);
 162 }
 163
 164 # FIXME: Updating the avatar should not make a person go online.
 165 sub send_message {
 166     my $self = shift;
 167     my $session = shift;
 168     my $to = shift;
 169     my $body_text = shift;
 170     my $type = shift;
 171     my $error_sub = shift;
 172     my $chatstate = shift;
 173
 174     if (my ($error) = ($body_text =~ /^Error: ([a-z_]+)/)) {
 175         $error_sub->($error);
 176         return;
 177     }
 178
 179     # Record a message was sent
 180     my $message = [$to, $body_text, $type];
 181     push(@{$session->{messages}}, $message);
 182
 183     my $from = $session->{jid};
 184
 185     debug("Message From: $from, To: $to, body: $body_text\n");
 186
 187     if ($body_text =~ /^Tell me: (.*)$/) {
 188         my $target_jid = $self->{backend}->legacy_name_to_jid
 189             (Thrasher::Component::strip_resource($from),
 190              $to, $session->{component}->{component_name}, 'en');
 191         print "Sending message from $target_jid to $from\n";
 192         $session->{component}->send_message($target_jid, $from, $1);
 193     }
 194
 195     if ($body_text =~ /^avatar (\d)/) {
 196         my $avatar = $avatars[$1];
 197         if (!$avatar) { return; }
 198         log("Changing avatar for $session->{jid}");
 199
 200         my $to_jid = $self->{backend}->legacy_name_to_jid
 201             ($from, $to, $session->{component}->{component_name});
 202
 203         Thrasher::Avatar::set_avatar
 204             ($session->{component}, $session->{jid}, $to_jid, $avatar);
 205     }
 206
 207     if ($body_text =~ /^presence ([^ ]+) ([^ ]+) (.*)$/) {
 208         my $type = $1;
 209         $type = '' if $type eq 'online';
 210         my $show = $2;
 211         my $status = $3;
 212         $self->legacy_presence_update($session, $to, $type, $show, $status);
 213     }
 214
 215     return undef;
 216 }
 217
 218 sub outgoing_chatstate {
 219     my ($self, $session, $to, $chatstate) = @_;
 220     if ($session->{'chatstates'}) {
 221         push(@{$session->{'chatstates'}}, $chatstate);
 222     }
 223     return;
 224 }
 225
 226 sub subscribed {
 227     my $self = shift;
 228     my $session = shift;
 229     my $component = shift;
 230     my $legacy_username = shift;
 231
 232     print Dumper($session->{jid}, $legacy_username);
 233
 234     $session->{subscribed}->{$legacy_username} = 'subscribed';
 235
 236     $component->send_presence($session->{jid}, $legacy_username,
 237                                       'subscribed');
 238
 239     my $jid = $self->{backend}->legacy_name_to_jid
 240         ($session->{jid}, $legacy_username,
 241          $component->{component_name}, 'en');
 242
 243     $component->{protocol}->{backend}->set_roster_user_state
 244         ($session->{jid}, $jid,
 245          $component->{protocol}->{backend}->subscribed);
 246
 247     # Lie that the user is currently online
 248     $component->send_presence($session->{jid},
 249                               $legacy_username,
 250                               undef, 'Online');
 251 }
 252
 253 sub unsubscribed {
 254     my $self = shift;
 255     my $session = shift;
 256     my $component = shift;
 257     my $legacy_username = shift;
 258
 259     if (!defined($legacy_username)) {
 260         confess "Unsubscribing an undef user; shouldn't be called.";
 261     }
 262
 263     $component->{protocol}->{backend}->set_roster_user_state
 264         ($session->{jid}, $legacy_username,
 265          $component->{protocol}->{backend}->unsubscribed);
 266
 267     $session->{subscribed}->{$legacy_username} = 'unsubscribed';
 268 }
 269
 270 sub gateway_prompt {
 271     my $self = shift;
 272     my $lang = shift;
 273
 274     return "Prompt" . ($lang ? " $lang" : "");
 275 }
 276
 277 sub gateway_desc {
 278     my $self = shift;
 279     # allows testing that returning undef is permitted
 280     return $self->{gateway_desc};
 281 }
 282
 283 sub user_presence_update {
 284     my $self = shift;
 285     my $session = shift;
 286     my $type = shift || '';
 287     my $show = shift || '';
 288     my $status = shift || '';
 289
 290     push(@{$self->{presence_update}},
 291          [$session->{jid}, $type, $show, $status]);
 292
 293     log "User presence update: type: $type, show: $show, status: $status";
 294 }
 295
 296 sub user_targeted_presence_update {
 297     my $self = shift;
 298     my $session = shift;
 299     my $type = shift || '';
 300     my $show = shift || '';
 301     my $status = shift || '';
 302     my $target_user = shift || '';
 303
 304     push(@{$self->{targeted_presence_update}},
 305          [$session->{jid}, $type, $show, $status, $target_user]);
 306
 307     log "User presence update to $target_user: type: $type, show: $show, status: $status";
 308 }
 309
 310 1;