lib/CWMP/Server.pm

   1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
   2 package CWMP::Server;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/Class::Accessor/;
   8 __PACKAGE__->mk_accessors( qw/
   9 port
  10 session
  11 background
  12 debug
  13 create_dump
  14
  15 server
  16 / );
  17
  18 use CWMP::Session;
  19 use CWMP::Queue;
  20
  21 use Carp qw/confess/;
  22 use Data::Dump qw/dump/;
  23
  24 use IO::Socket::INET;
  25 use File::Path qw/mkpath/;
  26 use File::Slurp;
  27
  28 =head1 NAME
  29
  30 CWMP::Server - description
  31
  32 =head1 METHODS
  33
  34 =head2 new
  35
  36   my $server = CWMP::Server->new({
  37         port => 3333,
  38         session => { ... },
  39         background => 1,
  40         debug => 1
  41   });
  42
  43 Options:
  44
  45 =over 4
  46
  47 =item port
  48
  49 port to listen on
  50
  51 =item session
  52
  53 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
  54 is used. Other parametars are optional.
  55
  56 =back
  57
  58 =cut
  59
  60 sub new {
  61         my $class = shift;
  62         my $self = $class->SUPER::new( @_ );
  63
  64         warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
  65
  66         warn "ACS waiting for request on port ", $self->port, "\n";
  67
  68         $self->debug( 0 ) unless $self->debug;
  69         warn "## debug level: ", $self->debug, "\n" if $self->debug;
  70
  71         return $self;
  72 }
  73
  74 =head2 run
  75
  76 =cut
  77
  78 sub run {
  79         my $self = shift;
  80
  81         my $server = IO::Socket::INET->new(
  82                         Proto     => 'tcp',
  83                         LocalPort => $self->port,
  84                         Listen    => SOMAXCONN,
  85                         Reuse     => 1
  86         ) || die "can't start server on ", $self->port, ": $!";
  87
  88         warn "listen on ", $server->sockhost, ":", $server->sockport, "\n";
  89
  90         while (1) {
  91                 my $client = $server->accept() || next; # ALARM trickle us
  92
  93                 my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
  94
  95                 while ( $self->sock_session( $client, $session ) ) {
  96                         warn "# another one\n";
  97                 }
  98
  99                 warn "# connection to ", $client->peerhost, " closed\n";
 100         }
 101
 102 }
 103
 104 my $dump_by_ip;
 105
 106 sub sock_session {
 107         my ( $self, $sock, $session ) = @_;
 108
 109         my $request = <$sock>;
 110         return unless $request;
 111         my $ip = $sock->peerhost;
 112
 113         my $headers;
 114
 115         while ( my $header = <$sock> ) {
 116                 $request .= $header;
 117                 chomp $header;
 118                 last if $header =~ m{^\s*$};
 119                 my ( $n, $v ) = split(/:\s*/, $header);
 120                 $v =~ s/[\r\n]+$//;
 121                 $headers->{ lc $n } = $v;
 122         }
 123
 124         warn "<<<< $ip START\n$request\n";
 125
 126         return $sock->connected unless $headers;
 127
 128 warn dump( $headers );
 129
 130         warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 131
 132         my $body;
 133         if ( my $len = $headers->{'content-length'} ) {
 134                 read( $sock, $body, $len );
 135         } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
 136                 while ( my $len = <$sock> ) {
 137 warn "chunked ",dump($len);
 138                         $len =~ s/[\r\n]+$//;
 139                         $len = hex($len);
 140                         last if $len == 0;
 141 warn "reading $len bytes\n";
 142                         read( $sock, my $chunk, $len );
 143 warn "|$chunk| $len == ", length($chunk);
 144                         $body .= $chunk;
 145                         my $padding = <$sock>;
 146 warn "padding ",dump($padding);
 147                 }
 148         } else {
 149                 warn "empty request\n";
 150         }
 151
 152         warn "$body\n<<<< $ip END\n";
 153
 154         my $response = $session->process_request( $ip, $body );
 155
 156         my $dump_nr = $dump_by_ip->{$ip}++;
 157
 158         if ( $self->create_dump ) {
 159                 mkpath "dump/$ip" unless -e "dump/$ip";
 160                 write_file( sprintf("dump/%s/%04d.request", $ip, $dump_nr), "$request\r\n$body" );
 161                 write_file( sprintf("dump/%s/%04d.response", $ip, $dump_nr ), $response );
 162         }
 163
 164         warn ">>>> $ip START\n$response\n>>>> $ip END\n";
 165         print $sock $response;
 166
 167         return $sock->connected;
 168
 169 }
 170
 171
 172 1;