lib/BS/HTTPD.pm

   1 package BS::HTTPD;
   2 use feature ':5.10';
   3 use strict;
   4 no warnings;
   5
   6 use Scalar::Util qw/weaken/;
   7 use URI;
   8 use BS::HTTPD::HTTPServer;
   9 use BS::HTTPD::Request;
  10
  11 our @ISA = qw/BS::HTTPD::HTTPServer/;
  12
  13 =head1 NAME
  14
  15 BS::HTTPD - A simple lightweight event based web (application) server
  16
  17 =head1 VERSION
  18
  19 Version 0.01
  20
  21 =cut
  22
  23 our $VERSION = '0.01';
  24
  25 =head1 SYNOPSIS
  26
  27     use BS::HTTPD;
  28
  29     my $httpd = BS::HTTPD->new (port => 9090);
  30
  31     $httpd->reg_cb (
  32        _ => sub {
  33           my ($httpd, $req) = @_;
  34
  35           $req->o ("<html><body><h1>Hello World!</h1>");
  36           $req->o ("<a href=\"/test\">another test page</a>");
  37           $req->o ("</body></html>");
  38           $req->respond;
  39        },
  40        _test => sub {
  41           my ($httpd, $req) = @_;
  42
  43           $req->o ("<html><body><h1>Test page</h1>");
  44           $req->o ("<a href=\"/\">Back to the main page</a>");
  45           $req->o ("</body></html>");
  46           $req->respond;
  47        },
  48     );
  49
  50 =head1 DESCRIPTION
  51
  52 This module provides a simple HTTPD for serving simple web application
  53 interfaces. It's completly event based and independend from any event loop
  54 by using the L<AnyEvent> module.
  55
  56 It's HTTP implementation is a bit hacky, so before using this module make sure
  57 it works for you and the expected deployment. Feel free to improve the HTTP support
  58 and send in patches!
  59
  60 I mainly wrote this module to provide a HTTP interface in L<BS>. However,
  61 it doesn't depend on L<BS> and it can be used to extend any application
  62 with a (simple) web interface.
  63
  64 The documentation is currently only the source code, but next versions of
  65 this module will be better documented hopefully. See also the C<samples/> directory
  66 in the L<BS::HTTPD> distribution for basic starting points.
  67
  68 L<BS::HTTPD> even comes with some basic AJAX framework/helper.
  69
  70 =head1 FEATURES
  71
  72 =over 4
  73
  74 =item * support for GET and POST requests
  75
  76 =item * processing of C<x-www-form-urlencoded> and C<multipart/form-data> encoded form parameters
  77
  78 =item * ajax helper and javascript output functions in L<BS::HTTPD::Appgets>
  79
  80 =item * support for chunked encoding output to the HTTP client
  81
  82 =back
  83
  84 =head1 METHODS
  85
  86 The L<BS::HTTPD> class inherits directly from L<BS::HTTPD::HTTPServer>
  87 which inherits the event callback interface from L<BS::Event>.
  88
  89 Event callbacks can be registered via the L<BS::Event> API (see the documentation
  90 of L<BS::Event> for details).
  91
  92 For a list of available events see below in the I<EVENTS> section.
  93
  94 =over 4
  95
  96 =cut
  97
  98 sub new {
  99    my $this  = shift;
 100    my $class = ref($this) || $this;
 101    my $self  = $class->SUPER::new (@_);
 102
 103    $self->start_cleanup;
 104
 105    $self->reg_cb (
 106       connect => sub {
 107          my ($self, $con) = @_;
 108
 109          $self->{conns}->{$con} = $con->reg_cb (
 110             request => sub {
 111                my ($con, $meth, $url, $hdr, $cont) = @_;
 112                #d# warn "REQUEST: $meth, $url, [$cont] " . join (',', %$hdr) . "\n";
 113
 114                $url = URI->new ($url);
 115
 116                if ($meth eq 'GET') {
 117                   $cont = $con->parse_urlencoded ($url->query);
 118                }
 119
 120                if ($meth eq 'GET' or $meth eq 'POST') {
 121
 122                   weaken $con;
 123                   $self->handle_app_req ($url, $hdr, $cont, sub {
 124                      $con->response (@_) if $con;
 125                   });
 126                } else {
 127                   $con->response (200, "ok");
 128                }
 129             }
 130          );
 131       },
 132       disconnect => sub {
 133          my ($self, $con) = @_;
 134          $con->unreg_cb (delete $self->{conns}->{$con});
 135       }
 136    );
 137
 138    $self->{max_data} //= 10;
 139    $self->{cleanup_interval} //= 60;
 140    $self->{state} //= {};
 141
 142    return $self
 143 }
 144
 145 sub start_cleanup {
 146    my ($self) = @_;
 147    $self->{clean_tmr} =
 148       AnyEvent->timer (after => $self->{cleanup_interval}, cb => sub {
 149          $self->cleanup;
 150          $self->start_cleanup;
 151       });
 152 }
 153
 154 sub cleanup {
 155    my ($self) = @_;
 156
 157    my $cnt = scalar @{$self->{form_ages} || []};
 158
 159    if ($cnt > $self->{max_data}) {
 160       my $diff = $cnt - $self->{max_data};
 161
 162       while ($cnt-- > 0) {
 163          my $d = pop @{$self->{form_ages} || []};
 164          last unless defined $d;
 165          delete $self->{form_cbs}->{$d->[1]};
 166       }
 167    }
 168 }
 169
 170 sub alloc_id {
 171    my ($self, $dest, @args) = @_;
 172    $self->{form_id}++;
 173    $self->{form_cbs}->{"$self->{form_id}"} = [$dest, \@args];
 174    push @{$self->{form_ages}}, [time, $self->{form_id}];
 175    $self->{form_id}
 176 }
 177
 178 sub handle_app_req {
 179    my ($self, $url, $hdr, $cont, $respcb) = @_;
 180
 181    weaken $self;
 182
 183    my $req =
 184       BS::HTTPD::Request->new (
 185          httpd => $self,
 186          url   => $url,
 187          hdr   => $hdr,
 188          parm  => (ref $cont ? $cont : {}),
 189          input => (ref $cont ? undef : $cont),
 190          resp  => $respcb
 191       );
 192
 193    if ($req->is_form_submit) {
 194       my $id = $req->form_id;
 195       my $cb = $self->{form_cbs}->{"$id"};
 196
 197       if (ref $cb->[0] eq 'CODE') {
 198          $cb->[0]->($req);
 199       }
 200    }
 201
 202    my (@segs) = $url->path_segments;
 203    my $ev = join "_", @segs;
 204
 205    my @res = $self->event ('request' => $req);
 206    push @res, $self->event ($ev => $req);
 207 }
 208
 209 =back
 210
 211 =head1 EVENTS
 212
 213 Every request goes to a specific URL. After a (GET or POST) request is
 214 received the URL is split at the '/' characters and joined again with '_' characters.
 215 After that the event with the name of the converted URL is invoked, this means that
 216 if you get a request to the url '/test/bla' the even C<_test_bla> is emitted,
 217 you can register a callback for that URL like this:
 218
 219    $httpd->reg_cb (
 220       _test_bla => sub {
 221          my ($httpd, $url, $headers, $respcb) = @_;
 222
 223          # ...
 224
 225          [200, 'ok', { 'Content-Type' => 'text/html' }, '<h1>Test</h1>' }]
 226       }
 227    );
 228
 229 The first argument to such a callback is always the L<BS::HTTPD> object itself.
 230 The second argument (C<$url>) is the L<URI::URL> object of the request URL, the
 231 third argument (C<$headers>) are the HTTP headers as hashreference of array
 232 references.
 233
 234 The C<$respcb> argument is a callback that you can call with the values that
 235 you would normally return from the callback. It will then generate a response
 236 and send it back as response to the request. Take care that you return the
 237 string C<'delay'> from the event if you want to handle it later.
 238 See also the C<delayed_example> in the C<samples/> directory.
 239
 240 Also every request also emits the C<request> event, with the same arguments and semantics,
 241 you can use this to implement your own request multiplexing.
 242
 243 The return value of these event callbacks are searched for array or hash references.
 244 The first callback that returned some response (a non-empty list) determines what
 245 the server will respond to the HTTP useragent.
 246
 247 If the return value was an array reference it's elements have the following semantics:
 248
 249 Alternatively you can fill the response via the C<o> method which will append
 250 any strings it gets as argument to the response. The content type of a
 251 response constructed by C<o> will be C<text/html>.
 252
 253 =head1 CACHING
 254
 255 Any response from the HTTP server will have C<Cache-Control> set to C<max-age=0> and
 256 also the C<Expires> header set to the C<Date> header. Meaning: Caching is disabled.
 257
 258 If you need caching or would like to have it you can send me a mail or even
 259 better: a patch :)
 260
 261 =head1 AUTHOR
 262
 263 Robin Redeker, C<< <elmex at ta-sa.org> >>
 264
 265 =head1 BUGS
 266
 267 Please report any bugs or feature requests to C<bug-bs-httpd at rt.cpan.org>, or through
 268 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=BS-HTTPD>.  I will be notified, and then you'll
 269 automatically be notified of progress on your bug as I make changes.
 270
 271 =head1 SUPPORT
 272
 273 You can find documentation for this module with the perldoc command.
 274
 275     perldoc BS::HTTPD
 276
 277
 278 You can also look for information at:
 279
 280 =over 4
 281
 282 =item * RT: CPAN's request tracker
 283
 284 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=BS-HTTPD>
 285
 286 =item * AnnoCPAN: Annotated CPAN documentation
 287
 288 L<http://annocpan.org/dist/BS-HTTPD>
 289
 290 =item * CPAN Ratings
 291
 292 L<http://cpanratings.perl.org/d/BS-HTTPD>
 293
 294 =item * Search CPAN
 295
 296 L<http://search.cpan.org/dist/BS-HTTPD>
 297
 298 =back
 299
 300
 301 =head1 ACKNOWLEDGEMENTS
 302
 303
 304 =head1 COPYRIGHT & LICENSE
 305
 306 Copyright 2008 Robin Redeker, all rights reserved.
 307
 308 This program is free software; you can redistribute it and/or modify it
 309 under the same terms as Perl itself.
 310
 311
 312 =cut
 313
 314 1; # End of BS::HTTPD