1#!/usr/bin/env perl
2
3use strict;
4use warnings;
5use Test::More;
6use FindBin qw($Bin);
7use lib "$Bin/lib";
8use Carp qw(croak);
9use MemcachedTest;
10use IO::Socket qw(AF_INET SOCK_STREAM);
11use IO::Select;
12
13if (!supports_proxy()) {
14    plan skip_all => 'proxy not enabled';
15    exit 0;
16}
17
18# Set up some server sockets.
19sub mock_server {
20    my $port = shift;
21    my $srv = IO::Socket->new(
22        Domain => AF_INET,
23        Type => SOCK_STREAM,
24        Proto => 'tcp',
25        LocalHost => '127.0.0.1',
26        LocalPort => $port,
27        ReusePort => 1,
28        Listen => 5) || die "IO::Socket: $@";
29    return $srv;
30}
31
32# Accept and validate a new backend connection.
33sub accept_backend {
34    my $srv = shift;
35    my $be = $srv->accept();
36    $be->autoflush(1);
37    ok(defined $be, "mock backend created");
38    like(<$be>, qr/version/, "received version command");
39    print $be "VERSION 1.0.0-mock\r\n";
40
41    return $be;
42}
43
44note("Initialization:" . __LINE__);
45
46my @mocksrvs = ();
47#diag "making mock servers";
48for my $port (11411, 11412, 11413) {
49    my $srv = mock_server($port);
50    ok(defined $srv, "mock server created");
51    push(@mocksrvs, $srv);
52}
53
54my $p_srv = new_memcached('-o proxy_config=./t/proxyunits.lua -t 1');
55my $ps = $p_srv->sock;
56$ps->autoflush(1);
57
58my $pss = IO::Select->new();
59$pss->add($ps);
60
61# set up server backend sockets.
62my @mbe = ();
63#diag "accepting mock backends";
64for my $msrv (@mocksrvs) {
65    my $be = accept_backend($msrv);
66    push(@mbe, $be);
67}
68
69# Put a version command down the pipe to ensure the socket is clear.
70# client version commands skip the proxy code
71sub check_version {
72    my $ps = shift;
73    print $ps "version\r\n";
74    like(<$ps>, qr/VERSION /, "version received");
75}
76
77# Send a touch command to all backends, and verify response.
78# This makes sure socket buffers are clean between tests.
79sub check_sanity {
80    my $ps = shift;
81    my $cmd = "touch /sanity/a 50\r\n";
82    print $ps $cmd;
83    foreach my $idx (keys @mbe) {
84        my $be = $mbe[$idx];
85        is(scalar <$be>, $cmd, "sanity check: touch cmd received for be " . $idx);
86        print $be "TOUCHED\r\n";
87    }
88    is(scalar <$ps>, "TOUCHED\r\n", "sanity check: TOUCHED response received.");
89}
90
91# $ps_send : request to proxy
92# $be_recv : ref to a hashmap from be index to an array of received requests for validation.
93# $be_send : ref to a hashmap from be index to an array of responses to proxy.
94# $ps_recv : ref to response returned by proxy
95# backends in $be_recv and $be_send are vistied by looping through the @mbe.
96sub proxy_test {
97    my %args = @_;
98
99    my $ps_send = $args{ps_send};
100    my $be_recv = $args{be_recv} // {};
101    my $be_send = $args{be_send} // {};
102    my $ps_recv = $args{ps_recv};
103
104    # sends request to proxy
105    if ($ps_send) {
106        print $ps $ps_send;
107    }
108
109    # verify all backends received request
110    foreach my $idx (keys @mbe) {
111        if (exists $be_recv->{$idx}) {
112            my $be = $mbe[$idx];
113            foreach my $recv (@{$be_recv->{$idx}}) {
114                is(scalar <$be>, $recv, "be " . $idx . " received expected response");
115            }
116        }
117    }
118
119    # backends send responses
120    foreach my $idx (keys @mbe) {
121        if (exists $be_send->{$idx}) {
122            my $be = $mbe[$idx];
123            foreach my $send (@{$be_send->{$idx}}) {
124                print $be $send;
125            }
126        }
127    }
128
129    if (defined $ps_recv) {
130        if (scalar @{$ps_recv}) {
131            foreach my $recv (@{$ps_recv}) {
132                is(scalar <$ps>, $recv, "ps returned expected response.");
133            }
134            # makes sure nothing remains in $ps.
135            check_version($ps);
136        } else {
137            # when $ps_recv is empty, make sure it is not readable.
138            my @readable = $pss->can_read(0.1);
139            is(scalar @readable, 0, "ps is expected to be non-readable");
140        }
141    }
142}
143
144{
145    note("Bad syntax tests");
146    # Write a request with bad syntax, and check the response.
147    print $ps "set with the wrong number of tokens\n";
148    is(scalar <$ps>, "CLIENT_ERROR parsing request\r\n", "got CLIENT_ERROR for bad syntax");
149
150    for ('get', 'incr', 'decr', 'touch', 'gat', 'gats', 'mg', 'md', 'ma', 'ms') {
151        print $ps "$_\r\n";
152        is(scalar <$ps>, "CLIENT_ERROR parsing request\r\n", "$_ got CLIENT_ERROR for too few tokens");
153    }
154
155    my $space = ' ' x 200;
156    print $ps "get$space key key\r\n";
157    is(scalar <$ps>, "CLIENT_ERROR malformed request\r\n");
158    is(scalar <$ps>, "CLIENT_ERROR malformed request\r\n");
159    is(scalar <$ps>, "END\r\n"); # god damn multiget syntax.
160}
161
162{
163    note("Test dead backend");
164    my $start = int(time());
165    print $ps "get /dead/foo\r\n";
166    is(scalar <$ps>, "SERVER_ERROR backend failure\r\n", "Backend failed");
167    my $end = int(time());
168    cmp_ok($end - $start, '<', 3, "backend failed immediately");
169
170    print $ps "get /deadrespcode/foo\r\n";
171    is(scalar <$ps>, "ERROR code_correct\r\n", "Backend had correct response code on failure");
172}
173
174{
175    note("millisecond timer");
176    print $ps "mg /millis/key\r\n";
177    my $res = <$ps>;
178    if ($res =~ m/^HD t(\d+)/) {
179        my $time = $1;
180        my $now = int(time());
181        cmp_ok($time, '>', $now*5, "mcp.time_millis is a reasonable value: $now*5 vs $time");
182        cmp_ok($time, '!=', 0, 'mcp.time_millis is non zero');
183    } else {
184        fail("mcp.time_millis failure: $res");
185    }
186}
187
188# Basic test with a backend; write a request to the client socket, read it
189# from a backend socket, and write a response to the backend socket.
190#
191# The array @mbe holds references to our sockets for the backends listening on
192# the above mocked servers. In most tests we're only routing to the first
193# backend in the list ($mbe[0])
194#
195# In this case the client will receive an error and the backend gets closed,
196# so we have to re-establish it.
197{
198    note("Test missing END:" . __LINE__);
199
200    # Test a fix for passing through partial read data if END ends up missing.
201    my $be = $mbe[0];
202    my $w = $p_srv->new_sock;
203    print $w "watch proxyevents\n";
204    is(<$w>, "OK\r\n", "watcher enabled");
205
206    # write a request to proxy.
207    print $ps "get /b/a\r\n";
208
209    # verify request is received by backend.
210    is(scalar <$be>, "get /b/a\r\n", "get passthrough");
211
212    # write a response with partial data.
213    print $be "VALUE /b/a 0 2\r\nhi\r\nEN";
214
215    # verify the error response from proxy
216    is(scalar <$ps>, "SERVER_ERROR backend failure\r\n", "backend failure error");
217
218    # verify a particular proxy event logline is received
219    like(<$w>, qr/ts=(\S+) gid=\d+ type=proxy_backend error=timeout name=127.0.0.1 port=\d+ label=b\d+ depth=1 rbuf=EN/, "got backend error log line");
220
221    # backend is disconnected due to the error, so we have to re-establish it.
222    $mbe[0] = accept_backend($mocksrvs[0]);
223}
224
225# This test is similar to the above one, except we also establish a watcher to
226# check for appropriate log entries.
227{
228    note("Test trailingdata:" . __LINE__);
229
230    # Test a log line with detailed data from backend failures.
231    my $be = $mbe[0];
232    my $w = $p_srv->new_sock;
233    print $w "watch proxyevents\n";
234    is(<$w>, "OK\r\n", "watcher enabled");
235
236    print $ps "get /b/c\r\n";
237    is(scalar <$be>, "get /b/c\r\n", "get passthrough");
238    # Set off a "trailing data" error
239    print $be "VALUE /b/c 0 2\r\nok\r\nEND\r\ngarbage";
240
241    is(scalar <$ps>, "VALUE /b/c 0 2\r\n", "got value back");
242    is(scalar <$ps>, "ok\r\n", "got data back");
243    is(scalar <$ps>, "END\r\n", "got end string");
244
245    like(<$w>, qr/ts=(\S+) gid=\d+ type=proxy_backend error=trailingdata name=127.0.0.1 port=\d+ label=b\d+ depth=0 rbuf=garbage/, "got backend error log line");
246
247    $mbe[0] = accept_backend($mocksrvs[0]);
248}
249
250{
251    note("Test proxyevents for a backend without a label");
252
253    my $msrv_nolabel = mock_server(11414);
254    ok(defined $msrv_nolabel, "mock server with no label created");
255    my $mbe_nolabel = accept_backend($msrv_nolabel);
256
257    # Trigger a proxyevent error by adding trailing data ("garbage") to the
258    # backend response.
259    my $w = $p_srv->new_sock;
260    print $w "watch proxyevents\n";
261    is(<$w>, "OK\r\n", "watcher enabled");
262
263    print $ps "get /nolabel/c\r\n";
264    is(scalar <$mbe_nolabel>, "get /nolabel/c\r\n", "get passthrough");
265    # Set off a "trailing data" error
266    print $mbe_nolabel "VALUE /nolabel/c 0 2\r\nok\r\nEND\r\ngarbage";
267
268    is(scalar <$ps>, "VALUE /nolabel/c 0 2\r\n", "got value back");
269    is(scalar <$ps>, "ok\r\n", "got data back");
270    is(scalar <$ps>, "END\r\n", "got end string");
271
272    # Verify a proxy event logline is received with empty label
273    like(<$w>, qr/ts=(\S+) gid=\d+ type=proxy_backend error=trailingdata name=127.0.0.1 port=11414 label= depth=0 rbuf=garbage/, "got backend error log line");
274}
275
276# This is an example of a test which will only pass before a bugfix is issued.
277# It's good practice where possible to write a failing test, then check it
278# against a code fix. We then leave the test in the file for reference.
279# Though noting when it was fixed is probably better than what I did here :)
280SKIP: {
281    note("Test bugfix for missingend:" . __LINE__);
282    skip "Remove this skip line to demonstrate pre-patch bug", 1;
283    # Test issue with finding response complete when read lands between value
284    # size and value + response line in size.
285    my $be = $mbe[0];
286    my $w = $p_srv->new_sock;
287    print $w "watch proxyevents\n";
288    is(<$w>, "OK\r\n", "watcher enabled");
289
290    print $ps "get /b/c\r\n";
291    is(scalar <$be>, "get /b/c\r\n", "get passthrough");
292
293    # Set off a "missingend" error.
294    # The server will wake up several times, thinking it has read the
295    # full size of response but it only read enough for the value portion.
296    print $be "VALUE /b/c 0 5\r\nhe";
297    sleep 0.1;
298    print $be "llo";
299    sleep 0.1;
300    print $be "\r\nEND\r\n";
301
302    is(scalar <$ps>, "SERVER_ERROR backend failure\r\n");
303
304    like(<$w>, qr/ts=(\S+) gid=\d+ type=proxy_backend error=missingend name=127.0.0.1 port=\d+ label=b\d+ depth=1 rbuf=/, "got missingend error log line");
305
306    $mbe[0] = accept_backend($mocksrvs[0]);
307}
308
309{
310    # Test issue with finding response complete when read lands between value
311    # size and value + response line in size.
312    my $be = $mbe[0];
313
314    print $ps "get /b/c\r\n";
315    is(scalar <$be>, "get /b/c\r\n", "get passthrough");
316
317    # Set off a "missingend" error.
318    # The server will wake up several times, thinking it has read the
319    # full size of response but it only read enough for the value portion.
320    print $be "VALUE /b/c 0 5\r\nhe";
321    sleep 0.1;
322    print $be "llo";
323    sleep 0.1;
324    print $be "\r\nEND\r\n";
325
326    is(scalar <$ps>, "VALUE /b/c 0 5\r\n", "got value back");
327    is(scalar <$ps>, "hello\r\n", "got data back");
328    is(scalar <$ps>, "END\r\n", "got end string");
329}
330
331#diag "ready for main tests";
332# Target a single backend, validating basic syntax.
333# Should test all command types.
334# uses /b/ path for "basic"
335{
336    note("Test all commands to a single backend:" . __LINE__);
337
338    # Test invalid route.
339    print $ps "set /invalid/a 0 0 2\r\nhi\r\n";
340    is(scalar <$ps>, "SERVER_ERROR no set route\r\n");
341
342    # Testing against just one backend. Results should make sense despite our
343    # invalid request above.
344    my $be = $mbe[0];
345    my $cmd;
346
347    # TODO: add more tests for the varying response codes.
348
349    # Basic set.
350    $cmd = "set /b/a 0 0 2";
351    print $ps "$cmd\r\nhi\r\n";
352    is(scalar <$be>, "$cmd\r\n", "set passthrough");
353    is(scalar <$be>, "hi\r\n", "set value");
354    print $be "STORED\r\n";
355
356    is(scalar <$ps>, "STORED\r\n", "got STORED from set");
357
358    # set (large value)
359    my $datasize = 256000;
360    my $data = 'x' x $datasize;
361    $cmd = "set /b/a 0 0 $datasize";
362    print $ps "$cmd\r\n$data\r\n";
363    is(scalar <$be>, "$cmd\r\n", "set passthrough (large value)");
364    is(scalar <$be>, "$data\r\n", "set value (large value)");
365    print $be "STORED\r\n";
366
367    is(scalar <$ps>, "STORED\r\n", "got STORED from set (large value)");
368
369    # set (pipelined)
370    my $num_repetitions = 5;
371    $cmd = "set /b/a 0 0 2";
372    $data = "ab";
373    my $req_ps = "$cmd\r\n$data\r\n";
374    my $resp_be = "STORED\r\n";
375
376    my $repeated_req_ps = "";
377    my $repeated_resp_be = "";
378    for (1..$num_repetitions) {
379        $repeated_req_ps = $repeated_req_ps . $req_ps;
380        $repeated_resp_be = $repeated_resp_be . $resp_be;
381    }
382
383    print $ps $repeated_req_ps;
384
385    for (1..$num_repetitions) {
386        is(scalar <$be>, "$cmd\r\n", "set passthrough (repeated)");
387        is(scalar <$be>, "$data\r\n", "set value (repeated)");
388    }
389
390    print $be $repeated_resp_be;
391
392    for (1..$num_repetitions) {
393        is(scalar <$ps>, "STORED\r\n", "got STORED from set (repeated)");
394    }
395
396    # Basic get
397    $cmd = "get /b/a\r\n";
398    print $ps $cmd;
399    is(scalar <$be>, $cmd, "get passthrough");
400    print $be "VALUE /b/a 0 2\r\nhi\r\nEND\r\n";
401
402    is(scalar <$ps>, "VALUE /b/a 0 2\r\n", "get rline");
403    is(scalar <$ps>, "hi\r\n", "get data");
404    is(scalar <$ps>, "END\r\n", "get end");
405
406    # get (large value)
407    $datasize = 256000;
408    $data = 'x' x $datasize;
409    $cmd = "get /b/a\r\n";
410    print $ps $cmd;
411    is(scalar <$be>, $cmd, "get passthrough (large value)");
412    print $be "VALUE /b/a 0 $datasize\r\n$data\r\nEND\r\n";
413
414    is(scalar <$ps>, "VALUE /b/a 0 $datasize\r\n", "get rline (large value)");
415    is(scalar <$ps>, "$data\r\n", "get data (large value)");
416    is(scalar <$ps>, "END\r\n", "get end (large value)");
417
418    # touch
419    $cmd = "touch /b/a 50\r\n";
420    print $ps $cmd;
421    is(scalar <$be>, $cmd, "touch passthrough");
422    print $be "TOUCHED\r\n";
423
424    is(scalar <$ps>, "TOUCHED\r\n", "got touch response");
425
426    # gets
427    $cmd = "gets /b/a\r\n";
428    print $ps $cmd;
429    is(scalar <$be>, $cmd, "gets passthrough");
430    print $be "VALUE /b/a 0 2 2\r\nhi\r\nEND\r\n";
431
432    is(scalar <$ps>, "VALUE /b/a 0 2 2\r\n", "gets rline");
433    is(scalar <$ps>, "hi\r\n", "gets data");
434    is(scalar <$ps>, "END\r\n", "gets end");
435
436    # gat
437    $cmd = "gat 10 /b/a\r\n";
438    print $ps $cmd;
439    is(scalar <$be>, $cmd, "gat passthrough");
440    print $be "VALUE /b/a 0 2\r\nhi\r\nEND\r\n";
441
442    is(scalar <$ps>, "VALUE /b/a 0 2\r\n", "gat rline");
443    is(scalar <$ps>, "hi\r\n", "gat data");
444    is(scalar <$ps>, "END\r\n", "gat end");
445
446    # gat (cache miss)
447    $cmd = "gat 10 /b/a\r\n";
448    print $ps $cmd;
449    is(scalar <$be>, $cmd, "gat passthrough");
450    print $be "END\r\n";
451
452    is(scalar <$ps>, "END\r\n", "gat end, cache miss");
453
454    # gats
455    $cmd = "gats 11 /b/a\r\n";
456    print $ps $cmd;
457    is(scalar <$be>, $cmd, "gats passthrough");
458    print $be "VALUE /b/a 0 2 1\r\nhi\r\nEND\r\n";
459
460    is(scalar <$ps>, "VALUE /b/a 0 2 1\r\n", "gats rline");
461    is(scalar <$ps>, "hi\r\n", "gats data");
462    is(scalar <$ps>, "END\r\n", "gats end");
463
464    # cas
465    $cmd = "cas /b/a 0 0 2 5";
466    print $ps "$cmd\r\nhi\r\n";
467    is(scalar <$be>, "$cmd\r\n", "cas passthrough");
468    is(scalar <$be>, "hi\r\n", "cas value");
469    print $be "STORED\r\n";
470
471    is(scalar <$ps>, "STORED\r\n", "got STORED from cas");
472
473    # cas (already exists failure)
474    $cmd = "cas /b/a 0 0 3 6";
475    print $ps "$cmd\r\nabc\r\n";
476    is(scalar <$be>, "$cmd\r\n", "cas passthrough");
477    is(scalar <$be>, "abc\r\n", "cas value");
478    print $be "EXISTS\r\n";
479
480    is(scalar <$ps>, "EXISTS\r\n", "got EXISTS from cas");
481
482    # add
483    $cmd = "add /b/a 0 0 2";
484    print $ps "$cmd\r\nhi\r\n";
485    is(scalar <$be>, "$cmd\r\n", "add passthrough");
486    is(scalar <$be>, "hi\r\n", "add value");
487    print $be "STORED\r\n";
488
489    is(scalar <$ps>, "STORED\r\n", "got STORED from add");
490
491    # add (re-add failure)
492    $cmd = "add /b/a 0 0 4";
493    print $ps "$cmd\r\nabcd\r\n";
494    is(scalar <$be>, "$cmd\r\n", "add passthrough");
495    is(scalar <$be>, "abcd\r\n", "add value");
496    print $be "NOT_STORED\r\n";
497
498    is(scalar <$ps>, "NOT_STORED\r\n", "got STORED from add");
499
500    # delete
501    $cmd = "delete /b/a\r\n";
502    print $ps $cmd;
503    is(scalar <$be>, $cmd, "delete passthrough");
504    print $be "DELETED\r\n";
505
506    is(scalar <$ps>, "DELETED\r\n", "got delete response");
507
508    # incr
509    $cmd = "incr /b/a 1\r\n";
510    print $ps $cmd;
511    is(scalar <$be>, $cmd, "incr passthrough");
512    print $be "2\r\n";
513
514    is(scalar <$ps>, "2\r\n", "got incr response");
515
516    # decr
517    $cmd = "decr /b/a 1\r\n";
518    print $ps $cmd;
519    is(scalar <$be>, $cmd, "decr passthrough");
520    print $be "10\r\n";
521
522    is(scalar <$ps>, "10\r\n", "got decr response");
523
524    # append
525    $cmd = "append /b/a 0 0 2";
526    print $ps "$cmd\r\nhi\r\n";
527    is(scalar <$be>, "$cmd\r\n", "append passthrough");
528    is(scalar <$be>, "hi\r\n", "append value");
529    print $be "STORED\r\n";
530
531    is(scalar <$ps>, "STORED\r\n", "got STORED from append");
532
533    # prepend
534    $cmd = "prepend /b/a 0 0 2";
535    print $ps "$cmd\r\nhi\r\n";
536    is(scalar <$be>, "$cmd\r\n", "prepend passthrough");
537    is(scalar <$be>, "hi\r\n", "prepend value");
538    print $be "STORED\r\n";
539
540    is(scalar <$ps>, "STORED\r\n", "got STORED from prepend");
541
542    # [meta commands]
543    # testing the bare meta commands.
544    # TODO: add more tests for tokens and changing response codes.
545    # mg
546    $cmd = "mg /b/a\r\n";
547    print $ps $cmd;
548    is(scalar <$be>, $cmd, "mg passthrough");
549    print $be "HD\r\n";
550
551    is(scalar <$ps>, "HD\r\n", "got mg response");
552    # ms
553    $cmd = "ms /b/a 2";
554    print $ps "$cmd\r\nhi\r\n";
555    is(scalar <$be>, "$cmd\r\n", "ms passthrough");
556    is(scalar <$be>, "hi\r\n", "ms value");
557    print $be "HD\r\n";
558
559    is(scalar <$ps>, "HD\r\n", "got HD from ms");
560
561    # md
562    $cmd = "md /b/a\r\n";
563    print $ps $cmd;
564    is(scalar <$be>, $cmd, "md passthrough");
565    print $be "HD\r\n";
566
567    is(scalar <$ps>, "HD\r\n", "got HD from md");
568    # ma
569    $cmd = "ma /b/a\r\n";
570    print $ps $cmd;
571    is(scalar <$be>, $cmd, "ma passthrough");
572    print $be "HD\r\n";
573
574    is(scalar <$ps>, "HD\r\n", "got HD from ma");
575    # mn?
576    # me?
577}
578
579# run a cleanser check between each set of tests.
580# This ensures nothing was left in the client pipeline.
581check_sanity($ps);
582
583{
584    note("Test multiget:" . __LINE__);
585
586    # multiget syntax
587    # - gets broken into individual gets on backend
588    my $be = $mbe[0];
589    my $cmd = "get /b/a /b/b /b/c\r\n";
590    print $ps $cmd;
591    is(scalar <$be>, "get /b/a\r\n", "multiget breakdown a");
592    is(scalar <$be>, "get /b/b\r\n", "multiget breakdown b");
593    is(scalar <$be>, "get /b/c\r\n", "multiget breakdown c");
594
595    print $be "VALUE /b/a 0 1\r\na\r\n",
596              "END\r\n",
597              "VALUE /b/b 0 1\r\nb\r\n",
598              "END\r\n",
599              "VALUE /b/c 0 1\r\nc\r\n",
600              "END\r\n";
601
602    for my $key ('a', 'b', 'c') {
603        is(scalar <$ps>, "VALUE /b/$key 0 1\r\n", "multiget res $key");
604        is(scalar <$ps>, "$key\r\n", "multiget value $key");
605    }
606    is(scalar <$ps>, "END\r\n", "final END from multiget");
607
608    # Test multiget workaround with misses (known bug)
609    print $ps $cmd;
610    is(scalar <$be>, "get /b/a\r\n", "multiget breakdown a");
611    is(scalar <$be>, "get /b/b\r\n", "multiget breakdown b");
612    is(scalar <$be>, "get /b/c\r\n", "multiget breakdown c");
613
614    print $be "END\r\nEND\r\nEND\r\n";
615    is(scalar <$ps>, "END\r\n", "final END from multiget");
616
617    # If bugged, the backend will have closed.
618    print $ps "get /b/a\r\n";
619    is(scalar <$be>, "get /b/a\r\n", "get works after empty multiget");
620    print $be "END\r\n";
621    is(scalar <$ps>, "END\r\n", "end after empty multiget");
622}
623
624check_sanity($ps);
625
626{
627    note("Test noreply:" . __LINE__);
628
629    # noreply tests.
630    # - backend should receive with noreply/q stripped or mangled
631    # - backend should reply as normal
632    # - frontend should get nothing; to test issue another command and ensure
633    # it only gets that response.
634    my $be = $mbe[0];
635    my $cmd = "set /b/a 0 0 2 noreply\r\nhi\r\n";
636    print $ps $cmd;
637    is(scalar <$be>, "set /b/a 0 0 2 noreplY\r\n", "set received with broken noreply");
638    is(scalar <$be>, "hi\r\n", "set payload received");
639
640    print $be "STORED\r\n";
641
642    # To ensure success, make another req and ensure res isn't STORED
643    $cmd = "touch /b/a 50\r\n";
644    print $ps $cmd;
645    is(scalar <$be>, $cmd, "canary touch received");
646    print $be "TOUCHED\r\n";
647
648    is(scalar <$ps>, "TOUCHED\r\n", "got TOUCHED instread of STORED");
649}
650
651check_sanity($ps);
652
653{
654    subtest 'quiet flag: HD response' => sub {
655        # be_recv must receive a response with quiet flag replaced by a space.
656        # ps_recv must not receoved HD response.
657        proxy_test(
658            ps_send => "ms /b/a 2 q\r\nhi\r\n",
659            be_recv => {0 => ["ms /b/a 2  \r\n", "hi\r\n"]},
660            be_send => {0 => ["HD\r\n"]},
661            ps_recv => [],
662        );
663    };
664
665    subtest 'quiet flag: EX response' => sub {
666        # be_recv must receive a response with quiet flag replaced by a space.
667        # ps_recv must return EX response from the backend.
668        proxy_test(
669            ps_send => "ms /b/a 2 q\r\nhi\r\n",
670            be_recv => {0 => ["ms /b/a 2  \r\n", "hi\r\n"]},
671            be_send => {0 => ["EX\r\n"]},
672            ps_recv => ["EX\r\n"],
673        );
674    };
675
676    subtest 'quiet flag: backend failure' => sub {
677        # be_recv must receive a response with quiet flag replaced by a space.
678        # ps_recv must return backend failure response from the backend.
679        proxy_test(
680            ps_send => "ms /b/a 2 q\r\nhi\r\n",
681            be_recv => {0 => ["ms /b/a 2  \r\n", "hi\r\n"]},
682            be_send => {0 => ["garbage\r\n"]},
683            ps_recv => ["SERVER_ERROR backend failure\r\n"],
684        );
685        $mbe[0] = accept_backend($mocksrvs[0]);
686    };
687}
688
689check_sanity($ps);
690
691# Test Lua request API
692{
693    note("Test Lua request APIs:" . __LINE__);
694
695    my $be = $mbe[0];
696
697    # fetching the key.
698    print $ps "get /getkey/testkey\r\n";
699    # look for the key to be slightly different to ensure we hit lua.
700    is(scalar <$ps>, "VALUE |/getkey/testkey 0 2\r\n", "request:key()");
701    is(scalar <$ps>, "ts\r\n", "request:key() value");
702    is(scalar <$ps>, "END\r\n", "request:key() END");
703
704    # rtrimkey
705    # this overwrites part of the key with spaces, which should be skipped by
706    # a valid protocol parser.
707    print $ps "get /rtrimkey/onehalf\r\n";
708    is(scalar <$be>, "get /rtrimkey/one    \r\n", "request:rtrimkey()");
709    print $be "END\r\n";
710    is(scalar <$ps>, "END\r\n", "rtrimkey END");
711
712    # ltrimkey
713    print $ps "get /ltrimkey/test\r\n";
714    is(scalar <$be>, "get           test\r\n", "request:ltrimkey()");
715    print $be "END\r\n";
716    is(scalar <$ps>, "END\r\n", "ltrimkey END");
717
718    subtest 'request:ntokens()' => sub {
719        # ps_recv must return value that matches the number of tokens.
720        proxy_test(
721            ps_send => "mg /ntokens/test c v\r\n",
722            ps_recv => ["VA 1 C123 v\r\n", "4\r\n"],
723        );
724    };
725
726    subtest 'request:token() replacement' => sub {
727        # be_recv must received a response with replaced CAS token.
728        proxy_test(
729            ps_send => "ms /token/replacement 2 C123\r\nhi\r\n",
730            be_recv => {0 => ["ms /token/replacement 2 C456\r\n", "hi\r\n"]},
731            be_send => {0 => ["NF\r\n"]},
732            ps_recv => ["NF\r\n"],
733        );
734    };
735
736    subtest 'request:token() remove' => sub {
737        # be_recv must received a response with CAS token removed.
738        proxy_test(
739            ps_send => "ms /token/removal 2 C123\r\nhi\r\n",
740            be_recv => {0 => ["ms /token/removal 2\r\n", "hi\r\n"]},
741            be_send => {0 => ["NF\r\n"]},
742            ps_recv => ["NF\r\n"],
743        );
744    };
745
746    subtest 'request:token() fetch' => sub {
747        # be_recv must received the key token in the P flag.
748        proxy_test(
749            ps_send => "ms /token/fetch 2 C123 P\r\nhi\r\n",
750            be_recv => {0 => ["ms /token/fetch 2 C123 P/token/fetch\r\n", "hi\r\n"]},
751            be_send => {0 => ["HD\r\n"]},
752            ps_recv => ["HD\r\n"],
753        );
754    };
755
756    # # command() integer
757
758    subtest 'request:has_flag() meta positive 1' => sub {
759        # ps_recv must receive HD C123 for a successful hash_flag call.
760        proxy_test(
761            ps_send => "mg /hasflag/test c\r\n",
762            ps_recv => ["HD C123\r\n"],
763        );
764    };
765
766    subtest 'request:has_flag() meta positive 2' => sub {
767        # ps_recv must receive HD Oabc for a successful hash_flag call.
768        proxy_test(
769            ps_send => "mg /hasflag/test Oabc T999\r\n",
770            ps_recv => ["HD Oabc\r\n"],
771        );
772    };
773
774    subtest 'request:has_flag() meta negative' => sub {
775        # ps_recv must receive NF when has_flag returns false.
776        proxy_test(
777            ps_send => "mg /hasflag/test T999\r\n",
778            ps_recv => ["NF\r\n"],
779        );
780    };
781
782    subtest 'request:has_flag() none-meta ' => sub {
783        # ps_recv must receive END for a successful hash_flag call.
784        proxy_test(
785            ps_send => "get /hasflag/test\r\n",
786            ps_recv => ["END\r\n"],
787        );
788    };
789
790    subtest 'request:flag_token()' => sub {
791        # be_recv must receive expected flags after a series of flag_token() calls.
792        proxy_test(
793            ps_send => "mg /flagtoken/a N10 k c R10\r\n",
794            ps_recv => ["HD\r\n"],
795        );
796    };
797
798
799    subtest 'request edit' => sub {
800        # be_recv must receive the edited request.
801        proxy_test(
802            ps_send => "ms /request/edit 2\r\nhi\r\n",
803            be_recv => {0 => ["ms /request/edit 2\r\n", "ab\r\n"]},
804            be_send => {0 => ["HD\r\n"]},
805            ps_recv => ["HD\r\n"],
806        );
807    };
808
809    subtest 'request new' => sub {
810        # be_recv must receive the new request.
811        proxy_test(
812            ps_send => "mg /request/old\r\n",
813            be_recv => {0 => ["mg /request/new c\r\n"]},
814            be_send => {0 => ["HD C123\r\n"]},
815            ps_recv => ["HD C123\r\n"],
816        );
817    };
818
819    subtest 'request clone response' => sub {
820        # be must receive cloned meta-set from the previous meta-get.
821        my $be = $mbe[0];
822        my $be2 = $mbe[1];
823        print $ps "mg /request/clone v\r\n";
824        is(scalar <$be>, "mg /request/clone v\r\n", "get passthrough");
825        print $be "VA 1 v\r\n4\r\n";
826        is(scalar <$be2>, "ms /request/a 1\r\n", "received cloned meta-set");
827        is(scalar <$be2>, "4\r\n", "received cloned meta-set value");
828        print $be2 "HD\r\n";
829        is(scalar <$ps>, "HD\r\n", "received HD");
830    };
831}
832
833check_sanity($ps);
834
835# Test Lua response API
836{
837    subtest 'response:elapsed() >100000micros' => sub {
838        # ps_recv must not receive an error
839        my $be = $mbe[0];
840        my $cmd = "mg /response/elapsed\r\n";
841        print $ps $cmd;
842        is(scalar <$be>, $cmd, "be received request.");
843        sleep 0.1;
844        print $be "HD\r\n";
845        is(scalar <$ps>, "HD\r\n", "proxy received HD");
846    };
847
848
849    subtest 'response:ok()' => sub {
850        # ps_recv must not receive an error
851        proxy_test(
852            ps_send => "mg /response/ok\r\n",
853            be_recv => {0 => ["mg /response/ok\r\n"]},
854            be_send => {0 => ["HD\r\n"]},
855            ps_recv => ["HD\r\n"],
856        );
857    };
858
859    subtest 'response:ok() false 1' => sub {
860        # ps_recv must receive an error
861        proxy_test(
862            ps_send => "mg /response/not_ok\r\n",
863            be_recv => {0 => ["mg /response/not_ok\r\n"]},
864            be_send => {0 => ["SERVER_ERROR\r\n"]},
865            ps_recv => ["SERVER_ERROR\r\n"],
866        );
867    };
868
869    subtest 'response:ok() false 2' => sub {
870        # ps_recv must receive an error
871        proxy_test(
872            ps_send => "mg /response/not_ok\r\n",
873            be_recv => {0 => ["mg /response/not_ok\r\n"]},
874            be_send => {0 => ["GARBAGE\r\n"]},
875            ps_recv => ["SERVER_ERROR\r\n"],
876        );
877
878        # test not_ok when backend is disconnected.
879        # ps_recv must receive an error
880        proxy_test(
881            ps_send => "mg /response/not_ok\r\n",
882            ps_recv => ["SERVER_ERROR\r\n"],
883        );
884
885        $mbe[0] = accept_backend($mocksrvs[0]);
886        $mbe[0] = accept_backend($mocksrvs[0]);
887    };
888
889    subtest 'response:ok() false 3' => sub {
890        # ps_recv must receive an error
891        proxy_test(
892            ps_send => "mg /response/not_ok\r\n",
893            be_recv => {0 => ["mg /response/not_ok\r\n"]},
894            be_send => {0 => ["HD\r"]},
895            ps_recv => ["SERVER_ERROR\r\n"],
896        );
897        $mbe[0] = accept_backend($mocksrvs[0]);
898    };
899
900    subtest 'response:hit() mg' => sub {
901        # ps_recv must not receive an error
902        proxy_test(
903            ps_send => "mg /response/hit\r\n",
904            be_recv => {0 => ["mg /response/hit\r\n"]},
905            be_send => {0 => ["HD\r\n"]},
906            ps_recv => ["HD\r\n"],
907        );
908    };
909
910    subtest 'response:hit() get' => sub {
911        # ps_recv must not receive an error
912        my $key = "/response/hit";
913        proxy_test(
914            ps_send => "get $key\r\n",
915            be_recv => {0 => ["get $key\r\n"]},
916            be_send => {0 => ["VALUE $key 0 1\r\na\r\nEND\r\n"]},
917            ps_recv => ["VALUE $key 0 1\r\n", "a\r\n", "END\r\n"],
918        );
919    };
920
921    subtest 'response:hit() false 1' => sub {
922        # ps_recv must receive an error
923        proxy_test(
924            ps_send => "mg /response/not_hit\r\n",
925            be_recv => {0 => ["mg /response/not_hit\r\n"]},
926            be_send => {0 => ["EN\r\n"]},
927            ps_recv => ["SERVER_ERROR\r\n"],
928        );
929    };
930
931    subtest 'response:hit() false 2' => sub {
932        # ps_recv must receive an error
933        proxy_test(
934            ps_send => "get /response/not_hit\r\n",
935            be_recv => {0 => ["get /response/not_hit\r\n"]},
936            be_send => {0 => ["END\r\n"]},
937            ps_recv => ["SERVER_ERROR\r\n"],
938        );
939    };
940
941    subtest 'response:hit() false 3' => sub {
942        # ps_recv must receive an error
943        proxy_test(
944            ps_send => "mg /response/not_hit\r\n",
945            be_recv => {0 => ["mg /response/not_hit\r\n"]},
946            be_send => {0 => ["SERVER_ERROR\r\n"]},
947            ps_recv => ["SERVER_ERROR\r\n"],
948        );
949    };
950
951    subtest 'response:vlen()' => sub {
952        # ps_recv must not receive an error
953        proxy_test(
954            ps_send => "mg /response/vlen v\r\n",
955            be_recv => {0 => ["mg /response/vlen v\r\n"]},
956            be_send => {0 => ["VA 1 v\r\n", "4\r\n"]},
957            ps_recv => ["VA 1 v\r\n", "4\r\n"],
958        );
959    };
960
961    subtest 'response:code() MCMC_CODE_OK' => sub {
962        # ps_recv must not receive an error
963        my $cmd = "mg /response/code_ok v\r\n";
964        proxy_test(
965            ps_send => $cmd,
966            be_recv => {0 => [$cmd]},
967            be_send => {0 => ["VA 1 v\r\n", "4\r\n"]},
968            ps_recv => ["VA 1 v\r\n", "4\r\n"],
969        );
970
971        proxy_test(
972            ps_send => "ms /response/code_ok 1\r\na\r\n",
973            be_recv => {0 => ["ms /response/code_ok 1\r\n", "a\r\n"]},
974            be_send => {0 => ["HD\r\n"]},
975            ps_recv => ["HD\r\n"],
976        );
977    };
978
979    subtest 'response:code() MCMC_CODE_MISS' => sub {
980        # ps_recv must not receive an error
981        my $cmd = "mg /response/code_miss v\r\n";
982        proxy_test(
983            ps_send => $cmd,
984            be_recv => {0 => [$cmd]},
985            be_send => {0 => ["EN\r\n"]},
986            ps_recv => ["EN\r\n"],
987        );
988    };
989
990    subtest 'response:code() MCMC_CODE_STORED' => sub {
991        # ps_recv must not receive an error
992        proxy_test(
993            ps_send => "set /response/code_stored 0 0 1\r\na\r\n",
994            be_recv => {0 => ["set /response/code_stored 0 0 1\r\n", "a\r\n"]},
995            be_send => {0 => ["STORED\r\n"]},
996            ps_recv => ["STORED\r\n"],
997        );
998    };
999
1000    subtest 'response:code() MCMC_CODE_EXISTS' => sub {
1001        # ps_recv must not receive an error
1002        proxy_test(
1003            ps_send => "set /response/code_exists 0 0 1\r\na\r\n",
1004            be_recv => {0 => ["set /response/code_exists 0 0 1\r\n", "a\r\n"]},
1005            be_send => {0 => ["EXISTS\r\n"]},
1006            ps_recv => ["EXISTS\r\n"],
1007        );
1008    };
1009
1010    subtest 'response:code() MCMC_CODE_NOT_STORED' => sub {
1011        # ps_recv must not receive an error
1012        proxy_test(
1013            ps_send => "set /response/code_not_stored 0 0 1\r\na\r\n",
1014            be_recv => {0 => ["set /response/code_not_stored 0 0 1\r\n", "a\r\n"]},
1015            be_send => {0 => ["NOT_STORED\r\n"]},
1016            ps_recv => ["NOT_STORED\r\n"],
1017        );
1018    };
1019
1020    subtest 'response:code() MCMC_CODE_NOT_FOUND' => sub {
1021        # ps_recv must not receive an error
1022        proxy_test(
1023            ps_send => "set /response/code_not_found 0 0 1\r\na\r\n",
1024            be_recv => {0 => ["set /response/code_not_found 0 0 1\r\n", "a\r\n"]},
1025            be_send => {0 => ["NOT_FOUND\r\n"]},
1026            ps_recv => ["NOT_FOUND\r\n"],
1027        );
1028    };
1029
1030    subtest 'response:code() MCMC_CODE_TOUCHED' => sub {
1031        # ps_recv must not receive an error
1032        proxy_test(
1033            ps_send => "touch /response/code_touched 50\r\n",
1034            be_recv => {0 => ["touch /response/code_touched 50\r\n"]},
1035            be_send => {0 => ["TOUCHED\r\n"]},
1036            ps_recv => ["TOUCHED\r\n"],
1037        );
1038    };
1039
1040    subtest 'response:code() MCMC_CODE_DELETED' => sub {
1041        # ps_recv must not receive an error
1042        proxy_test(
1043            ps_send => "delete /response/code_deleted\r\n",
1044            be_recv => {0 => ["delete /response/code_deleted\r\n"]},
1045            be_send => {0 => ["DELETED\r\n"]},
1046            ps_recv => ["DELETED\r\n"],
1047        );
1048    };
1049
1050    subtest 'response:line()' => sub {
1051        # ps_recv must not receive an error
1052        my $cmd = "mg /response/line v\r\n";
1053        proxy_test(
1054            ps_send => $cmd,
1055            be_recv => {0 => [$cmd]},
1056            be_send => {0 => ["VA 1 v c123\r\n", "a\r\n"]},
1057            ps_recv => ["VA 1 v c123\r\n", "a\r\n"],
1058        );
1059
1060        # ps_recv must not receive an error
1061        proxy_test(
1062            ps_send => "ms /response/line 2\r\nab\r\n",
1063            be_recv => {0 => ["ms /response/line 2\r\n", "ab\r\n"]},
1064            be_send => {0 => ["HD O123 C123\r\n"]},
1065            ps_recv => ["HD O123 C123\r\n"],
1066        );
1067    };
1068
1069    subtest 'response:flag_blank()' => sub {
1070        proxy_test(
1071            ps_send => "mg /response/blank f Ofoo t\r\n",
1072            be_recv => {0 => ["mg /response/blank f Ofoo t\r\n"]},
1073            be_send => {0 => ["HD f1234 Ofoo t999\r\n"]},
1074            ps_recv => ["HD f1234      t999\r\n"],
1075        );
1076    };
1077}
1078
1079
1080# Test requests land in proper backend in basic scenarios
1081{
1082    note("Test routing by zone:" . __LINE__);
1083
1084    # TODO: maybe should send values to ensure the right response?
1085    # I don't think this test is very useful though; probably better to try
1086    # harder when testing error conditions.
1087    for my $tu (['a', $mbe[0]], ['b', $mbe[1]], ['c', $mbe[2]]) {
1088        my $be = $tu->[1];
1089        my $cmd = "get /zonetest/" . $tu->[0] . "\r\n";
1090        print $ps $cmd;
1091        is(scalar <$be>, $cmd, "routed proper zone: " . $tu->[0]);
1092        print $be "END\r\n";
1093        is(scalar <$ps>, "END\r\n", "end from zone fetch");
1094    }
1095    my $cmd = "get /zonetest/invalid\r\n";
1096    print $ps $cmd;
1097    is(scalar <$ps>, "END\r\n", "END from invalid route");
1098}
1099
1100check_sanity($ps);
1101# Test re-requests in lua.
1102# - fetch zones.z1() then fetch zones.z2()
1103# - return z1 or z2 or netiher
1104# - fetch all three zones
1105# - hit the same zone multiple times
1106
1107# Test delayed read (timeout)
1108
1109# Test Lua logging (see t/watcher.t)
1110{
1111    note("Test Lua logging:" . __LINE__);
1112
1113    my $be = $mbe[0];
1114    my $watcher = $p_srv->new_sock;
1115    print $watcher "watch proxyuser proxyreqs\n";
1116    is(<$watcher>, "OK\r\n", "watcher enabled");
1117
1118    # log(msg)
1119    print $ps "get /logtest/a\r\n";
1120    like(<$watcher>, qr/ts=(\S+) gid=\d+ type=proxy_user msg=testing manual log messages/,
1121        "log a manual message");
1122    is(scalar <$ps>, "END\r\n", "logtest END");
1123
1124    # log_req(r, res)
1125    my $cmd = "get /logreqtest/a\r\n";
1126    print $ps $cmd;
1127    is(scalar <$be>, $cmd, "got passthru for log");
1128    print $be "END\r\n";
1129    is(scalar <$ps>, "END\r\n", "got END from log test");
1130    like(<$watcher>, qr/ts=(\S+) gid=\d+ type=proxy_req elapsed=\d+ type=105 code=17 status=0 cfd=\d+ be=127.0.0.1:11411 detail=logreqtest req=get \/logreqtest\/a/, "found request log entry");
1131
1132    # test log_req with nil res (should be 0's in places)
1133    # log_reqsample()
1134    $cmd = "get /logreqstest/a\r\n";
1135    print $ps $cmd;
1136    is(scalar <$be>, $cmd, "got passthru for logsamp");
1137    print $be "END\r\n";
1138    is(scalar <$ps>, "END\r\n", "got END from log test");
1139
1140    $cmd = "get /logreqstest/b\r\n";
1141    print $ps $cmd;
1142    is(scalar <$be>, $cmd, "got passthru for logsamp");
1143
1144    # cause the sampler time limit to trigger.
1145    sleep 0.3;
1146    print $be "END\r\n";
1147    is(scalar <$ps>, "END\r\n", "got END from log test");
1148    like(<$watcher>, qr/ts=(\S+) gid=\d+ type=proxy_req elapsed=\d+ type=105 code=17 status=0 cfd=\d+ be=127.0.0.1:11411 detail=logsampletest req=get \/logreqstest\/b/, "only got b request from log sample");
1149}
1150
1151# Test out of spec commands from client
1152# - wrong # of tokens
1153# - bad key size
1154# - etc
1155
1156# Test errors/garbage from server
1157# - certain errors pass through to the client, most close the backend.
1158# - should be able to retrieve the error message
1159{
1160    note("Test error/garbage from backend:" . __LINE__);
1161
1162    my $be = $mbe[0];
1163    print $ps "set /b/foo 0 0 2\r\nhi\r\n";
1164    is(scalar <$be>, "set /b/foo 0 0 2\r\n", "received set cmd");
1165    is(scalar <$be>, "hi\r\n", "received set data");
1166    # Send a classic back up the pipe.
1167    my $msg = "SERVER_ERROR object too large for cache\r\n";
1168    print $be $msg;
1169    is(scalar <$ps>, $msg, "client received error message");
1170
1171    print $ps "get /b/foo\r\n";
1172    is(scalar <$be>, "get /b/foo\r\n", "backend still works");
1173    print $be "END\r\n";
1174    is(scalar <$ps>, "END\r\n", "got end back");
1175
1176    # ERROR and CLIENT_ERROR should both break the backend.
1177    print $ps "get /b/moo\r\n";
1178    is(scalar <$be>, "get /b/moo\r\n", "received get command");
1179    $msg = "CLIENT_ERROR bad command line format\r\n";
1180    my $data;
1181    print $be $msg;
1182    is(scalar <$ps>, $msg, "client received error message");
1183    my $read = $be->read($data, 1);
1184    is($read, 0, "backend disconnected");
1185
1186    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1187
1188    print $ps "get /b/too\r\n";
1189    is(scalar <$be>, "get /b/too\r\n", "received get command");
1190    $msg = "ERROR unhappy\r\n";
1191    print $be $msg;
1192    is(scalar <$ps>, $msg, "client received error message");
1193    $read = $be->read($data, 1);
1194    is($read, 0, "backend disconnected");
1195
1196    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1197
1198    # Sometimes blank ERRORS can be sent.
1199    print $ps "get /b/zoo\r\n";
1200    is(scalar <$be>, "get /b/zoo\r\n", "received get command");
1201    $msg = "ERROR\r\n";
1202    print $be $msg;
1203    is(scalar <$ps>, $msg, "client received error message");
1204    $read = $be->read($data, 1);
1205    is($read, 0, "backend disconnected");
1206
1207    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1208
1209    # Ensure garbage doesn't surface to client.
1210    print $ps "get /b/doo\r\n";
1211    is(scalar <$be>, "get /b/doo\r\n", "received get command");
1212    print $be "garbage\r\n"; # don't need the \r\n but it makes tests easier
1213    is(scalar <$ps>, "SERVER_ERROR backend failure\r\n", "generic backend error");
1214
1215    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1216
1217    # Check errors from pipelined commands past a CLIENT_ERROR
1218    print $ps "get /b/quu\r\nget /b/muu\r\n";
1219    is(scalar <$be>, "get /b/quu\r\n", "received get command");
1220    is(scalar <$be>, "get /b/muu\r\n", "received next get command");
1221    print $be "CLIENT_ERROR bad protocol\r\nEND\r\n";
1222    is(scalar <$ps>, "CLIENT_ERROR bad protocol\r\n", "backend error");
1223    is(scalar <$ps>, "SERVER_ERROR backend failure\r\n", "backend error");
1224
1225    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1226
1227    # Check that lua handles errors properly.
1228    print $ps "get /errcheck/a\r\n";
1229    is(scalar <$be>, "get /errcheck/a\r\n", "received get command");
1230    print $be "ERROR test1\r\n";
1231    is(scalar <$ps>, "ERROR\r\n", "lua saw correct error code");
1232
1233    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1234
1235    print $ps "get /errcheck/b\r\n";
1236    is(scalar <$be>, "get /errcheck/b\r\n", "received get command");
1237    print $be "CLIENT_ERROR test2\r\n";
1238    is(scalar <$ps>, "CLIENT_ERROR\r\n", "lua saw correct error code");
1239
1240    $be = $mbe[0] = accept_backend($mocksrvs[0]);
1241
1242    print $ps "get /errcheck/c\r\n";
1243    is(scalar <$be>, "get /errcheck/c\r\n", "received get command");
1244    print $be "SERVER_ERROR test3\r\n";
1245    is(scalar <$ps>, "SERVER_ERROR\r\n", "lua saw correct error code");
1246}
1247
1248check_sanity($ps);
1249done_testing();
1250