Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 161 lines (143 sloc) 4.629 kb
a77c85d @stash psgix.io support!
authored
1 #!perl
2 use warnings;
3 use strict;
4 use constant CLIENTS => 10;
5 use constant ROUNDS => 4;
f443861 @stash Support Websockets under Web::Hippie.
authored
6 use Scalar::Util qw/refaddr/;
a77c85d @stash psgix.io support!
authored
7 use Test::More tests => 3 + ROUNDS*(
f443861 @stash Support Websockets under Web::Hippie.
authored
8 CLIENTS*5 + # server setup
a77c85d @stash psgix.io support!
authored
9 CLIENTS*3 + # client setup
10 CLIENTS + # server msg
11 CLIENTS + # client send
12 CLIENTS*CLIENTS + # client msg
13 4 # round
14 );
15 use lib 't'; use Utils;
16
17 BEGIN { use_ok('Feersum') };
18
19 my ($socket,$port) = get_listen_socket();
20 ok $socket, "made listen socket";
21
22 my $evh = Feersum->new();
23 {
24 no warnings 'redefine';
25 *Feersum::DIED = sub {
26 my $err = shift;
27 fail "Died during request handler: $err";
28 };
29 }
30 $evh->use_socket($socket);
31
32 our $CRLF = "\015\012";
33 my $app = sub {
34 my $env = shift;
35 is $env->{HTTP_UPGRADE}, 'chatz', "server setup: got an upgrade req";
36 my $n = $env->{HTTP_X_CLIENT};
f443861 @stash Support Websockets under Web::Hippie.
authored
37 return sub {
38 my $respond = shift;
a77c85d @stash psgix.io support!
authored
39 do_chat($n,$env);
f443861 @stash Support Websockets under Web::Hippie.
authored
40 };
a77c85d @stash psgix.io support!
authored
41 };
42 $evh->psgi_request_handler($app);
43
44 my $cv;
45
46 # read lines, broadcast to other server-side handles
47 my @ss_handles;
48 sub do_chat {
f443861 @stash Support Websockets under Web::Hippie.
authored
49 my ($n, $env, $strm) = @_;
a77c85d @stash psgix.io support!
authored
50 $cv->begin;
51 my $fh = $env->{'psgix.io'};
52 isa_ok $fh, 'IO::Socket', "server setup: $n fh";
53
f443861 @stash Support Websockets under Web::Hippie.
authored
54 my $websocket_turd;
55 read $fh, $websocket_turd, 8;
56 is $websocket_turd, '12345678', "server setup: $n websocket turd";
57
58 my $fh2 = $env->{'psgix.io'};
59 is refaddr($fh), refaddr($fh2),
60 "server setup: duplicated psgix.io read results in same handle";
61
a77c85d @stash psgix.io support!
authored
62 # use AnyEvent::Handle here specifically as that's what Web::Hippie
63 # uses.
64 my $h = AnyEvent::Handle->new(fh => $fh);
65 $ss_handles[$n] = $h;
66 $h->{guard} = guard { pass "server setup: $n destroyed" };
67 $h->push_write("HTTP/1.1 101 Switching Protocols$CRLF$CRLF");
68 $h->push_read(line => sub {
69 my $line = $_[1];
70 is $line, "hello from $n", "server msg: read a line for server $n";
71 $line .= "\n";
72 $ss_handles[$_]->push_write($line) for (1..CLIENTS);
73 $cv->end;
74 });
75 $h->on_error(sub {
76 diag "server handle error: $_[2]";
77 $h->destroy; # important self-ref
78 $cv->croak("server handle: ".$_[2]);
79 });
80 }
81
82 for my $round (1..ROUNDS) {
83 $cv = AE::cv;
84
85 # connect a number of clients, keeping the handle in a client-side handles
86 # array. Once all of the clients are connected ($connect_cv synchronizes
87 # them) send a "hello from" line for each client. Check that every client
88 # gets every message.
89 my @cs_handles;
90 my $connect_cv = AE::cv(sub {
91 pass "round $round : all clients connected, sending chats...";
92 eval {
93 for my $n (1 .. CLIENTS) {
94 my $h = $cs_handles[$n];
95 $h->push_write("hello from $n\n");
96 pass "client send: wrote to $n";
97 }
98 };
99 warn "during connect cv: $@" if $@;
100 });
101
102 $connect_cv->begin;
103 for my $n (1 .. CLIENTS) {
104 $connect_cv->begin;
105 $cv->begin;
106 my $h = AnyEvent::Handle->new(
107 connect => ['127.0.0.1',$port],
108 timeout => 3,
109 );
110 $cs_handles[$n] = $h;
111 $h->{guard} = guard { pass "client setup: $n destroyed" };
112
113 $h->on_error(sub {
114 diag "client handle error: $_[2]";
115 $h->destroy;
116 $connect_cv->croak("client handle: ".$_[2]);
117 $cv->croak("client handle: ".$_[2]);
118 });
119
120 $h->push_write("GET / HTTP/1.1$CRLF".
121 "Upgrade: chatz$CRLF".
122 "X-Client: $n$CRLF".
f443861 @stash Support Websockets under Web::Hippie.
authored
123 $CRLF.
124 "12345678" # extra websocket v76 hanshake turd
a77c85d @stash psgix.io support!
authored
125 );
126
127 # one line for the upgrade, CLIENTS lines for the chatting
128 $h->push_read(line => qr/$CRLF$CRLF/, sub {
129 my $line = $_[1];
130 is $line, 'HTTP/1.1 101 Switching Protocols',
131 "client setup: client $n got upgraded";
132 $connect_cv->end;
133 });
134 my $to_read = CLIENTS;
135 $h->push_read(line => sub {
136 my $line = $_[1];
137 $to_read--;
138 like $line, qr/^hello from \d+$/,
139 "client msg: $n got a chat, $to_read left";
140 unless ($to_read) {
141 pass "client setup: client $n is done";
142 $cv->end;
143 }
144 }) for (1 .. CLIENTS);
145 }
146 $connect_cv->end;
147
148 $connect_cv->recv;
149 pass "round: all connected";
150 $cv->recv;
151 pass "round: done round $round";
152 $_->destroy() for grep {defined} @cs_handles;
153 @cs_handles = ();
154 $_->destroy() for grep {defined} @ss_handles;
155 @ss_handles = ();
156 pass "round: cleaned up round $round";
157 }
158
159 pass "all done";
160 done_testing;
Something went wrong with that request. Please try again.