1#!/usr/bin/perl -w
2
3use strict;
4use Test::More tests => 13;
5
6use LWP::UserAgent;
7use HTTP::Request;
8use POE::Kernel;
9use POE::Component::Server::HTTP;
10use YAML;
11
12my $PORT = 2081;
13
14my $pid = fork;
15die "Unable to fork: $!" unless defined $pid;
16
17END {
18    if ($pid) {
19        kill 2, $pid or warn "Unable to kill $pid: $!";
20    }
21}
22
23$|++;
24
25####################################################################
26if ($pid) {                      # we are parent
27
28    # stop kernel from griping
29    ${$poe_kernel->[POE::Kernel::KR_RUN]} |=
30      POE::Kernel::KR_RUN_CALLED;
31
32    print STDERR "$$: Sleep 2...";
33    sleep 2;
34    print STDERR "continue\n";
35
36    if(@ARGV) {
37        print STDERR "Please connect to http://localhost:$PORT/ with your browser and make sure everything works\n";
38        local @ARGV=();
39        {} while <>;
40    }
41
42    my $UA = LWP::UserAgent->new;
43
44    ##################################### welcome
45    my $req=HTTP::Request->new(GET => "http://localhost:$PORT/");
46    my $resp=$UA->request($req);
47
48    ok(($resp->is_success and $resp->content_type eq 'text/html'),
49                "got index") or die "resp=", Dump $resp;
50    my $content = $resp->content;
51    ok(($content =~ /multipart.txt/), "proper index")
52                            or die "resp=", Dump $content;
53
54    ##################################### last.txt
55    $req=HTTP::Request->new(GET => "http://localhost:$PORT/last.txt");
56    $resp=$UA->request($req);
57
58    ok(($resp->is_success and $resp->content_type eq 'text/plain'),
59                "got last.txt") or die "resp=", Dump $resp;
60    $content = $resp->content;
61    ok(($content =~ /everything worked/), "everything worked")
62                            or die "resp=", Dump $content;
63
64    ##################################### multipart.txt
65    $req=HTTP::Request->new(GET => "http://localhost:$PORT/multipart.txt");
66    $resp=$UA->request($req);
67
68    ok(($resp->is_success and $resp->content_type =~ m(^multipart/mixed)),
69                "got multipart.txt") or die "resp=", Dump $resp;
70    $content = $resp->content;
71    ok(($content =~ /everything worked/), "everything worked")
72                            or die "resp=", Dump $content;
73
74
75    ##################################### last.gif
76    my $last = File::Basename::dirname($0).'/last.gif';
77    open LAST, $last or die "Unable to open $last: $!";
78    {
79        local $/;
80        $last = <LAST>;
81    }
82    close LAST;
83
84    ##################################### last.gif
85    $req=HTTP::Request->new(GET => "http://localhost:$PORT/last.gif");
86    $resp=$UA->request($req);
87
88    ok(($resp->is_success and $resp->content_type eq 'image/gif'),
89                "got last.gif") or die "resp=", Dump $resp;
90    $content = $resp->content;
91    ok(($content eq $last), "everything worked");
92
93    ##################################### multipart.gif
94    $req=HTTP::Request->new(GET => "http://localhost:$PORT/multipart.gif");
95    $resp=$UA->request($req);
96
97    ok(($resp->is_success and $resp->content_type =~ m(^multipart/mixed)),
98                "got multipart.txt") or die "resp=", Dump $resp;
99    $content = $resp->content;
100    $last = quotemeta $last;
101    ok(($content =~ /$last/), "everything worked");
102
103    ##################################### multipart.mixed
104    $req=HTTP::Request->new(GET => "http://localhost:$PORT/multipart.mixed");
105    $resp=$UA->request($req);
106
107    ok(($resp->is_success and $resp->content_type =~ m(^multipart/mixed)),
108                "got multipart.mixed") or die "resp=", Dump $resp;
109    $content = $resp->content;
110    ok(($content =~ /Please wait/), "first part worked");
111    ok(($content =~ /$last/), "last part worked");
112}
113####################################################################
114else {                          # we are the child
115
116    Worker->spawn(port => $PORT);
117    $poe_kernel->run();
118}
119
120###########################################################
121package Worker;
122
123use HTTP::Status;
124use POE::Kernel;
125use POE::Component::Server::HTTP;
126use POE;
127use File::Basename;
128
129sub DEBUG () { 0 }
130
131sub spawn
132{
133    my($package, %parms)=@_;
134    my $self = bless { dir => dirname($0),
135                       delay => 2,
136                       stream_todo => []}, $package;
137
138    POE::Component::Server::HTTP->new(
139        Port => $parms{port},
140        ContentHandler => {
141            '/' => sub { $self->welcome(@_) },
142            '/favicon.ico' => sub { $self->favicon(@_) },
143            '/multipart.gif' => sub { $self->multipart(@_) },
144            '/multipart.mixed' => sub { $self->multipart_mixed(@_) },
145            '/last.gif' => sub { $self->last(@_) },
146            '/multipart.txt' => sub { $self->multipart_txt(@_) },
147            '/last.txt' => sub { $self->last_txt(@_) },
148        },
149        StreamHandler => sub { $self->stream_start(@_) }
150    );
151
152    POE::Session->create(
153        inline_states => {
154            _start     => sub {  $self->_start() },
155            _stop      => sub {  DEBUG and warn "_stop\n" },
156            wait_start => sub { $self->wait_start(@_[ARG0..$#_])},
157            wait_done  => sub { $self->wait_done(@_[ARG0..$#_])}
158        }
159    );
160
161    DEBUG and warn "Listening on port $parms{port}\n";
162}
163
164#######################################
165# POE event
166sub _start
167{
168    my($self)=@_;
169    $self->{session} = $poe_kernel->get_active_session->ID;
170
171    $poe_kernel->alias_set(ref $self);
172    return;
173}
174
175#######################################
176# Called as ContentHandler
177sub welcome
178{
179    my($self, $request, $response)=@_;
180
181    DEBUG and warn "Welcome\n";
182
183    $response->code(RC_OK);
184    $response->content_type('text/html; charset=iso-8859-1');
185
186    $response->content(<<HTML);
187<html>
188<head>
189<title>Hello world</title>
190</head>
191<body>
192<h1>Hello world from POE::Component::Server::HTTP</h1>
193
194<ul>
195    <li><a href="/last.txt">Text</a></li>
196    <li><a href="/multipart.txt">Multipart text</a></li>
197    <li><a href="/last.gif">Image</a></li>
198    <li><a href="/multipart.gif">Multipart image</a></li>
199    <li><a href="/multipart.mixed">Text, then image</a></li>
200</ul>
201
202
203</body>
204</html>
205HTML
206    return RC_OK;
207}
208
209#######################################
210# Called as ContentHandler
211sub favicon
212{
213    my($self, $request, $response)=@_;
214
215    DEBUG and warn "favicon\n";
216
217    $response->code(RC_NOT_FOUND);
218    $response->content_type('text/html; charset=iso-8859-1');
219
220    $response->content(<<HTML);
221<html>
222<head>
223<title>Go away</title>
224</head>
225<body>
226<h1>Go away</h1>
227</body>
228</html>
229HTML
230    return RC_NOT_FOUND;
231}
232
233
234#######################################
235# Called as ContentHandler
236sub multipart
237{
238    my($self, $request, $response)=@_;
239
240    DEBUG and warn "multipart\n";
241
242    # Send an HTTP header and turn streaming on
243    $self->multipart_start($request, $response);
244    # After the HTTP header is sent, our StreamHandler will be called
245    # Save the values that stream_start needs to do its work
246    push @{$self->{stream_todo}}, [$request, $response,
247                                        'first.gif', 'last.gif'];
248
249    return RC_OK;
250}
251
252#######################################
253# Called as ContentHandler
254sub multipart_mixed
255{
256    my($self, $request, $response)=@_;
257
258    DEBUG and warn "multipart\n";
259
260    $self->multipart_start($request, $response);
261    push @{$self->{stream_todo}}, [$request, $response,
262                                        'first.txt', 'last.gif'];
263
264    return RC_OK;
265}
266
267#######################################
268# Called as ContentHandler
269sub last
270{
271    my($self, $request, $response)=@_;
272
273    DEBUG and warn "last\n";
274    $response->code(RC_OK);
275    $response->content_type('image/gif');
276    $response->content($self->data('last.gif'));
277    return RC_OK;
278}
279
280#######################################
281# Called as ContentHandler
282sub multipart_txt
283{
284    my($self, $request, $response)=@_;
285
286    DEBUG and warn "multipart_txt\n";
287
288    $self->multipart_start($request, $response);
289    push @{$self->{stream_todo}}, [$request, $response,
290                                        'first.txt', 'last.txt'];
291
292    return RC_OK;
293}
294
295#######################################
296# Called as ContentHandler
297sub last_txt
298{
299    my($self, $request, $response)=@_;
300
301    DEBUG and warn "last_txt\n";
302    $response->code(RC_OK);
303    $response->content_type('text/plain');
304    $response->content($self->data('last.txt'));
305    return RC_OK;
306}
307
308#######################################
309# Called as StreamHandler
310sub stream_start
311{
312    my($self, $request, $response)=@_;
313
314    DEBUG and warn "stream_start\n";
315
316    foreach my $todo (@{$self->{stream_todo}}) {
317        my($request, $response, $first, $last)=@$todo;
318
319        DEBUG and warn("post to wait_start for $first, $last\n");
320        $self->multipart_send($response, $first);
321
322        # get into our POE session
323        $poe_kernel->post($self->{session} => 'wait_start',
324                                $request, $response, $last);
325    }
326
327
328
329    $self->{stream_todo}=[];
330    return;
331}
332
333
334#######################################
335# POE event
336sub wait_start
337{
338    my($self, $request, $response, $next)=@_;
339    DEBUG and warn "Going to wait for $self->{delay} seconds\n";
340    $poe_kernel->delay_set(wait_done => $self->{delay}, $request, $response, $next);
341    return;
342}
343
344#######################################
345# POE event
346sub wait_done
347{
348    my($self, $request, $response, $next)=@_;
349    DEBUG and warn "Waiting done, sending $next\n";
350
351    $self->multipart_send($response, $next);
352    $self->multipart_end($request, $response);
353
354    return;
355}
356
357#######################################
358# Healper
359sub data
360{
361    my($self, $name)=@_;
362    my $file = "$self->{dir}/$name";
363    open FILE, $file or die "Can't open $file: $!";
364    {
365        local $/;
366        $file = <FILE>;
367    }
368    close FILE;
369    return $file;
370}
371
372
373####################################################################
374
375#######################################
376# This function sends a file over the connection
377# We create a new HTTP response, with content and content_length
378# Because HTTP response->as_string sends HTTP status line, we hide it
379#   behind a X-HTTP-Status header, just after the boundary.
380# This means that this part of the response looks like:
381#
382# --BoundaryString
383# X-HTTP-Status: HTTP/1.0 200 (OK)
384# Content-Type: text/plain
385# Content-Length: 13
386#
387# Content here
388#
389# Setting Content-Length is important for images
390sub multipart_send
391{
392    my($self, $response, $file)=@_;
393
394    DEBUG and warn "multipart_send $file\n";
395
396    my $ct = 'image/gif';
397    $ct = 'text/plain' if $file =~ /txt$/;
398
399    my $resp =  $self->multipart_response($ct);
400
401    my $data=$self->data($file);
402    $resp->content($data);
403    $resp->content_length(length($data));
404
405    $response->send("--$self->{boundary}\cM\cJX-HTTP-Status: ");
406    $response->send($resp->as_string);
407    return;
408}
409
410#######################################
411# Create a HTTP::Response object to be sent as a part of the response
412sub multipart_response
413{
414    my($self, $ct, $resp)=@_;
415    $resp ||= HTTP::Response->new;
416    $resp->content_type($ct||'text/plain');
417    $resp->code(200);
418    return $resp;
419}
420
421#######################################
422# Send an HTTP header that sets up multipart/mixed response
423# Also turns on streaming.
424#
425# PoCo::Server::HTTP will send the $response object, then run PostHandler
426# then switch to Streaming mode.
427sub multipart_start
428{
429    my($self, $request, $response)=@_;
430
431    $response->code(RC_OK);
432    $self->{boundary} ||= 'ThisRandomString';
433    $response->content_type("multipart/mixed;boundary=$self->{boundary}");
434
435    $response->streaming(1);
436}
437
438#######################################
439# The request is done.  Turn off streaming and end the multipart response
440# Setting the header Connection to 'close' forces PoCo::Server::HTTP to
441# close the socket.  This is needed so that the browsers stop "twirling".
442sub multipart_end
443{
444    my($self, $request, $response)=@_;
445    DEBUG and warn "Closing connection\n";
446    $response->close;
447    $request->header(Connection => 'close');
448    $response->send("--$self->{boundary}--\cM\cJ");
449}
450
451