10 my $supports_sasl = supports_sasl();
14 if (supports_sasl()) {
15 if ($ENV{'RUN_SASL_TESTS'}) {
18 plan skip_all => 'Skipping SASL tests';
24 my $server = new_memcached("-S");
26 ok($@, "Died with illegal -S args when SASL is not supported.");
31 my $server = new_memcached("-S -B auto");
33 ok($@, "SASL shouldn't be used with protocol auto negotiate");
36 my $server = new_memcached("-S -B ascii");
38 ok($@, "SASL isn't implemented in the ascii protocol");
41 my $server = new_memcached("-S -B binary -B ascii");
43 ok($@, "SASL isn't implemented in the ascii protocol");
45 # Based almost 100% off testClient.py which is:
46 # Copyright (c) 2007 Dustin Sallings <dustin@spy.net>
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;
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;
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;
93 $ENV{'SASL_CONF_PATH'} = "$pwd/t/sasl";
95 my $server = new_memcached('-B binary -S ');
97 my $mc = MC::Client->new;
100 my ($key, $orig_val) = @_;
101 my ($status, $val, $cas) = $mc->get($key);
103 if ($val =~ /^\d+$/) {
104 cmp_ok($val,'==', $orig_val, "$val = $orig_val");
107 cmp_ok($val, 'eq', $orig_val, "$val = $orig_val");
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);
120 my ($status,$rv) =()= eval { $mc->get($key) };
121 #if ($status == ERR_AUTH_ERROR) {
122 # ok($@->auth_error, "Not authorized to connect");
125 # ok($@->not_found, "We got a not found error when we expected one");
128 ok($@->not_found, "We got a not found error when we expected one");
133 my ($key, $when) = @_;
134 $mc->delete($key, $when);
139 ok($server, "started the server");
141 my $v = $mc->version;
142 ok(defined $v && length($v), "Proper version: $v");
145 my $mechs= $mc->list_mechs();
146 Test::More::cmp_ok($mechs, 'eq', 'CRAM-MD5 PLAIN', "list_mechs $mechs");
148 # this should fail, not authenticated
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");
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");
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");
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");
177 # Build the auth DB for testing.
178 my $sasldb = '/tmp/test-memcached.sasldb';
182 for my $dir (split(/:/, $ENV{PATH}),
188 my $exe = $dir . '/saslpasswd2';
190 $saslpasswd_path = $exe;
195 system("echo testpass | $saslpasswd_path -a memcached -c -p testuser");
197 $mc = MC::Client->new;
199 # Attempt a bad auth mech.
200 is ($mc->authenticate('testuser', 'testpass', "X" x 40), 0x4, "bad mech");
202 # Attempt bad authentication.
203 is ($mc->authenticate('testuser', 'wrongpassword'), 0x20, "bad auth");
205 # Now try good authentication and make the tests work.
206 is ($mc->authenticate('testuser', 'testpass'), 0, "authenticated");
209 my ($status, $val)= $mc->set('x', "somevalue");
212 $check->('x','somevalue');
215 my ($status, $val)= $mc->delete('x');
221 my ($status, $val)= $mc->set('x', "somevalue");
224 $check->('x','somevalue');
227 my ($status, $val)= $mc->flush('x');
232 # check the SASL stats, make sure they track things correctly
233 # note: the enabled or not is presence checked in stats.t
235 # while authenticated, get current counter
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.
243 my %stats = $mc->stats('');
244 is ($stats{'auth_cmds'}, 2, "auth commands counted");
245 is ($stats{'auth_errors'}, 1, "auth errors correct");
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
252 # my %stats = $mc->stats('detail dump');
254 # ######################################################################
255 # Test ends around here.
256 # ######################################################################
262 use fields qw(socket);
263 use IO
::Socket
::INET
;
265 use constant ERR_AUTH_ERROR
=> 0x20;
270 $s = $server unless defined $s;
272 $self = fields
::new
($self);
273 $self->{socket} = $sock;
278 my ($self, $user, $pass, $mech)= @_;
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, '');
286 my ($status, $rv, undef) = $self->_do_command(::CMD_SASL_LIST_MECHS
, '', '', '');
287 return join(" ", sort(split(/\s+/, $rv)));
292 die "Not enough args to send_command" unless @_ >= 4;
293 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
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;
306 $ident_hi = int($cas / 2 ** 32);
307 $ident_lo = int($cas % 2 ** 32);
310 my $msg = pack(::REQ_PKT_FMT
, ::REQ_MAGIC
, $cmd, $keylen, $extralen,
311 $datatype, $reserved, $totallen, $opaque, $ident_hi,
313 my $full_msg = $msg . $extra_header . $key . $val;
319 die "Not enough args to send_command" unless @_ >= 4;
320 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
322 my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
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");
333 $self->{socket}->flush;
336 # Send a silent command and ensure it doesn't respond.
339 die "Not enough args to send_silent" unless @_ >= 4;
340 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
342 $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
343 $self->send_command(::CMD_NOOP
, '', '', $opaque + 1);
345 my ($ropaque, $status, $data) = $self->_handle_single_response;
346 Test
::More
::is
($ropaque, $opaque + 1);
349 sub silent_mutation
{
351 my ($cmd, $key, $value) = @_;
354 my $extra = pack "NN", 82, 0;
355 $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
356 $check->($key, $value);
359 sub _handle_single_response
{
361 my $myopaque = shift;
363 $self->{socket}->recv(my $response, ::MIN_RECV_BYTES
);
365 my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
366 $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT
, $response);
368 return ($opaque, '', '', '', 0) if not defined $remaining;
369 return ($opaque, '', '', '', 0) if ($remaining == 0);
373 while($remaining - length($rv) > 0) {
374 $self->{socket}->recv(my $buf, $remaining - length($rv));
377 if(length($rv) != $remaining) {
378 my $found = length($rv);
379 die("Expected $remaining bytes, got $found");
382 my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
385 #die MC::Error->new($status, $rv);
388 return ($opaque, $status, $rv, $cas, $keylen);
394 my ($cmd, $key, $val, $extra_header, $cas) = @_;
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);
403 sub _incrdecr_header
{
405 my ($amt, $init, $exp) = @_;
407 my $amt_hi = int($amt / 2 ** 32);
408 my $amt_lo = int($amt % 2 ** 32);
410 my $init_hi = int($init / 2 ** 32);
411 my $init_lo = int($init % 2 ** 32);
413 my $extra_header = pack(::INCRDECR_PKT_FMT
, $amt_hi, $amt_lo, $init_hi,
416 return $extra_header;
421 my ($cmd, $key, $amt, $init, $exp) = @_;
423 my ($status, $data, undef) = $self->_do_command($cmd, $key, '',
424 $self->_incrdecr_header($amt, $init, $exp));
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;
433 sub silent_incrdecr
{
435 my ($cmd, $key, $amt, $init, $exp) = @_;
436 my $opaque = 8275753;
438 $mc->send_silent($cmd, $key, '', $opaque,
439 $mc->_incrdecr_header($amt, $init, $exp));
446 my $opaque = int(rand(2**32));
447 $self->send_command(::CMD_STAT
, $key, '', $opaque, '', $cas);
454 my ($op, $status, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
456 $found_key = substr($data, 0, $keylen);
457 $found_val = substr($data, $keylen);
458 $rv{$found_key} = $found_val;
462 } while($found_key ne '');
469 my ($status, $rv, $cas) = $self->_do_command(::CMD_GET
, $key, '', '');
471 my $header = substr $rv, 0, 4, '';
472 my $flags = unpack("N", $header);
474 return ($status, $rv);
481 for (my $i = 0; $i < @keys; $i++) {
482 $self->send_command(::CMD_GETQ
, $keys[$i], '', $i, '', 0);
485 my $terminal = @keys + 10;
486 $self->send_command(::CMD_NOOP
, '', '', $terminal);
491 my ($opaque, $status, $data) = $self->_handle_single_response;
492 last if $opaque == $terminal;
494 my $header = substr $data, 0, 4, '';
495 my $flags = unpack("N", $header);
497 $return{$keys[$opaque]} = [$flags, $data];
500 return %return if wantarray;
506 return $self->_do_command(::CMD_VERSION
, '', '');
511 return $self->_do_command(::CMD_FLUSH
, '', '');
516 my ($key, $val, $flags, $expire) = @_;
517 my $extra_header = pack "NN", $flags, $expire;
519 return $self->_do_command(::CMD_ADD
, $key, $val, $extra_header, $cas);
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);
532 sub _append_prepend
{
534 my ($cmd, $key, $val, $cas) = @_;
535 return $self->_do_command($cmd, $key, $val, '', $cas);
540 my ($key, $val, $flags, $expire) = @_;
541 my $extra_header = pack "NN", $flags, $expire;
543 return $self->_do_command(::CMD_REPLACE
, $key, $val, $extra_header, $cas);
549 return $self->_do_command(::CMD_DELETE
, $key, '');
554 my ($key, $amt, $init, $exp) = @_;
555 $amt = 1 unless defined $amt;
556 $init = 0 unless defined $init;
557 $exp = 0 unless defined $exp;
559 return $self->_incrdecr(::CMD_INCR
, $key, $amt, $init, $exp);
564 my ($key, $amt, $init, $exp) = @_;
565 $amt = 1 unless defined $amt;
566 $init = 0 unless defined $init;
567 $exp = 0 unless defined $exp;
569 return $self->_incrdecr(::CMD_DECR
, $key, $amt, $init, $exp);
574 return $self->_do_command(::CMD_NOOP
, '', '');
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;
591 use overload
'""' => sub {
593 return "Memcache Error ($self->[0]): $self->[1]";
599 my $self = bless $error, (ref $class || $class);
606 return $self->[0] == ERR_NOT_FOUND
;
611 return $self->[0] == ERR_EXISTS
;
616 return $self->[0] == ERR_TOO_BIG
;
621 return $self->[0] == ERR_DELTA_BADVAL
;
626 return $self->[0] == ERR_AUTH_ERROR
;