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