perl/lib/Thrasher/Test.pm

   1 package Thrasher::Test;
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME
   8
   9 Thrasher::Test - repeated code in the test cases
  10
  11 =head1 DESCRIPTION
  12
  13 Thrasher::Test contains code that repeatedly came up in the test code.
  14 This module is never use'd in a production install.
  15
  16 =cut
  17
  18 use Test::More;
  19 use Test::Deep;
  20 use Data::Dumper;
  21 use MIME::Base64 qw(decode_base64 encode_base64);
  22 use Digest::SHA1 qw(sha1_hex);
  23 use Image::Magick;
  24
  25 use Thrasher::Log;
  26
  27 BEGIN {
  28     use_ok 'Thrasher::Protocol::Test';
  29     use_ok 'Thrasher::Backend::Test';
  30 }
  31
  32 $Thrasher::TESTING = 1;
  33
  34 use Digest::SHA1 qw(sha1_hex);
  35
  36 use base qw(Exporter);
  37 our @ISA = qw(Exporter);
  38
  39 our @EXPORT_OK = qw(clear output clear_log logged transport_jid
  40                     new_component send_server_stream show_log
  41                     accepted_handshake connected_component
  42                     clean_xml get_registered_comp logged_in_comp
  43                     dies get_mysql_username_password
  44                     rand_string
  45
  46                     $small_png $small_png_base64
  47                     $small_gif $small_gif_base64
  48                     $small_gif_png_base64
  49                     $small_gif_png_sha1
  50                     $small_gif_png_len
  51                     $binary_garbage
  52                     );
  53 our %EXPORT_TAGS = (all => \@EXPORT_OK);
  54
  55 my $JID = 'test.transport';
  56
  57 sub transport_jid { $JID }
  58
  59 my @accum;
  60 my $output = sub {
  61     push @accum, @_;
  62 };
  63
  64 sub clear {
  65     @accum = ();
  66 }
  67
  68 sub output {
  69     my $output = join '', @accum;
  70     clear;
  71     return $output;
  72 }
  73
  74 my @log_entries;
  75 sub logger {
  76     push @log_entries, @_;
  77 }
  78 $Thrasher::Log::logger_sub = \&logger;
  79
  80 sub clear_log {
  81     @log_entries = ();
  82 }
  83
  84 sub logged {
  85     my $test = shift;
  86     my $name = shift;
  87     for my $log_entry (@log_entries) {
  88         if ($log_entry =~ /$test/) {
  89             pass($name);
  90             clear_log;
  91             return;
  92         }
  93     }
  94     fail($name);
  95     clear_log;
  96 }
  97
  98 sub show_log {
  99     print Dumper(\@log_entries);
 100 }
 101
 102 #END {
 103 #    show_log();
 104 #}
 105
 106 sub new_component {
 107     my $preregistered_accounts = shift || {};
 108
 109     clear;
 110
 111     my $test_backend =
 112         new Thrasher::Backend::Test({registered => $preregistered_accounts});
 113     my $test_protocol = new Thrasher::Protocol::Test({}, $test_backend);
 114     my $comp = new Thrasher::Component
 115         ($test_protocol, $output, 'secret', $JID);
 116
 117     is(ref($comp), 'Thrasher::Component',
 118        'get a component as expected');
 119
 120     $comp->output_initial_stream_tag();
 121     $test_protocol->{component} = $comp;
 122
 123     cmp_deeply(\@accum,
 124                ["<stream:stream to=\'$JID\' xmlns=\'jabber:component:accept\' xmlns:stream=\'http://etherx.jabber.org/streams\'>"],
 125                'stream open tag accumulated');
 126
 127     clear;
 128
 129     return $comp;
 130 }
 131
 132 sub send_server_stream {
 133     my $comp = shift;
 134     $comp->xml_in(<<STREAM);
 135 <?xml version='1.0'?>
 136 <stream:stream
 137   xmlns:stream='http://etherx.jabber.org/streams'
 138   xmlns='jabber:component:accept'
 139   id='4152762083'
 140   from='ni.cuda.ims'>
 141 STREAM
 142
 143     cmp_deeply(\@accum,
 144                ['<handshake>', sha1_hex('4152762083'.'secret'),
 145                 '</handshake>'],
 146                'hands all properly shaken');
 147
 148     @accum = ();
 149 }
 150
 151 sub accepted_handshake {
 152     my $comp = shift;
 153     $comp->xml_in('<handshake/>');
 154 }
 155
 156 # This is a connected component that is ready to process actual
 157 # events.
 158 sub connected_component {
 159     my $comp = new_component;
 160     send_server_stream($comp);
 161     accepted_handshake($comp);
 162
 163     is($comp->{state}, 'connected', 'component connected');
 164
 165     return $comp;
 166 }
 167
 168 # This allows me to write nicely formatted XML in this file,
 169 # and strips it down to what we expect in output.
 170 sub clean_xml {
 171     my $s = shift;
 172     $s =~ s/ +$//gm;
 173     $s =~ s/^ +//gm;
 174     $s =~ s/\n/ /gm;
 175
 176     # Don't separate tags with spaces. Hacky, but OK for testing.
 177     $s =~ s/\> +\</></gm;
 178     # Clean up the last newline which went to a space
 179     $s =~ s/ +$//s;
 180     return $s;
 181 }
 182
 183 # FIXME: Test that first connection after registration!
 184
 185 sub get_registered_comp {
 186     # Reset counters used for generating unique IDs.
 187     $Thrasher::Component::id = 1;
 188     $Thrasher::XMPPStreamOut::namespace_index = 0;
 189
 190     my $comp = connected_component;
 191
 192     # Romeo gets registered.
 193     $comp->{protocol}->registration('romeo@montague.lit',
 194                                     {username => 'RomeoMyRomeo',
 195                                      password => 'ILoveJuliet'});
 196
 197     # A user that will error out if they login
 198     # HACK HACK HACK for testing
 199     Thrasher::Protocol::registration
 200         ($comp->{protocol}, 'juliet@capulet.lit',
 201          {username => 'fail',
 202           password => 'remote_server_timeout'});
 203     return $comp;
 204 }
 205
 206 # Return a component with a logged in Romeo.
 207 sub logged_in_comp {
 208     my $comp = get_registered_comp;
 209     $comp->xml_in(<<LOGIN);
 210 <presence from='romeo\@montague.lit/orchard'
 211           to='$JID'/>
 212 LOGIN
 213
 214     # this is Psi's disco reply
 215     my $expected_id = $Thrasher::Component::id - 1;
 216     clear;
 217     $comp->xml_in(<<CLIENT_DISCO_REPLY);
 218 <iq from='romeo\@montague.lit'
 219     to='$JID'
 220     id='id$expected_id'
 221     type='result'>
 222     <query xmlns='http://jabber.org/protocol/disco#info'>
 223         <identity category='pubsub' type='pep'/>
 224         <feature var='vcard-temp'/>
 225         <feature var='http://jabber.org/protocol/commands'/>
 226     </query>
 227 </iq>
 228 CLIENT_DISCO_REPLY
 229
 230     my $session = $comp->session_for('romeo@montague.lit');
 231     cmp_deeply($session->{client_identities},
 232                [['pep', 'pubsub', undef]]);
 233     cmp_deeply($session->{client_features},
 234                {'vcard-temp' => 1,
 235                 'http://jabber.org/protocol/commands' => 1},
 236                'discovery worked correctly');
 237
 238     return $comp;
 239 }
 240
 241 sub dies (&;$$) {
 242     eval 'use Test::More;';
 243     my $code = shift;
 244     my $check = '';
 245     if (@_ == 2) {
 246         $check = shift;
 247     }
 248     my $name = shift;
 249
 250     {
 251         local $@ = '';
 252         eval { $code->(); };
 253
 254         if (!$@) {
 255             fail($name);
 256             return;
 257         }
 258
 259         my $die_message = $@ . '';
 260         if ($check) {
 261             if (ref($check) eq 'Regexp') {
 262                 if ($die_message !~ /$check/) {
 263                     fail($name . " (regex $check not in '$die_message')");
 264                 }
 265             } else {
 266                 if (index($die_message, $check) == -1) {
 267                     fail($name . " (string $check not in $die_message)");
 268                 }
 269             }
 270         }
 271     }
 272
 273     pass($name);
 274 }
 275
 276 # This opens a file (implicitly in the test directory) to get the
 277 # username and password to connect to MySQL with. This file is
 278 # .gitignored so you shouldn't accidentally commit it.
 279 # This assumes localhost for testing; if that's a problem, add
 280 # more lines in for port, etc.
 281 sub get_mysql_username_password {
 282     my $fh;
 283     if (!(open $fh, '<', 'mysql_innodb_password')) {
 284         if (!(open $fh, '<', '../mysql_innodb_password')) {
 285             die "Can't locate mysql_innodb_password in this directory "
 286                 ."or parent. Create a file called "
 287                 ."'mysql_innodb_password', where the first line is "
 288                 ."the user account, and the second is the password";
 289         }
 290     }
 291     my $username = <$fh>;
 292     chomp($username);
 293     my $password = <$fh>;
 294     chomp($password);
 295     close $fh;
 296     return ($username, $password);
 297 }
 298
 299 ### TEST DATA
 300
 301 our $small_png_base64 = <<'SMALL_PNG';
 302 iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsOAAALDgFAvuFBAAAA
 303 B3RJTUUH0wkJFSIsp+GiggAAAAZiS0dEAP8A/wD/oL2nkwAAAnJJREFUOI11Ut1LU2EYP1chEUF3
 304 dRNB/8HZzoee7bhW0ZSmBl5ERaE0qagkEYwVIhHUhR9DC7KbkMIiCIpCzD6uKtCtqZllNkPc2Zru
 305 aHZcsvTQr/c5OreZPfDjPe9znt/z9f44bgMbtkkFg7zofM+LVSFeqA7yYvErsXDzRrHriVs+2KTr
 306 n3lxXrPLmDxUicjR49AEGR+Zb8AmdvZJys7/kbeP2KSxeKkXvx48RFqLYdkwLCwldcw/fwHt8DGE
 307 eSHZo6iuPPIQL1LlMd13CqnRT0hPTW2IxYlviPkvUxK9W92zYy0Bm7c5VlqGn2/eYXF8HCarmgqH
 308 85DxL4RCiLKx3trlTp/Pt4ljSyqg+fRAB+Z6+7A0OwsyOulOMPqDyJjRPwDt1m2M8OJCwFOyixI4
 309 J2UHprvuYuZet4XfiYQVTOePvpdrZP3xE6RLvIDiQpQt+WmR8wglqJpi7cda2hAPtCPefsNCOqoh
 310 14yOm1isqAQcbgYXkpKCXkVtpATVsX0eJM7XYbr+Imb8jTBqTiN9qTHLDg8CTncWLElScqDHUdzE
 311 kUiiQiGWDxxcg1nfkE/OTaLuBVz7LW08crpOcqQwWqLp8cJko5gN/iz53IUV0mqSP0PDMD2sAItl
 312 S0xdLa+wWc/IFNaqMfJczRksjX2xgo3mNuueQa6fYl9LRffZM65ogclzW8guRSbP1iLedAX6nS7r
 313 XA/yU0zQLkWvlVUolg4y9kxRd4cEeeIrU+P3lgASrfkgH/0LCnK0zVteyshbufVG8iSFDaruhdET
 314 VYjU1lmgb+ZLUdurlf8lZ4zaIoWRSOid6alo27QwmjmvbWZ/AQkpPzEuxY62AAAAAElFTkSuQmCC
 315 SMALL_PNG
 316
 317 our $small_png = decode_base64($small_png_base64);
 318
 319 our $small_gif_base64 = <<'SMALL_GIF';
 320 R0lGODdhLAA3AMQAAP///wgICBAQEBgYGCEhISkpKTExMTk5OUJCQkpKSlJSUlpaWmNjY2tra3Nz
 321 c3t7e4SEhIyMjJSUlJycnKWlpa2trbW1tb29vcbGxs7OztbW1t7e3ufn5+/v7/f39wAAACwAAAAA
 322 LAA3AAAF/yAgjmRpniIXLQzloXAcV8Nnf8cm73sW3LfDi0c0LYDASnEp8hCQtwZz6RFAbdJpMXH9
 323 TLTFyw8pBBcxCWtg0OhoK46HfA55QO6QCGbo2ehEGxlMEl1XAwgLDnUOCwcCAYJLFAWFlUgFQ0Ue
 324 GBAJNZaFD2YeGRMNCQRjoB8CfzEUEW4wfRcSqpUOOweMDhISCQmuJYSgA7IoGwcAHhYTFxsMBQ8W
 325 FZkiBqsUMQ5ZJRoWBgQmFqsKMBIIHCgcAUolHpSWA9YiGQwQxyYKyicOq5EjKBC4MOODBhTkQH0Z
 326 seFDgw0YUGgQIAFGQ1CiRvyy8ODQhAkMHqjbMIBBjCqgTP+e6BBBggZmDSAU6IbCw6dKCTBQ+Pix
 327 Qs8KPmEdAkqBQoWD7xAUKECgqdMBUAcoYLDLASMB3BosYNMgDoGpDKiaA/NAAU8IAyR8hEBA7UcC
 328 D3ZSWEBzBNC7QC3otXDhWYQC3BwwENCgsAKuYQfQLVwAgokMqxaYGuHBAMMEJA4caxDBxITIFcYC
 329 6IBJBAYEIzoYOLbAHYkGqxigoWxAHYAMqJsUOIaAYAlsGJORqF0v92h+14QBYLdKQgcCLBYsEDB1
 330 gaewDKYXbsCAAL0Kqz5cgBdhAgUJ0tQ6KOBLwgMCEeI7MEDvwSoB6hC4SoA0A2YRGojmnwlcgGIZ
 331 AAlYMEL/Tqb9B8AFDs71jhVIGHDLB/8toI0IDAIwmwgXiBZBXRhAIYAGTwAxVkwetJiACx5cgMAL
 332 HkgoglXDQCFKgTeohNYBQApQAJAGCIDAAUoNkAACniw0whFAGAOAfUDkAsAKfmyQQAQabEDBARpk
 333 oEFZGZSJgGsipHhDRQCAB4RjAID05IYfXmklgr4BeMkQF60pggWiMcBmnRBYWZkwFCCxoQjx2ECn
 334 gw505qGDcuiWD2w30EcClDa4s4EBYmqQyAYafOkHB11xwAEGZYwAnA0KkhABEBGNNoABuEKFKwEC
 335 GLCUALcyZdxyqjg4wgVARHJoiw840CKELXrAWYsTLECCvps21EpCB2ME4AoCSDULooMtiCABTVR+
 336 YO0JB9gQwDEKxFooiKJpKIK4IyDgLlImMGCDAJm0Zq6VGNTrG2epUajSCcSUJoJWRVFVAQUPGHCX
 337 AdNUcOax/9p2QokfHCiCTNKFIx0Cikl3iAKHaUtlRihw+8GwEVhZgUoXrItgJGAu+IGUMTxhrJwP
 338 joWBzulcw1s7OzgQwKIAgAPUAwVMbYBeFAxAgQWTZBImER6nwADLCkhHNjAKJMByAneaEQIAOw==
 339 SMALL_GIF
 340
 341 our $small_gif = decode_base64($small_gif_base64);
 342
 343 # We have to compute this, since different Image::Magicks may
 344 # create different PNGs.
 345 my $small_gif_image = new Image::Magick;
 346 $small_gif_image->BlobToImage(decode_base64($small_gif_base64));
 347 $small_gif_image->Set(magick => 'PNG');
 348
 349 our $small_gif_png = $small_gif_image->ImageToBlob;
 350
 351 our $small_gif_png_base64 = encode_base64($small_gif_png);
 352 our $small_gif_png_len = length($small_gif_png);
 353
 354 our $small_gif_png_sha1 = sha1_hex($small_gif_png);
 355
 356 our $binary_garbage = <<'XML_HUNK';
 357 <presence from='test.transport'
 358           to='test\@test.com'>
 359     <c hash='sha-1'
 360        node='http://developer.berlios.de/projects/thrasher/'
 361        ver='AgYmsFJ/8ZcNIfFSst43VBp9Qec'
 362        xmlns='http://jabber.org/protocol/caps'/>
 363 o</presence>
 364 XML_HUNK
 365
 366 sub rand_string {
 367     my ($length, $chars) = @_;
 368
 369     my $s = '';
 370     for (1 .. $length) {
 371         $s .= $chars->[int(rand(scalar(@{$chars})))];
 372     }
 373     return $s;
 374 }
 375
 376 1;