git.m6w6.name Git - awesomized/libmemcached/blob - memcached/t/binary-sasl.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Cwd;
   6 use FindBin qw($Bin);
   7 use lib "$Bin/lib";
   8 use MemcachedTest;
   9
  10 my $supports_sasl = supports_sasl();
  11
  12 use Test::More;
  13
  14 if (supports_sasl()) {
  15     if ($ENV{'RUN_SASL_TESTS'}) {
  16         plan tests => 25;
  17     } else {
  18         plan skip_all => 'Skipping SASL tests';
  19         exit 0;
  20     }
  21 } else {
  22     plan tests => 1;
  23     eval {
  24         my $server = new_memcached("-S");
  25     };
  26     ok($@, "Died with illegal -S args when SASL is not supported.");
  27     exit 0;
  28 }
  29
  30 eval {
  31     my $server = new_memcached("-S -B auto");
  32 };
  33 ok($@, "SASL shouldn't be used with protocol auto negotiate");
  34
  35 eval {
  36     my $server = new_memcached("-S -B ascii");
  37 };
  38 ok($@, "SASL isn't implemented in the ascii protocol");
  39
  40 eval {
  41     my $server = new_memcached("-S -B binary -B ascii");
  42 };
  43 ok($@, "SASL isn't implemented in the ascii protocol");
  44
  45 # Based almost 100% off testClient.py which is:
  46 # Copyright (c) 2007  Dustin Sallings <dustin@spy.net>
  47
  48 # Command constants
  49 use constant CMD_GET        => 0x00;
  50 use constant CMD_SET        => 0x01;
  51 use constant CMD_ADD        => 0x02;
  52 use constant CMD_REPLACE    => 0x03;
  53 use constant CMD_DELETE     => 0x04;
  54 use constant CMD_INCR       => 0x05;
  55 use constant CMD_DECR       => 0x06;
  56 use constant CMD_QUIT       => 0x07;
  57 use constant CMD_FLUSH      => 0x08;
  58 use constant CMD_GETQ       => 0x09;
  59 use constant CMD_NOOP       => 0x0A;
  60 use constant CMD_VERSION    => 0x0B;
  61 use constant CMD_GETK       => 0x0C;
  62 use constant CMD_GETKQ      => 0x0D;
  63 use constant CMD_APPEND     => 0x0E;
  64 use constant CMD_PREPEND    => 0x0F;
  65 use constant CMD_STAT       => 0x10;
  66 use constant CMD_SETQ       => 0x11;
  67 use constant CMD_ADDQ       => 0x12;
  68 use constant CMD_REPLACEQ   => 0x13;
  69 use constant CMD_DELETEQ    => 0x14;
  70 use constant CMD_INCREMENTQ => 0x15;
  71 use constant CMD_DECREMENTQ => 0x16;
  72 use constant CMD_QUITQ      => 0x17;
  73 use constant CMD_FLUSHQ     => 0x18;
  74 use constant CMD_APPENDQ    => 0x19;
  75 use constant CMD_PREPENDQ   => 0x1A;
  76
  77 use constant CMD_SASL_LIST_MECHS    => 0x20;
  78 use constant CMD_SASL_AUTH          => 0x21;
  79 use constant CMD_SASL_STEP          => 0x22;
  80 use constant ERR_AUTH_ERROR   => 0x20;
  81
  82
  83 # REQ and RES formats are divided even though they currently share
  84 # the same format, since they _could_ differ in the future.
  85 use constant REQ_PKT_FMT      => "CCnCCnNNNN";
  86 use constant RES_PKT_FMT      => "CCnCCnNNNN";
  87 use constant INCRDECR_PKT_FMT => "NNNNN";
  88 use constant MIN_RECV_BYTES   => length(pack(RES_PKT_FMT));
  89 use constant REQ_MAGIC        => 0x80;
  90 use constant RES_MAGIC        => 0x81;
  91
  92 my $pwd=getcwd;
  93 $ENV{'SASL_CONF_PATH'} = "$pwd/t/sasl";
  94
  95 my $server = new_memcached('-B binary -S ');
  96
  97 my $mc = MC::Client->new;
  98
  99 my $check = sub {
 100     my ($key, $orig_val) = @_;
 101     my ($status, $val, $cas) = $mc->get($key);
 102
 103     if ($val =~ /^\d+$/) {
 104         cmp_ok($val,'==', $orig_val, "$val = $orig_val");
 105     }
 106     else {
 107         cmp_ok($val, 'eq', $orig_val, "$val = $orig_val");
 108     }
 109 };
 110
 111 my $set = sub {
 112     my ($key, $orig_value, $exp) = @_;
 113     $exp = defined $exp ? $exp : 0;
 114     my ($status, $rv)= $mc->set($key, $orig_value, $exp);
 115     $check->($key, $orig_value);
 116 };
 117
 118 my $empty = sub {
 119     my $key = shift;
 120     my ($status,$rv) =()= eval { $mc->get($key) };
 121     #if ($status == ERR_AUTH_ERROR) {
 122     #    ok($@->auth_error, "Not authorized to connect");
 123     #}
 124     #else {
 125     #    ok($@->not_found, "We got a not found error when we expected one");
 126     #}
 127     if ($status) {
 128         ok($@->not_found, "We got a not found error when we expected one");
 129     }
 130 };
 131
 132 my $delete = sub {
 133     my ($key, $when) = @_;
 134     $mc->delete($key, $when);
 135     $empty->($key);
 136 };
 137
 138 # BEGIN THE TEST
 139 ok($server, "started the server");
 140
 141 my $v = $mc->version;
 142 ok(defined $v && length($v), "Proper version: $v");
 143
 144 # list mechs
 145 my $mechs= $mc->list_mechs();
 146 Test::More::cmp_ok($mechs, 'eq', 'CRAM-MD5 PLAIN', "list_mechs $mechs");
 147
 148 # this should fail, not authenticated
 149 {
 150     my ($status, $val)= $mc->set('x', "somevalue");
 151     ok($status, "this fails to authenticate");
 152     cmp_ok($status,'==',ERR_AUTH_ERROR, "error code matches");
 153 }
 154 $empty->('x');
 155 {
 156     my $mc = MC::Client->new;
 157     my ($status, $val) = $mc->delete('x');
 158     ok($status, "this fails to authenticate");
 159     cmp_ok($status,'==',ERR_AUTH_ERROR, "error code matches");
 160 }
 161 $empty->('x');
 162 {
 163     my $mc = MC::Client->new;
 164     my ($status, $val)= $mc->set('x', "somevalue");
 165     ok($status, "this fails to authenticate");
 166     cmp_ok($status,'==',ERR_AUTH_ERROR, "error code matches");
 167 }
 168 $empty->('x');
 169 {
 170     my $mc = MC::Client->new;
 171     my ($status, $val)=  $mc->flush('x');
 172     ok($status, "this fails to authenticate");
 173     cmp_ok($status,'==',ERR_AUTH_ERROR, "error code matches");
 174 }
 175 $empty->('x');
 176
 177 # Build the auth DB for testing.
 178 my $sasldb = '/tmp/test-memcached.sasldb';
 179 unlink $sasldb;
 180
 181 my $saslpasswd_path;
 182 for my $dir (split(/:/, $ENV{PATH}),
 183              "/usr/bin",
 184              "/usr/sbin",
 185              "/usr/local/bin",
 186              "/usr/local/sbin",
 187     ) {
 188     my $exe = $dir . '/saslpasswd2';
 189     if (-x $exe) {
 190         $saslpasswd_path = $exe;
 191         last;
 192     }
 193 }
 194
 195 system("echo testpass | $saslpasswd_path -a memcached -c -p testuser");
 196
 197 $mc = MC::Client->new;
 198
 199 # Attempt a bad auth mech.
 200 is ($mc->authenticate('testuser', 'testpass', "X" x 40), 0x4, "bad mech");
 201
 202 # Attempt bad authentication.
 203 is ($mc->authenticate('testuser', 'wrongpassword'), 0x20, "bad auth");
 204
 205 # Now try good authentication and make the tests work.
 206 is ($mc->authenticate('testuser', 'testpass'), 0, "authenticated");
 207 # these should work
 208 {
 209     my ($status, $val)= $mc->set('x', "somevalue");
 210     ok(! $status);
 211 }
 212 $check->('x','somevalue');
 213
 214 {
 215     my ($status, $val)= $mc->delete('x');
 216     ok(! $status);
 217 }
 218 $empty->('x');
 219
 220 {
 221     my ($status, $val)= $mc->set('x', "somevalue");
 222     ok(! $status);
 223 }
 224 $check->('x','somevalue');
 225
 226 {
 227     my ($status, $val)=  $mc->flush('x');
 228     ok(! $status);
 229 }
 230 $empty->('x');
 231
 232 # check the SASL stats, make sure they track things correctly
 233 # note: the enabled or not is presence checked in stats.t
 234
 235 # while authenticated, get current counter
 236 #
 237 # My initial approach was going to be to get current counts, reauthenticate
 238 # and fail, followed by a reauth successfully so I'd know what happened.
 239 # Reauthentication is currently unsupported, so it doesn't work that way at the
 240 # moment.  Adding tests may break this.
 241
 242 {
 243     my %stats = $mc->stats('');
 244     is ($stats{'auth_cmds'}, 2, "auth commands counted");
 245     is ($stats{'auth_errors'}, 1, "auth errors correct");
 246 }
 247
 248
 249 # Along with the assertion added to the code to verify we're staying
 250 # within bounds when we do a stats detail dump (detail turned on at
 251 # the top).
 252 # my %stats = $mc->stats('detail dump');
 253
 254 # ######################################################################
 255 # Test ends around here.
 256 # ######################################################################
 257
 258 package MC::Client;
 259
 260 use strict;
 261 use warnings;
 262 use fields qw(socket);
 263 use IO::Socket::INET;
 264
 265 use constant ERR_AUTH_ERROR   => 0x20;
 266
 267 sub new {
 268     my $self = shift;
 269     my ($s) = @_;
 270     $s = $server unless defined $s;
 271     my $sock = $s->sock;
 272     $self = fields::new($self);
 273     $self->{socket} = $sock;
 274     return $self;
 275 }
 276
 277 sub authenticate {
 278     my ($self, $user, $pass, $mech)= @_;
 279     $mech ||= 'PLAIN';
 280     my $buf = sprintf("%c%s%c%s", 0, $user, 0, $pass);
 281     my ($status, $rv, undef) = $self->_do_command(::CMD_SASL_AUTH, $mech, $buf, '');
 282     return $status;
 283 }
 284 sub list_mechs {
 285     my ($self)= @_;
 286     my ($status, $rv, undef) = $self->_do_command(::CMD_SASL_LIST_MECHS, '', '', '');
 287     return join(" ", sort(split(/\s+/, $rv)));
 288 }
 289
 290 sub build_command {
 291     my $self = shift;
 292     die "Not enough args to send_command" unless @_ >= 4;
 293     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 294
 295     $extra_header = '' unless defined $extra_header;
 296     my $keylen    = length($key);
 297     my $vallen    = length($val);
 298     my $extralen  = length($extra_header);
 299     my $datatype  = 0;  # field for future use
 300     my $reserved  = 0;  # field for future use
 301     my $totallen  = $keylen + $vallen + $extralen;
 302     my $ident_hi  = 0;
 303     my $ident_lo  = 0;
 304
 305     if ($cas) {
 306         $ident_hi = int($cas / 2 ** 32);
 307         $ident_lo = int($cas % 2 ** 32);
 308     }
 309
 310     my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,
 311                    $datatype, $reserved, $totallen, $opaque, $ident_hi,
 312                    $ident_lo);
 313     my $full_msg = $msg . $extra_header . $key . $val;
 314     return $full_msg;
 315 }
 316
 317 sub send_command {
 318     my $self = shift;
 319     die "Not enough args to send_command" unless @_ >= 4;
 320     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 321
 322     my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 323
 324     my $sent = $self->{socket}->send($full_msg);
 325     die("Send failed:  $!") unless $sent;
 326     if($sent != length($full_msg)) {
 327         die("only sent $sent of " . length($full_msg) . " bytes");
 328     }
 329 }
 330
 331 sub flush_socket {
 332     my $self = shift;
 333     $self->{socket}->flush;
 334 }
 335
 336 # Send a silent command and ensure it doesn't respond.
 337 sub send_silent {
 338     my $self = shift;
 339     die "Not enough args to send_silent" unless @_ >= 4;
 340     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 341
 342     $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 343     $self->send_command(::CMD_NOOP, '', '', $opaque + 1);
 344
 345     my ($ropaque, $status, $data) = $self->_handle_single_response;
 346     Test::More::is($ropaque, $opaque + 1);
 347 }
 348
 349 sub silent_mutation {
 350     my $self = shift;
 351     my ($cmd, $key, $value) = @_;
 352
 353     $empty->($key);
 354     my $extra = pack "NN", 82, 0;
 355     $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
 356     $check->($key, $value);
 357 }
 358
 359 sub _handle_single_response {
 360     my $self = shift;
 361     my $myopaque = shift;
 362
 363     $self->{socket}->recv(my $response, ::MIN_RECV_BYTES);
 364
 365     my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
 366         $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $response);
 367
 368     return ($opaque, '', '', '', 0) if not defined $remaining;
 369     return ($opaque, '', '', '', 0) if ($remaining == 0);
 370
 371     # fetch the value
 372     my $rv="";
 373     while($remaining - length($rv) > 0) {
 374         $self->{socket}->recv(my $buf, $remaining - length($rv));
 375         $rv .= $buf;
 376     }
 377     if(length($rv) != $remaining) {
 378         my $found = length($rv);
 379         die("Expected $remaining bytes, got $found");
 380     }
 381
 382     my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
 383
 384     #if ($status) {
 385         #die MC::Error->new($status, $rv);
 386     #}
 387
 388     return ($opaque, $status, $rv, $cas, $keylen);
 389 }
 390
 391 sub _do_command {
 392     my $self = shift;
 393     die unless @_ >= 3;
 394     my ($cmd, $key, $val, $extra_header, $cas) = @_;
 395
 396     $extra_header = '' unless defined $extra_header;
 397     my $opaque = int(rand(2**32));
 398     $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 399     my (undef, $status, $rv, $rcas) = $self->_handle_single_response($opaque);
 400     return ($status, $rv, $rcas);
 401 }
 402
 403 sub _incrdecr_header {
 404     my $self = shift;
 405     my ($amt, $init, $exp) = @_;
 406
 407     my $amt_hi = int($amt / 2 ** 32);
 408     my $amt_lo = int($amt % 2 ** 32);
 409
 410     my $init_hi = int($init / 2 ** 32);
 411     my $init_lo = int($init % 2 ** 32);
 412
 413     my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,
 414                             $init_lo, $exp);
 415
 416     return $extra_header;
 417 }
 418
 419 sub _incrdecr {
 420     my $self = shift;
 421     my ($cmd, $key, $amt, $init, $exp) = @_;
 422
 423     my ($status, $data, undef) = $self->_do_command($cmd, $key, '',
 424                                            $self->_incrdecr_header($amt, $init, $exp));
 425
 426     my $header = substr $data, 0, 8, '';
 427     my ($resp_hi, $resp_lo) = unpack "NN", $header;
 428     my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
 429
 430     return $resp;
 431 }
 432
 433 sub silent_incrdecr {
 434     my $self = shift;
 435     my ($cmd, $key, $amt, $init, $exp) = @_;
 436     my $opaque = 8275753;
 437
 438     $mc->send_silent($cmd, $key, '', $opaque,
 439                      $mc->_incrdecr_header($amt, $init, $exp));
 440 }
 441
 442 sub stats {
 443     my $self = shift;
 444     my $key  = shift;
 445     my $cas = 0;
 446     my $opaque = int(rand(2**32));
 447     $self->send_command(::CMD_STAT, $key, '', $opaque, '', $cas);
 448
 449     my %rv = ();
 450     my $found_key = '';
 451     my $found_val = '';
 452     my $status= 0;
 453     do {
 454         my ($op, $status, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
 455         if ($keylen > 0) {
 456             $found_key = substr($data, 0, $keylen);
 457             $found_val = substr($data, $keylen);
 458             $rv{$found_key} = $found_val;
 459         } else {
 460             $found_key = '';
 461         }
 462     } while($found_key ne '');
 463     return %rv;
 464 }
 465
 466 sub get {
 467     my $self = shift;
 468     my $key  = shift;
 469     my ($status, $rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');
 470
 471     my $header = substr $rv, 0, 4, '';
 472     my $flags  = unpack("N", $header);
 473
 474     return ($status, $rv);
 475 }
 476
 477 sub get_multi {
 478     my $self = shift;
 479     my @keys = @_;
 480
 481     for (my $i = 0; $i < @keys; $i++) {
 482         $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);
 483     }
 484
 485     my $terminal = @keys + 10;
 486     $self->send_command(::CMD_NOOP, '', '', $terminal);
 487
 488     my %return;
 489     my $status = 0;
 490     while (1) {
 491         my ($opaque, $status, $data) = $self->_handle_single_response;
 492         last if $opaque == $terminal;
 493
 494         my $header = substr $data, 0, 4, '';
 495         my $flags  = unpack("N", $header);
 496
 497         $return{$keys[$opaque]} = [$flags, $data];
 498     }
 499
 500     return %return if wantarray;
 501     return \%return;
 502 }
 503
 504 sub version {
 505     my $self = shift;
 506     return $self->_do_command(::CMD_VERSION, '', '');
 507 }
 508
 509 sub flush {
 510     my $self = shift;
 511     return $self->_do_command(::CMD_FLUSH, '', '');
 512 }
 513
 514 sub add {
 515     my $self = shift;
 516     my ($key, $val, $flags, $expire) = @_;
 517     my $extra_header = pack "NN", $flags, $expire;
 518     my $cas = 0;
 519     return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);
 520 }
 521
 522 sub set {
 523     my $self = shift;
 524     my $flags = 0;
 525     my $cas = 0;
 526     my ($key, $val, $expire) = @_;
 527     $expire = defined $expire ? $expire : 0;
 528     my $extra_header = pack "NN", $flags, $expire;
 529     return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);
 530 }
 531
 532 sub _append_prepend {
 533     my $self = shift;
 534     my ($cmd, $key, $val, $cas) = @_;
 535     return $self->_do_command($cmd, $key, $val, '', $cas);
 536 }
 537
 538 sub replace {
 539     my $self = shift;
 540     my ($key, $val, $flags, $expire) = @_;
 541     my $extra_header = pack "NN", $flags, $expire;
 542     my $cas = 0;
 543     return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);
 544 }
 545
 546 sub delete {
 547     my $self = shift;
 548     my ($key) = @_;
 549     return $self->_do_command(::CMD_DELETE, $key, '');
 550 }
 551
 552 sub incr {
 553     my $self = shift;
 554     my ($key, $amt, $init, $exp) = @_;
 555     $amt = 1 unless defined $amt;
 556     $init = 0 unless defined $init;
 557     $exp = 0 unless defined $exp;
 558
 559     return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
 560 }
 561
 562 sub decr {
 563     my $self = shift;
 564     my ($key, $amt, $init, $exp) = @_;
 565     $amt = 1 unless defined $amt;
 566     $init = 0 unless defined $init;
 567     $exp = 0 unless defined $exp;
 568
 569     return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
 570 }
 571
 572 sub noop {
 573     my $self = shift;
 574     return $self->_do_command(::CMD_NOOP, '', '');
 575 }
 576
 577 package MC::Error;
 578
 579 use strict;
 580 use warnings;
 581
 582 use constant ERR_UNKNOWN_CMD  => 0x81;
 583 use constant ERR_NOT_FOUND    => 0x1;
 584 use constant ERR_EXISTS       => 0x2;
 585 use constant ERR_TOO_BIG      => 0x3;
 586 use constant ERR_EINVAL       => 0x4;
 587 use constant ERR_NOT_STORED   => 0x5;
 588 use constant ERR_DELTA_BADVAL => 0x6;
 589 use constant ERR_AUTH_ERROR   => 0x20;
 590
 591 use overload '""' => sub {
 592     my $self = shift;
 593     return "Memcache Error ($self->[0]): $self->[1]";
 594 };
 595
 596 sub new {
 597     my $class = shift;
 598     my $error = [@_];
 599     my $self = bless $error, (ref $class || $class);
 600
 601     return $self;
 602 }
 603
 604 sub not_found {
 605     my $self = shift;
 606     return $self->[0] == ERR_NOT_FOUND;
 607 }
 608
 609 sub exists {
 610     my $self = shift;
 611     return $self->[0] == ERR_EXISTS;
 612 }
 613
 614 sub too_big {
 615     my $self = shift;
 616     return $self->[0] == ERR_TOO_BIG;
 617 }
 618
 619 sub delta_badval {
 620     my $self = shift;
 621     return $self->[0] == ERR_DELTA_BADVAL;
 622 }
 623
 624 sub auth_error {
 625     my $self = shift;
 626     return $self->[0] == ERR_AUTH_ERROR;
 627 }
 628
 629 unlink $sasldb;
 630
 631 # vim: filetype=perl
 632