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